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"
36 #include "fold-const.h"
37 #include "stringpool.h"
38 #include "diagnostic-core.h" /* For fatal_error. */
39 #include "langhooks.h"
42 #include "constructor.h"
44 #include "trans-const.h"
45 #include "trans-types.h"
46 #include "trans-array.h"
47 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
48 #include "trans-stmt.h"
49 #include "dependency.h"
52 /* Convert a scalar to an array descriptor. To be used for assumed-rank
56 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
58 enum gfc_array_kind akind
;
61 akind
= GFC_ARRAY_POINTER_CONT
;
62 else if (attr
.allocatable
)
63 akind
= GFC_ARRAY_ALLOCATABLE
;
65 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
67 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
68 scalar
= TREE_TYPE (scalar
);
69 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
70 akind
, !(attr
.pointer
|| attr
.target
));
74 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
78 type
= get_scalar_to_descriptor_type (scalar
, attr
);
79 desc
= gfc_create_var (type
, "desc");
80 DECL_ARTIFICIAL (desc
) = 1;
82 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
83 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
84 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
85 gfc_get_dtype (type
));
86 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
88 /* Copy pointer address back - but only if it could have changed and
89 if the actual argument is a pointer and not, e.g., NULL(). */
90 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
91 gfc_add_modify (&se
->post
, scalar
,
92 fold_convert (TREE_TYPE (scalar
),
93 gfc_conv_descriptor_data_get (desc
)));
98 /* This is the seed for an eventual trans-class.c
100 The following parameters should not be used directly since they might
101 in future implementations. Use the corresponding APIs. */
102 #define CLASS_DATA_FIELD 0
103 #define CLASS_VPTR_FIELD 1
104 #define CLASS_LEN_FIELD 2
105 #define VTABLE_HASH_FIELD 0
106 #define VTABLE_SIZE_FIELD 1
107 #define VTABLE_EXTENDS_FIELD 2
108 #define VTABLE_DEF_INIT_FIELD 3
109 #define VTABLE_COPY_FIELD 4
110 #define VTABLE_FINAL_FIELD 5
114 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
118 vec
<constructor_elt
, va_gc
> *init
= NULL
;
120 field
= TYPE_FIELDS (TREE_TYPE (decl
));
121 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
122 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
124 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
125 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
127 return build_constructor (TREE_TYPE (decl
), init
);
132 gfc_class_data_get (tree decl
)
135 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
136 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
137 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
139 return fold_build3_loc (input_location
, COMPONENT_REF
,
140 TREE_TYPE (data
), decl
, data
,
146 gfc_class_vptr_get (tree decl
)
149 /* For class arrays decl may be a temporary descriptor handle, the vptr is
150 then available through the saved descriptor. */
151 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
152 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
153 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
154 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
155 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
156 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
158 return fold_build3_loc (input_location
, COMPONENT_REF
,
159 TREE_TYPE (vptr
), decl
, vptr
,
165 gfc_class_len_get (tree decl
)
168 /* For class arrays decl may be a temporary descriptor handle, the len is
169 then available through the saved descriptor. */
170 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
171 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
172 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
173 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
174 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
175 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
177 return fold_build3_loc (input_location
, COMPONENT_REF
,
178 TREE_TYPE (len
), decl
, len
,
183 /* Get the specified FIELD from the VPTR. */
186 vptr_field_get (tree vptr
, int fieldno
)
189 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
190 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
192 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
193 TREE_TYPE (field
), vptr
, field
,
200 /* Get the field from the class' vptr. */
203 class_vtab_field_get (tree decl
, int fieldno
)
206 vptr
= gfc_class_vptr_get (decl
);
207 return vptr_field_get (vptr
, fieldno
);
211 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
213 #define VTAB_GET_FIELD_GEN(name, field) tree \
214 gfc_class_vtab_## name ##_get (tree cl) \
216 return class_vtab_field_get (cl, field); \
220 gfc_vptr_## name ##_get (tree vptr) \
222 return vptr_field_get (vptr, field); \
225 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
226 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
227 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
228 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
229 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
232 /* The size field is returned as an array index type. Therefore treat
233 it and only it specially. */
236 gfc_class_vtab_size_get (tree cl
)
239 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
240 /* Always return size as an array index type. */
241 size
= fold_convert (gfc_array_index_type
, size
);
247 gfc_vptr_size_get (tree vptr
)
250 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
251 /* Always return size as an array index type. */
252 size
= fold_convert (gfc_array_index_type
, size
);
258 #undef CLASS_DATA_FIELD
259 #undef CLASS_VPTR_FIELD
260 #undef VTABLE_HASH_FIELD
261 #undef VTABLE_SIZE_FIELD
262 #undef VTABLE_EXTENDS_FIELD
263 #undef VTABLE_DEF_INIT_FIELD
264 #undef VTABLE_COPY_FIELD
265 #undef VTABLE_FINAL_FIELD
268 /* Search for the last _class ref in the chain of references of this
269 expression and cut the chain there. Albeit this routine is similiar
270 to class.c::gfc_add_component_ref (), is there a significant
271 difference: gfc_add_component_ref () concentrates on an array ref to
272 be the last ref in the chain. This routine is oblivious to the kind
273 of refs following. */
276 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
279 gfc_ref
*ref
, *class_ref
, *tail
;
281 /* Find the last class reference. */
283 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
285 if (ref
->type
== REF_COMPONENT
286 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
289 if (ref
->next
== NULL
)
293 /* Remove and store all subsequent references after the
297 tail
= class_ref
->next
;
298 class_ref
->next
= NULL
;
306 base_expr
= gfc_expr_to_initialize (e
);
308 /* Restore the original tail expression. */
311 gfc_free_ref_list (class_ref
->next
);
312 class_ref
->next
= tail
;
316 gfc_free_ref_list (e
->ref
);
323 /* Reset the vptr to the declared type, e.g. after deallocation. */
326 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
328 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
333 /* If we have a class array, we need go back to the class
335 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
336 && lhs
->ref
->next
->type
== REF_ARRAY
337 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
338 && lhs
->ref
->type
== REF_COMPONENT
339 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
341 gfc_free_ref_list (lhs
->ref
);
345 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
346 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
347 && ref
->next
->next
->type
== REF_ARRAY
348 && ref
->next
->next
->u
.ar
.type
== AR_FULL
349 && ref
->next
->type
== REF_COMPONENT
350 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
352 gfc_free_ref_list (ref
->next
);
356 gfc_add_vptr_component (lhs
);
358 if (UNLIMITED_POLY (e
))
359 rhs
= gfc_get_null_expr (NULL
);
362 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
363 rhs
= gfc_lval_expr_from_sym (vtab
);
365 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
366 gfc_add_expr_to_block (block
, tmp
);
372 /* Reset the len for unlimited polymorphic objects. */
375 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
379 e
= gfc_find_and_cut_at_last_class_ref (expr
);
380 gfc_add_len_component (e
);
381 gfc_init_se (&se_len
, NULL
);
382 gfc_conv_expr (&se_len
, e
);
383 gfc_add_modify (block
, se_len
.expr
,
384 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
389 /* Obtain the vptr of the last class reference in an expression.
390 Return NULL_TREE if no class reference is found. */
393 gfc_get_vptr_from_expr (tree expr
)
398 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
400 type
= TREE_TYPE (tmp
);
403 if (GFC_CLASS_TYPE_P (type
))
404 return gfc_class_vptr_get (tmp
);
405 if (type
!= TYPE_CANONICAL (type
))
406 type
= TYPE_CANONICAL (type
);
410 if (TREE_CODE (tmp
) == VAR_DECL
)
418 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
421 tree tmp
, tmp2
, type
;
423 gfc_conv_descriptor_data_set (block
, lhs_desc
,
424 gfc_conv_descriptor_data_get (rhs_desc
));
425 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
426 gfc_conv_descriptor_offset_get (rhs_desc
));
428 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
429 gfc_conv_descriptor_dtype (rhs_desc
));
431 /* Assign the dimension as range-ref. */
432 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
433 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
435 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
436 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
437 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
438 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
439 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
440 gfc_add_modify (block
, tmp
, tmp2
);
444 /* Takes a derived type expression and returns the address of a temporary
445 class object of the 'declared' type. If vptr is not NULL, this is
446 used for the temporary class object.
447 optional_alloc_ptr is false when the dummy is neither allocatable
448 nor a pointer; that's only relevant for the optional handling. */
450 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
451 gfc_typespec class_ts
, tree vptr
, bool optional
,
452 bool optional_alloc_ptr
)
455 tree cond_optional
= NULL_TREE
;
461 /* The derived type needs to be converted to a temporary
463 tmp
= gfc_typenode_for_spec (&class_ts
);
464 var
= gfc_create_var (tmp
, "class");
467 ctree
= gfc_class_vptr_get (var
);
469 if (vptr
!= NULL_TREE
)
471 /* Use the dynamic vptr. */
476 /* In this case the vtab corresponds to the derived type and the
477 vptr must point to it. */
478 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
480 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
482 gfc_add_modify (&parmse
->pre
, ctree
,
483 fold_convert (TREE_TYPE (ctree
), tmp
));
485 /* Now set the data field. */
486 ctree
= gfc_class_data_get (var
);
489 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
491 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
493 /* For an array reference in an elemental procedure call we need
494 to retain the ss to provide the scalarized array reference. */
495 gfc_conv_expr_reference (parmse
, e
);
496 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
498 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
500 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
501 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
506 ss
= gfc_walk_expr (e
);
507 if (ss
== gfc_ss_terminator
)
510 gfc_conv_expr_reference (parmse
, e
);
512 /* Scalar to an assumed-rank array. */
513 if (class_ts
.u
.derived
->components
->as
)
516 type
= get_scalar_to_descriptor_type (parmse
->expr
,
518 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
519 gfc_get_dtype (type
));
521 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
522 TREE_TYPE (parmse
->expr
),
523 cond_optional
, parmse
->expr
,
524 fold_convert (TREE_TYPE (parmse
->expr
),
526 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
530 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
532 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
534 fold_convert (TREE_TYPE (tmp
),
536 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
542 gfc_init_block (&block
);
545 gfc_conv_expr_descriptor (parmse
, e
);
547 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
549 gcc_assert (class_ts
.u
.derived
->components
->as
->type
551 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
555 if (gfc_expr_attr (e
).codimension
)
556 parmse
->expr
= fold_build1_loc (input_location
,
560 gfc_add_modify (&block
, ctree
, parmse
->expr
);
565 tmp
= gfc_finish_block (&block
);
567 gfc_init_block (&block
);
568 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
570 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
571 gfc_finish_block (&block
));
572 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
575 gfc_add_block_to_block (&parmse
->pre
, &block
);
579 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
580 && class_ts
.u
.derived
->components
->ts
.u
.derived
581 ->attr
.unlimited_polymorphic
)
583 /* Take care about initializing the _len component correctly. */
584 ctree
= gfc_class_len_get (var
);
585 if (UNLIMITED_POLY (e
))
590 len
= gfc_copy_expr (e
);
591 gfc_add_len_component (len
);
592 gfc_init_se (&se
, NULL
);
593 gfc_conv_expr (&se
, len
);
595 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
596 cond_optional
, se
.expr
,
597 fold_convert (TREE_TYPE (se
.expr
),
603 tmp
= integer_zero_node
;
604 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
607 /* Pass the address of the class object. */
608 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
610 if (optional
&& optional_alloc_ptr
)
611 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
612 TREE_TYPE (parmse
->expr
),
613 cond_optional
, parmse
->expr
,
614 fold_convert (TREE_TYPE (parmse
->expr
),
619 /* Create a new class container, which is required as scalar coarrays
620 have an array descriptor while normal scalars haven't. Optionally,
621 NULL pointer checks are added if the argument is OPTIONAL. */
624 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
625 gfc_typespec class_ts
, bool optional
)
627 tree var
, ctree
, tmp
;
632 gfc_init_block (&block
);
635 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
637 if (ref
->type
== REF_COMPONENT
638 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
642 if (class_ref
== NULL
643 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
644 tmp
= e
->symtree
->n
.sym
->backend_decl
;
647 /* Remove everything after the last class reference, convert the
648 expression and then recover its tailend once more. */
650 ref
= class_ref
->next
;
651 class_ref
->next
= NULL
;
652 gfc_init_se (&tmpse
, NULL
);
653 gfc_conv_expr (&tmpse
, e
);
654 class_ref
->next
= ref
;
658 var
= gfc_typenode_for_spec (&class_ts
);
659 var
= gfc_create_var (var
, "class");
661 ctree
= gfc_class_vptr_get (var
);
662 gfc_add_modify (&block
, ctree
,
663 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
665 ctree
= gfc_class_data_get (var
);
666 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
667 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
669 /* Pass the address of the class object. */
670 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
674 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
677 tmp
= gfc_finish_block (&block
);
679 gfc_init_block (&block
);
680 tmp2
= gfc_class_data_get (var
);
681 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
683 tmp2
= gfc_finish_block (&block
);
685 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
687 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
690 gfc_add_block_to_block (&parmse
->pre
, &block
);
694 /* Takes an intrinsic type expression and returns the address of a temporary
695 class object of the 'declared' type. */
697 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
698 gfc_typespec class_ts
)
706 /* The intrinsic type needs to be converted to a temporary
708 tmp
= gfc_typenode_for_spec (&class_ts
);
709 var
= gfc_create_var (tmp
, "class");
712 ctree
= gfc_class_vptr_get (var
);
714 vtab
= gfc_find_vtab (&e
->ts
);
716 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
717 gfc_add_modify (&parmse
->pre
, ctree
,
718 fold_convert (TREE_TYPE (ctree
), tmp
));
720 /* Now set the data field. */
721 ctree
= gfc_class_data_get (var
);
722 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
724 /* For an array reference in an elemental procedure call we need
725 to retain the ss to provide the scalarized array reference. */
726 gfc_conv_expr_reference (parmse
, e
);
727 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
728 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
732 ss
= gfc_walk_expr (e
);
733 if (ss
== gfc_ss_terminator
)
736 gfc_conv_expr_reference (parmse
, e
);
737 if (class_ts
.u
.derived
->components
->as
738 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
740 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
742 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
743 TREE_TYPE (ctree
), tmp
);
746 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
747 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
752 parmse
->use_offset
= 1;
753 gfc_conv_expr_descriptor (parmse
, e
);
754 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
756 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
757 TREE_TYPE (ctree
), parmse
->expr
);
758 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
761 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
765 gcc_assert (class_ts
.type
== BT_CLASS
);
766 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
767 && class_ts
.u
.derived
->components
->ts
.u
.derived
768 ->attr
.unlimited_polymorphic
)
770 ctree
= gfc_class_len_get (var
);
771 /* When the actual arg is a char array, then set the _len component of the
772 unlimited polymorphic entity, too. */
773 if (e
->ts
.type
== BT_CHARACTER
)
775 /* Start with parmse->string_length because this seems to be set to a
776 correct value more often. */
777 if (parmse
->string_length
)
778 tmp
= parmse
->string_length
;
779 /* When the string_length is not yet set, then try the backend_decl of
781 else if (e
->ts
.u
.cl
->backend_decl
)
782 tmp
= e
->ts
.u
.cl
->backend_decl
;
783 /* If both of the above approaches fail, then try to generate an
784 expression from the input, which is only feasible currently, when the
785 expression can be evaluated to a constant one. */
788 /* Try to simplify the expression. */
789 gfc_simplify_expr (e
, 0);
790 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
792 /* Amazingly all data is present to compute the length of a
793 constant string, but the expression is not yet there. */
794 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
796 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
797 e
->value
.character
.length
);
798 gfc_conv_const_charlen (e
->ts
.u
.cl
);
799 e
->ts
.u
.cl
->resolved
= 1;
800 tmp
= e
->ts
.u
.cl
->backend_decl
;
804 gfc_error ("Can't compute the length of the char array at %L.",
810 tmp
= integer_zero_node
;
812 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
814 else if (class_ts
.type
== BT_CLASS
815 && class_ts
.u
.derived
->components
816 && class_ts
.u
.derived
->components
->ts
.u
817 .derived
->attr
.unlimited_polymorphic
)
819 ctree
= gfc_class_len_get (var
);
820 gfc_add_modify (&parmse
->pre
, ctree
,
821 fold_convert (TREE_TYPE (ctree
),
824 /* Pass the address of the class object. */
825 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
829 /* Takes a scalarized class array expression and returns the
830 address of a temporary scalar class object of the 'declared'
832 OOP-TODO: This could be improved by adding code that branched on
833 the dynamic type being the same as the declared type. In this case
834 the original class expression can be passed directly.
835 optional_alloc_ptr is false when the dummy is neither allocatable
836 nor a pointer; that's relevant for the optional handling.
837 Set copyback to true if class container's _data and _vtab pointers
838 might get modified. */
841 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
842 bool elemental
, bool copyback
, bool optional
,
843 bool optional_alloc_ptr
)
849 tree cond
= NULL_TREE
;
850 tree slen
= NULL_TREE
;
854 bool full_array
= false;
856 gfc_init_block (&block
);
859 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
861 if (ref
->type
== REF_COMPONENT
862 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
865 if (ref
->next
== NULL
)
869 if ((ref
== NULL
|| class_ref
== ref
)
870 && (!class_ts
.u
.derived
->components
->as
871 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
874 /* Test for FULL_ARRAY. */
875 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
876 && gfc_expr_attr (e
).dimension
)
879 gfc_is_class_array_ref (e
, &full_array
);
881 /* The derived type needs to be converted to a temporary
883 tmp
= gfc_typenode_for_spec (&class_ts
);
884 var
= gfc_create_var (tmp
, "class");
887 ctree
= gfc_class_data_get (var
);
888 if (class_ts
.u
.derived
->components
->as
889 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
893 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
895 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
896 gfc_get_dtype (type
));
898 tmp
= gfc_class_data_get (parmse
->expr
);
899 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
900 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
902 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
905 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
909 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
910 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
911 TREE_TYPE (ctree
), parmse
->expr
);
912 gfc_add_modify (&block
, ctree
, parmse
->expr
);
915 /* Return the data component, except in the case of scalarized array
916 references, where nullification of the cannot occur and so there
918 if (!elemental
&& full_array
&& copyback
)
920 if (class_ts
.u
.derived
->components
->as
921 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
924 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
925 gfc_conv_descriptor_data_get (ctree
));
927 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
930 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
934 ctree
= gfc_class_vptr_get (var
);
936 /* The vptr is the second field of the actual argument.
937 First we have to find the corresponding class reference. */
940 if (class_ref
== NULL
941 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
943 tmp
= e
->symtree
->n
.sym
->backend_decl
;
944 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
945 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
946 slen
= integer_zero_node
;
950 /* Remove everything after the last class reference, convert the
951 expression and then recover its tailend once more. */
953 ref
= class_ref
->next
;
954 class_ref
->next
= NULL
;
955 gfc_init_se (&tmpse
, NULL
);
956 gfc_conv_expr (&tmpse
, e
);
957 class_ref
->next
= ref
;
959 slen
= tmpse
.string_length
;
962 gcc_assert (tmp
!= NULL_TREE
);
964 /* Dereference if needs be. */
965 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
966 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
968 vptr
= gfc_class_vptr_get (tmp
);
969 gfc_add_modify (&block
, ctree
,
970 fold_convert (TREE_TYPE (ctree
), vptr
));
972 /* Return the vptr component, except in the case of scalarized array
973 references, where the dynamic type cannot change. */
974 if (!elemental
&& full_array
&& copyback
)
975 gfc_add_modify (&parmse
->post
, vptr
,
976 fold_convert (TREE_TYPE (vptr
), ctree
));
978 /* For unlimited polymorphic objects also set the _len component. */
979 if (class_ts
.type
== BT_CLASS
980 && class_ts
.u
.derived
->components
981 && class_ts
.u
.derived
->components
->ts
.u
982 .derived
->attr
.unlimited_polymorphic
)
984 ctree
= gfc_class_len_get (var
);
985 if (UNLIMITED_POLY (e
))
986 tmp
= gfc_class_len_get (tmp
);
987 else if (e
->ts
.type
== BT_CHARACTER
)
989 gcc_assert (slen
!= NULL_TREE
);
993 tmp
= integer_zero_node
;
994 gfc_add_modify (&parmse
->pre
, ctree
,
995 fold_convert (TREE_TYPE (ctree
), tmp
));
1002 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1003 /* parmse->pre may contain some preparatory instructions for the
1004 temporary array descriptor. Those may only be executed when the
1005 optional argument is set, therefore add parmse->pre's instructions
1006 to block, which is later guarded by an if (optional_arg_given). */
1007 gfc_add_block_to_block (&parmse
->pre
, &block
);
1008 block
.head
= parmse
->pre
.head
;
1009 parmse
->pre
.head
= NULL_TREE
;
1010 tmp
= gfc_finish_block (&block
);
1012 if (optional_alloc_ptr
)
1013 tmp2
= build_empty_stmt (input_location
);
1016 gfc_init_block (&block
);
1018 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1019 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1020 null_pointer_node
));
1021 tmp2
= gfc_finish_block (&block
);
1024 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1026 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1029 gfc_add_block_to_block (&parmse
->pre
, &block
);
1031 /* Pass the address of the class object. */
1032 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1034 if (optional
&& optional_alloc_ptr
)
1035 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1036 TREE_TYPE (parmse
->expr
),
1038 fold_convert (TREE_TYPE (parmse
->expr
),
1039 null_pointer_node
));
1043 /* Given a class array declaration and an index, returns the address
1044 of the referenced element. */
1047 gfc_get_class_array_ref (tree index
, tree class_decl
)
1049 tree data
= gfc_class_data_get (class_decl
);
1050 tree size
= gfc_class_vtab_size_get (class_decl
);
1051 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1052 gfc_array_index_type
,
1055 data
= gfc_conv_descriptor_data_get (data
);
1056 ptr
= fold_convert (pvoid_type_node
, data
);
1057 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1058 return fold_convert (TREE_TYPE (data
), ptr
);
1062 /* Copies one class expression to another, assuming that if either
1063 'to' or 'from' are arrays they are packed. Should 'from' be
1064 NULL_TREE, the initialization expression for 'to' is used, assuming
1065 that the _vptr is set. */
1068 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1078 vec
<tree
, va_gc
> *args
;
1085 /* To prevent warnings on uninitialized variables. */
1086 from_len
= to_len
= NULL_TREE
;
1088 if (from
!= NULL_TREE
)
1089 fcn
= gfc_class_vtab_copy_get (from
);
1091 fcn
= gfc_class_vtab_copy_get (to
);
1093 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1095 if (from
!= NULL_TREE
)
1096 from_data
= gfc_class_data_get (from
);
1098 from_data
= gfc_class_vtab_def_init_get (to
);
1102 if (from
!= NULL_TREE
&& unlimited
)
1103 from_len
= gfc_class_len_get (from
);
1105 from_len
= integer_zero_node
;
1108 to_data
= gfc_class_data_get (to
);
1110 to_len
= gfc_class_len_get (to
);
1112 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1114 stmtblock_t loopbody
;
1119 gfc_init_block (&body
);
1120 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1121 gfc_array_index_type
, nelems
,
1122 gfc_index_one_node
);
1123 nelems
= gfc_evaluate_now (tmp
, &body
);
1124 index
= gfc_create_var (gfc_array_index_type
, "S");
1126 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
1128 from_ref
= gfc_get_class_array_ref (index
, from
);
1129 vec_safe_push (args
, from_ref
);
1132 vec_safe_push (args
, from_data
);
1134 to_ref
= gfc_get_class_array_ref (index
, to
);
1135 vec_safe_push (args
, to_ref
);
1137 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1139 /* Build the body of the loop. */
1140 gfc_init_block (&loopbody
);
1141 gfc_add_expr_to_block (&loopbody
, tmp
);
1143 /* Build the loop and return. */
1144 gfc_init_loopinfo (&loop
);
1146 loop
.from
[0] = gfc_index_zero_node
;
1147 loop
.loopvar
[0] = index
;
1148 loop
.to
[0] = nelems
;
1149 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1150 gfc_init_block (&ifbody
);
1151 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1152 stdcopy
= gfc_finish_block (&ifbody
);
1153 /* In initialization mode from_len is a constant zero. */
1154 if (unlimited
&& !integer_zerop (from_len
))
1156 vec_safe_push (args
, from_len
);
1157 vec_safe_push (args
, to_len
);
1158 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1159 /* Build the body of the loop. */
1160 gfc_init_block (&loopbody
);
1161 gfc_add_expr_to_block (&loopbody
, tmp
);
1163 /* Build the loop and return. */
1164 gfc_init_loopinfo (&loop
);
1166 loop
.from
[0] = gfc_index_zero_node
;
1167 loop
.loopvar
[0] = index
;
1168 loop
.to
[0] = nelems
;
1169 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1170 gfc_init_block (&ifbody
);
1171 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1172 extcopy
= gfc_finish_block (&ifbody
);
1174 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1175 boolean_type_node
, from_len
,
1177 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1178 void_type_node
, tmp
, extcopy
, stdcopy
);
1179 gfc_add_expr_to_block (&body
, tmp
);
1180 tmp
= gfc_finish_block (&body
);
1184 gfc_add_expr_to_block (&body
, stdcopy
);
1185 tmp
= gfc_finish_block (&body
);
1187 gfc_cleanup_loop (&loop
);
1191 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
1192 vec_safe_push (args
, from_data
);
1193 vec_safe_push (args
, to_data
);
1194 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1196 /* In initialization mode from_len is a constant zero. */
1197 if (unlimited
&& !integer_zerop (from_len
))
1199 vec_safe_push (args
, from_len
);
1200 vec_safe_push (args
, to_len
);
1201 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1202 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1203 boolean_type_node
, from_len
,
1205 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1206 void_type_node
, tmp
, extcopy
, stdcopy
);
1212 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1213 if (from
== NULL_TREE
)
1216 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1218 from_data
, null_pointer_node
);
1219 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1220 void_type_node
, cond
,
1221 tmp
, build_empty_stmt (input_location
));
1229 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1231 gfc_actual_arglist
*actual
;
1236 actual
= gfc_get_actual_arglist ();
1237 actual
->expr
= gfc_copy_expr (rhs
);
1238 actual
->next
= gfc_get_actual_arglist ();
1239 actual
->next
->expr
= gfc_copy_expr (lhs
);
1240 ppc
= gfc_copy_expr (obj
);
1241 gfc_add_vptr_component (ppc
);
1242 gfc_add_component_ref (ppc
, "_copy");
1243 ppc_code
= gfc_get_code (EXEC_CALL
);
1244 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1245 /* Although '_copy' is set to be elemental in class.c, it is
1246 not staying that way. Find out why, sometime.... */
1247 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1248 ppc_code
->ext
.actual
= actual
;
1249 ppc_code
->expr1
= ppc
;
1250 /* Since '_copy' is elemental, the scalarizer will take care
1251 of arrays in gfc_trans_call. */
1252 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1253 gfc_free_statements (ppc_code
);
1255 if (UNLIMITED_POLY(obj
))
1257 /* Check if rhs is non-NULL. */
1259 gfc_init_se (&src
, NULL
);
1260 gfc_conv_expr (&src
, rhs
);
1261 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1262 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1263 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1264 null_pointer_node
));
1265 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1266 build_empty_stmt (input_location
));
1272 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1273 A MEMCPY is needed to copy the full data from the default initializer
1274 of the dynamic type. */
1277 gfc_trans_class_init_assign (gfc_code
*code
)
1281 gfc_se dst
,src
,memsz
;
1282 gfc_expr
*lhs
, *rhs
, *sz
;
1284 gfc_start_block (&block
);
1286 lhs
= gfc_copy_expr (code
->expr1
);
1287 gfc_add_data_component (lhs
);
1289 rhs
= gfc_copy_expr (code
->expr1
);
1290 gfc_add_vptr_component (rhs
);
1292 /* Make sure that the component backend_decls have been built, which
1293 will not have happened if the derived types concerned have not
1295 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1296 gfc_add_def_init_component (rhs
);
1297 /* The _def_init is always scalar. */
1300 if (code
->expr1
->ts
.type
== BT_CLASS
1301 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1302 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1305 sz
= gfc_copy_expr (code
->expr1
);
1306 gfc_add_vptr_component (sz
);
1307 gfc_add_size_component (sz
);
1309 gfc_init_se (&dst
, NULL
);
1310 gfc_init_se (&src
, NULL
);
1311 gfc_init_se (&memsz
, NULL
);
1312 gfc_conv_expr (&dst
, lhs
);
1313 gfc_conv_expr (&src
, rhs
);
1314 gfc_conv_expr (&memsz
, sz
);
1315 gfc_add_block_to_block (&block
, &src
.pre
);
1316 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1318 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1320 if (UNLIMITED_POLY(code
->expr1
))
1322 /* Check if _def_init is non-NULL. */
1323 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1324 boolean_type_node
, src
.expr
,
1325 fold_convert (TREE_TYPE (src
.expr
),
1326 null_pointer_node
));
1327 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1328 tmp
, build_empty_stmt (input_location
));
1332 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1333 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1335 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1336 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1338 build_empty_stmt (input_location
));
1341 gfc_add_expr_to_block (&block
, tmp
);
1343 return gfc_finish_block (&block
);
1347 /* Translate an assignment to a CLASS object
1348 (pointer or ordinary assignment). */
1351 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1359 gfc_start_block (&block
);
1362 while (ref
&& ref
->next
)
1365 /* Class valued proc_pointer assignments do not need any further
1367 if (ref
&& ref
->type
== REF_COMPONENT
1368 && ref
->u
.c
.component
->attr
.proc_pointer
1369 && expr2
->expr_type
== EXPR_VARIABLE
1370 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1371 && op
== EXEC_POINTER_ASSIGN
)
1374 if (expr2
->ts
.type
!= BT_CLASS
)
1376 /* Insert an additional assignment which sets the '_vptr' field. */
1377 gfc_symbol
*vtab
= NULL
;
1380 lhs
= gfc_copy_expr (expr1
);
1381 gfc_add_vptr_component (lhs
);
1383 if (UNLIMITED_POLY (expr1
)
1384 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1386 rhs
= gfc_get_null_expr (&expr2
->where
);
1390 if (expr2
->expr_type
== EXPR_NULL
)
1391 vtab
= gfc_find_vtab (&expr1
->ts
);
1393 vtab
= gfc_find_vtab (&expr2
->ts
);
1396 rhs
= gfc_get_expr ();
1397 rhs
->expr_type
= EXPR_VARIABLE
;
1398 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1402 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1403 gfc_add_expr_to_block (&block
, tmp
);
1405 gfc_free_expr (lhs
);
1406 gfc_free_expr (rhs
);
1408 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1410 /* F2003:C717 only sequence and bind-C types can come here. */
1411 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1412 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1413 gfc_add_data_component (expr2
);
1416 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1418 /* Insert an additional assignment which sets the '_vptr' field. */
1419 lhs
= gfc_copy_expr (expr1
);
1420 gfc_add_vptr_component (lhs
);
1422 rhs
= gfc_copy_expr (expr2
);
1423 gfc_add_vptr_component (rhs
);
1425 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1426 gfc_add_expr_to_block (&block
, tmp
);
1428 gfc_free_expr (lhs
);
1429 gfc_free_expr (rhs
);
1432 /* Do the actual CLASS assignment. */
1433 if (expr2
->ts
.type
== BT_CLASS
1434 && !CLASS_DATA (expr2
)->attr
.dimension
)
1436 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1437 || !CLASS_DATA (expr2
)->attr
.dimension
)
1438 gfc_add_data_component (expr1
);
1442 if (op
== EXEC_ASSIGN
)
1443 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1444 else if (op
== EXEC_POINTER_ASSIGN
)
1445 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1449 gfc_add_expr_to_block (&block
, tmp
);
1451 return gfc_finish_block (&block
);
1455 /* End of prototype trans-class.c */
1459 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1461 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1462 gfc_warning (OPT_Wrealloc_lhs
,
1463 "Code for reallocating the allocatable array at %L will "
1465 else if (warn_realloc_lhs_all
)
1466 gfc_warning (OPT_Wrealloc_lhs_all
,
1467 "Code for reallocating the allocatable variable at %L "
1468 "will be added", where
);
1472 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
);
1473 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1476 /* Copy the scalarization loop variables. */
1479 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1482 dest
->loop
= src
->loop
;
1486 /* Initialize a simple expression holder.
1488 Care must be taken when multiple se are created with the same parent.
1489 The child se must be kept in sync. The easiest way is to delay creation
1490 of a child se until after after the previous se has been translated. */
1493 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1495 memset (se
, 0, sizeof (gfc_se
));
1496 gfc_init_block (&se
->pre
);
1497 gfc_init_block (&se
->post
);
1499 se
->parent
= parent
;
1502 gfc_copy_se_loopvars (se
, parent
);
1506 /* Advances to the next SS in the chain. Use this rather than setting
1507 se->ss = se->ss->next because all the parents needs to be kept in sync.
1511 gfc_advance_se_ss_chain (gfc_se
* se
)
1516 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1519 /* Walk down the parent chain. */
1522 /* Simple consistency check. */
1523 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1524 || p
->parent
->ss
->nested_ss
== p
->ss
);
1526 /* If we were in a nested loop, the next scalarized expression can be
1527 on the parent ss' next pointer. Thus we should not take the next
1528 pointer blindly, but rather go up one nest level as long as next
1529 is the end of chain. */
1531 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1541 /* Ensures the result of the expression as either a temporary variable
1542 or a constant so that it can be used repeatedly. */
1545 gfc_make_safe_expr (gfc_se
* se
)
1549 if (CONSTANT_CLASS_P (se
->expr
))
1552 /* We need a temporary for this result. */
1553 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1554 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1559 /* Return an expression which determines if a dummy parameter is present.
1560 Also used for arguments to procedures with multiple entry points. */
1563 gfc_conv_expr_present (gfc_symbol
* sym
)
1567 gcc_assert (sym
->attr
.dummy
);
1568 decl
= gfc_get_symbol_decl (sym
);
1570 /* Intrinsic scalars with VALUE attribute which are passed by value
1571 use a hidden argument to denote the present status. */
1572 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1573 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1574 && !sym
->attr
.dimension
)
1576 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1579 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1581 strcpy (&name
[1], sym
->name
);
1582 tree_name
= get_identifier (name
);
1584 /* Walk function argument list to find hidden arg. */
1585 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1586 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1587 if (DECL_NAME (cond
) == tree_name
)
1594 if (TREE_CODE (decl
) != PARM_DECL
)
1596 /* Array parameters use a temporary descriptor, we want the real
1598 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1599 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1600 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1603 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1604 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1606 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1607 as actual argument to denote absent dummies. For array descriptors,
1608 we thus also need to check the array descriptor. For BT_CLASS, it
1609 can also occur for scalars and F2003 due to type->class wrapping and
1610 class->class wrapping. Note further that BT_CLASS always uses an
1611 array descriptor for arrays, also for explicit-shape/assumed-size. */
1613 if (!sym
->attr
.allocatable
1614 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1615 || (sym
->ts
.type
== BT_CLASS
1616 && !CLASS_DATA (sym
)->attr
.allocatable
1617 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1618 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1619 || sym
->ts
.type
== BT_CLASS
))
1623 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1624 || sym
->as
->type
== AS_ASSUMED_RANK
1625 || sym
->attr
.codimension
))
1626 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1628 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1629 if (sym
->ts
.type
== BT_CLASS
)
1630 tmp
= gfc_class_data_get (tmp
);
1631 tmp
= gfc_conv_array_data (tmp
);
1633 else if (sym
->ts
.type
== BT_CLASS
)
1634 tmp
= gfc_class_data_get (decl
);
1638 if (tmp
!= NULL_TREE
)
1640 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1641 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1642 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1643 boolean_type_node
, cond
, tmp
);
1651 /* Converts a missing, dummy argument into a null or zero. */
1654 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1659 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1663 /* Create a temporary and convert it to the correct type. */
1664 tmp
= gfc_get_int_type (kind
);
1665 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1668 /* Test for a NULL value. */
1669 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1670 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1671 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1672 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1676 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1678 build_zero_cst (TREE_TYPE (se
->expr
)));
1679 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1683 if (ts
.type
== BT_CHARACTER
)
1685 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1686 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1687 present
, se
->string_length
, tmp
);
1688 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1689 se
->string_length
= tmp
;
1695 /* Get the character length of an expression, looking through gfc_refs
1699 gfc_get_expr_charlen (gfc_expr
*e
)
1704 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1705 && e
->ts
.type
== BT_CHARACTER
);
1707 length
= NULL
; /* To silence compiler warning. */
1709 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1712 gfc_init_se (&tmpse
, NULL
);
1713 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1714 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1718 /* First candidate: if the variable is of type CHARACTER, the
1719 expression's length could be the length of the character
1721 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1722 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1724 /* Look through the reference chain for component references. */
1725 for (r
= e
->ref
; r
; r
= r
->next
)
1730 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1731 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1739 /* We should never got substring references here. These will be
1740 broken down by the scalarizer. */
1746 gcc_assert (length
!= NULL
);
1751 /* Return for an expression the backend decl of the coarray. */
1754 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1758 gfc_ref
*ref
, *comp_ref
= NULL
;
1760 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1762 /* Not-implemented diagnostic. */
1763 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1764 if (ref
->type
== REF_COMPONENT
)
1767 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1768 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1769 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1770 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1771 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1772 && !ref
->u
.c
.component
->attr
.codimension
1773 && (ref
->u
.c
.component
->attr
.pointer
1774 || ref
->u
.c
.component
->attr
.allocatable
)))
1775 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1776 "component of the coindexed coarray at %L is not yet "
1777 "supported", &expr
->where
);
1780 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1781 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1782 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1783 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1785 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1786 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1787 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1788 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1789 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1790 "not yet supported", &expr
->where
);
1794 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1795 general not possible as the required stride multiplier might be not
1796 a multiple of c_sizeof(b). In case of noncoindexed access, the
1797 scalarizer often takes care of it - for coarrays, it always fails. */
1798 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1799 if (ref
->type
== REF_COMPONENT
1800 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1801 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1802 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1803 && ref
->u
.c
.component
->attr
.codimension
)))
1807 for ( ; ref
; ref
= ref
->next
)
1808 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1810 for ( ; ref
; ref
= ref
->next
)
1811 if (ref
->type
== REF_COMPONENT
)
1812 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1813 "with an array partref is not yet supported",
1817 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1818 gcc_assert (caf_decl
);
1819 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1820 caf_decl
= gfc_class_data_get (caf_decl
);
1821 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1824 /* The following code assumes that the coarray is a component reachable via
1825 only scalar components/variables; the Fortran standard guarantees this. */
1827 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1828 if (ref
->type
== REF_COMPONENT
)
1830 gfc_component
*comp
= ref
->u
.c
.component
;
1832 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1833 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1834 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1835 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1836 comp
->backend_decl
, NULL_TREE
);
1837 if (comp
->ts
.type
== BT_CLASS
)
1838 caf_decl
= gfc_class_data_get (caf_decl
);
1839 if (comp
->attr
.codimension
)
1845 gcc_assert (found
&& caf_decl
);
1850 /* Obtain the Coarray token - and optionally also the offset. */
1853 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1858 /* Coarray token. */
1859 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1861 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1862 == GFC_ARRAY_ALLOCATABLE
1863 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1864 *token
= gfc_conv_descriptor_token (caf_decl
);
1866 else if (DECL_LANG_SPECIFIC (caf_decl
)
1867 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1868 *token
= GFC_DECL_TOKEN (caf_decl
);
1871 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1872 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1873 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1879 /* Offset between the coarray base address and the address wanted. */
1880 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1881 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1882 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1883 *offset
= build_int_cst (gfc_array_index_type
, 0);
1884 else if (DECL_LANG_SPECIFIC (caf_decl
)
1885 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1886 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1887 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1888 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1890 *offset
= build_int_cst (gfc_array_index_type
, 0);
1892 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1893 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1895 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1896 tmp
= gfc_conv_descriptor_data_get (tmp
);
1898 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1899 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1902 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1906 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1907 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1909 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1910 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1913 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1917 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1918 fold_convert (gfc_array_index_type
, *offset
),
1919 fold_convert (gfc_array_index_type
, tmp
));
1923 /* Convert the coindex of a coarray into an image index; the result is
1924 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1925 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1928 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1931 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1935 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1936 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1938 gcc_assert (ref
!= NULL
);
1940 img_idx
= integer_zero_node
;
1941 extent
= integer_one_node
;
1942 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1943 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1945 gfc_init_se (&se
, NULL
);
1946 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1947 gfc_add_block_to_block (block
, &se
.pre
);
1948 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1949 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1950 integer_type_node
, se
.expr
,
1951 fold_convert(integer_type_node
, lbound
));
1952 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1954 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1956 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1958 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1959 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1960 tmp
= fold_convert (integer_type_node
, tmp
);
1961 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1962 integer_type_node
, extent
, tmp
);
1966 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1968 gfc_init_se (&se
, NULL
);
1969 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1970 gfc_add_block_to_block (block
, &se
.pre
);
1971 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1972 lbound
= fold_convert (integer_type_node
, lbound
);
1973 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1974 integer_type_node
, se
.expr
, lbound
);
1975 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1977 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1979 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1981 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1982 ubound
= fold_convert (integer_type_node
, ubound
);
1983 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1984 integer_type_node
, ubound
, lbound
);
1985 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1986 tmp
, integer_one_node
);
1987 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1988 integer_type_node
, extent
, tmp
);
1991 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1992 img_idx
, integer_one_node
);
1997 /* For each character array constructor subexpression without a ts.u.cl->length,
1998 replace it by its first element (if there aren't any elements, the length
1999 should already be set to zero). */
2002 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2004 gfc_actual_arglist
* arg
;
2010 switch (e
->expr_type
)
2014 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2015 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2019 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2023 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2024 flatten_array_ctors_without_strlen (arg
->expr
);
2029 /* We've found what we're looking for. */
2030 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2035 gcc_assert (e
->value
.constructor
);
2037 c
= gfc_constructor_first (e
->value
.constructor
);
2041 flatten_array_ctors_without_strlen (new_expr
);
2042 gfc_replace_expr (e
, new_expr
);
2046 /* Otherwise, fall through to handle constructor elements. */
2047 case EXPR_STRUCTURE
:
2048 for (c
= gfc_constructor_first (e
->value
.constructor
);
2049 c
; c
= gfc_constructor_next (c
))
2050 flatten_array_ctors_without_strlen (c
->expr
);
2060 /* Generate code to initialize a string length variable. Returns the
2061 value. For array constructors, cl->length might be NULL and in this case,
2062 the first element of the constructor is needed. expr is the original
2063 expression so we can access it but can be NULL if this is not needed. */
2066 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2070 gfc_init_se (&se
, NULL
);
2074 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2077 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2078 "flatten" array constructors by taking their first element; all elements
2079 should be the same length or a cl->length should be present. */
2082 gfc_expr
* expr_flat
;
2084 expr_flat
= gfc_copy_expr (expr
);
2085 flatten_array_ctors_without_strlen (expr_flat
);
2086 gfc_resolve_expr (expr_flat
);
2088 gfc_conv_expr (&se
, expr_flat
);
2089 gfc_add_block_to_block (pblock
, &se
.pre
);
2090 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2092 gfc_free_expr (expr_flat
);
2096 /* Convert cl->length. */
2098 gcc_assert (cl
->length
);
2100 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2101 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2102 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2103 gfc_add_block_to_block (pblock
, &se
.pre
);
2105 if (cl
->backend_decl
)
2106 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2108 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2113 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2114 const char *name
, locus
*where
)
2124 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2125 type
= build_pointer_type (type
);
2127 gfc_init_se (&start
, se
);
2128 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2129 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2131 if (integer_onep (start
.expr
))
2132 gfc_conv_string_parameter (se
);
2137 /* Avoid multiple evaluation of substring start. */
2138 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2139 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2141 /* Change the start of the string. */
2142 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2145 tmp
= build_fold_indirect_ref_loc (input_location
,
2147 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2148 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2151 /* Length = end + 1 - start. */
2152 gfc_init_se (&end
, se
);
2153 if (ref
->u
.ss
.end
== NULL
)
2154 end
.expr
= se
->string_length
;
2157 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2158 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2162 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2163 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2165 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2167 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2168 boolean_type_node
, start
.expr
,
2171 /* Check lower bound. */
2172 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2174 build_int_cst (gfc_charlen_type_node
, 1));
2175 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2176 boolean_type_node
, nonempty
, fault
);
2178 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2179 "is less than one", name
);
2181 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2182 "is less than one");
2183 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2184 fold_convert (long_integer_type_node
,
2188 /* Check upper bound. */
2189 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2190 end
.expr
, se
->string_length
);
2191 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2192 boolean_type_node
, nonempty
, fault
);
2194 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2195 "exceeds string length (%%ld)", name
);
2197 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2198 "exceeds string length (%%ld)");
2199 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2200 fold_convert (long_integer_type_node
, end
.expr
),
2201 fold_convert (long_integer_type_node
,
2202 se
->string_length
));
2206 /* Try to calculate the length from the start and end expressions. */
2208 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2212 i_len
= mpz_get_si (length
) + 1;
2216 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2217 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2221 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2222 end
.expr
, start
.expr
);
2223 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2224 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2225 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2226 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2229 se
->string_length
= tmp
;
2233 /* Convert a derived type component reference. */
2236 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2243 c
= ref
->u
.c
.component
;
2245 if (c
->backend_decl
== NULL_TREE
2246 && ref
->u
.c
.sym
!= NULL
)
2247 gfc_get_derived_type (ref
->u
.c
.sym
);
2249 field
= c
->backend_decl
;
2250 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2253 /* Components can correspond to fields of different containing
2254 types, as components are created without context, whereas
2255 a concrete use of a component has the type of decl as context.
2256 So, if the type doesn't match, we search the corresponding
2257 FIELD_DECL in the parent type. To not waste too much time
2258 we cache this result in norestrict_decl. */
2260 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
2262 tree f2
= c
->norestrict_decl
;
2263 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2264 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2265 if (TREE_CODE (f2
) == FIELD_DECL
2266 && DECL_NAME (f2
) == DECL_NAME (field
))
2269 c
->norestrict_decl
= f2
;
2273 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2274 && strcmp ("_data", c
->name
) == 0)
2276 /* Found a ref to the _data component. Store the associated ref to
2277 the vptr in se->class_vptr. */
2278 se
->class_vptr
= gfc_class_vptr_get (decl
);
2281 se
->class_vptr
= NULL_TREE
;
2283 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2284 decl
, field
, NULL_TREE
);
2288 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2289 strlen () conditional below. */
2290 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2291 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2293 tmp
= c
->ts
.u
.cl
->backend_decl
;
2294 /* Components must always be constant length. */
2295 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2296 se
->string_length
= tmp
;
2299 if (gfc_deferred_strlen (c
, &field
))
2301 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2303 decl
, field
, NULL_TREE
);
2304 se
->string_length
= tmp
;
2307 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2308 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2309 && c
->ts
.type
!= BT_CHARACTER
)
2310 || c
->attr
.proc_pointer
)
2311 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2316 /* This function deals with component references to components of the
2317 parent type for derived type extensions. */
2319 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2327 c
= ref
->u
.c
.component
;
2329 /* Return if the component is in the parent type. */
2330 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2331 if (strcmp (c
->name
, cmp
->name
) == 0)
2334 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2335 parent
.type
= REF_COMPONENT
;
2337 parent
.u
.c
.sym
= dt
;
2338 parent
.u
.c
.component
= dt
->components
;
2340 if (dt
->backend_decl
== NULL
)
2341 gfc_get_derived_type (dt
);
2343 /* Build the reference and call self. */
2344 gfc_conv_component_ref (se
, &parent
);
2345 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2346 parent
.u
.c
.component
= c
;
2347 conv_parent_component_references (se
, &parent
);
2350 /* Return the contents of a variable. Also handles reference/pointer
2351 variables (all Fortran pointer references are implicit). */
2354 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2359 tree parent_decl
= NULL_TREE
;
2362 bool alternate_entry
;
2365 bool first_time
= true;
2367 sym
= expr
->symtree
->n
.sym
;
2368 is_classarray
= IS_CLASS_ARRAY (sym
);
2372 gfc_ss_info
*ss_info
= ss
->info
;
2374 /* Check that something hasn't gone horribly wrong. */
2375 gcc_assert (ss
!= gfc_ss_terminator
);
2376 gcc_assert (ss_info
->expr
== expr
);
2378 /* A scalarized term. We already know the descriptor. */
2379 se
->expr
= ss_info
->data
.array
.descriptor
;
2380 se
->string_length
= ss_info
->string_length
;
2381 ref
= ss_info
->data
.array
.ref
;
2383 gcc_assert (ref
->type
== REF_ARRAY
2384 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2386 gfc_conv_tmp_array_ref (se
);
2390 tree se_expr
= NULL_TREE
;
2392 se
->expr
= gfc_get_symbol_decl (sym
);
2394 /* Deal with references to a parent results or entries by storing
2395 the current_function_decl and moving to the parent_decl. */
2396 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2397 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2398 && sym
->result
== sym
;
2399 entry_master
= sym
->attr
.result
2400 && sym
->ns
->proc_name
->attr
.entry_master
2401 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2402 if (current_function_decl
)
2403 parent_decl
= DECL_CONTEXT (current_function_decl
);
2405 if ((se
->expr
== parent_decl
&& return_value
)
2406 || (sym
->ns
&& sym
->ns
->proc_name
2408 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2409 && (alternate_entry
|| entry_master
)))
2414 /* Special case for assigning the return value of a function.
2415 Self recursive functions must have an explicit return value. */
2416 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2417 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2419 /* Similarly for alternate entry points. */
2420 else if (alternate_entry
2421 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2424 gfc_entry_list
*el
= NULL
;
2426 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2429 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2434 else if (entry_master
2435 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2437 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2442 /* Procedure actual arguments. */
2443 else if (sym
->attr
.flavor
== FL_PROCEDURE
2444 && se
->expr
!= current_function_decl
)
2446 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2448 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2449 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2455 /* Dereference the expression, where needed. Since characters
2456 are entirely different from other types, they are treated
2458 if (sym
->ts
.type
== BT_CHARACTER
)
2460 /* Dereference character pointer dummy arguments
2462 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2464 || sym
->attr
.function
2465 || sym
->attr
.result
))
2466 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2470 else if (!sym
->attr
.value
)
2472 /* Dereference temporaries for class array dummy arguments. */
2473 if (sym
->attr
.dummy
&& is_classarray
2474 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2476 if (!se
->descriptor_only
)
2477 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2479 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2483 /* Dereference non-character scalar dummy arguments. */
2484 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2485 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2486 && (sym
->ts
.type
!= BT_CLASS
2487 || (!CLASS_DATA (sym
)->attr
.dimension
2488 && !(CLASS_DATA (sym
)->attr
.codimension
2489 && CLASS_DATA (sym
)->attr
.allocatable
))))
2490 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2493 /* Dereference scalar hidden result. */
2494 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2495 && (sym
->attr
.function
|| sym
->attr
.result
)
2496 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2497 && !sym
->attr
.always_explicit
)
2498 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2501 /* Dereference non-character, non-class pointer variables.
2502 These must be dummies, results, or scalars. */
2504 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2505 || gfc_is_associate_pointer (sym
)
2506 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2508 || sym
->attr
.function
2510 || (!sym
->attr
.dimension
2511 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2512 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2514 /* Now treat the class array pointer variables accordingly. */
2515 else if (sym
->ts
.type
== BT_CLASS
2517 && (CLASS_DATA (sym
)->attr
.dimension
2518 || CLASS_DATA (sym
)->attr
.codimension
)
2519 && ((CLASS_DATA (sym
)->as
2520 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2521 || CLASS_DATA (sym
)->attr
.allocatable
2522 || CLASS_DATA (sym
)->attr
.class_pointer
))
2523 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2525 /* And the case where a non-dummy, non-result, non-function,
2526 non-allotable and non-pointer classarray is present. This case was
2527 previously covered by the first if, but with introducing the
2528 condition !is_classarray there, that case has to be covered
2530 else if (sym
->ts
.type
== BT_CLASS
2532 && !sym
->attr
.function
2533 && !sym
->attr
.result
2534 && (CLASS_DATA (sym
)->attr
.dimension
2535 || CLASS_DATA (sym
)->attr
.codimension
)
2536 && !CLASS_DATA (sym
)->attr
.allocatable
2537 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2538 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2545 /* For character variables, also get the length. */
2546 if (sym
->ts
.type
== BT_CHARACTER
)
2548 /* If the character length of an entry isn't set, get the length from
2549 the master function instead. */
2550 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2551 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2553 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2554 gcc_assert (se
->string_length
);
2562 /* Return the descriptor if that's what we want and this is an array
2563 section reference. */
2564 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2566 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2567 /* Return the descriptor for array pointers and allocations. */
2568 if (se
->want_pointer
2569 && ref
->next
== NULL
&& (se
->descriptor_only
))
2572 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2573 /* Return a pointer to an element. */
2577 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2578 && se
->descriptor_only
2579 && !CLASS_DATA (sym
)->attr
.allocatable
2580 && !CLASS_DATA (sym
)->attr
.class_pointer
2581 && CLASS_DATA (sym
)->as
2582 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2583 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2584 /* Skip the first ref of a _data component, because for class
2585 arrays that one is already done by introducing a temporary
2586 array descriptor. */
2589 if (ref
->u
.c
.sym
->attr
.extension
)
2590 conv_parent_component_references (se
, ref
);
2592 gfc_conv_component_ref (se
, ref
);
2593 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2594 && se
->want_pointer
&& se
->descriptor_only
)
2600 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2601 expr
->symtree
->name
, &expr
->where
);
2611 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2613 if (se
->want_pointer
)
2615 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2616 gfc_conv_string_parameter (se
);
2618 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2623 /* Unary ops are easy... Or they would be if ! was a valid op. */
2626 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2631 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2632 /* Initialize the operand. */
2633 gfc_init_se (&operand
, se
);
2634 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2635 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2637 type
= gfc_typenode_for_spec (&expr
->ts
);
2639 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2640 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2641 All other unary operators have an equivalent GIMPLE unary operator. */
2642 if (code
== TRUTH_NOT_EXPR
)
2643 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2644 build_int_cst (type
, 0));
2646 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2650 /* Expand power operator to optimal multiplications when a value is raised
2651 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2652 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2653 Programming", 3rd Edition, 1998. */
2655 /* This code is mostly duplicated from expand_powi in the backend.
2656 We establish the "optimal power tree" lookup table with the defined size.
2657 The items in the table are the exponents used to calculate the index
2658 exponents. Any integer n less than the value can get an "addition chain",
2659 with the first node being one. */
2660 #define POWI_TABLE_SIZE 256
2662 /* The table is from builtins.c. */
2663 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2665 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2666 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2667 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2668 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2669 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2670 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2671 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2672 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2673 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2674 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2675 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2676 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2677 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2678 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2679 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2680 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2681 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2682 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2683 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2684 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2685 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2686 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2687 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2688 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2689 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2690 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2691 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2692 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2693 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2694 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2695 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2696 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2699 /* If n is larger than lookup table's max index, we use the "window
2701 #define POWI_WINDOW_SIZE 3
2703 /* Recursive function to expand the power operator. The temporary
2704 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2706 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2713 if (n
< POWI_TABLE_SIZE
)
2718 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2719 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2723 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2724 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2725 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2729 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2733 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2734 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2736 if (n
< POWI_TABLE_SIZE
)
2743 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2744 return 1. Else return 0 and a call to runtime library functions
2745 will have to be built. */
2747 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2752 tree vartmp
[POWI_TABLE_SIZE
];
2754 unsigned HOST_WIDE_INT n
;
2756 wide_int wrhs
= rhs
;
2758 /* If exponent is too large, we won't expand it anyway, so don't bother
2759 with large integer values. */
2760 if (!wi::fits_shwi_p (wrhs
))
2763 m
= wrhs
.to_shwi ();
2764 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2765 of the asymmetric range of the integer type. */
2766 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2768 type
= TREE_TYPE (lhs
);
2769 sgn
= tree_int_cst_sgn (rhs
);
2771 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2772 || optimize_size
) && (m
> 2 || m
< -1))
2778 se
->expr
= gfc_build_const (type
, integer_one_node
);
2782 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2783 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2785 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2786 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2787 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2788 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2791 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2794 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2795 boolean_type_node
, tmp
, cond
);
2796 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2797 tmp
, build_int_cst (type
, 1),
2798 build_int_cst (type
, 0));
2802 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2803 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2804 build_int_cst (type
, -1),
2805 build_int_cst (type
, 0));
2806 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2807 cond
, build_int_cst (type
, 1), tmp
);
2811 memset (vartmp
, 0, sizeof (vartmp
));
2815 tmp
= gfc_build_const (type
, integer_one_node
);
2816 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2820 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2826 /* Power op (**). Constant integer exponent has special handling. */
2829 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2831 tree gfc_int4_type_node
;
2834 int res_ikind_1
, res_ikind_2
;
2839 gfc_init_se (&lse
, se
);
2840 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2841 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2842 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2844 gfc_init_se (&rse
, se
);
2845 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2846 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2848 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2849 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2850 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2853 gfc_int4_type_node
= gfc_get_int_type (4);
2855 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2856 library routine. But in the end, we have to convert the result back
2857 if this case applies -- with res_ikind_K, we keep track whether operand K
2858 falls into this case. */
2862 kind
= expr
->value
.op
.op1
->ts
.kind
;
2863 switch (expr
->value
.op
.op2
->ts
.type
)
2866 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2871 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2872 res_ikind_2
= ikind
;
2894 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2896 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2923 switch (expr
->value
.op
.op1
->ts
.type
)
2926 if (kind
== 3) /* Case 16 was not handled properly above. */
2928 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2932 /* Use builtins for real ** int4. */
2938 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2942 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2946 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2950 /* Use the __builtin_powil() only if real(kind=16) is
2951 actually the C long double type. */
2952 if (!gfc_real16_is_float128
)
2953 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2961 /* If we don't have a good builtin for this, go for the
2962 library function. */
2964 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2968 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2977 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2981 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2989 se
->expr
= build_call_expr_loc (input_location
,
2990 fndecl
, 2, lse
.expr
, rse
.expr
);
2992 /* Convert the result back if it is of wrong integer kind. */
2993 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2995 /* We want the maximum of both operand kinds as result. */
2996 if (res_ikind_1
< res_ikind_2
)
2997 res_ikind_1
= res_ikind_2
;
2998 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3003 /* Generate code to allocate a string temporary. */
3006 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3011 if (gfc_can_put_var_on_stack (len
))
3013 /* Create a temporary variable to hold the result. */
3014 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3015 gfc_charlen_type_node
, len
,
3016 build_int_cst (gfc_charlen_type_node
, 1));
3017 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3019 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3020 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3022 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3024 var
= gfc_create_var (tmp
, "str");
3025 var
= gfc_build_addr_expr (type
, var
);
3029 /* Allocate a temporary to hold the result. */
3030 var
= gfc_create_var (type
, "pstr");
3031 gcc_assert (POINTER_TYPE_P (type
));
3032 tmp
= TREE_TYPE (type
);
3033 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3034 tmp
= TREE_TYPE (tmp
);
3035 tmp
= TYPE_SIZE_UNIT (tmp
);
3036 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3037 fold_convert (size_type_node
, len
),
3038 fold_convert (size_type_node
, tmp
));
3039 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3040 gfc_add_modify (&se
->pre
, var
, tmp
);
3042 /* Free the temporary afterwards. */
3043 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
3044 gfc_add_expr_to_block (&se
->post
, tmp
);
3051 /* Handle a string concatenation operation. A temporary will be allocated to
3055 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3058 tree len
, type
, var
, tmp
, fndecl
;
3060 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3061 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3062 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3064 gfc_init_se (&lse
, se
);
3065 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3066 gfc_conv_string_parameter (&lse
);
3067 gfc_init_se (&rse
, se
);
3068 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3069 gfc_conv_string_parameter (&rse
);
3071 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3072 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3074 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3075 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3076 if (len
== NULL_TREE
)
3078 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3079 TREE_TYPE (lse
.string_length
),
3080 lse
.string_length
, rse
.string_length
);
3083 type
= build_pointer_type (type
);
3085 var
= gfc_conv_string_tmp (se
, type
, len
);
3087 /* Do the actual concatenation. */
3088 if (expr
->ts
.kind
== 1)
3089 fndecl
= gfor_fndecl_concat_string
;
3090 else if (expr
->ts
.kind
== 4)
3091 fndecl
= gfor_fndecl_concat_string_char4
;
3095 tmp
= build_call_expr_loc (input_location
,
3096 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3097 rse
.string_length
, rse
.expr
);
3098 gfc_add_expr_to_block (&se
->pre
, tmp
);
3100 /* Add the cleanup for the operands. */
3101 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3102 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3105 se
->string_length
= len
;
3108 /* Translates an op expression. Common (binary) cases are handled by this
3109 function, others are passed on. Recursion is used in either case.
3110 We use the fact that (op1.ts == op2.ts) (except for the power
3112 Operators need no special handling for scalarized expressions as long as
3113 they call gfc_conv_simple_val to get their operands.
3114 Character strings get special handling. */
3117 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3119 enum tree_code code
;
3128 switch (expr
->value
.op
.op
)
3130 case INTRINSIC_PARENTHESES
:
3131 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3132 && flag_protect_parens
)
3134 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3135 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3140 case INTRINSIC_UPLUS
:
3141 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3144 case INTRINSIC_UMINUS
:
3145 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3149 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3152 case INTRINSIC_PLUS
:
3156 case INTRINSIC_MINUS
:
3160 case INTRINSIC_TIMES
:
3164 case INTRINSIC_DIVIDE
:
3165 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3166 an integer, we must round towards zero, so we use a
3168 if (expr
->ts
.type
== BT_INTEGER
)
3169 code
= TRUNC_DIV_EXPR
;
3174 case INTRINSIC_POWER
:
3175 gfc_conv_power_op (se
, expr
);
3178 case INTRINSIC_CONCAT
:
3179 gfc_conv_concat_op (se
, expr
);
3183 code
= TRUTH_ANDIF_EXPR
;
3188 code
= TRUTH_ORIF_EXPR
;
3192 /* EQV and NEQV only work on logicals, but since we represent them
3193 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3195 case INTRINSIC_EQ_OS
:
3203 case INTRINSIC_NE_OS
:
3204 case INTRINSIC_NEQV
:
3211 case INTRINSIC_GT_OS
:
3218 case INTRINSIC_GE_OS
:
3225 case INTRINSIC_LT_OS
:
3232 case INTRINSIC_LE_OS
:
3238 case INTRINSIC_USER
:
3239 case INTRINSIC_ASSIGN
:
3240 /* These should be converted into function calls by the frontend. */
3244 fatal_error (input_location
, "Unknown intrinsic op");
3248 /* The only exception to this is **, which is handled separately anyway. */
3249 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3251 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3255 gfc_init_se (&lse
, se
);
3256 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3257 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3260 gfc_init_se (&rse
, se
);
3261 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3262 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3266 gfc_conv_string_parameter (&lse
);
3267 gfc_conv_string_parameter (&rse
);
3269 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3270 rse
.string_length
, rse
.expr
,
3271 expr
->value
.op
.op1
->ts
.kind
,
3273 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3274 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3277 type
= gfc_typenode_for_spec (&expr
->ts
);
3281 /* The result of logical ops is always boolean_type_node. */
3282 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3283 lse
.expr
, rse
.expr
);
3284 se
->expr
= convert (type
, tmp
);
3287 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3289 /* Add the post blocks. */
3290 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3291 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3294 /* If a string's length is one, we convert it to a single character. */
3297 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3301 || !tree_fits_uhwi_p (len
)
3302 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3305 if (TREE_INT_CST_LOW (len
) == 1)
3307 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3308 return build_fold_indirect_ref_loc (input_location
, str
);
3312 && TREE_CODE (str
) == ADDR_EXPR
3313 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3314 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3315 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3316 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3317 && TREE_INT_CST_LOW (len
) > 1
3318 && TREE_INT_CST_LOW (len
)
3319 == (unsigned HOST_WIDE_INT
)
3320 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3322 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3323 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3324 if (TREE_CODE (ret
) == INTEGER_CST
)
3326 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3327 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3328 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3330 for (i
= 1; i
< length
; i
++)
3343 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3346 if (sym
->backend_decl
)
3348 /* This becomes the nominal_type in
3349 function.c:assign_parm_find_data_types. */
3350 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3351 /* This becomes the passed_type in
3352 function.c:assign_parm_find_data_types. C promotes char to
3353 integer for argument passing. */
3354 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3356 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3361 /* If we have a constant character expression, make it into an
3363 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3368 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3369 (int)(*expr
)->value
.character
.string
[0]);
3370 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3372 /* The expr needs to be compatible with a C int. If the
3373 conversion fails, then the 2 causes an ICE. */
3374 ts
.type
= BT_INTEGER
;
3375 ts
.kind
= gfc_c_int_kind
;
3376 gfc_convert_type (*expr
, &ts
, 2);
3379 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3381 if ((*expr
)->ref
== NULL
)
3383 se
->expr
= gfc_string_to_single_character
3384 (build_int_cst (integer_type_node
, 1),
3385 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3387 ((*expr
)->symtree
->n
.sym
)),
3392 gfc_conv_variable (se
, *expr
);
3393 se
->expr
= gfc_string_to_single_character
3394 (build_int_cst (integer_type_node
, 1),
3395 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3403 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3404 if STR is a string literal, otherwise return -1. */
3407 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3410 && TREE_CODE (str
) == ADDR_EXPR
3411 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3412 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3413 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3414 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3415 && tree_fits_uhwi_p (len
)
3416 && tree_to_uhwi (len
) >= 1
3417 && tree_to_uhwi (len
)
3418 == (unsigned HOST_WIDE_INT
)
3419 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3421 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3422 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3423 if (TREE_CODE (folded
) == INTEGER_CST
)
3425 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3426 int length
= TREE_STRING_LENGTH (string_cst
);
3427 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3429 for (; length
> 0; length
--)
3430 if (ptr
[length
- 1] != ' ')
3439 /* Helper to build a call to memcmp. */
3442 build_memcmp_call (tree s1
, tree s2
, tree n
)
3446 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3447 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3449 s1
= fold_convert (pvoid_type_node
, s1
);
3451 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3452 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3454 s2
= fold_convert (pvoid_type_node
, s2
);
3456 n
= fold_convert (size_type_node
, n
);
3458 tmp
= build_call_expr_loc (input_location
,
3459 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3462 return fold_convert (integer_type_node
, tmp
);
3465 /* Compare two strings. If they are all single characters, the result is the
3466 subtraction of them. Otherwise, we build a library call. */
3469 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3470 enum tree_code code
)
3476 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3477 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3479 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3480 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3482 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3484 /* Deal with single character specially. */
3485 sc1
= fold_convert (integer_type_node
, sc1
);
3486 sc2
= fold_convert (integer_type_node
, sc2
);
3487 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3491 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3493 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3495 /* If one string is a string literal with LEN_TRIM longer
3496 than the length of the second string, the strings
3498 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3499 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3500 return integer_one_node
;
3501 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3502 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3503 return integer_one_node
;
3506 /* We can compare via memcpy if the strings are known to be equal
3507 in length and they are
3509 - kind=4 and the comparison is for (in)equality. */
3511 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3512 && tree_int_cst_equal (len1
, len2
)
3513 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3518 chartype
= gfc_get_char_type (kind
);
3519 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3520 fold_convert (TREE_TYPE(len1
),
3521 TYPE_SIZE_UNIT(chartype
)),
3523 return build_memcmp_call (str1
, str2
, tmp
);
3526 /* Build a call for the comparison. */
3528 fndecl
= gfor_fndecl_compare_string
;
3530 fndecl
= gfor_fndecl_compare_string_char4
;
3534 return build_call_expr_loc (input_location
, fndecl
, 4,
3535 len1
, str1
, len2
, str2
);
3539 /* Return the backend_decl for a procedure pointer component. */
3542 get_proc_ptr_comp (gfc_expr
*e
)
3548 gfc_init_se (&comp_se
, NULL
);
3549 e2
= gfc_copy_expr (e
);
3550 /* We have to restore the expr type later so that gfc_free_expr frees
3551 the exact same thing that was allocated.
3552 TODO: This is ugly. */
3553 old_type
= e2
->expr_type
;
3554 e2
->expr_type
= EXPR_VARIABLE
;
3555 gfc_conv_expr (&comp_se
, e2
);
3556 e2
->expr_type
= old_type
;
3558 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3562 /* Convert a typebound function reference from a class object. */
3564 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3569 if (TREE_CODE (base_object
) != VAR_DECL
)
3571 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3572 gfc_add_modify (&se
->pre
, var
, base_object
);
3574 se
->expr
= gfc_class_vptr_get (base_object
);
3575 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3577 while (ref
&& ref
->next
)
3579 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3580 if (ref
->u
.c
.sym
->attr
.extension
)
3581 conv_parent_component_references (se
, ref
);
3582 gfc_conv_component_ref (se
, ref
);
3583 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3588 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3592 if (gfc_is_proc_ptr_comp (expr
))
3593 tmp
= get_proc_ptr_comp (expr
);
3594 else if (sym
->attr
.dummy
)
3596 tmp
= gfc_get_symbol_decl (sym
);
3597 if (sym
->attr
.proc_pointer
)
3598 tmp
= build_fold_indirect_ref_loc (input_location
,
3600 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3601 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3605 if (!sym
->backend_decl
)
3606 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3608 TREE_USED (sym
->backend_decl
) = 1;
3610 tmp
= sym
->backend_decl
;
3612 if (sym
->attr
.cray_pointee
)
3614 /* TODO - make the cray pointee a pointer to a procedure,
3615 assign the pointer to it and use it for the call. This
3617 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3618 gfc_get_symbol_decl (sym
->cp_pointer
));
3619 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3622 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3624 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3625 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3632 /* Initialize MAPPING. */
3635 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3637 mapping
->syms
= NULL
;
3638 mapping
->charlens
= NULL
;
3642 /* Free all memory held by MAPPING (but not MAPPING itself). */
3645 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3647 gfc_interface_sym_mapping
*sym
;
3648 gfc_interface_sym_mapping
*nextsym
;
3650 gfc_charlen
*nextcl
;
3652 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3654 nextsym
= sym
->next
;
3655 sym
->new_sym
->n
.sym
->formal
= NULL
;
3656 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3657 gfc_free_expr (sym
->expr
);
3658 free (sym
->new_sym
);
3661 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3664 gfc_free_expr (cl
->length
);
3670 /* Return a copy of gfc_charlen CL. Add the returned structure to
3671 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3673 static gfc_charlen
*
3674 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3677 gfc_charlen
*new_charlen
;
3679 new_charlen
= gfc_get_charlen ();
3680 new_charlen
->next
= mapping
->charlens
;
3681 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3683 mapping
->charlens
= new_charlen
;
3688 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3689 array variable that can be used as the actual argument for dummy
3690 argument SYM. Add any initialization code to BLOCK. PACKED is as
3691 for gfc_get_nodesc_array_type and DATA points to the first element
3692 in the passed array. */
3695 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3696 gfc_packed packed
, tree data
)
3701 type
= gfc_typenode_for_spec (&sym
->ts
);
3702 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3703 !sym
->attr
.target
&& !sym
->attr
.pointer
3704 && !sym
->attr
.proc_pointer
);
3706 var
= gfc_create_var (type
, "ifm");
3707 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3713 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3714 and offset of descriptorless array type TYPE given that it has the same
3715 size as DESC. Add any set-up code to BLOCK. */
3718 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3725 offset
= gfc_index_zero_node
;
3726 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3728 dim
= gfc_rank_cst
[n
];
3729 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3730 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3732 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3733 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3734 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3735 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3737 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3739 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3740 gfc_array_index_type
,
3741 gfc_conv_descriptor_ubound_get (desc
, dim
),
3742 gfc_conv_descriptor_lbound_get (desc
, dim
));
3743 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3744 gfc_array_index_type
,
3745 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3746 tmp
= gfc_evaluate_now (tmp
, block
);
3747 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3749 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3750 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3751 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3752 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3753 gfc_array_index_type
, offset
, tmp
);
3755 offset
= gfc_evaluate_now (offset
, block
);
3756 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3760 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3761 in SE. The caller may still use se->expr and se->string_length after
3762 calling this function. */
3765 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3766 gfc_symbol
* sym
, gfc_se
* se
,
3769 gfc_interface_sym_mapping
*sm
;
3773 gfc_symbol
*new_sym
;
3775 gfc_symtree
*new_symtree
;
3777 /* Create a new symbol to represent the actual argument. */
3778 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3779 new_sym
->ts
= sym
->ts
;
3780 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3781 new_sym
->attr
.referenced
= 1;
3782 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3783 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3784 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3785 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3786 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3787 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3788 new_sym
->attr
.function
= sym
->attr
.function
;
3790 /* Ensure that the interface is available and that
3791 descriptors are passed for array actual arguments. */
3792 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3794 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3795 new_sym
->attr
.always_explicit
3796 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3799 /* Create a fake symtree for it. */
3801 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3802 new_symtree
->n
.sym
= new_sym
;
3803 gcc_assert (new_symtree
== root
);
3805 /* Create a dummy->actual mapping. */
3806 sm
= XCNEW (gfc_interface_sym_mapping
);
3807 sm
->next
= mapping
->syms
;
3809 sm
->new_sym
= new_symtree
;
3810 sm
->expr
= gfc_copy_expr (expr
);
3813 /* Stabilize the argument's value. */
3814 if (!sym
->attr
.function
&& se
)
3815 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3817 if (sym
->ts
.type
== BT_CHARACTER
)
3819 /* Create a copy of the dummy argument's length. */
3820 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3821 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3823 /* If the length is specified as "*", record the length that
3824 the caller is passing. We should use the callee's length
3825 in all other cases. */
3826 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3828 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3829 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3836 /* Use the passed value as-is if the argument is a function. */
3837 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3840 /* If the argument is either a string or a pointer to a string,
3841 convert it to a boundless character type. */
3842 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3844 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3845 tmp
= build_pointer_type (tmp
);
3846 if (sym
->attr
.pointer
)
3847 value
= build_fold_indirect_ref_loc (input_location
,
3851 value
= fold_convert (tmp
, value
);
3854 /* If the argument is a scalar, a pointer to an array or an allocatable,
3856 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3857 value
= build_fold_indirect_ref_loc (input_location
,
3860 /* For character(*), use the actual argument's descriptor. */
3861 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3862 value
= build_fold_indirect_ref_loc (input_location
,
3865 /* If the argument is an array descriptor, use it to determine
3866 information about the actual argument's shape. */
3867 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3868 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3870 /* Get the actual argument's descriptor. */
3871 desc
= build_fold_indirect_ref_loc (input_location
,
3874 /* Create the replacement variable. */
3875 tmp
= gfc_conv_descriptor_data_get (desc
);
3876 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3879 /* Use DESC to work out the upper bounds, strides and offset. */
3880 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3883 /* Otherwise we have a packed array. */
3884 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3885 PACKED_FULL
, se
->expr
);
3887 new_sym
->backend_decl
= value
;
3891 /* Called once all dummy argument mappings have been added to MAPPING,
3892 but before the mapping is used to evaluate expressions. Pre-evaluate
3893 the length of each argument, adding any initialization code to PRE and
3894 any finalization code to POST. */
3897 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3898 stmtblock_t
* pre
, stmtblock_t
* post
)
3900 gfc_interface_sym_mapping
*sym
;
3904 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3905 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3906 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3908 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3909 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3910 gfc_init_se (&se
, NULL
);
3911 gfc_conv_expr (&se
, expr
);
3912 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3913 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3914 gfc_add_block_to_block (pre
, &se
.pre
);
3915 gfc_add_block_to_block (post
, &se
.post
);
3917 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3922 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3926 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3927 gfc_constructor_base base
)
3930 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3932 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3935 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3936 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3937 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3943 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3947 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3952 for (; ref
; ref
= ref
->next
)
3956 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3958 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3959 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3960 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3968 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3969 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3975 /* Convert intrinsic function calls into result expressions. */
3978 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3986 arg1
= expr
->value
.function
.actual
->expr
;
3987 if (expr
->value
.function
.actual
->next
)
3988 arg2
= expr
->value
.function
.actual
->next
->expr
;
3992 sym
= arg1
->symtree
->n
.sym
;
3994 if (sym
->attr
.dummy
)
3999 switch (expr
->value
.function
.isym
->id
)
4002 /* TODO figure out why this condition is necessary. */
4003 if (sym
->attr
.function
4004 && (arg1
->ts
.u
.cl
->length
== NULL
4005 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4006 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4009 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4013 if (!sym
->as
|| sym
->as
->rank
== 0)
4016 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4018 dup
= mpz_get_si (arg2
->value
.integer
);
4023 dup
= sym
->as
->rank
;
4027 for (; d
< dup
; d
++)
4031 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4033 gfc_free_expr (new_expr
);
4037 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4038 gfc_get_int_expr (gfc_default_integer_kind
,
4040 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4042 new_expr
= gfc_multiply (new_expr
, tmp
);
4048 case GFC_ISYM_LBOUND
:
4049 case GFC_ISYM_UBOUND
:
4050 /* TODO These implementations of lbound and ubound do not limit if
4051 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4053 if (!sym
->as
|| sym
->as
->rank
== 0)
4056 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4057 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4059 /* TODO: If the need arises, this could produce an array of
4063 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4065 if (sym
->as
->lower
[d
])
4066 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4070 if (sym
->as
->upper
[d
])
4071 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4079 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4083 gfc_replace_expr (expr
, new_expr
);
4089 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4090 gfc_interface_mapping
* mapping
)
4092 gfc_formal_arglist
*f
;
4093 gfc_actual_arglist
*actual
;
4095 actual
= expr
->value
.function
.actual
;
4096 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4098 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4103 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4106 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4111 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4113 for (d
= 0; d
< as
->rank
; d
++)
4115 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4116 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4119 expr
->value
.function
.esym
->as
= as
;
4122 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4124 expr
->value
.function
.esym
->ts
.u
.cl
->length
4125 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4127 gfc_apply_interface_mapping_to_expr (mapping
,
4128 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4133 /* EXPR is a copy of an expression that appeared in the interface
4134 associated with MAPPING. Walk it recursively looking for references to
4135 dummy arguments that MAPPING maps to actual arguments. Replace each such
4136 reference with a reference to the associated actual argument. */
4139 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4142 gfc_interface_sym_mapping
*sym
;
4143 gfc_actual_arglist
*actual
;
4148 /* Copying an expression does not copy its length, so do that here. */
4149 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4151 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4152 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4155 /* Apply the mapping to any references. */
4156 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4158 /* ...and to the expression's symbol, if it has one. */
4159 /* TODO Find out why the condition on expr->symtree had to be moved into
4160 the loop rather than being outside it, as originally. */
4161 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4162 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4164 if (sym
->new_sym
->n
.sym
->backend_decl
)
4165 expr
->symtree
= sym
->new_sym
;
4167 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4170 /* ...and to subexpressions in expr->value. */
4171 switch (expr
->expr_type
)
4176 case EXPR_SUBSTRING
:
4180 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4181 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4185 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4186 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4188 if (expr
->value
.function
.esym
== NULL
4189 && expr
->value
.function
.isym
!= NULL
4190 && expr
->value
.function
.actual
->expr
->symtree
4191 && gfc_map_intrinsic_function (expr
, mapping
))
4194 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4195 if (sym
->old
== expr
->value
.function
.esym
)
4197 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4198 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4199 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4204 case EXPR_STRUCTURE
:
4205 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4218 /* Evaluate interface expression EXPR using MAPPING. Store the result
4222 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4223 gfc_se
* se
, gfc_expr
* expr
)
4225 expr
= gfc_copy_expr (expr
);
4226 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4227 gfc_conv_expr (se
, expr
);
4228 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4229 gfc_free_expr (expr
);
4233 /* Returns a reference to a temporary array into which a component of
4234 an actual argument derived type array is copied and then returned
4235 after the function call. */
4237 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4238 sym_intent intent
, bool formal_ptr
)
4246 gfc_array_info
*info
;
4256 gfc_init_se (&lse
, NULL
);
4257 gfc_init_se (&rse
, NULL
);
4259 /* Walk the argument expression. */
4260 rss
= gfc_walk_expr (expr
);
4262 gcc_assert (rss
!= gfc_ss_terminator
);
4264 /* Initialize the scalarizer. */
4265 gfc_init_loopinfo (&loop
);
4266 gfc_add_ss_to_loop (&loop
, rss
);
4268 /* Calculate the bounds of the scalarization. */
4269 gfc_conv_ss_startstride (&loop
);
4271 /* Build an ss for the temporary. */
4272 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4273 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4275 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4276 if (GFC_ARRAY_TYPE_P (base_type
)
4277 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4278 base_type
= gfc_get_element_type (base_type
);
4280 if (expr
->ts
.type
== BT_CLASS
)
4281 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4283 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4284 ? expr
->ts
.u
.cl
->backend_decl
4288 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4290 /* Associate the SS with the loop. */
4291 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4293 /* Setup the scalarizing loops. */
4294 gfc_conv_loop_setup (&loop
, &expr
->where
);
4296 /* Pass the temporary descriptor back to the caller. */
4297 info
= &loop
.temp_ss
->info
->data
.array
;
4298 parmse
->expr
= info
->descriptor
;
4300 /* Setup the gfc_se structures. */
4301 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4302 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4305 lse
.ss
= loop
.temp_ss
;
4306 gfc_mark_ss_chain_used (rss
, 1);
4307 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4309 /* Start the scalarized loop body. */
4310 gfc_start_scalarized_body (&loop
, &body
);
4312 /* Translate the expression. */
4313 gfc_conv_expr (&rse
, expr
);
4315 /* Reset the offset for the function call since the loop
4316 is zero based on the data pointer. Note that the temp
4317 comes first in the loop chain since it is added second. */
4318 if (gfc_is_alloc_class_array_function (expr
))
4320 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4321 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4322 gfc_index_zero_node
);
4325 gfc_conv_tmp_array_ref (&lse
);
4327 if (intent
!= INTENT_OUT
)
4329 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
4330 gfc_add_expr_to_block (&body
, tmp
);
4331 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4332 gfc_trans_scalarizing_loops (&loop
, &body
);
4336 /* Make sure that the temporary declaration survives by merging
4337 all the loop declarations into the current context. */
4338 for (n
= 0; n
< loop
.dimen
; n
++)
4340 gfc_merge_block_scope (&body
);
4341 body
= loop
.code
[loop
.order
[n
]];
4343 gfc_merge_block_scope (&body
);
4346 /* Add the post block after the second loop, so that any
4347 freeing of allocated memory is done at the right time. */
4348 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4350 /**********Copy the temporary back again.*********/
4352 gfc_init_se (&lse
, NULL
);
4353 gfc_init_se (&rse
, NULL
);
4355 /* Walk the argument expression. */
4356 lss
= gfc_walk_expr (expr
);
4357 rse
.ss
= loop
.temp_ss
;
4360 /* Initialize the scalarizer. */
4361 gfc_init_loopinfo (&loop2
);
4362 gfc_add_ss_to_loop (&loop2
, lss
);
4364 dimen
= rse
.ss
->dimen
;
4366 /* Skip the write-out loop for this case. */
4367 if (gfc_is_alloc_class_array_function (expr
))
4368 goto class_array_fcn
;
4370 /* Calculate the bounds of the scalarization. */
4371 gfc_conv_ss_startstride (&loop2
);
4373 /* Setup the scalarizing loops. */
4374 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4376 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4377 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4379 gfc_mark_ss_chain_used (lss
, 1);
4380 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4382 /* Declare the variable to hold the temporary offset and start the
4383 scalarized loop body. */
4384 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4385 gfc_start_scalarized_body (&loop2
, &body
);
4387 /* Build the offsets for the temporary from the loop variables. The
4388 temporary array has lbounds of zero and strides of one in all
4389 dimensions, so this is very simple. The offset is only computed
4390 outside the innermost loop, so the overall transfer could be
4391 optimized further. */
4392 info
= &rse
.ss
->info
->data
.array
;
4394 tmp_index
= gfc_index_zero_node
;
4395 for (n
= dimen
- 1; n
> 0; n
--)
4398 tmp
= rse
.loop
->loopvar
[n
];
4399 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4400 tmp
, rse
.loop
->from
[n
]);
4401 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4404 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4405 gfc_array_index_type
,
4406 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4407 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4408 gfc_array_index_type
,
4409 tmp_str
, gfc_index_one_node
);
4411 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4412 gfc_array_index_type
, tmp
, tmp_str
);
4415 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4416 gfc_array_index_type
,
4417 tmp_index
, rse
.loop
->from
[0]);
4418 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4420 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4421 gfc_array_index_type
,
4422 rse
.loop
->loopvar
[0], offset
);
4424 /* Now use the offset for the reference. */
4425 tmp
= build_fold_indirect_ref_loc (input_location
,
4427 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4429 if (expr
->ts
.type
== BT_CHARACTER
)
4430 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4432 gfc_conv_expr (&lse
, expr
);
4434 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4436 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4437 gfc_add_expr_to_block (&body
, tmp
);
4439 /* Generate the copying loops. */
4440 gfc_trans_scalarizing_loops (&loop2
, &body
);
4442 /* Wrap the whole thing up by adding the second loop to the post-block
4443 and following it by the post-block of the first loop. In this way,
4444 if the temporary needs freeing, it is done after use! */
4445 if (intent
!= INTENT_IN
)
4447 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4448 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4453 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4455 gfc_cleanup_loop (&loop
);
4456 gfc_cleanup_loop (&loop2
);
4458 /* Pass the string length to the argument expression. */
4459 if (expr
->ts
.type
== BT_CHARACTER
)
4460 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4462 /* Determine the offset for pointer formal arguments and set the
4466 size
= gfc_index_one_node
;
4467 offset
= gfc_index_zero_node
;
4468 for (n
= 0; n
< dimen
; n
++)
4470 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4472 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4473 gfc_array_index_type
, tmp
,
4474 gfc_index_one_node
);
4475 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4479 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4482 gfc_index_one_node
);
4483 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4484 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4485 gfc_array_index_type
,
4487 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4488 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4489 gfc_array_index_type
,
4490 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4491 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4492 gfc_array_index_type
,
4493 tmp
, gfc_index_one_node
);
4494 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4495 gfc_array_index_type
, size
, tmp
);
4498 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4502 /* We want either the address for the data or the address of the descriptor,
4503 depending on the mode of passing array arguments. */
4505 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4507 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4513 /* Generate the code for argument list functions. */
4516 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4518 /* Pass by value for g77 %VAL(arg), pass the address
4519 indirectly for %LOC, else by reference. Thus %REF
4520 is a "do-nothing" and %LOC is the same as an F95
4522 if (strncmp (name
, "%VAL", 4) == 0)
4523 gfc_conv_expr (se
, expr
);
4524 else if (strncmp (name
, "%LOC", 4) == 0)
4526 gfc_conv_expr_reference (se
, expr
);
4527 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4529 else if (strncmp (name
, "%REF", 4) == 0)
4530 gfc_conv_expr_reference (se
, expr
);
4532 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4536 /* Generate code for a procedure call. Note can return se->post != NULL.
4537 If se->direct_byref is set then se->expr contains the return parameter.
4538 Return nonzero, if the call has alternate specifiers.
4539 'expr' is only needed for procedure pointer components. */
4542 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4543 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4544 vec
<tree
, va_gc
> *append_args
)
4546 gfc_interface_mapping mapping
;
4547 vec
<tree
, va_gc
> *arglist
;
4548 vec
<tree
, va_gc
> *retargs
;
4552 gfc_array_info
*info
;
4559 vec
<tree
, va_gc
> *stringargs
;
4560 vec
<tree
, va_gc
> *optionalargs
;
4562 gfc_formal_arglist
*formal
;
4563 gfc_actual_arglist
*arg
;
4564 int has_alternate_specifier
= 0;
4565 bool need_interface_mapping
;
4572 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4573 gfc_component
*comp
= NULL
;
4579 optionalargs
= NULL
;
4584 comp
= gfc_get_proc_ptr_comp (expr
);
4588 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4590 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4591 if (se
->ss
->info
->useflags
)
4593 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4594 && sym
->result
->attr
.dimension
)
4595 || (comp
&& comp
->attr
.dimension
)
4596 || gfc_is_alloc_class_array_function (expr
));
4597 gcc_assert (se
->loop
!= NULL
);
4598 /* Access the previously obtained result. */
4599 gfc_conv_tmp_array_ref (se
);
4603 info
= &se
->ss
->info
->data
.array
;
4608 gfc_init_block (&post
);
4609 gfc_init_interface_mapping (&mapping
);
4612 formal
= gfc_sym_get_dummy_args (sym
);
4613 need_interface_mapping
= sym
->attr
.dimension
||
4614 (sym
->ts
.type
== BT_CHARACTER
4615 && sym
->ts
.u
.cl
->length
4616 && sym
->ts
.u
.cl
->length
->expr_type
4621 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4622 need_interface_mapping
= comp
->attr
.dimension
||
4623 (comp
->ts
.type
== BT_CHARACTER
4624 && comp
->ts
.u
.cl
->length
4625 && comp
->ts
.u
.cl
->length
->expr_type
4629 base_object
= NULL_TREE
;
4631 /* Evaluate the arguments. */
4632 for (arg
= args
; arg
!= NULL
;
4633 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4636 fsym
= formal
? formal
->sym
: NULL
;
4637 parm_kind
= MISSING
;
4639 /* Class array expressions are sometimes coming completely unadorned
4640 with either arrayspec or _data component. Correct that here.
4641 OOP-TODO: Move this to the frontend. */
4642 if (e
&& e
->expr_type
== EXPR_VARIABLE
4644 && e
->ts
.type
== BT_CLASS
4645 && (CLASS_DATA (e
)->attr
.codimension
4646 || CLASS_DATA (e
)->attr
.dimension
))
4648 gfc_typespec temp_ts
= e
->ts
;
4649 gfc_add_class_array_ref (e
);
4655 if (se
->ignore_optional
)
4657 /* Some intrinsics have already been resolved to the correct
4661 else if (arg
->label
)
4663 has_alternate_specifier
= 1;
4668 gfc_init_se (&parmse
, NULL
);
4670 /* For scalar arguments with VALUE attribute which are passed by
4671 value, pass "0" and a hidden argument gives the optional
4673 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4674 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4675 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4677 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4679 vec_safe_push (optionalargs
, boolean_false_node
);
4683 /* Pass a NULL pointer for an absent arg. */
4684 parmse
.expr
= null_pointer_node
;
4685 if (arg
->missing_arg_type
== BT_CHARACTER
)
4686 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4691 else if (arg
->expr
->expr_type
== EXPR_NULL
4692 && fsym
&& !fsym
->attr
.pointer
4693 && (fsym
->ts
.type
!= BT_CLASS
4694 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4696 /* Pass a NULL pointer to denote an absent arg. */
4697 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4698 && (fsym
->ts
.type
!= BT_CLASS
4699 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4700 gfc_init_se (&parmse
, NULL
);
4701 parmse
.expr
= null_pointer_node
;
4702 if (arg
->missing_arg_type
== BT_CHARACTER
)
4703 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4705 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4706 && e
->ts
.type
== BT_DERIVED
)
4708 /* The derived type needs to be converted to a temporary
4710 gfc_init_se (&parmse
, se
);
4711 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4713 && e
->expr_type
== EXPR_VARIABLE
4714 && e
->symtree
->n
.sym
->attr
.optional
,
4715 CLASS_DATA (fsym
)->attr
.class_pointer
4716 || CLASS_DATA (fsym
)->attr
.allocatable
);
4718 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4720 /* The intrinsic type needs to be converted to a temporary
4721 CLASS object for the unlimited polymorphic formal. */
4722 gfc_init_se (&parmse
, se
);
4723 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4725 else if (se
->ss
&& se
->ss
->info
->useflags
)
4731 /* An elemental function inside a scalarized loop. */
4732 gfc_init_se (&parmse
, se
);
4733 parm_kind
= ELEMENTAL
;
4735 if (fsym
&& fsym
->attr
.value
)
4736 gfc_conv_expr (&parmse
, e
);
4738 gfc_conv_expr_reference (&parmse
, e
);
4740 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4741 && e
->expr_type
== EXPR_FUNCTION
)
4742 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4745 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4746 && gfc_is_class_container_ref (e
))
4748 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4750 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4751 && e
->symtree
->n
.sym
->attr
.optional
)
4753 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4754 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4755 TREE_TYPE (parmse
.expr
),
4757 fold_convert (TREE_TYPE (parmse
.expr
),
4758 null_pointer_node
));
4762 /* If we are passing an absent array as optional dummy to an
4763 elemental procedure, make sure that we pass NULL when the data
4764 pointer is NULL. We need this extra conditional because of
4765 scalarization which passes arrays elements to the procedure,
4766 ignoring the fact that the array can be absent/unallocated/... */
4767 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4769 tree descriptor_data
;
4771 descriptor_data
= ss
->info
->data
.array
.data
;
4772 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4774 fold_convert (TREE_TYPE (descriptor_data
),
4775 null_pointer_node
));
4777 = fold_build3_loc (input_location
, COND_EXPR
,
4778 TREE_TYPE (parmse
.expr
),
4779 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4780 fold_convert (TREE_TYPE (parmse
.expr
),
4785 /* The scalarizer does not repackage the reference to a class
4786 array - instead it returns a pointer to the data element. */
4787 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4788 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4789 fsym
->attr
.intent
!= INTENT_IN
4790 && (CLASS_DATA (fsym
)->attr
.class_pointer
4791 || CLASS_DATA (fsym
)->attr
.allocatable
),
4793 && e
->expr_type
== EXPR_VARIABLE
4794 && e
->symtree
->n
.sym
->attr
.optional
,
4795 CLASS_DATA (fsym
)->attr
.class_pointer
4796 || CLASS_DATA (fsym
)->attr
.allocatable
);
4803 gfc_init_se (&parmse
, NULL
);
4805 /* Check whether the expression is a scalar or not; we cannot use
4806 e->rank as it can be nonzero for functions arguments. */
4807 argss
= gfc_walk_expr (e
);
4808 scalar
= argss
== gfc_ss_terminator
;
4810 gfc_free_ss_chain (argss
);
4812 /* Special handling for passing scalar polymorphic coarrays;
4813 otherwise one passes "class->_data.data" instead of "&class". */
4814 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4815 && fsym
&& fsym
->ts
.type
== BT_CLASS
4816 && CLASS_DATA (fsym
)->attr
.codimension
4817 && !CLASS_DATA (fsym
)->attr
.dimension
)
4819 gfc_add_class_array_ref (e
);
4820 parmse
.want_coarray
= 1;
4824 /* A scalar or transformational function. */
4827 if (e
->expr_type
== EXPR_VARIABLE
4828 && e
->symtree
->n
.sym
->attr
.cray_pointee
4829 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4831 /* The Cray pointer needs to be converted to a pointer to
4832 a type given by the expression. */
4833 gfc_conv_expr (&parmse
, e
);
4834 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4835 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4836 parmse
.expr
= convert (type
, tmp
);
4838 else if (fsym
&& fsym
->attr
.value
)
4840 if (fsym
->ts
.type
== BT_CHARACTER
4841 && fsym
->ts
.is_c_interop
4842 && fsym
->ns
->proc_name
!= NULL
4843 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4846 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4847 if (parmse
.expr
== NULL
)
4848 gfc_conv_expr (&parmse
, e
);
4852 gfc_conv_expr (&parmse
, e
);
4853 if (fsym
->attr
.optional
4854 && fsym
->ts
.type
!= BT_CLASS
4855 && fsym
->ts
.type
!= BT_DERIVED
)
4857 if (e
->expr_type
!= EXPR_VARIABLE
4858 || !e
->symtree
->n
.sym
->attr
.optional
4860 vec_safe_push (optionalargs
, boolean_true_node
);
4863 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4864 if (!e
->symtree
->n
.sym
->attr
.value
)
4866 = fold_build3_loc (input_location
, COND_EXPR
,
4867 TREE_TYPE (parmse
.expr
),
4869 fold_convert (TREE_TYPE (parmse
.expr
),
4870 integer_zero_node
));
4872 vec_safe_push (optionalargs
, tmp
);
4877 else if (arg
->name
&& arg
->name
[0] == '%')
4878 /* Argument list functions %VAL, %LOC and %REF are signalled
4879 through arg->name. */
4880 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4881 else if ((e
->expr_type
== EXPR_FUNCTION
)
4882 && ((e
->value
.function
.esym
4883 && e
->value
.function
.esym
->result
->attr
.pointer
)
4884 || (!e
->value
.function
.esym
4885 && e
->symtree
->n
.sym
->attr
.pointer
))
4886 && fsym
&& fsym
->attr
.target
)
4888 gfc_conv_expr (&parmse
, e
);
4889 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4891 else if (e
->expr_type
== EXPR_FUNCTION
4892 && e
->symtree
->n
.sym
->result
4893 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4894 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4896 /* Functions returning procedure pointers. */
4897 gfc_conv_expr (&parmse
, e
);
4898 if (fsym
&& fsym
->attr
.proc_pointer
)
4899 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4903 if (e
->ts
.type
== BT_CLASS
&& fsym
4904 && fsym
->ts
.type
== BT_CLASS
4905 && (!CLASS_DATA (fsym
)->as
4906 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4907 && CLASS_DATA (e
)->attr
.codimension
)
4909 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4910 gcc_assert (!CLASS_DATA (fsym
)->as
);
4911 gfc_add_class_array_ref (e
);
4912 parmse
.want_coarray
= 1;
4913 gfc_conv_expr_reference (&parmse
, e
);
4914 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4916 && e
->expr_type
== EXPR_VARIABLE
);
4918 else if (e
->ts
.type
== BT_CLASS
&& fsym
4919 && fsym
->ts
.type
== BT_CLASS
4920 && !CLASS_DATA (fsym
)->as
4921 && !CLASS_DATA (e
)->as
4922 && strcmp (fsym
->ts
.u
.derived
->name
,
4923 e
->ts
.u
.derived
->name
))
4925 type
= gfc_typenode_for_spec (&fsym
->ts
);
4926 var
= gfc_create_var (type
, fsym
->name
);
4927 gfc_conv_expr (&parmse
, e
);
4928 if (fsym
->attr
.optional
4929 && e
->expr_type
== EXPR_VARIABLE
4930 && e
->symtree
->n
.sym
->attr
.optional
)
4934 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4935 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4936 boolean_type_node
, tmp
,
4937 fold_convert (TREE_TYPE (tmp
),
4938 null_pointer_node
));
4939 gfc_start_block (&block
);
4940 gfc_add_modify (&block
, var
,
4941 fold_build1_loc (input_location
,
4943 type
, parmse
.expr
));
4944 gfc_add_expr_to_block (&parmse
.pre
,
4945 fold_build3_loc (input_location
,
4946 COND_EXPR
, void_type_node
,
4947 cond
, gfc_finish_block (&block
),
4948 build_empty_stmt (input_location
)));
4949 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4950 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4951 TREE_TYPE (parmse
.expr
),
4953 fold_convert (TREE_TYPE (parmse
.expr
),
4954 null_pointer_node
));
4958 gfc_add_modify (&parmse
.pre
, var
,
4959 fold_build1_loc (input_location
,
4961 type
, parmse
.expr
));
4962 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4966 gfc_conv_expr_reference (&parmse
, e
);
4968 /* Catch base objects that are not variables. */
4969 if (e
->ts
.type
== BT_CLASS
4970 && e
->expr_type
!= EXPR_VARIABLE
4971 && expr
&& e
== expr
->base_expr
)
4972 base_object
= build_fold_indirect_ref_loc (input_location
,
4975 /* A class array element needs converting back to be a
4976 class object, if the formal argument is a class object. */
4977 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4978 && e
->ts
.type
== BT_CLASS
4979 && ((CLASS_DATA (fsym
)->as
4980 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4981 || CLASS_DATA (e
)->attr
.dimension
))
4982 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4983 fsym
->attr
.intent
!= INTENT_IN
4984 && (CLASS_DATA (fsym
)->attr
.class_pointer
4985 || CLASS_DATA (fsym
)->attr
.allocatable
),
4987 && e
->expr_type
== EXPR_VARIABLE
4988 && e
->symtree
->n
.sym
->attr
.optional
,
4989 CLASS_DATA (fsym
)->attr
.class_pointer
4990 || CLASS_DATA (fsym
)->attr
.allocatable
);
4992 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4993 allocated on entry, it must be deallocated. */
4994 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4995 && (fsym
->attr
.allocatable
4996 || (fsym
->ts
.type
== BT_CLASS
4997 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5002 gfc_init_block (&block
);
5004 if (e
->ts
.type
== BT_CLASS
)
5005 ptr
= gfc_class_data_get (ptr
);
5007 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5009 gfc_add_expr_to_block (&block
, tmp
);
5010 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5011 void_type_node
, ptr
,
5013 gfc_add_expr_to_block (&block
, tmp
);
5015 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5017 gfc_add_modify (&block
, ptr
,
5018 fold_convert (TREE_TYPE (ptr
),
5019 null_pointer_node
));
5020 gfc_add_expr_to_block (&block
, tmp
);
5022 else if (fsym
->ts
.type
== BT_CLASS
)
5025 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5026 tmp
= gfc_get_symbol_decl (vtab
);
5027 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5028 ptr
= gfc_class_vptr_get (parmse
.expr
);
5029 gfc_add_modify (&block
, ptr
,
5030 fold_convert (TREE_TYPE (ptr
), tmp
));
5031 gfc_add_expr_to_block (&block
, tmp
);
5034 if (fsym
->attr
.optional
5035 && e
->expr_type
== EXPR_VARIABLE
5036 && e
->symtree
->n
.sym
->attr
.optional
)
5038 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5040 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5041 gfc_finish_block (&block
),
5042 build_empty_stmt (input_location
));
5045 tmp
= gfc_finish_block (&block
);
5047 gfc_add_expr_to_block (&se
->pre
, tmp
);
5050 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5051 || fsym
->ts
.type
== BT_ASSUMED
)
5052 && e
->ts
.type
== BT_CLASS
5053 && !CLASS_DATA (e
)->attr
.dimension
5054 && !CLASS_DATA (e
)->attr
.codimension
)
5055 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5057 /* Wrap scalar variable in a descriptor. We need to convert
5058 the address of a pointer back to the pointer itself before,
5059 we can assign it to the data field. */
5061 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5062 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5065 if (TREE_CODE (tmp
) == ADDR_EXPR
5066 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5067 tmp
= TREE_OPERAND (tmp
, 0);
5068 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5070 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5073 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5074 && ((fsym
->attr
.pointer
5075 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5076 || (fsym
->attr
.proc_pointer
5077 && !(e
->expr_type
== EXPR_VARIABLE
5078 && e
->symtree
->n
.sym
->attr
.dummy
))
5079 || (fsym
->attr
.proc_pointer
5080 && e
->expr_type
== EXPR_VARIABLE
5081 && gfc_is_proc_ptr_comp (e
))
5082 || (fsym
->attr
.allocatable
5083 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5085 /* Scalar pointer dummy args require an extra level of
5086 indirection. The null pointer already contains
5087 this level of indirection. */
5088 parm_kind
= SCALAR_POINTER
;
5089 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5093 else if (e
->ts
.type
== BT_CLASS
5094 && fsym
&& fsym
->ts
.type
== BT_CLASS
5095 && (CLASS_DATA (fsym
)->attr
.dimension
5096 || CLASS_DATA (fsym
)->attr
.codimension
))
5098 /* Pass a class array. */
5099 parmse
.use_offset
= 1;
5100 gfc_conv_expr_descriptor (&parmse
, e
);
5102 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5103 allocated on entry, it must be deallocated. */
5104 if (fsym
->attr
.intent
== INTENT_OUT
5105 && CLASS_DATA (fsym
)->attr
.allocatable
)
5110 gfc_init_block (&block
);
5112 ptr
= gfc_class_data_get (ptr
);
5114 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5115 NULL_TREE
, NULL_TREE
,
5118 gfc_add_expr_to_block (&block
, tmp
);
5119 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5120 void_type_node
, ptr
,
5122 gfc_add_expr_to_block (&block
, tmp
);
5123 gfc_reset_vptr (&block
, e
);
5125 if (fsym
->attr
.optional
5126 && e
->expr_type
== EXPR_VARIABLE
5128 || (e
->ref
->type
== REF_ARRAY
5129 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5130 && e
->symtree
->n
.sym
->attr
.optional
)
5132 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5134 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5135 gfc_finish_block (&block
),
5136 build_empty_stmt (input_location
));
5139 tmp
= gfc_finish_block (&block
);
5141 gfc_add_expr_to_block (&se
->pre
, tmp
);
5144 /* The conversion does not repackage the reference to a class
5145 array - _data descriptor. */
5146 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5147 fsym
->attr
.intent
!= INTENT_IN
5148 && (CLASS_DATA (fsym
)->attr
.class_pointer
5149 || CLASS_DATA (fsym
)->attr
.allocatable
),
5151 && e
->expr_type
== EXPR_VARIABLE
5152 && e
->symtree
->n
.sym
->attr
.optional
,
5153 CLASS_DATA (fsym
)->attr
.class_pointer
5154 || CLASS_DATA (fsym
)->attr
.allocatable
);
5158 /* If the procedure requires an explicit interface, the actual
5159 argument is passed according to the corresponding formal
5160 argument. If the corresponding formal argument is a POINTER,
5161 ALLOCATABLE or assumed shape, we do not use g77's calling
5162 convention, and pass the address of the array descriptor
5163 instead. Otherwise we use g77's calling convention. */
5166 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5167 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
5168 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5170 f
= f
|| !comp
->attr
.always_explicit
;
5172 f
= f
|| !sym
->attr
.always_explicit
;
5174 /* If the argument is a function call that may not create
5175 a temporary for the result, we have to check that we
5176 can do it, i.e. that there is no alias between this
5177 argument and another one. */
5178 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5184 intent
= fsym
->attr
.intent
;
5186 intent
= INTENT_UNKNOWN
;
5188 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5190 parmse
.force_tmp
= 1;
5192 iarg
= e
->value
.function
.actual
->expr
;
5194 /* Temporary needed if aliasing due to host association. */
5195 if (sym
->attr
.contained
5197 && !sym
->attr
.implicit_pure
5198 && !sym
->attr
.use_assoc
5199 && iarg
->expr_type
== EXPR_VARIABLE
5200 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5201 parmse
.force_tmp
= 1;
5203 /* Ditto within module. */
5204 if (sym
->attr
.use_assoc
5206 && !sym
->attr
.implicit_pure
5207 && iarg
->expr_type
== EXPR_VARIABLE
5208 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5209 parmse
.force_tmp
= 1;
5212 if (e
->expr_type
== EXPR_VARIABLE
5213 && is_subref_array (e
))
5214 /* The actual argument is a component reference to an
5215 array of derived types. In this case, the argument
5216 is converted to a temporary, which is passed and then
5217 written back after the procedure call. */
5218 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5219 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5220 fsym
&& fsym
->attr
.pointer
);
5221 else if (gfc_is_class_array_ref (e
, NULL
)
5222 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5223 /* The actual argument is a component reference to an
5224 array of derived types. In this case, the argument
5225 is converted to a temporary, which is passed and then
5226 written back after the procedure call.
5227 OOP-TODO: Insert code so that if the dynamic type is
5228 the same as the declared type, copy-in/copy-out does
5230 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5231 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5232 fsym
&& fsym
->attr
.pointer
);
5234 else if (gfc_is_alloc_class_array_function (e
)
5235 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5236 /* See previous comment. For function actual argument,
5237 the write out is not needed so the intent is set as
5240 e
->must_finalize
= 1;
5241 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5243 fsym
&& fsym
->attr
.pointer
);
5246 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
5248 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5249 allocated on entry, it must be deallocated. */
5250 if (fsym
&& fsym
->attr
.allocatable
5251 && fsym
->attr
.intent
== INTENT_OUT
)
5253 tmp
= build_fold_indirect_ref_loc (input_location
,
5255 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5256 if (fsym
->attr
.optional
5257 && e
->expr_type
== EXPR_VARIABLE
5258 && e
->symtree
->n
.sym
->attr
.optional
)
5259 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5261 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5262 tmp
, build_empty_stmt (input_location
));
5263 gfc_add_expr_to_block (&se
->pre
, tmp
);
5268 /* The case with fsym->attr.optional is that of a user subroutine
5269 with an interface indicating an optional argument. When we call
5270 an intrinsic subroutine, however, fsym is NULL, but we might still
5271 have an optional argument, so we proceed to the substitution
5273 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5275 /* If an optional argument is itself an optional dummy argument,
5276 check its presence and substitute a null if absent. This is
5277 only needed when passing an array to an elemental procedure
5278 as then array elements are accessed - or no NULL pointer is
5279 allowed and a "1" or "0" should be passed if not present.
5280 When passing a non-array-descriptor full array to a
5281 non-array-descriptor dummy, no check is needed. For
5282 array-descriptor actual to array-descriptor dummy, see
5283 PR 41911 for why a check has to be inserted.
5284 fsym == NULL is checked as intrinsics required the descriptor
5285 but do not always set fsym. */
5286 if (e
->expr_type
== EXPR_VARIABLE
5287 && e
->symtree
->n
.sym
->attr
.optional
5288 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
5289 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5293 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5294 || fsym
->as
->type
== AS_ASSUMED_RANK
5295 || fsym
->as
->type
== AS_DEFERRED
))))))
5296 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5297 e
->representation
.length
);
5302 /* Obtain the character length of an assumed character length
5303 length procedure from the typespec. */
5304 if (fsym
->ts
.type
== BT_CHARACTER
5305 && parmse
.string_length
== NULL_TREE
5306 && e
->ts
.type
== BT_PROCEDURE
5307 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5308 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5309 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5311 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5312 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5316 if (fsym
&& need_interface_mapping
&& e
)
5317 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5319 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5320 gfc_add_block_to_block (&post
, &parmse
.post
);
5322 /* Allocated allocatable components of derived types must be
5323 deallocated for non-variable scalars. Non-variable arrays are
5324 dealt with in trans-array.c(gfc_conv_array_parameter). */
5325 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5326 && e
->ts
.u
.derived
->attr
.alloc_comp
5327 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
5328 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
5331 tmp
= build_fold_indirect_ref_loc (input_location
,
5333 parm_rank
= e
->rank
;
5341 case (SCALAR_POINTER
):
5342 tmp
= build_fold_indirect_ref_loc (input_location
,
5347 if (e
->expr_type
== EXPR_OP
5348 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5349 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5352 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5353 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5354 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5357 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5359 /* The derived type is passed to gfc_deallocate_alloc_comp.
5360 Therefore, class actuals can handled correctly but derived
5361 types passed to class formals need the _data component. */
5362 tmp
= gfc_class_data_get (tmp
);
5363 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5364 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5367 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5369 gfc_add_expr_to_block (&se
->post
, tmp
);
5372 /* Add argument checking of passing an unallocated/NULL actual to
5373 a nonallocatable/nonpointer dummy. */
5375 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5377 symbol_attribute attr
;
5381 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5382 attr
= gfc_expr_attr (e
);
5384 goto end_pointer_check
;
5386 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5387 allocatable to an optional dummy, cf. 12.5.2.12. */
5388 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5389 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5390 goto end_pointer_check
;
5394 /* If the actual argument is an optional pointer/allocatable and
5395 the formal argument takes an nonpointer optional value,
5396 it is invalid to pass a non-present argument on, even
5397 though there is no technical reason for this in gfortran.
5398 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5399 tree present
, null_ptr
, type
;
5401 if (attr
.allocatable
5402 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5403 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5404 "allocated or not present",
5405 e
->symtree
->n
.sym
->name
);
5406 else if (attr
.pointer
5407 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5408 msg
= xasprintf ("Pointer actual argument '%s' is not "
5409 "associated or not present",
5410 e
->symtree
->n
.sym
->name
);
5411 else if (attr
.proc_pointer
5412 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5413 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5414 "associated or not present",
5415 e
->symtree
->n
.sym
->name
);
5417 goto end_pointer_check
;
5419 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5420 type
= TREE_TYPE (present
);
5421 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5422 boolean_type_node
, present
,
5424 null_pointer_node
));
5425 type
= TREE_TYPE (parmse
.expr
);
5426 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5427 boolean_type_node
, parmse
.expr
,
5429 null_pointer_node
));
5430 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5431 boolean_type_node
, present
, null_ptr
);
5435 if (attr
.allocatable
5436 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5437 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5438 "allocated", e
->symtree
->n
.sym
->name
);
5439 else if (attr
.pointer
5440 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5441 msg
= xasprintf ("Pointer actual argument '%s' is not "
5442 "associated", e
->symtree
->n
.sym
->name
);
5443 else if (attr
.proc_pointer
5444 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5445 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5446 "associated", e
->symtree
->n
.sym
->name
);
5448 goto end_pointer_check
;
5452 /* If the argument is passed by value, we need to strip the
5454 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5455 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5457 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5458 boolean_type_node
, tmp
,
5459 fold_convert (TREE_TYPE (tmp
),
5460 null_pointer_node
));
5463 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5469 /* Deferred length dummies pass the character length by reference
5470 so that the value can be returned. */
5471 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5473 if (INDIRECT_REF_P (parmse
.string_length
))
5474 /* In chains of functions/procedure calls the string_length already
5475 is a pointer to the variable holding the length. Therefore
5476 remove the deref on call. */
5477 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5480 tmp
= parmse
.string_length
;
5481 if (TREE_CODE (tmp
) != VAR_DECL
)
5482 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5483 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5487 /* Character strings are passed as two parameters, a length and a
5488 pointer - except for Bind(c) which only passes the pointer.
5489 An unlimited polymorphic formal argument likewise does not
5491 if (parmse
.string_length
!= NULL_TREE
5492 && !sym
->attr
.is_bind_c
5493 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5494 vec_safe_push (stringargs
, parmse
.string_length
);
5496 /* When calling __copy for character expressions to unlimited
5497 polymorphic entities, the dst argument needs a string length. */
5498 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5499 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5500 && arg
->next
&& arg
->next
->expr
5501 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5502 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5503 vec_safe_push (stringargs
, parmse
.string_length
);
5505 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5506 pass the token and the offset as additional arguments. */
5507 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5508 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5509 && !fsym
->attr
.allocatable
)
5510 || (fsym
->ts
.type
== BT_CLASS
5511 && CLASS_DATA (fsym
)->attr
.codimension
5512 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5514 /* Token and offset. */
5515 vec_safe_push (stringargs
, null_pointer_node
);
5516 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5517 gcc_assert (fsym
->attr
.optional
);
5519 else if (fsym
&& 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 tree caf_decl
, caf_type
;
5529 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5530 caf_type
= TREE_TYPE (caf_decl
);
5532 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5533 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5534 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5535 tmp
= gfc_conv_descriptor_token (caf_decl
);
5536 else if (DECL_LANG_SPECIFIC (caf_decl
)
5537 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5538 tmp
= GFC_DECL_TOKEN (caf_decl
);
5541 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5542 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5543 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5546 vec_safe_push (stringargs
, tmp
);
5548 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5549 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5550 offset
= build_int_cst (gfc_array_index_type
, 0);
5551 else if (DECL_LANG_SPECIFIC (caf_decl
)
5552 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5553 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5554 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5555 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5557 offset
= build_int_cst (gfc_array_index_type
, 0);
5559 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5560 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5563 gcc_assert (POINTER_TYPE_P (caf_type
));
5567 tmp2
= fsym
->ts
.type
== BT_CLASS
5568 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5569 if ((fsym
->ts
.type
!= BT_CLASS
5570 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5571 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5572 || (fsym
->ts
.type
== BT_CLASS
5573 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5574 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5576 if (fsym
->ts
.type
== BT_CLASS
)
5577 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5580 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5581 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5583 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5584 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5586 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5587 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5590 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5593 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5594 gfc_array_index_type
,
5595 fold_convert (gfc_array_index_type
, tmp2
),
5596 fold_convert (gfc_array_index_type
, tmp
));
5597 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5598 gfc_array_index_type
, offset
, tmp
);
5600 vec_safe_push (stringargs
, offset
);
5603 vec_safe_push (arglist
, parmse
.expr
);
5605 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5612 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5613 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5614 else if (ts
.type
== BT_CHARACTER
)
5616 if (ts
.u
.cl
->length
== NULL
)
5618 /* Assumed character length results are not allowed by 5.1.1.5 of the
5619 standard and are trapped in resolve.c; except in the case of SPREAD
5620 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5621 we take the character length of the first argument for the result.
5622 For dummies, we have to look through the formal argument list for
5623 this function and use the character length found there.*/
5625 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5626 else if (!sym
->attr
.dummy
)
5627 cl
.backend_decl
= (*stringargs
)[0];
5630 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5631 for (; formal
; formal
= formal
->next
)
5632 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5633 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5635 len
= cl
.backend_decl
;
5641 /* Calculate the length of the returned string. */
5642 gfc_init_se (&parmse
, NULL
);
5643 if (need_interface_mapping
)
5644 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5646 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5647 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5648 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5650 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5651 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5652 gfc_charlen_type_node
, tmp
,
5653 build_int_cst (gfc_charlen_type_node
, 0));
5654 cl
.backend_decl
= tmp
;
5657 /* Set up a charlen structure for it. */
5662 len
= cl
.backend_decl
;
5665 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5666 || (!comp
&& gfc_return_by_reference (sym
));
5669 if (se
->direct_byref
)
5671 /* Sometimes, too much indirection can be applied; e.g. for
5672 function_result = array_valued_recursive_function. */
5673 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5674 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5675 && GFC_DESCRIPTOR_TYPE_P
5676 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5677 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5680 /* If the lhs of an assignment x = f(..) is allocatable and
5681 f2003 is allowed, we must do the automatic reallocation.
5682 TODO - deal with intrinsics, without using a temporary. */
5683 if (flag_realloc_lhs
5684 && se
->ss
&& se
->ss
->loop_chain
5685 && se
->ss
->loop_chain
->is_alloc_lhs
5686 && !expr
->value
.function
.isym
5687 && sym
->result
->as
!= NULL
)
5689 /* Evaluate the bounds of the result, if known. */
5690 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5693 /* Perform the automatic reallocation. */
5694 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5696 gfc_add_expr_to_block (&se
->pre
, tmp
);
5698 /* Pass the temporary as the first argument. */
5699 result
= info
->descriptor
;
5702 result
= build_fold_indirect_ref_loc (input_location
,
5704 vec_safe_push (retargs
, se
->expr
);
5706 else if (comp
&& comp
->attr
.dimension
)
5708 gcc_assert (se
->loop
&& info
);
5710 /* Set the type of the array. */
5711 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5712 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5714 /* Evaluate the bounds of the result, if known. */
5715 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5717 /* If the lhs of an assignment x = f(..) is allocatable and
5718 f2003 is allowed, we must not generate the function call
5719 here but should just send back the results of the mapping.
5720 This is signalled by the function ss being flagged. */
5721 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5723 gfc_free_interface_mapping (&mapping
);
5724 return has_alternate_specifier
;
5727 /* Create a temporary to store the result. In case the function
5728 returns a pointer, the temporary will be a shallow copy and
5729 mustn't be deallocated. */
5730 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5731 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5732 tmp
, NULL_TREE
, false,
5733 !comp
->attr
.pointer
, callee_alloc
,
5734 &se
->ss
->info
->expr
->where
);
5736 /* Pass the temporary as the first argument. */
5737 result
= info
->descriptor
;
5738 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5739 vec_safe_push (retargs
, tmp
);
5741 else if (!comp
&& sym
->result
->attr
.dimension
)
5743 gcc_assert (se
->loop
&& info
);
5745 /* Set the type of the array. */
5746 tmp
= gfc_typenode_for_spec (&ts
);
5747 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5749 /* Evaluate the bounds of the result, if known. */
5750 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5752 /* If the lhs of an assignment x = f(..) is allocatable and
5753 f2003 is allowed, we must not generate the function call
5754 here but should just send back the results of the mapping.
5755 This is signalled by the function ss being flagged. */
5756 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5758 gfc_free_interface_mapping (&mapping
);
5759 return has_alternate_specifier
;
5762 /* Create a temporary to store the result. In case the function
5763 returns a pointer, the temporary will be a shallow copy and
5764 mustn't be deallocated. */
5765 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5766 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5767 tmp
, NULL_TREE
, false,
5768 !sym
->attr
.pointer
, callee_alloc
,
5769 &se
->ss
->info
->expr
->where
);
5771 /* Pass the temporary as the first argument. */
5772 result
= info
->descriptor
;
5773 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5774 vec_safe_push (retargs
, tmp
);
5776 else if (ts
.type
== BT_CHARACTER
)
5778 /* Pass the string length. */
5779 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5780 type
= build_pointer_type (type
);
5782 /* Return an address to a char[0:len-1]* temporary for
5783 character pointers. */
5784 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5785 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5787 var
= gfc_create_var (type
, "pstr");
5789 if ((!comp
&& sym
->attr
.allocatable
)
5790 || (comp
&& comp
->attr
.allocatable
))
5792 gfc_add_modify (&se
->pre
, var
,
5793 fold_convert (TREE_TYPE (var
),
5794 null_pointer_node
));
5795 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5796 gfc_add_expr_to_block (&se
->post
, tmp
);
5799 /* Provide an address expression for the function arguments. */
5800 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5803 var
= gfc_conv_string_tmp (se
, type
, len
);
5805 vec_safe_push (retargs
, var
);
5809 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5811 type
= gfc_get_complex_type (ts
.kind
);
5812 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5813 vec_safe_push (retargs
, var
);
5816 /* Add the string length to the argument list. */
5817 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5820 if (TREE_CODE (tmp
) != VAR_DECL
)
5821 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5822 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5823 vec_safe_push (retargs
, tmp
);
5825 else if (ts
.type
== BT_CHARACTER
)
5826 vec_safe_push (retargs
, len
);
5828 gfc_free_interface_mapping (&mapping
);
5830 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5831 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5832 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5833 vec_safe_reserve (retargs
, arglen
);
5835 /* Add the return arguments. */
5836 retargs
->splice (arglist
);
5838 /* Add the hidden present status for optional+value to the arguments. */
5839 retargs
->splice (optionalargs
);
5841 /* Add the hidden string length parameters to the arguments. */
5842 retargs
->splice (stringargs
);
5844 /* We may want to append extra arguments here. This is used e.g. for
5845 calls to libgfortran_matmul_??, which need extra information. */
5846 if (!vec_safe_is_empty (append_args
))
5847 retargs
->splice (append_args
);
5850 /* Generate the actual call. */
5851 if (base_object
== NULL_TREE
)
5852 conv_function_val (se
, sym
, expr
);
5854 conv_base_obj_fcn_val (se
, base_object
, expr
);
5856 /* If there are alternate return labels, function type should be
5857 integer. Can't modify the type in place though, since it can be shared
5858 with other functions. For dummy arguments, the typing is done to
5859 this result, even if it has to be repeated for each call. */
5860 if (has_alternate_specifier
5861 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5863 if (!sym
->attr
.dummy
)
5865 TREE_TYPE (sym
->backend_decl
)
5866 = build_function_type (integer_type_node
,
5867 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5868 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5871 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5874 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5875 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5877 /* If we have a pointer function, but we don't want a pointer, e.g.
5880 where f is pointer valued, we have to dereference the result. */
5881 if (!se
->want_pointer
&& !byref
5882 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5883 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5884 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5886 /* f2c calling conventions require a scalar default real function to
5887 return a double precision result. Convert this back to default
5888 real. We only care about the cases that can happen in Fortran 77.
5890 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5891 && sym
->ts
.kind
== gfc_default_real_kind
5892 && !sym
->attr
.always_explicit
)
5893 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5895 /* A pure function may still have side-effects - it may modify its
5897 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5899 if (!sym
->attr
.pure
)
5900 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5905 /* Add the function call to the pre chain. There is no expression. */
5906 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5907 se
->expr
= NULL_TREE
;
5909 if (!se
->direct_byref
)
5911 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5913 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5915 /* Check the data pointer hasn't been modified. This would
5916 happen in a function returning a pointer. */
5917 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5918 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5921 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5924 se
->expr
= info
->descriptor
;
5925 /* Bundle in the string length. */
5926 se
->string_length
= len
;
5928 else if (ts
.type
== BT_CHARACTER
)
5930 /* Dereference for character pointer results. */
5931 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5932 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5933 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5937 se
->string_length
= len
;
5941 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5942 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5947 /* Follow the function call with the argument post block. */
5950 gfc_add_block_to_block (&se
->pre
, &post
);
5952 /* Transformational functions of derived types with allocatable
5953 components must have the result allocatable components copied. */
5954 arg
= expr
->value
.function
.actual
;
5955 if (result
&& arg
&& expr
->rank
5956 && expr
->value
.function
.isym
5957 && expr
->value
.function
.isym
->transformational
5958 && arg
->expr
->ts
.type
== BT_DERIVED
5959 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5962 /* Copy the allocatable components. We have to use a
5963 temporary here to prevent source allocatable components
5964 from being corrupted. */
5965 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5966 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5967 result
, tmp2
, expr
->rank
);
5968 gfc_add_expr_to_block (&se
->pre
, tmp
);
5969 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5971 gfc_add_expr_to_block (&se
->pre
, tmp
);
5973 /* Finally free the temporary's data field. */
5974 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5975 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5976 NULL_TREE
, NULL_TREE
, true,
5978 gfc_add_expr_to_block (&se
->pre
, tmp
);
5983 /* For a function with a class array result, save the result as
5984 a temporary, set the info fields needed by the scalarizer and
5985 call the finalization function of the temporary. Note that the
5986 nullification of allocatable components needed by the result
5987 is done in gfc_trans_assignment_1. */
5988 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
5989 && se
->ss
&& se
->ss
->loop
)
5990 || gfc_is_alloc_class_scalar_function (expr
))
5991 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
5992 && expr
->must_finalize
)
5997 if (se
->ss
&& se
->ss
->loop
)
5999 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6000 tmp
= gfc_class_data_get (se
->expr
);
6001 info
->descriptor
= tmp
;
6002 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6003 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6004 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6006 tree dim
= gfc_rank_cst
[n
];
6007 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6008 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6013 /* TODO Eliminate the doubling of temporaries. This
6014 one is necessary to ensure no memory leakage. */
6015 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6016 tmp
= gfc_class_data_get (se
->expr
);
6017 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6018 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6021 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6022 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6025 fold_convert (TREE_TYPE (final_fndecl
),
6026 null_pointer_node
));
6027 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6029 tmp
= build_call_expr_loc (input_location
,
6031 gfc_build_addr_expr (NULL
, tmp
),
6032 gfc_class_vtab_size_get (se
->expr
),
6033 boolean_false_node
);
6034 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6035 void_type_node
, is_final
, tmp
,
6036 build_empty_stmt (input_location
));
6038 if (se
->ss
&& se
->ss
->loop
)
6040 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6041 tmp
= gfc_call_free (convert (pvoid_type_node
, info
->data
));
6042 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6046 gfc_add_expr_to_block (&se
->post
, tmp
);
6047 tmp
= gfc_class_data_get (se
->expr
);
6048 tmp
= gfc_call_free (convert (pvoid_type_node
, tmp
));
6049 gfc_add_expr_to_block (&se
->post
, tmp
);
6051 expr
->must_finalize
= 0;
6054 gfc_add_block_to_block (&se
->post
, &post
);
6057 return has_alternate_specifier
;
6061 /* Fill a character string with spaces. */
6064 fill_with_spaces (tree start
, tree type
, tree size
)
6066 stmtblock_t block
, loop
;
6067 tree i
, el
, exit_label
, cond
, tmp
;
6069 /* For a simple char type, we can call memset(). */
6070 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6071 return build_call_expr_loc (input_location
,
6072 builtin_decl_explicit (BUILT_IN_MEMSET
),
6074 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6075 lang_hooks
.to_target_charset (' ')),
6078 /* Otherwise, we use a loop:
6079 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6083 /* Initialize variables. */
6084 gfc_init_block (&block
);
6085 i
= gfc_create_var (sizetype
, "i");
6086 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6087 el
= gfc_create_var (build_pointer_type (type
), "el");
6088 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6089 exit_label
= gfc_build_label_decl (NULL_TREE
);
6090 TREE_USED (exit_label
) = 1;
6094 gfc_init_block (&loop
);
6096 /* Exit condition. */
6097 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6098 build_zero_cst (sizetype
));
6099 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6100 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6101 build_empty_stmt (input_location
));
6102 gfc_add_expr_to_block (&loop
, tmp
);
6105 gfc_add_modify (&loop
,
6106 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6107 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6109 /* Increment loop variables. */
6110 gfc_add_modify (&loop
, i
,
6111 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6112 TYPE_SIZE_UNIT (type
)));
6113 gfc_add_modify (&loop
, el
,
6114 fold_build_pointer_plus_loc (input_location
,
6115 el
, TYPE_SIZE_UNIT (type
)));
6117 /* Making the loop... actually loop! */
6118 tmp
= gfc_finish_block (&loop
);
6119 tmp
= build1_v (LOOP_EXPR
, tmp
);
6120 gfc_add_expr_to_block (&block
, tmp
);
6122 /* The exit label. */
6123 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6124 gfc_add_expr_to_block (&block
, tmp
);
6127 return gfc_finish_block (&block
);
6131 /* Generate code to copy a string. */
6134 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6135 int dkind
, tree slength
, tree src
, int skind
)
6137 tree tmp
, dlen
, slen
;
6146 stmtblock_t tempblock
;
6148 gcc_assert (dkind
== skind
);
6150 if (slength
!= NULL_TREE
)
6152 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6153 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6157 slen
= build_int_cst (size_type_node
, 1);
6161 if (dlength
!= NULL_TREE
)
6163 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6164 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6168 dlen
= build_int_cst (size_type_node
, 1);
6172 /* Assign directly if the types are compatible. */
6173 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6174 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6176 gfc_add_modify (block
, dsc
, ssc
);
6180 /* Do nothing if the destination length is zero. */
6181 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6182 build_int_cst (size_type_node
, 0));
6184 /* The following code was previously in _gfortran_copy_string:
6186 // The two strings may overlap so we use memmove.
6188 copy_string (GFC_INTEGER_4 destlen, char * dest,
6189 GFC_INTEGER_4 srclen, const char * src)
6191 if (srclen >= destlen)
6193 // This will truncate if too long.
6194 memmove (dest, src, destlen);
6198 memmove (dest, src, srclen);
6200 memset (&dest[srclen], ' ', destlen - srclen);
6204 We're now doing it here for better optimization, but the logic
6207 /* For non-default character kinds, we have to multiply the string
6208 length by the base type size. */
6209 chartype
= gfc_get_char_type (dkind
);
6210 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6211 fold_convert (size_type_node
, slen
),
6212 fold_convert (size_type_node
,
6213 TYPE_SIZE_UNIT (chartype
)));
6214 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6215 fold_convert (size_type_node
, dlen
),
6216 fold_convert (size_type_node
,
6217 TYPE_SIZE_UNIT (chartype
)));
6219 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6220 dest
= fold_convert (pvoid_type_node
, dest
);
6222 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6224 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6225 src
= fold_convert (pvoid_type_node
, src
);
6227 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6229 /* Truncate string if source is too long. */
6230 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6232 tmp2
= build_call_expr_loc (input_location
,
6233 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6234 3, dest
, src
, dlen
);
6236 /* Else copy and pad with spaces. */
6237 tmp3
= build_call_expr_loc (input_location
,
6238 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6239 3, dest
, src
, slen
);
6241 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6242 tmp4
= fill_with_spaces (tmp4
, chartype
,
6243 fold_build2_loc (input_location
, MINUS_EXPR
,
6244 TREE_TYPE(dlen
), dlen
, slen
));
6246 gfc_init_block (&tempblock
);
6247 gfc_add_expr_to_block (&tempblock
, tmp3
);
6248 gfc_add_expr_to_block (&tempblock
, tmp4
);
6249 tmp3
= gfc_finish_block (&tempblock
);
6251 /* The whole copy_string function is there. */
6252 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6254 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6255 build_empty_stmt (input_location
));
6256 gfc_add_expr_to_block (block
, tmp
);
6260 /* Translate a statement function.
6261 The value of a statement function reference is obtained by evaluating the
6262 expression using the values of the actual arguments for the values of the
6263 corresponding dummy arguments. */
6266 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6270 gfc_formal_arglist
*fargs
;
6271 gfc_actual_arglist
*args
;
6274 gfc_saved_var
*saved_vars
;
6280 sym
= expr
->symtree
->n
.sym
;
6281 args
= expr
->value
.function
.actual
;
6282 gfc_init_se (&lse
, NULL
);
6283 gfc_init_se (&rse
, NULL
);
6286 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6288 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6289 temp_vars
= XCNEWVEC (tree
, n
);
6291 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6292 fargs
= fargs
->next
, n
++)
6294 /* Each dummy shall be specified, explicitly or implicitly, to be
6296 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6299 if (fsym
->ts
.type
== BT_CHARACTER
)
6301 /* Copy string arguments. */
6304 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6305 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6307 /* Create a temporary to hold the value. */
6308 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6309 fsym
->ts
.u
.cl
->backend_decl
6310 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6312 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6313 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6315 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6317 gfc_conv_expr (&rse
, args
->expr
);
6318 gfc_conv_string_parameter (&rse
);
6319 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6320 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6322 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6323 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6324 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6325 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6329 /* For everything else, just evaluate the expression. */
6331 /* Create a temporary to hold the value. */
6332 type
= gfc_typenode_for_spec (&fsym
->ts
);
6333 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6335 gfc_conv_expr (&lse
, args
->expr
);
6337 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6338 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6339 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6345 /* Use the temporary variables in place of the real ones. */
6346 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6347 fargs
= fargs
->next
, n
++)
6348 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6350 gfc_conv_expr (se
, sym
->value
);
6352 if (sym
->ts
.type
== BT_CHARACTER
)
6354 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6356 /* Force the expression to the correct length. */
6357 if (!INTEGER_CST_P (se
->string_length
)
6358 || tree_int_cst_lt (se
->string_length
,
6359 sym
->ts
.u
.cl
->backend_decl
))
6361 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6362 tmp
= gfc_create_var (type
, sym
->name
);
6363 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6364 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6365 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6369 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6372 /* Restore the original variables. */
6373 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6374 fargs
= fargs
->next
, n
++)
6375 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6381 /* Translate a function expression. */
6384 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6388 if (expr
->value
.function
.isym
)
6390 gfc_conv_intrinsic_function (se
, expr
);
6394 /* expr.value.function.esym is the resolved (specific) function symbol for
6395 most functions. However this isn't set for dummy procedures. */
6396 sym
= expr
->value
.function
.esym
;
6398 sym
= expr
->symtree
->n
.sym
;
6400 /* The IEEE_ARITHMETIC functions are caught here. */
6401 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6402 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6405 /* We distinguish statement functions from general functions to improve
6406 runtime performance. */
6407 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6409 gfc_conv_statement_function (se
, expr
);
6413 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6418 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6421 is_zero_initializer_p (gfc_expr
* expr
)
6423 if (expr
->expr_type
!= EXPR_CONSTANT
)
6426 /* We ignore constants with prescribed memory representations for now. */
6427 if (expr
->representation
.string
)
6430 switch (expr
->ts
.type
)
6433 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6436 return mpfr_zero_p (expr
->value
.real
)
6437 && MPFR_SIGN (expr
->value
.real
) >= 0;
6440 return expr
->value
.logical
== 0;
6443 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6444 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6445 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6446 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6456 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6461 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6462 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6464 gfc_conv_tmp_array_ref (se
);
6468 /* Build a static initializer. EXPR is the expression for the initial value.
6469 The other parameters describe the variable of the component being
6470 initialized. EXPR may be null. */
6473 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6474 bool array
, bool pointer
, bool procptr
)
6478 if (!(expr
|| pointer
|| procptr
))
6481 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6482 (these are the only two iso_c_binding derived types that can be
6483 used as initialization expressions). If so, we need to modify
6484 the 'expr' to be that for a (void *). */
6485 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6486 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6488 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6490 /* The derived symbol has already been converted to a (void *). Use
6492 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6493 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6495 gfc_init_se (&se
, NULL
);
6496 gfc_conv_constant (&se
, expr
);
6497 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6501 if (array
&& !procptr
)
6504 /* Arrays need special handling. */
6506 ctor
= gfc_build_null_descriptor (type
);
6507 /* Special case assigning an array to zero. */
6508 else if (is_zero_initializer_p (expr
))
6509 ctor
= build_constructor (type
, NULL
);
6511 ctor
= gfc_conv_array_initializer (type
, expr
);
6512 TREE_STATIC (ctor
) = 1;
6515 else if (pointer
|| procptr
)
6517 if (ts
->type
== BT_CLASS
&& !procptr
)
6519 gfc_init_se (&se
, NULL
);
6520 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6521 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6522 TREE_STATIC (se
.expr
) = 1;
6525 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6526 return fold_convert (type
, null_pointer_node
);
6529 gfc_init_se (&se
, NULL
);
6530 se
.want_pointer
= 1;
6531 gfc_conv_expr (&se
, expr
);
6532 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6542 gfc_init_se (&se
, NULL
);
6543 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6544 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6546 gfc_conv_structure (&se
, expr
, 1);
6547 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6548 TREE_STATIC (se
.expr
) = 1;
6553 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6554 TREE_STATIC (ctor
) = 1;
6559 gfc_init_se (&se
, NULL
);
6560 gfc_conv_constant (&se
, expr
);
6561 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6568 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6574 gfc_array_info
*lss_array
;
6581 gfc_start_block (&block
);
6583 /* Initialize the scalarizer. */
6584 gfc_init_loopinfo (&loop
);
6586 gfc_init_se (&lse
, NULL
);
6587 gfc_init_se (&rse
, NULL
);
6590 rss
= gfc_walk_expr (expr
);
6591 if (rss
== gfc_ss_terminator
)
6592 /* The rhs is scalar. Add a ss for the expression. */
6593 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6595 /* Create a SS for the destination. */
6596 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6598 lss_array
= &lss
->info
->data
.array
;
6599 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6600 lss_array
->descriptor
= dest
;
6601 lss_array
->data
= gfc_conv_array_data (dest
);
6602 lss_array
->offset
= gfc_conv_array_offset (dest
);
6603 for (n
= 0; n
< cm
->as
->rank
; n
++)
6605 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6606 lss_array
->stride
[n
] = gfc_index_one_node
;
6608 mpz_init (lss_array
->shape
[n
]);
6609 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6610 cm
->as
->lower
[n
]->value
.integer
);
6611 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6614 /* Associate the SS with the loop. */
6615 gfc_add_ss_to_loop (&loop
, lss
);
6616 gfc_add_ss_to_loop (&loop
, rss
);
6618 /* Calculate the bounds of the scalarization. */
6619 gfc_conv_ss_startstride (&loop
);
6621 /* Setup the scalarizing loops. */
6622 gfc_conv_loop_setup (&loop
, &expr
->where
);
6624 /* Setup the gfc_se structures. */
6625 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6626 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6629 gfc_mark_ss_chain_used (rss
, 1);
6631 gfc_mark_ss_chain_used (lss
, 1);
6633 /* Start the scalarized loop body. */
6634 gfc_start_scalarized_body (&loop
, &body
);
6636 gfc_conv_tmp_array_ref (&lse
);
6637 if (cm
->ts
.type
== BT_CHARACTER
)
6638 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6640 gfc_conv_expr (&rse
, expr
);
6642 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6643 gfc_add_expr_to_block (&body
, tmp
);
6645 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6647 /* Generate the copying loops. */
6648 gfc_trans_scalarizing_loops (&loop
, &body
);
6650 /* Wrap the whole thing up. */
6651 gfc_add_block_to_block (&block
, &loop
.pre
);
6652 gfc_add_block_to_block (&block
, &loop
.post
);
6654 gcc_assert (lss_array
->shape
!= NULL
);
6655 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6656 gfc_cleanup_loop (&loop
);
6658 return gfc_finish_block (&block
);
6663 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6673 gfc_expr
*arg
= NULL
;
6675 gfc_start_block (&block
);
6676 gfc_init_se (&se
, NULL
);
6678 /* Get the descriptor for the expressions. */
6679 se
.want_pointer
= 0;
6680 gfc_conv_expr_descriptor (&se
, expr
);
6681 gfc_add_block_to_block (&block
, &se
.pre
);
6682 gfc_add_modify (&block
, dest
, se
.expr
);
6684 /* Deal with arrays of derived types with allocatable components. */
6685 if (cm
->ts
.type
== BT_DERIVED
6686 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6687 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6690 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6691 && CLASS_DATA(cm
)->attr
.allocatable
)
6693 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6694 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6699 tmp
= TREE_TYPE (dest
);
6700 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6701 tmp
, expr
->rank
, NULL_TREE
);
6705 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6706 TREE_TYPE(cm
->backend_decl
),
6707 cm
->as
->rank
, NULL_TREE
);
6709 gfc_add_expr_to_block (&block
, tmp
);
6710 gfc_add_block_to_block (&block
, &se
.post
);
6712 if (expr
->expr_type
!= EXPR_VARIABLE
)
6713 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6716 /* We need to know if the argument of a conversion function is a
6717 variable, so that the correct lower bound can be used. */
6718 if (expr
->expr_type
== EXPR_FUNCTION
6719 && expr
->value
.function
.isym
6720 && expr
->value
.function
.isym
->conversion
6721 && expr
->value
.function
.actual
->expr
6722 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6723 arg
= expr
->value
.function
.actual
->expr
;
6725 /* Obtain the array spec of full array references. */
6727 as
= gfc_get_full_arrayspec_from_expr (arg
);
6729 as
= gfc_get_full_arrayspec_from_expr (expr
);
6731 /* Shift the lbound and ubound of temporaries to being unity,
6732 rather than zero, based. Always calculate the offset. */
6733 offset
= gfc_conv_descriptor_offset_get (dest
);
6734 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6735 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6737 for (n
= 0; n
< expr
->rank
; n
++)
6742 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6743 TODO It looks as if gfc_conv_expr_descriptor should return
6744 the correct bounds and that the following should not be
6745 necessary. This would simplify gfc_conv_intrinsic_bound
6747 if (as
&& as
->lower
[n
])
6750 gfc_init_se (&lbse
, NULL
);
6751 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6752 gfc_add_block_to_block (&block
, &lbse
.pre
);
6753 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6757 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6758 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6762 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6765 lbound
= gfc_index_one_node
;
6767 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6769 /* Shift the bounds and set the offset accordingly. */
6770 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6771 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6772 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6773 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6775 gfc_conv_descriptor_ubound_set (&block
, dest
,
6776 gfc_rank_cst
[n
], tmp
);
6777 gfc_conv_descriptor_lbound_set (&block
, dest
,
6778 gfc_rank_cst
[n
], lbound
);
6780 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6781 gfc_conv_descriptor_lbound_get (dest
,
6783 gfc_conv_descriptor_stride_get (dest
,
6785 gfc_add_modify (&block
, tmp2
, tmp
);
6786 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6788 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6793 /* If a conversion expression has a null data pointer
6794 argument, nullify the allocatable component. */
6798 if (arg
->symtree
->n
.sym
->attr
.allocatable
6799 || arg
->symtree
->n
.sym
->attr
.pointer
)
6801 non_null_expr
= gfc_finish_block (&block
);
6802 gfc_start_block (&block
);
6803 gfc_conv_descriptor_data_set (&block
, dest
,
6805 null_expr
= gfc_finish_block (&block
);
6806 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6807 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6808 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6809 return build3_v (COND_EXPR
, tmp
,
6810 null_expr
, non_null_expr
);
6814 return gfc_finish_block (&block
);
6818 /* Allocate or reallocate scalar component, as necessary. */
6821 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6831 tree lhs_cl_size
= NULL_TREE
;
6836 if (!expr2
|| expr2
->rank
)
6839 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6841 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6843 char name
[GFC_MAX_SYMBOL_LEN
+9];
6844 gfc_component
*strlen
;
6845 /* Use the rhs string length and the lhs element size. */
6846 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6847 if (!expr2
->ts
.u
.cl
->backend_decl
)
6849 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6850 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6853 size
= expr2
->ts
.u
.cl
->backend_decl
;
6855 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6857 sprintf (name
, "_%s_length", cm
->name
);
6858 strlen
= gfc_find_component (sym
, name
, true, true);
6859 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6860 gfc_charlen_type_node
,
6861 TREE_OPERAND (comp
, 0),
6862 strlen
->backend_decl
, NULL_TREE
);
6864 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6865 tmp
= TYPE_SIZE_UNIT (tmp
);
6866 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6867 TREE_TYPE (tmp
), tmp
,
6868 fold_convert (TREE_TYPE (tmp
), size
));
6872 /* Otherwise use the length in bytes of the rhs. */
6873 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6874 size_in_bytes
= size
;
6877 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6878 size_in_bytes
, size_one_node
);
6880 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6882 tmp
= build_call_expr_loc (input_location
,
6883 builtin_decl_explicit (BUILT_IN_CALLOC
),
6884 2, build_one_cst (size_type_node
),
6886 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6887 gfc_add_modify (block
, comp
, tmp
);
6891 tmp
= build_call_expr_loc (input_location
,
6892 builtin_decl_explicit (BUILT_IN_MALLOC
),
6894 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
6895 ptr
= gfc_class_data_get (comp
);
6898 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
6899 gfc_add_modify (block
, ptr
, tmp
);
6902 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6903 /* Update the lhs character length. */
6904 gfc_add_modify (block
, lhs_cl_size
, size
);
6908 /* Assign a single component of a derived type constructor. */
6911 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6912 gfc_symbol
*sym
, bool init
)
6920 gfc_start_block (&block
);
6922 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6924 /* Only care about pointers here, not about allocatables. */
6925 gfc_init_se (&se
, NULL
);
6926 /* Pointer component. */
6927 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6928 && !cm
->attr
.proc_pointer
)
6930 /* Array pointer. */
6931 if (expr
->expr_type
== EXPR_NULL
)
6932 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6935 se
.direct_byref
= 1;
6937 gfc_conv_expr_descriptor (&se
, expr
);
6938 gfc_add_block_to_block (&block
, &se
.pre
);
6939 gfc_add_block_to_block (&block
, &se
.post
);
6944 /* Scalar pointers. */
6945 se
.want_pointer
= 1;
6946 gfc_conv_expr (&se
, expr
);
6947 gfc_add_block_to_block (&block
, &se
.pre
);
6949 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6950 && expr
->symtree
->n
.sym
->attr
.dummy
)
6951 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6953 gfc_add_modify (&block
, dest
,
6954 fold_convert (TREE_TYPE (dest
), se
.expr
));
6955 gfc_add_block_to_block (&block
, &se
.post
);
6958 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6960 /* NULL initialization for CLASS components. */
6961 tmp
= gfc_trans_structure_assign (dest
,
6962 gfc_class_initializer (&cm
->ts
, expr
),
6964 gfc_add_expr_to_block (&block
, tmp
);
6966 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6967 && !cm
->attr
.proc_pointer
)
6969 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6970 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6971 else if (cm
->attr
.allocatable
)
6973 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6974 gfc_add_expr_to_block (&block
, tmp
);
6978 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6979 gfc_add_expr_to_block (&block
, tmp
);
6982 else if (cm
->ts
.type
== BT_CLASS
6983 && CLASS_DATA (cm
)->attr
.dimension
6984 && CLASS_DATA (cm
)->attr
.allocatable
6985 && expr
->ts
.type
== BT_DERIVED
)
6987 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
6988 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
6989 tmp
= gfc_class_vptr_get (dest
);
6990 gfc_add_modify (&block
, tmp
,
6991 fold_convert (TREE_TYPE (tmp
), vtab
));
6992 tmp
= gfc_class_data_get (dest
);
6993 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
6994 gfc_add_expr_to_block (&block
, tmp
);
6996 else if (init
&& (cm
->attr
.allocatable
6997 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
6999 /* Take care about non-array allocatable components here. The alloc_*
7000 routine below is motivated by the alloc_scalar_allocatable_for_
7001 assignment() routine, but with the realloc portions removed and
7003 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7008 /* The remainder of these instructions follow the if (cm->attr.pointer)
7009 if (!cm->attr.dimension) part above. */
7010 gfc_init_se (&se
, NULL
);
7011 gfc_conv_expr (&se
, expr
);
7012 gfc_add_block_to_block (&block
, &se
.pre
);
7014 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7015 && expr
->symtree
->n
.sym
->attr
.dummy
)
7016 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7018 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7020 tmp
= gfc_class_data_get (dest
);
7021 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7022 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7023 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7024 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7025 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7028 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7030 /* For deferred strings insert a memcpy. */
7031 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7034 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7035 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7037 : expr
->ts
.u
.cl
->backend_decl
);
7038 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7039 gfc_add_expr_to_block (&block
, tmp
);
7042 gfc_add_modify (&block
, tmp
,
7043 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7044 gfc_add_block_to_block (&block
, &se
.post
);
7046 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7048 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7050 tree dealloc
= NULL_TREE
;
7051 gfc_init_se (&se
, NULL
);
7052 gfc_conv_expr (&se
, expr
);
7053 gfc_add_block_to_block (&block
, &se
.pre
);
7054 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7055 expression in a temporary variable and deallocate the allocatable
7056 components. Then we can the copy the expression to the result. */
7057 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7058 && expr
->expr_type
!= EXPR_VARIABLE
)
7060 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7061 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7064 gfc_add_modify (&block
, dest
,
7065 fold_convert (TREE_TYPE (dest
), se
.expr
));
7066 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7067 && expr
->expr_type
!= EXPR_NULL
)
7069 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7071 gfc_add_expr_to_block (&block
, tmp
);
7072 if (dealloc
!= NULL_TREE
)
7073 gfc_add_expr_to_block (&block
, dealloc
);
7075 gfc_add_block_to_block (&block
, &se
.post
);
7079 /* Nested constructors. */
7080 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7081 gfc_add_expr_to_block (&block
, tmp
);
7084 else if (gfc_deferred_strlen (cm
, &tmp
))
7088 gcc_assert (strlen
);
7089 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7091 TREE_OPERAND (dest
, 0),
7094 if (expr
->expr_type
== EXPR_NULL
)
7096 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7097 gfc_add_modify (&block
, dest
, tmp
);
7098 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7099 gfc_add_modify (&block
, strlen
, tmp
);
7104 gfc_init_se (&se
, NULL
);
7105 gfc_conv_expr (&se
, expr
);
7106 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7107 tmp
= build_call_expr_loc (input_location
,
7108 builtin_decl_explicit (BUILT_IN_MALLOC
),
7110 gfc_add_modify (&block
, dest
,
7111 fold_convert (TREE_TYPE (dest
), tmp
));
7112 gfc_add_modify (&block
, strlen
, se
.string_length
);
7113 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7114 gfc_add_expr_to_block (&block
, tmp
);
7117 else if (!cm
->attr
.artificial
)
7119 /* Scalar component (excluding deferred parameters). */
7120 gfc_init_se (&se
, NULL
);
7121 gfc_init_se (&lse
, NULL
);
7123 gfc_conv_expr (&se
, expr
);
7124 if (cm
->ts
.type
== BT_CHARACTER
)
7125 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7127 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
7128 gfc_add_expr_to_block (&block
, tmp
);
7130 return gfc_finish_block (&block
);
7133 /* Assign a derived type constructor to a variable. */
7136 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7144 gfc_start_block (&block
);
7145 cm
= expr
->ts
.u
.derived
->components
;
7147 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7148 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7149 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7153 gcc_assert (cm
->backend_decl
== NULL
);
7154 gfc_init_se (&se
, NULL
);
7155 gfc_init_se (&lse
, NULL
);
7156 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7158 gfc_add_modify (&block
, lse
.expr
,
7159 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7161 return gfc_finish_block (&block
);
7164 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7165 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7167 /* Skip absent members in default initializers. */
7168 if (!c
->expr
&& !cm
->attr
.allocatable
)
7171 field
= cm
->backend_decl
;
7172 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7173 dest
, field
, NULL_TREE
);
7176 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7177 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7182 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7183 expr
->ts
.u
.derived
, init
);
7184 gfc_add_expr_to_block (&block
, tmp
);
7186 return gfc_finish_block (&block
);
7189 /* Build an expression for a constructor. If init is nonzero then
7190 this is part of a static variable initializer. */
7193 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7200 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7202 gcc_assert (se
->ss
== NULL
);
7203 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7204 type
= gfc_typenode_for_spec (&expr
->ts
);
7208 /* Create a temporary variable and fill it in. */
7209 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7210 /* The symtree in expr is NULL, if the code to generate is for
7211 initializing the static members only. */
7212 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7213 gfc_add_expr_to_block (&se
->pre
, tmp
);
7217 cm
= expr
->ts
.u
.derived
->components
;
7219 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7220 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7222 /* Skip absent members in default initializers and allocatable
7223 components. Although the latter have a default initializer
7224 of EXPR_NULL,... by default, the static nullify is not needed
7225 since this is done every time we come into scope. */
7226 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7229 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7230 && strcmp (cm
->name
, "_extends") == 0
7231 && cm
->initializer
->symtree
)
7235 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7236 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7237 vtab
= unshare_expr_without_location (vtab
);
7238 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7240 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7242 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7243 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7244 fold_convert (TREE_TYPE (cm
->backend_decl
),
7247 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7248 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7249 fold_convert (TREE_TYPE (cm
->backend_decl
),
7250 integer_zero_node
));
7253 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7254 TREE_TYPE (cm
->backend_decl
),
7255 cm
->attr
.dimension
, cm
->attr
.pointer
,
7256 cm
->attr
.proc_pointer
);
7257 val
= unshare_expr_without_location (val
);
7259 /* Append it to the constructor list. */
7260 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7263 se
->expr
= build_constructor (type
, v
);
7265 TREE_CONSTANT (se
->expr
) = 1;
7269 /* Translate a substring expression. */
7272 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7278 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7280 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7281 expr
->value
.character
.length
,
7282 expr
->value
.character
.string
);
7284 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7285 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7288 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7292 /* Entry point for expression translation. Evaluates a scalar quantity.
7293 EXPR is the expression to be translated, and SE is the state structure if
7294 called from within the scalarized. */
7297 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7302 if (ss
&& ss
->info
->expr
== expr
7303 && (ss
->info
->type
== GFC_SS_SCALAR
7304 || ss
->info
->type
== GFC_SS_REFERENCE
))
7306 gfc_ss_info
*ss_info
;
7309 /* Substitute a scalar expression evaluated outside the scalarization
7311 se
->expr
= ss_info
->data
.scalar
.value
;
7312 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7313 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7315 se
->string_length
= ss_info
->string_length
;
7316 gfc_advance_se_ss_chain (se
);
7320 /* We need to convert the expressions for the iso_c_binding derived types.
7321 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7322 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7323 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7324 updated to be an integer with a kind equal to the size of a (void *). */
7325 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7326 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7328 if (expr
->expr_type
== EXPR_VARIABLE
7329 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7330 || expr
->symtree
->n
.sym
->intmod_sym_id
7331 == ISOCBINDING_NULL_FUNPTR
))
7333 /* Set expr_type to EXPR_NULL, which will result in
7334 null_pointer_node being used below. */
7335 expr
->expr_type
= EXPR_NULL
;
7339 /* Update the type/kind of the expression to be what the new
7340 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7341 expr
->ts
.type
= BT_INTEGER
;
7342 expr
->ts
.f90_type
= BT_VOID
;
7343 expr
->ts
.kind
= gfc_index_integer_kind
;
7347 gfc_fix_class_refs (expr
);
7349 switch (expr
->expr_type
)
7352 gfc_conv_expr_op (se
, expr
);
7356 gfc_conv_function_expr (se
, expr
);
7360 gfc_conv_constant (se
, expr
);
7364 gfc_conv_variable (se
, expr
);
7368 se
->expr
= null_pointer_node
;
7371 case EXPR_SUBSTRING
:
7372 gfc_conv_substring_expr (se
, expr
);
7375 case EXPR_STRUCTURE
:
7376 gfc_conv_structure (se
, expr
, 0);
7380 gfc_conv_array_constructor_expr (se
, expr
);
7389 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7390 of an assignment. */
7392 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7394 gfc_conv_expr (se
, expr
);
7395 /* All numeric lvalues should have empty post chains. If not we need to
7396 figure out a way of rewriting an lvalue so that it has no post chain. */
7397 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7400 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7401 numeric expressions. Used for scalar values where inserting cleanup code
7404 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7408 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7409 gfc_conv_expr (se
, expr
);
7412 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7413 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7415 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7419 /* Helper to translate an expression and convert it to a particular type. */
7421 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7423 gfc_conv_expr_val (se
, expr
);
7424 se
->expr
= convert (type
, se
->expr
);
7428 /* Converts an expression so that it can be passed by reference. Scalar
7432 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7438 if (ss
&& ss
->info
->expr
== expr
7439 && ss
->info
->type
== GFC_SS_REFERENCE
)
7441 /* Returns a reference to the scalar evaluated outside the loop
7443 gfc_conv_expr (se
, expr
);
7445 if (expr
->ts
.type
== BT_CHARACTER
7446 && expr
->expr_type
!= EXPR_FUNCTION
)
7447 gfc_conv_string_parameter (se
);
7449 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7454 if (expr
->ts
.type
== BT_CHARACTER
)
7456 gfc_conv_expr (se
, expr
);
7457 gfc_conv_string_parameter (se
);
7461 if (expr
->expr_type
== EXPR_VARIABLE
)
7463 se
->want_pointer
= 1;
7464 gfc_conv_expr (se
, expr
);
7467 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7468 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7469 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7475 if (expr
->expr_type
== EXPR_FUNCTION
7476 && ((expr
->value
.function
.esym
7477 && expr
->value
.function
.esym
->result
->attr
.pointer
7478 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7479 || (!expr
->value
.function
.esym
&& !expr
->ref
7480 && expr
->symtree
->n
.sym
->attr
.pointer
7481 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7483 se
->want_pointer
= 1;
7484 gfc_conv_expr (se
, expr
);
7485 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7486 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7491 gfc_conv_expr (se
, expr
);
7493 /* Create a temporary var to hold the value. */
7494 if (TREE_CONSTANT (se
->expr
))
7496 tree tmp
= se
->expr
;
7497 STRIP_TYPE_NOPS (tmp
);
7498 var
= build_decl (input_location
,
7499 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7500 DECL_INITIAL (var
) = tmp
;
7501 TREE_STATIC (var
) = 1;
7506 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7507 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7509 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7511 /* Take the address of that value. */
7512 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7513 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
7514 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
7515 && expr
->ts
.u
.derived
->attr
.alloc_comp
7516 && expr
->expr_type
!= EXPR_VARIABLE
)
7520 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7521 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7523 /* The components shall be deallocated before
7524 their containing entity. */
7525 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7531 gfc_trans_pointer_assign (gfc_code
* code
)
7533 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7537 /* Generate code for a pointer assignment. */
7540 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7542 gfc_expr
*expr1_vptr
= NULL
;
7552 gfc_start_block (&block
);
7554 gfc_init_se (&lse
, NULL
);
7556 /* Check whether the expression is a scalar or not; we cannot use
7557 expr1->rank as it can be nonzero for proc pointers. */
7558 ss
= gfc_walk_expr (expr1
);
7559 scalar
= ss
== gfc_ss_terminator
;
7561 gfc_free_ss_chain (ss
);
7563 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7564 && expr2
->expr_type
!= EXPR_FUNCTION
)
7566 gfc_add_data_component (expr2
);
7567 /* The following is required as gfc_add_data_component doesn't
7568 update ts.type if there is a tailing REF_ARRAY. */
7569 expr2
->ts
.type
= BT_DERIVED
;
7574 /* Scalar pointers. */
7575 lse
.want_pointer
= 1;
7576 gfc_conv_expr (&lse
, expr1
);
7577 gfc_init_se (&rse
, NULL
);
7578 rse
.want_pointer
= 1;
7579 gfc_conv_expr (&rse
, expr2
);
7581 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7582 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7583 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7586 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7587 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7588 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7591 gfc_add_block_to_block (&block
, &lse
.pre
);
7592 gfc_add_block_to_block (&block
, &rse
.pre
);
7594 /* For string assignments to unlimited polymorphic pointers add an
7595 assignment of the string_length to the _len component of the
7597 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7598 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7599 && (expr2
->ts
.type
== BT_CHARACTER
||
7600 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7601 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7605 len_comp
= gfc_get_len_component (expr1
);
7606 gfc_init_se (&se
, NULL
);
7607 gfc_conv_expr (&se
, len_comp
);
7609 /* ptr % _len = len (str) */
7610 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7611 lse
.string_length
= se
.expr
;
7612 gfc_free_expr (len_comp
);
7615 /* Check character lengths if character expression. The test is only
7616 really added if -fbounds-check is enabled. Exclude deferred
7617 character length lefthand sides. */
7618 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7619 && !expr1
->ts
.deferred
7620 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7621 && !gfc_is_proc_ptr_comp (expr1
))
7623 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7624 gcc_assert (lse
.string_length
&& rse
.string_length
);
7625 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7626 lse
.string_length
, rse
.string_length
,
7630 /* The assignment to an deferred character length sets the string
7631 length to that of the rhs. */
7632 if (expr1
->ts
.deferred
)
7634 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7635 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7636 else if (lse
.string_length
!= NULL
)
7637 gfc_add_modify (&block
, lse
.string_length
,
7638 build_int_cst (gfc_charlen_type_node
, 0));
7641 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7642 rse
.expr
= gfc_class_data_get (rse
.expr
);
7644 gfc_add_modify (&block
, lse
.expr
,
7645 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7647 gfc_add_block_to_block (&block
, &rse
.post
);
7648 gfc_add_block_to_block (&block
, &lse
.post
);
7655 tree strlen_rhs
= NULL_TREE
;
7657 /* Array pointer. Find the last reference on the LHS and if it is an
7658 array section ref, we're dealing with bounds remapping. In this case,
7659 set it to AR_FULL so that gfc_conv_expr_descriptor does
7660 not see it and process the bounds remapping afterwards explicitly. */
7661 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7662 if (!remap
->next
&& remap
->type
== REF_ARRAY
7663 && remap
->u
.ar
.type
== AR_SECTION
)
7665 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7667 gfc_init_se (&lse
, NULL
);
7669 lse
.descriptor_only
= 1;
7670 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7671 && expr1
->ts
.type
== BT_CLASS
)
7672 expr1_vptr
= gfc_copy_expr (expr1
);
7673 gfc_conv_expr_descriptor (&lse
, expr1
);
7674 strlen_lhs
= lse
.string_length
;
7677 if (expr2
->expr_type
== EXPR_NULL
)
7679 /* Just set the data pointer to null. */
7680 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7682 else if (rank_remap
)
7684 /* If we are rank-remapping, just get the RHS's descriptor and
7685 process this later on. */
7686 gfc_init_se (&rse
, NULL
);
7687 rse
.direct_byref
= 1;
7688 rse
.byref_noassign
= 1;
7690 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7692 gfc_conv_function_expr (&rse
, expr2
);
7694 if (expr1
->ts
.type
!= BT_CLASS
)
7695 rse
.expr
= gfc_class_data_get (rse
.expr
);
7698 gfc_add_block_to_block (&block
, &rse
.pre
);
7699 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7700 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7702 gfc_add_vptr_component (expr1_vptr
);
7703 gfc_init_se (&rse
, NULL
);
7704 rse
.want_pointer
= 1;
7705 gfc_conv_expr (&rse
, expr1_vptr
);
7706 gfc_add_modify (&lse
.pre
, rse
.expr
,
7707 fold_convert (TREE_TYPE (rse
.expr
),
7708 gfc_class_vptr_get (tmp
)));
7709 rse
.expr
= gfc_class_data_get (tmp
);
7712 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7714 tree bound
[GFC_MAX_DIMENSIONS
];
7717 for (i
= 0; i
< expr2
->rank
; i
++)
7718 bound
[i
] = NULL_TREE
;
7719 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7720 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7722 GFC_ARRAY_POINTER_CONT
, false);
7723 tmp
= gfc_create_var (tmp
, "ptrtemp");
7724 lse
.descriptor_only
= 0;
7726 lse
.direct_byref
= 1;
7727 gfc_conv_expr_descriptor (&lse
, expr2
);
7728 strlen_rhs
= lse
.string_length
;
7733 gfc_conv_expr_descriptor (&rse
, expr2
);
7734 strlen_rhs
= rse
.string_length
;
7737 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7739 /* Assign directly to the LHS's descriptor. */
7740 lse
.descriptor_only
= 0;
7741 lse
.direct_byref
= 1;
7742 gfc_conv_expr_descriptor (&lse
, expr2
);
7743 strlen_rhs
= lse
.string_length
;
7745 /* If this is a subreference array pointer assignment, use the rhs
7746 descriptor element size for the lhs span. */
7747 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7749 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7750 gfc_init_se (&rse
, NULL
);
7751 rse
.descriptor_only
= 1;
7752 gfc_conv_expr (&rse
, expr2
);
7753 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7754 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7755 if (!INTEGER_CST_P (tmp
))
7756 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7757 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7760 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7762 gfc_init_se (&rse
, NULL
);
7763 rse
.want_pointer
= 1;
7764 gfc_conv_function_expr (&rse
, expr2
);
7765 if (expr1
->ts
.type
!= BT_CLASS
)
7767 rse
.expr
= gfc_class_data_get (rse
.expr
);
7768 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7772 gfc_add_block_to_block (&block
, &rse
.pre
);
7773 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7774 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7776 gfc_add_vptr_component (expr1_vptr
);
7777 gfc_init_se (&rse
, NULL
);
7778 rse
.want_pointer
= 1;
7779 gfc_conv_expr (&rse
, expr1_vptr
);
7780 gfc_add_modify (&lse
.pre
, rse
.expr
,
7781 fold_convert (TREE_TYPE (rse
.expr
),
7782 gfc_class_vptr_get (tmp
)));
7783 rse
.expr
= gfc_class_data_get (tmp
);
7784 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7789 /* Assign to a temporary descriptor and then copy that
7790 temporary to the pointer. */
7791 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7792 lse
.descriptor_only
= 0;
7794 lse
.direct_byref
= 1;
7795 gfc_conv_expr_descriptor (&lse
, expr2
);
7796 strlen_rhs
= lse
.string_length
;
7797 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7801 gfc_free_expr (expr1_vptr
);
7803 gfc_add_block_to_block (&block
, &lse
.pre
);
7805 gfc_add_block_to_block (&block
, &rse
.pre
);
7807 /* If we do bounds remapping, update LHS descriptor accordingly. */
7811 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7815 /* Do rank remapping. We already have the RHS's descriptor
7816 converted in rse and now have to build the correct LHS
7817 descriptor for it. */
7821 tree lbound
, ubound
;
7824 dtype
= gfc_conv_descriptor_dtype (desc
);
7825 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7826 gfc_add_modify (&block
, dtype
, tmp
);
7828 /* Copy data pointer. */
7829 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7830 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7832 /* Copy offset but adjust it such that it would correspond
7833 to a lbound of zero. */
7834 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7835 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7837 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7839 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7841 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7842 gfc_array_index_type
, stride
, lbound
);
7843 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7844 gfc_array_index_type
, offs
, tmp
);
7846 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7848 /* Set the bounds as declared for the LHS and calculate strides as
7849 well as another offset update accordingly. */
7850 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7852 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7857 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7859 /* Convert declared bounds. */
7860 gfc_init_se (&lower_se
, NULL
);
7861 gfc_init_se (&upper_se
, NULL
);
7862 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7863 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7865 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7866 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7868 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7869 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7871 lbound
= gfc_evaluate_now (lbound
, &block
);
7872 ubound
= gfc_evaluate_now (ubound
, &block
);
7874 gfc_add_block_to_block (&block
, &lower_se
.post
);
7875 gfc_add_block_to_block (&block
, &upper_se
.post
);
7877 /* Set bounds in descriptor. */
7878 gfc_conv_descriptor_lbound_set (&block
, desc
,
7879 gfc_rank_cst
[dim
], lbound
);
7880 gfc_conv_descriptor_ubound_set (&block
, desc
,
7881 gfc_rank_cst
[dim
], ubound
);
7884 stride
= gfc_evaluate_now (stride
, &block
);
7885 gfc_conv_descriptor_stride_set (&block
, desc
,
7886 gfc_rank_cst
[dim
], stride
);
7888 /* Update offset. */
7889 offs
= gfc_conv_descriptor_offset_get (desc
);
7890 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7891 gfc_array_index_type
, lbound
, stride
);
7892 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7893 gfc_array_index_type
, offs
, tmp
);
7894 offs
= gfc_evaluate_now (offs
, &block
);
7895 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7897 /* Update stride. */
7898 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7899 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7900 gfc_array_index_type
, stride
, tmp
);
7905 /* Bounds remapping. Just shift the lower bounds. */
7907 gcc_assert (expr1
->rank
== expr2
->rank
);
7909 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7913 gcc_assert (remap
->u
.ar
.start
[dim
]);
7914 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7915 gfc_init_se (&lbound_se
, NULL
);
7916 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7918 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7919 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7920 dim
, lbound_se
.expr
);
7921 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7926 /* Check string lengths if applicable. The check is only really added
7927 to the output code if -fbounds-check is enabled. */
7928 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7930 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7931 gcc_assert (strlen_lhs
&& strlen_rhs
);
7932 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7933 strlen_lhs
, strlen_rhs
, &block
);
7936 /* If rank remapping was done, check with -fcheck=bounds that
7937 the target is at least as large as the pointer. */
7938 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7944 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7945 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7947 lsize
= gfc_evaluate_now (lsize
, &block
);
7948 rsize
= gfc_evaluate_now (rsize
, &block
);
7949 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7952 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7953 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7957 gfc_add_block_to_block (&block
, &lse
.post
);
7959 gfc_add_block_to_block (&block
, &rse
.post
);
7962 return gfc_finish_block (&block
);
7966 /* Makes sure se is suitable for passing as a function string parameter. */
7967 /* TODO: Need to check all callers of this function. It may be abused. */
7970 gfc_conv_string_parameter (gfc_se
* se
)
7974 if (TREE_CODE (se
->expr
) == STRING_CST
)
7976 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7977 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7981 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7983 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7985 type
= TREE_TYPE (se
->expr
);
7986 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7990 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7992 type
= build_pointer_type (type
);
7993 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7997 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8001 /* Generate code for assignment of scalar variables. Includes character
8002 strings and derived types with allocatable components.
8003 If you know that the LHS has no allocations, set dealloc to false.
8005 DEEP_COPY has no effect if the typespec TS is not a derived type with
8006 allocatable components. Otherwise, if it is set, an explicit copy of each
8007 allocatable component is made. This is necessary as a simple copy of the
8008 whole object would copy array descriptors as is, so that the lhs's
8009 allocatable components would point to the rhs's after the assignment.
8010 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8011 necessary if the rhs is a non-pointer function, as the allocatable components
8012 are not accessible by other means than the function's result after the
8013 function has returned. It is even more subtle when temporaries are involved,
8014 as the two following examples show:
8015 1. When we evaluate an array constructor, a temporary is created. Thus
8016 there is theoretically no alias possible. However, no deep copy is
8017 made for this temporary, so that if the constructor is made of one or
8018 more variable with allocatable components, those components still point
8019 to the variable's: DEEP_COPY should be set for the assignment from the
8020 temporary to the lhs in that case.
8021 2. When assigning a scalar to an array, we evaluate the scalar value out
8022 of the loop, store it into a temporary variable, and assign from that.
8023 In that case, deep copying when assigning to the temporary would be a
8024 waste of resources; however deep copies should happen when assigning from
8025 the temporary to each array element: again DEEP_COPY should be set for
8026 the assignment from the temporary to the lhs. */
8029 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8030 bool l_is_temp
, bool deep_copy
, bool dealloc
)
8036 gfc_init_block (&block
);
8038 if (ts
.type
== BT_CHARACTER
)
8043 if (lse
->string_length
!= NULL_TREE
)
8045 gfc_conv_string_parameter (lse
);
8046 gfc_add_block_to_block (&block
, &lse
->pre
);
8047 llen
= lse
->string_length
;
8050 if (rse
->string_length
!= NULL_TREE
)
8052 gcc_assert (rse
->string_length
!= NULL_TREE
);
8053 gfc_conv_string_parameter (rse
);
8054 gfc_add_block_to_block (&block
, &rse
->pre
);
8055 rlen
= rse
->string_length
;
8058 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8059 rse
->expr
, ts
.kind
);
8061 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8063 tree tmp_var
= NULL_TREE
;
8066 /* Are the rhs and the lhs the same? */
8069 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8070 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8071 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8072 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8075 /* Deallocate the lhs allocated components as long as it is not
8076 the same as the rhs. This must be done following the assignment
8077 to prevent deallocating data that could be used in the rhs
8079 if (!l_is_temp
&& dealloc
)
8081 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8082 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8084 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8086 gfc_add_expr_to_block (&lse
->post
, tmp
);
8089 gfc_add_block_to_block (&block
, &rse
->pre
);
8090 gfc_add_block_to_block (&block
, &lse
->pre
);
8092 gfc_add_modify (&block
, lse
->expr
,
8093 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8095 /* Restore pointer address of coarray components. */
8096 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8098 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8099 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8101 gfc_add_expr_to_block (&block
, tmp
);
8104 /* Do a deep copy if the rhs is a variable, if it is not the
8108 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8109 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8111 gfc_add_expr_to_block (&block
, tmp
);
8114 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8116 gfc_add_block_to_block (&block
, &lse
->pre
);
8117 gfc_add_block_to_block (&block
, &rse
->pre
);
8118 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8119 TREE_TYPE (lse
->expr
), rse
->expr
);
8120 gfc_add_modify (&block
, lse
->expr
, tmp
);
8124 gfc_add_block_to_block (&block
, &lse
->pre
);
8125 gfc_add_block_to_block (&block
, &rse
->pre
);
8127 gfc_add_modify (&block
, lse
->expr
,
8128 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8131 gfc_add_block_to_block (&block
, &lse
->post
);
8132 gfc_add_block_to_block (&block
, &rse
->post
);
8134 return gfc_finish_block (&block
);
8138 /* There are quite a lot of restrictions on the optimisation in using an
8139 array function assign without a temporary. */
8142 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8145 bool seen_array_ref
;
8147 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8149 /* Play it safe with class functions assigned to a derived type. */
8150 if (gfc_is_alloc_class_array_function (expr2
)
8151 && expr1
->ts
.type
== BT_DERIVED
)
8154 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8155 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8158 /* Elemental functions are scalarized so that they don't need a
8159 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8160 they would need special treatment in gfc_trans_arrayfunc_assign. */
8161 if (expr2
->value
.function
.esym
!= NULL
8162 && expr2
->value
.function
.esym
->attr
.elemental
)
8165 /* Need a temporary if rhs is not FULL or a contiguous section. */
8166 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8169 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8170 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8173 /* Functions returning pointers or allocatables need temporaries. */
8174 c
= expr2
->value
.function
.esym
8175 ? (expr2
->value
.function
.esym
->attr
.pointer
8176 || expr2
->value
.function
.esym
->attr
.allocatable
)
8177 : (expr2
->symtree
->n
.sym
->attr
.pointer
8178 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8182 /* Character array functions need temporaries unless the
8183 character lengths are the same. */
8184 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8186 if (expr1
->ts
.u
.cl
->length
== NULL
8187 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8190 if (expr2
->ts
.u
.cl
->length
== NULL
8191 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8194 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8195 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8199 /* Check that no LHS component references appear during an array
8200 reference. This is needed because we do not have the means to
8201 span any arbitrary stride with an array descriptor. This check
8202 is not needed for the rhs because the function result has to be
8204 seen_array_ref
= false;
8205 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8207 if (ref
->type
== REF_ARRAY
)
8208 seen_array_ref
= true;
8209 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8213 /* Check for a dependency. */
8214 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8215 expr2
->value
.function
.esym
,
8216 expr2
->value
.function
.actual
,
8220 /* If we have reached here with an intrinsic function, we do not
8221 need a temporary except in the particular case that reallocation
8222 on assignment is active and the lhs is allocatable and a target. */
8223 if (expr2
->value
.function
.isym
)
8224 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8226 /* If the LHS is a dummy, we need a temporary if it is not
8228 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8231 /* If the lhs has been host_associated, is in common, a pointer or is
8232 a target and the function is not using a RESULT variable, aliasing
8233 can occur and a temporary is needed. */
8234 if ((sym
->attr
.host_assoc
8235 || sym
->attr
.in_common
8236 || sym
->attr
.pointer
8237 || sym
->attr
.cray_pointee
8238 || sym
->attr
.target
)
8239 && expr2
->symtree
!= NULL
8240 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8243 /* A PURE function can unconditionally be called without a temporary. */
8244 if (expr2
->value
.function
.esym
!= NULL
8245 && expr2
->value
.function
.esym
->attr
.pure
)
8248 /* Implicit_pure functions are those which could legally be declared
8250 if (expr2
->value
.function
.esym
!= NULL
8251 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8254 if (!sym
->attr
.use_assoc
8255 && !sym
->attr
.in_common
8256 && !sym
->attr
.pointer
8257 && !sym
->attr
.target
8258 && !sym
->attr
.cray_pointee
8259 && expr2
->value
.function
.esym
)
8261 /* A temporary is not needed if the function is not contained and
8262 the variable is local or host associated and not a pointer or
8264 if (!expr2
->value
.function
.esym
->attr
.contained
)
8267 /* A temporary is not needed if the lhs has never been host
8268 associated and the procedure is contained. */
8269 else if (!sym
->attr
.host_assoc
)
8272 /* A temporary is not needed if the variable is local and not
8273 a pointer, a target or a result. */
8275 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8279 /* Default to temporary use. */
8284 /* Provide the loop info so that the lhs descriptor can be built for
8285 reallocatable assignments from extrinsic function calls. */
8288 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8291 /* Signal that the function call should not be made by
8292 gfc_conv_loop_setup. */
8293 se
->ss
->is_alloc_lhs
= 1;
8294 gfc_init_loopinfo (loop
);
8295 gfc_add_ss_to_loop (loop
, *ss
);
8296 gfc_add_ss_to_loop (loop
, se
->ss
);
8297 gfc_conv_ss_startstride (loop
);
8298 gfc_conv_loop_setup (loop
, where
);
8299 gfc_copy_loopinfo_to_se (se
, loop
);
8300 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8301 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8302 se
->ss
->is_alloc_lhs
= 0;
8306 /* For assignment to a reallocatable lhs from intrinsic functions,
8307 replace the se.expr (ie. the result) with a temporary descriptor.
8308 Null the data field so that the library allocates space for the
8309 result. Free the data of the original descriptor after the function,
8310 in case it appears in an argument expression and transfer the
8311 result to the original descriptor. */
8314 fcncall_realloc_result (gfc_se
*se
, int rank
)
8323 /* Use the allocation done by the library. Substitute the lhs
8324 descriptor with a copy, whose data field is nulled.*/
8325 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8326 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8327 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8329 /* Unallocated, the descriptor does not have a dtype. */
8330 tmp
= gfc_conv_descriptor_dtype (desc
);
8331 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8333 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8334 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8335 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8337 /* Free the lhs after the function call and copy the result data to
8338 the lhs descriptor. */
8339 tmp
= gfc_conv_descriptor_data_get (desc
);
8340 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8341 boolean_type_node
, tmp
,
8342 build_int_cst (TREE_TYPE (tmp
), 0));
8343 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8344 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
8345 gfc_add_expr_to_block (&se
->post
, tmp
);
8347 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8348 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8350 /* Check that the shapes are the same between lhs and expression. */
8351 for (n
= 0 ; n
< rank
; n
++)
8354 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8355 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8356 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8357 gfc_array_index_type
, tmp
, tmp1
);
8358 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8359 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8360 gfc_array_index_type
, tmp
, tmp1
);
8361 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8362 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8363 gfc_array_index_type
, tmp
, tmp1
);
8364 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8365 boolean_type_node
, tmp
,
8366 gfc_index_zero_node
);
8367 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8368 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8369 boolean_type_node
, tmp
,
8373 /* 'zero_cond' being true is equal to lhs not being allocated or the
8374 shapes being different. */
8375 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8377 /* Now reset the bounds returned from the function call to bounds based
8378 on the lhs lbounds, except where the lhs is not allocated or the shapes
8379 of 'variable and 'expr' are different. Set the offset accordingly. */
8380 offset
= gfc_index_zero_node
;
8381 for (n
= 0 ; n
< rank
; n
++)
8385 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8386 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8387 gfc_array_index_type
, zero_cond
,
8388 gfc_index_one_node
, lbound
);
8389 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8391 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8392 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8393 gfc_array_index_type
, tmp
, lbound
);
8394 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8395 gfc_rank_cst
[n
], lbound
);
8396 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8397 gfc_rank_cst
[n
], tmp
);
8399 /* Set stride and accumulate the offset. */
8400 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8401 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8402 gfc_rank_cst
[n
], tmp
);
8403 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8404 gfc_array_index_type
, lbound
, tmp
);
8405 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8406 gfc_array_index_type
, offset
, tmp
);
8407 offset
= gfc_evaluate_now (offset
, &se
->post
);
8410 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8415 /* Try to translate array(:) = func (...), where func is a transformational
8416 array function, without using a temporary. Returns NULL if this isn't the
8420 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8424 gfc_component
*comp
= NULL
;
8427 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8430 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8432 comp
= gfc_get_proc_ptr_comp (expr2
);
8433 gcc_assert (expr2
->value
.function
.isym
8434 || (comp
&& comp
->attr
.dimension
)
8435 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8436 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8438 gfc_init_se (&se
, NULL
);
8439 gfc_start_block (&se
.pre
);
8440 se
.want_pointer
= 1;
8442 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8444 if (expr1
->ts
.type
== BT_DERIVED
8445 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8448 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8450 gfc_add_expr_to_block (&se
.pre
, tmp
);
8453 se
.direct_byref
= 1;
8454 se
.ss
= gfc_walk_expr (expr2
);
8455 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8457 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8458 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8459 Clearly, this cannot be done for an allocatable function result, since
8460 the shape of the result is unknown and, in any case, the function must
8461 correctly take care of the reallocation internally. For intrinsic
8462 calls, the array data is freed and the library takes care of allocation.
8463 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8465 if (flag_realloc_lhs
8466 && gfc_is_reallocatable_lhs (expr1
)
8467 && !gfc_expr_attr (expr1
).codimension
8468 && !gfc_is_coindexed (expr1
)
8469 && !(expr2
->value
.function
.esym
8470 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8472 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8474 if (!expr2
->value
.function
.isym
)
8476 ss
= gfc_walk_expr (expr1
);
8477 gcc_assert (ss
!= gfc_ss_terminator
);
8479 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8480 ss
->is_alloc_lhs
= 1;
8483 fcncall_realloc_result (&se
, expr1
->rank
);
8486 gfc_conv_function_expr (&se
, expr2
);
8487 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8490 gfc_cleanup_loop (&loop
);
8492 gfc_free_ss_chain (se
.ss
);
8494 return gfc_finish_block (&se
.pre
);
8498 /* Try to efficiently translate array(:) = 0. Return NULL if this
8502 gfc_trans_zero_assign (gfc_expr
* expr
)
8504 tree dest
, len
, type
;
8508 sym
= expr
->symtree
->n
.sym
;
8509 dest
= gfc_get_symbol_decl (sym
);
8511 type
= TREE_TYPE (dest
);
8512 if (POINTER_TYPE_P (type
))
8513 type
= TREE_TYPE (type
);
8514 if (!GFC_ARRAY_TYPE_P (type
))
8517 /* Determine the length of the array. */
8518 len
= GFC_TYPE_ARRAY_SIZE (type
);
8519 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8522 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8523 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8524 fold_convert (gfc_array_index_type
, tmp
));
8526 /* If we are zeroing a local array avoid taking its address by emitting
8528 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8529 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8530 dest
, build_constructor (TREE_TYPE (dest
),
8533 /* Convert arguments to the correct types. */
8534 dest
= fold_convert (pvoid_type_node
, dest
);
8535 len
= fold_convert (size_type_node
, len
);
8537 /* Construct call to __builtin_memset. */
8538 tmp
= build_call_expr_loc (input_location
,
8539 builtin_decl_explicit (BUILT_IN_MEMSET
),
8540 3, dest
, integer_zero_node
, len
);
8541 return fold_convert (void_type_node
, tmp
);
8545 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8546 that constructs the call to __builtin_memcpy. */
8549 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8553 /* Convert arguments to the correct types. */
8554 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8555 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8557 dst
= fold_convert (pvoid_type_node
, dst
);
8559 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8560 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8562 src
= fold_convert (pvoid_type_node
, src
);
8564 len
= fold_convert (size_type_node
, len
);
8566 /* Construct call to __builtin_memcpy. */
8567 tmp
= build_call_expr_loc (input_location
,
8568 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8570 return fold_convert (void_type_node
, tmp
);
8574 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8575 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8576 source/rhs, both are gfc_full_array_ref_p which have been checked for
8580 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8582 tree dst
, dlen
, dtype
;
8583 tree src
, slen
, stype
;
8586 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8587 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8589 dtype
= TREE_TYPE (dst
);
8590 if (POINTER_TYPE_P (dtype
))
8591 dtype
= TREE_TYPE (dtype
);
8592 stype
= TREE_TYPE (src
);
8593 if (POINTER_TYPE_P (stype
))
8594 stype
= TREE_TYPE (stype
);
8596 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8599 /* Determine the lengths of the arrays. */
8600 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8601 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8603 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8604 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8605 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8607 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8608 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8610 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8611 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8612 slen
, fold_convert (gfc_array_index_type
, tmp
));
8614 /* Sanity check that they are the same. This should always be
8615 the case, as we should already have checked for conformance. */
8616 if (!tree_int_cst_equal (slen
, dlen
))
8619 return gfc_build_memcpy_call (dst
, src
, dlen
);
8623 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8624 this can't be done. EXPR1 is the destination/lhs for which
8625 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8628 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8630 unsigned HOST_WIDE_INT nelem
;
8636 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8640 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8641 dtype
= TREE_TYPE (dst
);
8642 if (POINTER_TYPE_P (dtype
))
8643 dtype
= TREE_TYPE (dtype
);
8644 if (!GFC_ARRAY_TYPE_P (dtype
))
8647 /* Determine the lengths of the array. */
8648 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8649 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8652 /* Confirm that the constructor is the same size. */
8653 if (compare_tree_int (len
, nelem
) != 0)
8656 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8657 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8658 fold_convert (gfc_array_index_type
, tmp
));
8660 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8661 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8663 stype
= TREE_TYPE (src
);
8664 if (POINTER_TYPE_P (stype
))
8665 stype
= TREE_TYPE (stype
);
8667 return gfc_build_memcpy_call (dst
, src
, len
);
8671 /* Tells whether the expression is to be treated as a variable reference. */
8674 expr_is_variable (gfc_expr
*expr
)
8677 gfc_component
*comp
;
8678 gfc_symbol
*func_ifc
;
8680 if (expr
->expr_type
== EXPR_VARIABLE
)
8683 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8686 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8687 return expr_is_variable (arg
);
8690 /* A data-pointer-returning function should be considered as a variable
8692 if (expr
->expr_type
== EXPR_FUNCTION
8693 && expr
->ref
== NULL
)
8695 if (expr
->value
.function
.isym
!= NULL
)
8698 if (expr
->value
.function
.esym
!= NULL
)
8700 func_ifc
= expr
->value
.function
.esym
;
8705 gcc_assert (expr
->symtree
);
8706 func_ifc
= expr
->symtree
->n
.sym
;
8713 comp
= gfc_get_proc_ptr_comp (expr
);
8714 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8717 func_ifc
= comp
->ts
.interface
;
8721 if (expr
->expr_type
== EXPR_COMPCALL
)
8723 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8724 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8731 gcc_assert (func_ifc
->attr
.function
8732 && func_ifc
->result
!= NULL
);
8733 return func_ifc
->result
->attr
.pointer
;
8737 /* Is the lhs OK for automatic reallocation? */
8740 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8744 /* An allocatable variable with no reference. */
8745 if (expr
->symtree
->n
.sym
->attr
.allocatable
8749 /* All that can be left are allocatable components. */
8750 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8751 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8752 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8755 /* Find an allocatable component ref last. */
8756 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8757 if (ref
->type
== REF_COMPONENT
8759 && ref
->u
.c
.component
->attr
.allocatable
)
8766 /* Allocate or reallocate scalar lhs, as necessary. */
8769 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8783 if (!expr1
|| expr1
->rank
)
8786 if (!expr2
|| expr2
->rank
)
8789 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8791 /* Since this is a scalar lhs, we can afford to do this. That is,
8792 there is no risk of side effects being repeated. */
8793 gfc_init_se (&lse
, NULL
);
8794 lse
.want_pointer
= 1;
8795 gfc_conv_expr (&lse
, expr1
);
8797 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8798 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8800 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8801 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8802 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8804 tmp
= build3_v (COND_EXPR
, cond
,
8805 build1_v (GOTO_EXPR
, jump_label1
),
8806 build_empty_stmt (input_location
));
8807 gfc_add_expr_to_block (block
, tmp
);
8809 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8811 /* Use the rhs string length and the lhs element size. */
8812 size
= string_length
;
8813 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8814 tmp
= TYPE_SIZE_UNIT (tmp
);
8815 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8816 TREE_TYPE (tmp
), tmp
,
8817 fold_convert (TREE_TYPE (tmp
), size
));
8821 /* Otherwise use the length in bytes of the rhs. */
8822 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8823 size_in_bytes
= size
;
8826 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8827 size_in_bytes
, size_one_node
);
8829 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8831 tmp
= build_call_expr_loc (input_location
,
8832 builtin_decl_explicit (BUILT_IN_CALLOC
),
8833 2, build_one_cst (size_type_node
),
8835 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8836 gfc_add_modify (block
, lse
.expr
, tmp
);
8840 tmp
= build_call_expr_loc (input_location
,
8841 builtin_decl_explicit (BUILT_IN_MALLOC
),
8843 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8844 gfc_add_modify (block
, lse
.expr
, tmp
);
8847 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8849 /* Deferred characters need checking for lhs and rhs string
8850 length. Other deferred parameter variables will have to
8852 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8853 gfc_add_expr_to_block (block
, tmp
);
8855 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8856 gfc_add_expr_to_block (block
, tmp
);
8858 /* For a deferred length character, reallocate if lengths of lhs and
8859 rhs are different. */
8860 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8862 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8863 lse
.string_length
, size
);
8864 /* Jump past the realloc if the lengths are the same. */
8865 tmp
= build3_v (COND_EXPR
, cond
,
8866 build1_v (GOTO_EXPR
, jump_label2
),
8867 build_empty_stmt (input_location
));
8868 gfc_add_expr_to_block (block
, tmp
);
8869 tmp
= build_call_expr_loc (input_location
,
8870 builtin_decl_explicit (BUILT_IN_REALLOC
),
8871 2, fold_convert (pvoid_type_node
, lse
.expr
),
8873 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8874 gfc_add_modify (block
, lse
.expr
, tmp
);
8875 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8876 gfc_add_expr_to_block (block
, tmp
);
8878 /* Update the lhs character length. */
8879 size
= string_length
;
8880 gfc_add_modify (block
, lse
.string_length
, size
);
8884 /* Check for assignments of the type
8888 to make sure we do not check for reallocation unneccessarily. */
8892 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8894 gfc_actual_arglist
*a
;
8897 switch (expr2
->expr_type
)
8900 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8903 if (expr2
->value
.function
.esym
8904 && expr2
->value
.function
.esym
->attr
.elemental
)
8906 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8909 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8914 else if (expr2
->value
.function
.isym
8915 && expr2
->value
.function
.isym
->elemental
)
8917 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8920 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8929 switch (expr2
->value
.op
.op
)
8932 case INTRINSIC_UPLUS
:
8933 case INTRINSIC_UMINUS
:
8934 case INTRINSIC_PARENTHESES
:
8935 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8937 case INTRINSIC_PLUS
:
8938 case INTRINSIC_MINUS
:
8939 case INTRINSIC_TIMES
:
8940 case INTRINSIC_DIVIDE
:
8941 case INTRINSIC_POWER
:
8945 case INTRINSIC_NEQV
:
8952 case INTRINSIC_EQ_OS
:
8953 case INTRINSIC_NE_OS
:
8954 case INTRINSIC_GT_OS
:
8955 case INTRINSIC_GE_OS
:
8956 case INTRINSIC_LT_OS
:
8957 case INTRINSIC_LE_OS
:
8959 e1
= expr2
->value
.op
.op1
;
8960 e2
= expr2
->value
.op
.op2
;
8962 if (e1
->rank
== 0 && e2
->rank
> 0)
8963 return is_runtime_conformable (expr1
, e2
);
8964 else if (e1
->rank
> 0 && e2
->rank
== 0)
8965 return is_runtime_conformable (expr1
, e1
);
8966 else if (e1
->rank
> 0 && e2
->rank
> 0)
8967 return is_runtime_conformable (expr1
, e1
)
8968 && is_runtime_conformable (expr1
, e2
);
8984 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8985 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8986 init_flag indicates initialization expressions and dealloc that no
8987 deallocate prior assignment is needed (if in doubt, set true). */
8990 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8996 gfc_ss
*lss_section
;
9003 bool scalar_to_array
;
9007 /* Assignment of the form lhs = rhs. */
9008 gfc_start_block (&block
);
9010 gfc_init_se (&lse
, NULL
);
9011 gfc_init_se (&rse
, NULL
);
9014 lss
= gfc_walk_expr (expr1
);
9015 if (gfc_is_reallocatable_lhs (expr1
)
9016 && !(expr2
->expr_type
== EXPR_FUNCTION
9017 && expr2
->value
.function
.isym
!= NULL
))
9018 lss
->is_alloc_lhs
= 1;
9021 if ((expr1
->ts
.type
== BT_DERIVED
)
9022 && (gfc_is_alloc_class_array_function (expr2
)
9023 || gfc_is_alloc_class_scalar_function (expr2
)))
9024 expr2
->must_finalize
= 1;
9026 if (lss
!= gfc_ss_terminator
)
9028 /* The assignment needs scalarization. */
9031 /* Find a non-scalar SS from the lhs. */
9032 while (lss_section
!= gfc_ss_terminator
9033 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9034 lss_section
= lss_section
->next
;
9036 gcc_assert (lss_section
!= gfc_ss_terminator
);
9038 /* Initialize the scalarizer. */
9039 gfc_init_loopinfo (&loop
);
9042 rss
= gfc_walk_expr (expr2
);
9043 if (rss
== gfc_ss_terminator
)
9044 /* The rhs is scalar. Add a ss for the expression. */
9045 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9047 /* Associate the SS with the loop. */
9048 gfc_add_ss_to_loop (&loop
, lss
);
9049 gfc_add_ss_to_loop (&loop
, rss
);
9051 /* Calculate the bounds of the scalarization. */
9052 gfc_conv_ss_startstride (&loop
);
9053 /* Enable loop reversal. */
9054 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9055 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9056 /* Resolve any data dependencies in the statement. */
9057 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9058 /* Setup the scalarizing loops. */
9059 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9061 /* Setup the gfc_se structures. */
9062 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9063 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9066 gfc_mark_ss_chain_used (rss
, 1);
9067 if (loop
.temp_ss
== NULL
)
9070 gfc_mark_ss_chain_used (lss
, 1);
9074 lse
.ss
= loop
.temp_ss
;
9075 gfc_mark_ss_chain_used (lss
, 3);
9076 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9079 /* Allow the scalarizer to workshare array assignments. */
9080 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9081 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9083 /* Start the scalarized loop body. */
9084 gfc_start_scalarized_body (&loop
, &body
);
9087 gfc_init_block (&body
);
9089 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9091 /* Translate the expression. */
9092 gfc_conv_expr (&rse
, expr2
);
9094 /* Deal with the case of a scalar class function assigned to a derived type. */
9095 if (gfc_is_alloc_class_scalar_function (expr2
)
9096 && expr1
->ts
.type
== BT_DERIVED
)
9098 rse
.expr
= gfc_class_data_get (rse
.expr
);
9099 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9102 /* Stabilize a string length for temporaries. */
9103 if (expr2
->ts
.type
== BT_CHARACTER
)
9104 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9106 string_length
= NULL_TREE
;
9110 gfc_conv_tmp_array_ref (&lse
);
9111 if (expr2
->ts
.type
== BT_CHARACTER
)
9112 lse
.string_length
= string_length
;
9115 gfc_conv_expr (&lse
, expr1
);
9117 /* Assignments of scalar derived types with allocatable components
9118 to arrays must be done with a deep copy and the rhs temporary
9119 must have its components deallocated afterwards. */
9120 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9121 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9122 && !expr_is_variable (expr2
)
9123 && !gfc_is_constant_expr (expr2
)
9124 && expr1
->rank
&& !expr2
->rank
);
9125 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9127 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9128 && gfc_is_alloc_class_scalar_function (expr2
));
9129 if (scalar_to_array
&& dealloc
)
9131 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9132 gfc_add_expr_to_block (&loop
.post
, tmp
);
9135 /* When assigning a character function result to a deferred-length variable,
9136 the function call must happen before the (re)allocation of the lhs -
9137 otherwise the character length of the result is not known.
9138 NOTE: This relies on having the exact dependence of the length type
9139 parameter available to the caller; gfortran saves it in the .mod files. */
9140 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9141 gfc_add_block_to_block (&block
, &rse
.pre
);
9143 /* Nullify the allocatable components corresponding to those of the lhs
9144 derived type, so that the finalization of the function result does not
9145 affect the lhs of the assignment. Prepend is used to ensure that the
9146 nullification occurs before the call to the finalizer. In the case of
9147 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9148 as part of the deep copy. */
9149 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9150 && (gfc_is_alloc_class_array_function (expr2
)
9151 || gfc_is_alloc_class_scalar_function (expr2
)))
9154 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9155 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9156 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9157 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9160 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9161 l_is_temp
|| init_flag
,
9162 expr_is_variable (expr2
) || scalar_to_array
9163 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
9164 gfc_add_expr_to_block (&body
, tmp
);
9166 if (lss
== gfc_ss_terminator
)
9168 /* F2003: Add the code for reallocation on assignment. */
9169 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9170 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9173 /* Use the scalar assignment as is. */
9174 gfc_add_block_to_block (&block
, &body
);
9178 gcc_assert (lse
.ss
== gfc_ss_terminator
9179 && rse
.ss
== gfc_ss_terminator
);
9183 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9185 /* We need to copy the temporary to the actual lhs. */
9186 gfc_init_se (&lse
, NULL
);
9187 gfc_init_se (&rse
, NULL
);
9188 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9189 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9191 rse
.ss
= loop
.temp_ss
;
9194 gfc_conv_tmp_array_ref (&rse
);
9195 gfc_conv_expr (&lse
, expr1
);
9197 gcc_assert (lse
.ss
== gfc_ss_terminator
9198 && rse
.ss
== gfc_ss_terminator
);
9200 if (expr2
->ts
.type
== BT_CHARACTER
)
9201 rse
.string_length
= string_length
;
9203 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9204 false, false, dealloc
);
9205 gfc_add_expr_to_block (&body
, tmp
);
9208 /* F2003: Allocate or reallocate lhs of allocatable array. */
9209 if (flag_realloc_lhs
9210 && gfc_is_reallocatable_lhs (expr1
)
9211 && !gfc_expr_attr (expr1
).codimension
9212 && !gfc_is_coindexed (expr1
)
9214 && !is_runtime_conformable (expr1
, expr2
))
9216 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9217 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9218 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9219 if (tmp
!= NULL_TREE
)
9220 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9223 /* Generate the copying loops. */
9224 gfc_trans_scalarizing_loops (&loop
, &body
);
9226 /* Wrap the whole thing up. */
9227 gfc_add_block_to_block (&block
, &loop
.pre
);
9228 gfc_add_block_to_block (&block
, &loop
.post
);
9230 gfc_cleanup_loop (&loop
);
9233 return gfc_finish_block (&block
);
9237 /* Check whether EXPR is a copyable array. */
9240 copyable_array_p (gfc_expr
* expr
)
9242 if (expr
->expr_type
!= EXPR_VARIABLE
)
9245 /* First check it's an array. */
9246 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9249 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9252 /* Next check that it's of a simple enough type. */
9253 switch (expr
->ts
.type
)
9265 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9274 /* Translate an assignment. */
9277 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9282 /* Special case a single function returning an array. */
9283 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9285 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9290 /* Special case assigning an array to zero. */
9291 if (copyable_array_p (expr1
)
9292 && is_zero_initializer_p (expr2
))
9294 tmp
= gfc_trans_zero_assign (expr1
);
9299 /* Special case copying one array to another. */
9300 if (copyable_array_p (expr1
)
9301 && copyable_array_p (expr2
)
9302 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9303 && !gfc_check_dependency (expr1
, expr2
, 0))
9305 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9310 /* Special case initializing an array from a constant array constructor. */
9311 if (copyable_array_p (expr1
)
9312 && expr2
->expr_type
== EXPR_ARRAY
9313 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9315 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9320 /* Fallback to the scalarizer to generate explicit loops. */
9321 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9325 gfc_trans_init_assign (gfc_code
* code
)
9327 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9331 gfc_trans_assign (gfc_code
* code
)
9333 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);