1 /* Expression translation
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "double-int.h"
39 #include "fold-const.h"
40 #include "stringpool.h"
41 #include "diagnostic-core.h" /* For fatal_error. */
42 #include "langhooks.h"
45 #include "constructor.h"
47 #include "trans-const.h"
48 #include "trans-types.h"
49 #include "trans-array.h"
50 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
51 #include "trans-stmt.h"
52 #include "dependency.h"
55 /* Convert a scalar to an array descriptor. To be used for assumed-rank
59 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
61 enum gfc_array_kind akind
;
64 akind
= GFC_ARRAY_POINTER_CONT
;
65 else if (attr
.allocatable
)
66 akind
= GFC_ARRAY_ALLOCATABLE
;
68 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
70 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
71 scalar
= TREE_TYPE (scalar
);
72 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
73 akind
, !(attr
.pointer
|| attr
.target
));
77 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
81 type
= get_scalar_to_descriptor_type (scalar
, attr
);
82 desc
= gfc_create_var (type
, "desc");
83 DECL_ARTIFICIAL (desc
) = 1;
85 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
86 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype (type
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* This is the seed for an eventual trans-class.c
103 The following parameters should not be used directly since they might
104 in future implementations. Use the corresponding APIs. */
105 #define CLASS_DATA_FIELD 0
106 #define CLASS_VPTR_FIELD 1
107 #define CLASS_LEN_FIELD 2
108 #define VTABLE_HASH_FIELD 0
109 #define VTABLE_SIZE_FIELD 1
110 #define VTABLE_EXTENDS_FIELD 2
111 #define VTABLE_DEF_INIT_FIELD 3
112 #define VTABLE_COPY_FIELD 4
113 #define VTABLE_FINAL_FIELD 5
117 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
121 vec
<constructor_elt
, va_gc
> *init
= NULL
;
123 field
= TYPE_FIELDS (TREE_TYPE (decl
));
124 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
125 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
127 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
128 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
130 return build_constructor (TREE_TYPE (decl
), init
);
135 gfc_class_data_get (tree decl
)
138 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
139 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
140 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
142 return fold_build3_loc (input_location
, COMPONENT_REF
,
143 TREE_TYPE (data
), decl
, data
,
149 gfc_class_vptr_get (tree decl
)
152 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
153 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
154 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
156 return fold_build3_loc (input_location
, COMPONENT_REF
,
157 TREE_TYPE (vptr
), decl
, vptr
,
163 gfc_class_len_get (tree decl
)
166 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
167 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
168 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
170 return fold_build3_loc (input_location
, COMPONENT_REF
,
171 TREE_TYPE (len
), decl
, len
,
177 gfc_vtable_field_get (tree decl
, int field
)
181 vptr
= gfc_class_vptr_get (decl
);
182 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
183 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
185 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
186 TREE_TYPE (size
), vptr
, size
,
188 /* Always return size as an array index type. */
189 if (field
== VTABLE_SIZE_FIELD
)
190 size
= fold_convert (gfc_array_index_type
, size
);
197 gfc_vtable_hash_get (tree decl
)
199 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
204 gfc_vtable_size_get (tree decl
)
206 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
211 gfc_vtable_extends_get (tree decl
)
213 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
218 gfc_vtable_def_init_get (tree decl
)
220 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
225 gfc_vtable_copy_get (tree decl
)
227 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
232 gfc_vtable_final_get (tree decl
)
234 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
238 #undef CLASS_DATA_FIELD
239 #undef CLASS_VPTR_FIELD
240 #undef VTABLE_HASH_FIELD
241 #undef VTABLE_SIZE_FIELD
242 #undef VTABLE_EXTENDS_FIELD
243 #undef VTABLE_DEF_INIT_FIELD
244 #undef VTABLE_COPY_FIELD
245 #undef VTABLE_FINAL_FIELD
248 /* Reset the vptr to the declared type, e.g. after deallocation. */
251 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
253 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
258 /* If we have a class array, we need go back to the class
260 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
261 && lhs
->ref
->next
->type
== REF_ARRAY
262 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
263 && lhs
->ref
->type
== REF_COMPONENT
264 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
266 gfc_free_ref_list (lhs
->ref
);
270 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
271 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
272 && ref
->next
->next
->type
== REF_ARRAY
273 && ref
->next
->next
->u
.ar
.type
== AR_FULL
274 && ref
->next
->type
== REF_COMPONENT
275 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
277 gfc_free_ref_list (ref
->next
);
281 gfc_add_vptr_component (lhs
);
283 if (UNLIMITED_POLY (e
))
284 rhs
= gfc_get_null_expr (NULL
);
287 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
288 rhs
= gfc_lval_expr_from_sym (vtab
);
290 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
291 gfc_add_expr_to_block (block
, tmp
);
297 /* Obtain the vptr of the last class reference in an expression.
298 Return NULL_TREE if no class reference is found. */
301 gfc_get_vptr_from_expr (tree expr
)
306 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
308 type
= TREE_TYPE (tmp
);
311 if (GFC_CLASS_TYPE_P (type
))
312 return gfc_class_vptr_get (tmp
);
313 if (type
!= TYPE_CANONICAL (type
))
314 type
= TYPE_CANONICAL (type
);
318 if (TREE_CODE (tmp
) == VAR_DECL
)
326 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
329 tree tmp
, tmp2
, type
;
331 gfc_conv_descriptor_data_set (block
, lhs_desc
,
332 gfc_conv_descriptor_data_get (rhs_desc
));
333 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
334 gfc_conv_descriptor_offset_get (rhs_desc
));
336 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
337 gfc_conv_descriptor_dtype (rhs_desc
));
339 /* Assign the dimension as range-ref. */
340 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
341 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
343 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
344 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
345 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
346 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
347 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
348 gfc_add_modify (block
, tmp
, tmp2
);
352 /* Takes a derived type expression and returns the address of a temporary
353 class object of the 'declared' type. If vptr is not NULL, this is
354 used for the temporary class object.
355 optional_alloc_ptr is false when the dummy is neither allocatable
356 nor a pointer; that's only relevant for the optional handling. */
358 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
359 gfc_typespec class_ts
, tree vptr
, bool optional
,
360 bool optional_alloc_ptr
)
363 tree cond_optional
= NULL_TREE
;
369 /* The derived type needs to be converted to a temporary
371 tmp
= gfc_typenode_for_spec (&class_ts
);
372 var
= gfc_create_var (tmp
, "class");
375 ctree
= gfc_class_vptr_get (var
);
377 if (vptr
!= NULL_TREE
)
379 /* Use the dynamic vptr. */
384 /* In this case the vtab corresponds to the derived type and the
385 vptr must point to it. */
386 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
388 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
390 gfc_add_modify (&parmse
->pre
, ctree
,
391 fold_convert (TREE_TYPE (ctree
), tmp
));
393 /* Now set the data field. */
394 ctree
= gfc_class_data_get (var
);
397 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
399 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
401 /* For an array reference in an elemental procedure call we need
402 to retain the ss to provide the scalarized array reference. */
403 gfc_conv_expr_reference (parmse
, e
);
404 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
406 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
408 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
409 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
414 ss
= gfc_walk_expr (e
);
415 if (ss
== gfc_ss_terminator
)
418 gfc_conv_expr_reference (parmse
, e
);
420 /* Scalar to an assumed-rank array. */
421 if (class_ts
.u
.derived
->components
->as
)
424 type
= get_scalar_to_descriptor_type (parmse
->expr
,
426 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
427 gfc_get_dtype (type
));
429 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
430 TREE_TYPE (parmse
->expr
),
431 cond_optional
, parmse
->expr
,
432 fold_convert (TREE_TYPE (parmse
->expr
),
434 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
438 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
440 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
442 fold_convert (TREE_TYPE (tmp
),
444 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
450 gfc_init_block (&block
);
453 gfc_conv_expr_descriptor (parmse
, e
);
455 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
457 gcc_assert (class_ts
.u
.derived
->components
->as
->type
459 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
463 if (gfc_expr_attr (e
).codimension
)
464 parmse
->expr
= fold_build1_loc (input_location
,
468 gfc_add_modify (&block
, ctree
, parmse
->expr
);
473 tmp
= gfc_finish_block (&block
);
475 gfc_init_block (&block
);
476 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
478 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
479 gfc_finish_block (&block
));
480 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
483 gfc_add_block_to_block (&parmse
->pre
, &block
);
487 /* Pass the address of the class object. */
488 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
490 if (optional
&& optional_alloc_ptr
)
491 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
492 TREE_TYPE (parmse
->expr
),
493 cond_optional
, parmse
->expr
,
494 fold_convert (TREE_TYPE (parmse
->expr
),
499 /* Create a new class container, which is required as scalar coarrays
500 have an array descriptor while normal scalars haven't. Optionally,
501 NULL pointer checks are added if the argument is OPTIONAL. */
504 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
505 gfc_typespec class_ts
, bool optional
)
507 tree var
, ctree
, tmp
;
512 gfc_init_block (&block
);
515 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
517 if (ref
->type
== REF_COMPONENT
518 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
522 if (class_ref
== NULL
523 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
524 tmp
= e
->symtree
->n
.sym
->backend_decl
;
527 /* Remove everything after the last class reference, convert the
528 expression and then recover its tailend once more. */
530 ref
= class_ref
->next
;
531 class_ref
->next
= NULL
;
532 gfc_init_se (&tmpse
, NULL
);
533 gfc_conv_expr (&tmpse
, e
);
534 class_ref
->next
= ref
;
538 var
= gfc_typenode_for_spec (&class_ts
);
539 var
= gfc_create_var (var
, "class");
541 ctree
= gfc_class_vptr_get (var
);
542 gfc_add_modify (&block
, ctree
,
543 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
545 ctree
= gfc_class_data_get (var
);
546 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
547 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
549 /* Pass the address of the class object. */
550 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
554 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
557 tmp
= gfc_finish_block (&block
);
559 gfc_init_block (&block
);
560 tmp2
= gfc_class_data_get (var
);
561 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
563 tmp2
= gfc_finish_block (&block
);
565 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
567 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
570 gfc_add_block_to_block (&parmse
->pre
, &block
);
574 /* Takes an intrinsic type expression and returns the address of a temporary
575 class object of the 'declared' type. */
577 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
578 gfc_typespec class_ts
)
586 /* The intrinsic type needs to be converted to a temporary
588 tmp
= gfc_typenode_for_spec (&class_ts
);
589 var
= gfc_create_var (tmp
, "class");
592 ctree
= gfc_class_vptr_get (var
);
594 vtab
= gfc_find_vtab (&e
->ts
);
596 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
597 gfc_add_modify (&parmse
->pre
, ctree
,
598 fold_convert (TREE_TYPE (ctree
), tmp
));
600 /* Now set the data field. */
601 ctree
= gfc_class_data_get (var
);
602 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
604 /* For an array reference in an elemental procedure call we need
605 to retain the ss to provide the scalarized array reference. */
606 gfc_conv_expr_reference (parmse
, e
);
607 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
608 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
612 ss
= gfc_walk_expr (e
);
613 if (ss
== gfc_ss_terminator
)
616 gfc_conv_expr_reference (parmse
, e
);
617 if (class_ts
.u
.derived
->components
->as
618 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
620 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
622 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
623 TREE_TYPE (ctree
), tmp
);
626 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
627 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
632 parmse
->use_offset
= 1;
633 gfc_conv_expr_descriptor (parmse
, e
);
634 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
636 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
637 TREE_TYPE (ctree
), parmse
->expr
);
638 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
641 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
645 /* When the actual arg is a char array, then set the _len component of the
646 unlimited polymorphic entity, too. */
647 if (e
->ts
.type
== BT_CHARACTER
)
649 ctree
= gfc_class_len_get (var
);
650 /* Start with parmse->string_length because this seems to be set to a
651 correct value more often. */
652 if (parmse
->string_length
)
653 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->string_length
);
654 /* When the string_length is not yet set, then try the backend_decl of
656 else if (e
->ts
.u
.cl
->backend_decl
)
657 gfc_add_modify (&parmse
->pre
, ctree
, e
->ts
.u
.cl
->backend_decl
);
658 /* If both of the above approaches fail, then try to generate an
659 expression from the input, which is only feasible currently, when the
660 expression can be evaluated to a constant one. */
663 /* Try to simplify the expression. */
664 gfc_simplify_expr (e
, 0);
665 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
667 /* Amazingly all data is present to compute the length of a
668 constant string, but the expression is not yet there. */
669 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
671 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
672 e
->value
.character
.length
);
673 gfc_conv_const_charlen (e
->ts
.u
.cl
);
674 e
->ts
.u
.cl
->resolved
= 1;
675 gfc_add_modify (&parmse
->pre
, ctree
, e
->ts
.u
.cl
->backend_decl
);
679 gfc_error ("Can't compute the length of the char array at %L.",
684 /* Pass the address of the class object. */
685 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
689 /* Takes a scalarized class array expression and returns the
690 address of a temporary scalar class object of the 'declared'
692 OOP-TODO: This could be improved by adding code that branched on
693 the dynamic type being the same as the declared type. In this case
694 the original class expression can be passed directly.
695 optional_alloc_ptr is false when the dummy is neither allocatable
696 nor a pointer; that's relevant for the optional handling.
697 Set copyback to true if class container's _data and _vtab pointers
698 might get modified. */
701 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
702 bool elemental
, bool copyback
, bool optional
,
703 bool optional_alloc_ptr
)
709 tree cond
= NULL_TREE
;
713 bool full_array
= false;
715 gfc_init_block (&block
);
718 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
720 if (ref
->type
== REF_COMPONENT
721 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
724 if (ref
->next
== NULL
)
728 if ((ref
== NULL
|| class_ref
== ref
)
729 && (!class_ts
.u
.derived
->components
->as
730 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
733 /* Test for FULL_ARRAY. */
734 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
735 && gfc_expr_attr (e
).dimension
)
738 gfc_is_class_array_ref (e
, &full_array
);
740 /* The derived type needs to be converted to a temporary
742 tmp
= gfc_typenode_for_spec (&class_ts
);
743 var
= gfc_create_var (tmp
, "class");
746 ctree
= gfc_class_data_get (var
);
747 if (class_ts
.u
.derived
->components
->as
748 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
752 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
754 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
755 gfc_get_dtype (type
));
757 tmp
= gfc_class_data_get (parmse
->expr
);
758 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
759 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
761 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
764 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
768 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
769 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
770 TREE_TYPE (ctree
), parmse
->expr
);
771 gfc_add_modify (&block
, ctree
, parmse
->expr
);
774 /* Return the data component, except in the case of scalarized array
775 references, where nullification of the cannot occur and so there
777 if (!elemental
&& full_array
&& copyback
)
779 if (class_ts
.u
.derived
->components
->as
780 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
783 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
784 gfc_conv_descriptor_data_get (ctree
));
786 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
789 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
793 ctree
= gfc_class_vptr_get (var
);
795 /* The vptr is the second field of the actual argument.
796 First we have to find the corresponding class reference. */
799 if (class_ref
== NULL
800 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
801 tmp
= e
->symtree
->n
.sym
->backend_decl
;
804 /* Remove everything after the last class reference, convert the
805 expression and then recover its tailend once more. */
807 ref
= class_ref
->next
;
808 class_ref
->next
= NULL
;
809 gfc_init_se (&tmpse
, NULL
);
810 gfc_conv_expr (&tmpse
, e
);
811 class_ref
->next
= ref
;
815 gcc_assert (tmp
!= NULL_TREE
);
817 /* Dereference if needs be. */
818 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
819 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
821 vptr
= gfc_class_vptr_get (tmp
);
822 gfc_add_modify (&block
, ctree
,
823 fold_convert (TREE_TYPE (ctree
), vptr
));
825 /* Return the vptr component, except in the case of scalarized array
826 references, where the dynamic type cannot change. */
827 if (!elemental
&& full_array
&& copyback
)
828 gfc_add_modify (&parmse
->post
, vptr
,
829 fold_convert (TREE_TYPE (vptr
), ctree
));
835 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
836 tmp
= gfc_finish_block (&block
);
838 if (optional_alloc_ptr
)
839 tmp2
= build_empty_stmt (input_location
);
842 gfc_init_block (&block
);
844 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
845 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
847 tmp2
= gfc_finish_block (&block
);
850 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
852 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
855 gfc_add_block_to_block (&parmse
->pre
, &block
);
857 /* Pass the address of the class object. */
858 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
860 if (optional
&& optional_alloc_ptr
)
861 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
862 TREE_TYPE (parmse
->expr
),
864 fold_convert (TREE_TYPE (parmse
->expr
),
869 /* Given a class array declaration and an index, returns the address
870 of the referenced element. */
873 gfc_get_class_array_ref (tree index
, tree class_decl
)
875 tree data
= gfc_class_data_get (class_decl
);
876 tree size
= gfc_vtable_size_get (class_decl
);
877 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
878 gfc_array_index_type
,
881 data
= gfc_conv_descriptor_data_get (data
);
882 ptr
= fold_convert (pvoid_type_node
, data
);
883 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
884 return fold_convert (TREE_TYPE (data
), ptr
);
888 /* Copies one class expression to another, assuming that if either
889 'to' or 'from' are arrays they are packed. Should 'from' be
890 NULL_TREE, the initialization expression for 'to' is used, assuming
891 that the _vptr is set. */
894 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
902 vec
<tree
, va_gc
> *args
;
905 stmtblock_t loopbody
;
911 if (from
!= NULL_TREE
)
912 fcn
= gfc_vtable_copy_get (from
);
914 fcn
= gfc_vtable_copy_get (to
);
916 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
918 if (from
!= NULL_TREE
)
919 from_data
= gfc_class_data_get (from
);
921 from_data
= gfc_vtable_def_init_get (to
);
923 to_data
= gfc_class_data_get (to
);
925 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
927 gfc_init_block (&body
);
928 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
929 gfc_array_index_type
, nelems
,
931 nelems
= gfc_evaluate_now (tmp
, &body
);
932 index
= gfc_create_var (gfc_array_index_type
, "S");
934 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
936 from_ref
= gfc_get_class_array_ref (index
, from
);
937 vec_safe_push (args
, from_ref
);
940 vec_safe_push (args
, from_data
);
942 to_ref
= gfc_get_class_array_ref (index
, to
);
943 vec_safe_push (args
, to_ref
);
945 tmp
= build_call_vec (fcn_type
, fcn
, args
);
947 /* Build the body of the loop. */
948 gfc_init_block (&loopbody
);
949 gfc_add_expr_to_block (&loopbody
, tmp
);
951 /* Build the loop and return. */
952 gfc_init_loopinfo (&loop
);
954 loop
.from
[0] = gfc_index_zero_node
;
955 loop
.loopvar
[0] = index
;
957 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
958 gfc_add_block_to_block (&body
, &loop
.pre
);
959 tmp
= gfc_finish_block (&body
);
960 gfc_cleanup_loop (&loop
);
964 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
965 vec_safe_push (args
, from_data
);
966 vec_safe_push (args
, to_data
);
967 tmp
= build_call_vec (fcn_type
, fcn
, args
);
974 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
976 gfc_actual_arglist
*actual
;
981 actual
= gfc_get_actual_arglist ();
982 actual
->expr
= gfc_copy_expr (rhs
);
983 actual
->next
= gfc_get_actual_arglist ();
984 actual
->next
->expr
= gfc_copy_expr (lhs
);
985 ppc
= gfc_copy_expr (obj
);
986 gfc_add_vptr_component (ppc
);
987 gfc_add_component_ref (ppc
, "_copy");
988 ppc_code
= gfc_get_code (EXEC_CALL
);
989 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
990 /* Although '_copy' is set to be elemental in class.c, it is
991 not staying that way. Find out why, sometime.... */
992 ppc_code
->resolved_sym
->attr
.elemental
= 1;
993 ppc_code
->ext
.actual
= actual
;
994 ppc_code
->expr1
= ppc
;
995 /* Since '_copy' is elemental, the scalarizer will take care
996 of arrays in gfc_trans_call. */
997 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
998 gfc_free_statements (ppc_code
);
1000 if (UNLIMITED_POLY(obj
))
1002 /* Check if rhs is non-NULL. */
1004 gfc_init_se (&src
, NULL
);
1005 gfc_conv_expr (&src
, rhs
);
1006 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1007 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1008 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1009 null_pointer_node
));
1010 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1011 build_empty_stmt (input_location
));
1017 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1018 A MEMCPY is needed to copy the full data from the default initializer
1019 of the dynamic type. */
1022 gfc_trans_class_init_assign (gfc_code
*code
)
1026 gfc_se dst
,src
,memsz
;
1027 gfc_expr
*lhs
, *rhs
, *sz
;
1029 gfc_start_block (&block
);
1031 lhs
= gfc_copy_expr (code
->expr1
);
1032 gfc_add_data_component (lhs
);
1034 rhs
= gfc_copy_expr (code
->expr1
);
1035 gfc_add_vptr_component (rhs
);
1037 /* Make sure that the component backend_decls have been built, which
1038 will not have happened if the derived types concerned have not
1040 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1041 gfc_add_def_init_component (rhs
);
1043 if (code
->expr1
->ts
.type
== BT_CLASS
1044 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1045 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1048 sz
= gfc_copy_expr (code
->expr1
);
1049 gfc_add_vptr_component (sz
);
1050 gfc_add_size_component (sz
);
1052 gfc_init_se (&dst
, NULL
);
1053 gfc_init_se (&src
, NULL
);
1054 gfc_init_se (&memsz
, NULL
);
1055 gfc_conv_expr (&dst
, lhs
);
1056 gfc_conv_expr (&src
, rhs
);
1057 gfc_conv_expr (&memsz
, sz
);
1058 gfc_add_block_to_block (&block
, &src
.pre
);
1059 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1061 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1063 if (UNLIMITED_POLY(code
->expr1
))
1065 /* Check if _def_init is non-NULL. */
1066 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1067 boolean_type_node
, src
.expr
,
1068 fold_convert (TREE_TYPE (src
.expr
),
1069 null_pointer_node
));
1070 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1071 tmp
, build_empty_stmt (input_location
));
1075 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1076 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1078 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1079 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1081 build_empty_stmt (input_location
));
1084 gfc_add_expr_to_block (&block
, tmp
);
1086 return gfc_finish_block (&block
);
1090 /* Translate an assignment to a CLASS object
1091 (pointer or ordinary assignment). */
1094 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1102 gfc_start_block (&block
);
1105 while (ref
&& ref
->next
)
1108 /* Class valued proc_pointer assignments do not need any further
1110 if (ref
&& ref
->type
== REF_COMPONENT
1111 && ref
->u
.c
.component
->attr
.proc_pointer
1112 && expr2
->expr_type
== EXPR_VARIABLE
1113 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1114 && op
== EXEC_POINTER_ASSIGN
)
1117 if (expr2
->ts
.type
!= BT_CLASS
)
1119 /* Insert an additional assignment which sets the '_vptr' field. */
1120 gfc_symbol
*vtab
= NULL
;
1123 lhs
= gfc_copy_expr (expr1
);
1124 gfc_add_vptr_component (lhs
);
1126 if (UNLIMITED_POLY (expr1
)
1127 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1129 rhs
= gfc_get_null_expr (&expr2
->where
);
1133 if (expr2
->expr_type
== EXPR_NULL
)
1134 vtab
= gfc_find_vtab (&expr1
->ts
);
1136 vtab
= gfc_find_vtab (&expr2
->ts
);
1139 rhs
= gfc_get_expr ();
1140 rhs
->expr_type
= EXPR_VARIABLE
;
1141 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1145 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1146 gfc_add_expr_to_block (&block
, tmp
);
1148 gfc_free_expr (lhs
);
1149 gfc_free_expr (rhs
);
1151 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1153 /* F2003:C717 only sequence and bind-C types can come here. */
1154 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1155 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1156 gfc_add_data_component (expr2
);
1159 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1161 /* Insert an additional assignment which sets the '_vptr' field. */
1162 lhs
= gfc_copy_expr (expr1
);
1163 gfc_add_vptr_component (lhs
);
1165 rhs
= gfc_copy_expr (expr2
);
1166 gfc_add_vptr_component (rhs
);
1168 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1169 gfc_add_expr_to_block (&block
, tmp
);
1171 gfc_free_expr (lhs
);
1172 gfc_free_expr (rhs
);
1175 /* Do the actual CLASS assignment. */
1176 if (expr2
->ts
.type
== BT_CLASS
1177 && !CLASS_DATA (expr2
)->attr
.dimension
)
1179 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1180 || !CLASS_DATA (expr2
)->attr
.dimension
)
1181 gfc_add_data_component (expr1
);
1185 if (op
== EXEC_ASSIGN
)
1186 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1187 else if (op
== EXEC_POINTER_ASSIGN
)
1188 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1192 gfc_add_expr_to_block (&block
, tmp
);
1194 return gfc_finish_block (&block
);
1198 /* End of prototype trans-class.c */
1202 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1204 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1205 gfc_warning (OPT_Wrealloc_lhs
,
1206 "Code for reallocating the allocatable array at %L will "
1208 else if (warn_realloc_lhs_all
)
1209 gfc_warning (OPT_Wrealloc_lhs_all
,
1210 "Code for reallocating the allocatable variable at %L "
1211 "will be added", where
);
1215 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
);
1216 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1219 /* Copy the scalarization loop variables. */
1222 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1225 dest
->loop
= src
->loop
;
1229 /* Initialize a simple expression holder.
1231 Care must be taken when multiple se are created with the same parent.
1232 The child se must be kept in sync. The easiest way is to delay creation
1233 of a child se until after after the previous se has been translated. */
1236 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1238 memset (se
, 0, sizeof (gfc_se
));
1239 gfc_init_block (&se
->pre
);
1240 gfc_init_block (&se
->post
);
1242 se
->parent
= parent
;
1245 gfc_copy_se_loopvars (se
, parent
);
1249 /* Advances to the next SS in the chain. Use this rather than setting
1250 se->ss = se->ss->next because all the parents needs to be kept in sync.
1254 gfc_advance_se_ss_chain (gfc_se
* se
)
1259 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1262 /* Walk down the parent chain. */
1265 /* Simple consistency check. */
1266 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1267 || p
->parent
->ss
->nested_ss
== p
->ss
);
1269 /* If we were in a nested loop, the next scalarized expression can be
1270 on the parent ss' next pointer. Thus we should not take the next
1271 pointer blindly, but rather go up one nest level as long as next
1272 is the end of chain. */
1274 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1284 /* Ensures the result of the expression as either a temporary variable
1285 or a constant so that it can be used repeatedly. */
1288 gfc_make_safe_expr (gfc_se
* se
)
1292 if (CONSTANT_CLASS_P (se
->expr
))
1295 /* We need a temporary for this result. */
1296 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1297 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1302 /* Return an expression which determines if a dummy parameter is present.
1303 Also used for arguments to procedures with multiple entry points. */
1306 gfc_conv_expr_present (gfc_symbol
* sym
)
1310 gcc_assert (sym
->attr
.dummy
);
1311 decl
= gfc_get_symbol_decl (sym
);
1313 /* Intrinsic scalars with VALUE attribute which are passed by value
1314 use a hidden argument to denote the present status. */
1315 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1316 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1317 && !sym
->attr
.dimension
)
1319 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1322 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1324 strcpy (&name
[1], sym
->name
);
1325 tree_name
= get_identifier (name
);
1327 /* Walk function argument list to find hidden arg. */
1328 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1329 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1330 if (DECL_NAME (cond
) == tree_name
)
1337 if (TREE_CODE (decl
) != PARM_DECL
)
1339 /* Array parameters use a temporary descriptor, we want the real
1341 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1342 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1343 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1346 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1347 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1349 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1350 as actual argument to denote absent dummies. For array descriptors,
1351 we thus also need to check the array descriptor. For BT_CLASS, it
1352 can also occur for scalars and F2003 due to type->class wrapping and
1353 class->class wrapping. Note further that BT_CLASS always uses an
1354 array descriptor for arrays, also for explicit-shape/assumed-size. */
1356 if (!sym
->attr
.allocatable
1357 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1358 || (sym
->ts
.type
== BT_CLASS
1359 && !CLASS_DATA (sym
)->attr
.allocatable
1360 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1361 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1362 || sym
->ts
.type
== BT_CLASS
))
1366 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1367 || sym
->as
->type
== AS_ASSUMED_RANK
1368 || sym
->attr
.codimension
))
1369 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1371 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1372 if (sym
->ts
.type
== BT_CLASS
)
1373 tmp
= gfc_class_data_get (tmp
);
1374 tmp
= gfc_conv_array_data (tmp
);
1376 else if (sym
->ts
.type
== BT_CLASS
)
1377 tmp
= gfc_class_data_get (decl
);
1381 if (tmp
!= NULL_TREE
)
1383 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1384 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1385 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1386 boolean_type_node
, cond
, tmp
);
1394 /* Converts a missing, dummy argument into a null or zero. */
1397 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1402 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1406 /* Create a temporary and convert it to the correct type. */
1407 tmp
= gfc_get_int_type (kind
);
1408 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1411 /* Test for a NULL value. */
1412 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1413 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1414 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1415 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1419 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1421 build_zero_cst (TREE_TYPE (se
->expr
)));
1422 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1426 if (ts
.type
== BT_CHARACTER
)
1428 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1429 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1430 present
, se
->string_length
, tmp
);
1431 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1432 se
->string_length
= tmp
;
1438 /* Get the character length of an expression, looking through gfc_refs
1442 gfc_get_expr_charlen (gfc_expr
*e
)
1447 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1448 && e
->ts
.type
== BT_CHARACTER
);
1450 length
= NULL
; /* To silence compiler warning. */
1452 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1455 gfc_init_se (&tmpse
, NULL
);
1456 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1457 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1461 /* First candidate: if the variable is of type CHARACTER, the
1462 expression's length could be the length of the character
1464 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1465 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1467 /* Look through the reference chain for component references. */
1468 for (r
= e
->ref
; r
; r
= r
->next
)
1473 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1474 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1482 /* We should never got substring references here. These will be
1483 broken down by the scalarizer. */
1489 gcc_assert (length
!= NULL
);
1494 /* Return for an expression the backend decl of the coarray. */
1497 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1503 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1505 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1506 gcc_assert (caf_decl
);
1507 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1508 caf_decl
= gfc_class_data_get (caf_decl
);
1509 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1512 /* The following code assumes that the coarray is a component reachable via
1513 only scalar components/variables; the Fortran standard guarantees this. */
1515 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1516 if (ref
->type
== REF_COMPONENT
)
1518 gfc_component
*comp
= ref
->u
.c
.component
;
1520 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1521 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1522 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1523 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1524 comp
->backend_decl
, NULL_TREE
);
1525 if (comp
->ts
.type
== BT_CLASS
)
1526 caf_decl
= gfc_class_data_get (caf_decl
);
1527 if (comp
->attr
.codimension
)
1533 gcc_assert (found
&& caf_decl
);
1538 /* Obtain the Coarray token - and optionally also the offset. */
1541 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1546 /* Coarray token. */
1547 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1549 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1550 == GFC_ARRAY_ALLOCATABLE
1551 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1552 *token
= gfc_conv_descriptor_token (caf_decl
);
1554 else if (DECL_LANG_SPECIFIC (caf_decl
)
1555 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1556 *token
= GFC_DECL_TOKEN (caf_decl
);
1559 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1560 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1561 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1567 /* Offset between the coarray base address and the address wanted. */
1568 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1569 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1570 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1571 *offset
= build_int_cst (gfc_array_index_type
, 0);
1572 else if (DECL_LANG_SPECIFIC (caf_decl
)
1573 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1574 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1575 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1576 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1578 *offset
= build_int_cst (gfc_array_index_type
, 0);
1580 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1581 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1583 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1584 tmp
= gfc_conv_descriptor_data_get (tmp
);
1586 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1587 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1590 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1594 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1595 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1597 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1598 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1601 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1605 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1606 fold_convert (gfc_array_index_type
, *offset
),
1607 fold_convert (gfc_array_index_type
, tmp
));
1611 /* Convert the coindex of a coarray into an image index; the result is
1612 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1613 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1616 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1619 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1623 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1624 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1626 gcc_assert (ref
!= NULL
);
1628 img_idx
= integer_zero_node
;
1629 extent
= integer_one_node
;
1630 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1631 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1633 gfc_init_se (&se
, NULL
);
1634 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1635 gfc_add_block_to_block (block
, &se
.pre
);
1636 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1637 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1638 integer_type_node
, se
.expr
,
1639 fold_convert(integer_type_node
, lbound
));
1640 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1642 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1644 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1646 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1647 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1648 tmp
= fold_convert (integer_type_node
, tmp
);
1649 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1650 integer_type_node
, extent
, tmp
);
1654 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1656 gfc_init_se (&se
, NULL
);
1657 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1658 gfc_add_block_to_block (block
, &se
.pre
);
1659 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1660 lbound
= fold_convert (integer_type_node
, lbound
);
1661 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1662 integer_type_node
, se
.expr
, lbound
);
1663 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1665 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1667 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1669 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1670 ubound
= fold_convert (integer_type_node
, ubound
);
1671 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1672 integer_type_node
, ubound
, lbound
);
1673 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1674 tmp
, integer_one_node
);
1675 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1676 integer_type_node
, extent
, tmp
);
1679 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1680 img_idx
, integer_one_node
);
1685 /* For each character array constructor subexpression without a ts.u.cl->length,
1686 replace it by its first element (if there aren't any elements, the length
1687 should already be set to zero). */
1690 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1692 gfc_actual_arglist
* arg
;
1698 switch (e
->expr_type
)
1702 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1703 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1707 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1711 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1712 flatten_array_ctors_without_strlen (arg
->expr
);
1717 /* We've found what we're looking for. */
1718 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1723 gcc_assert (e
->value
.constructor
);
1725 c
= gfc_constructor_first (e
->value
.constructor
);
1729 flatten_array_ctors_without_strlen (new_expr
);
1730 gfc_replace_expr (e
, new_expr
);
1734 /* Otherwise, fall through to handle constructor elements. */
1735 case EXPR_STRUCTURE
:
1736 for (c
= gfc_constructor_first (e
->value
.constructor
);
1737 c
; c
= gfc_constructor_next (c
))
1738 flatten_array_ctors_without_strlen (c
->expr
);
1748 /* Generate code to initialize a string length variable. Returns the
1749 value. For array constructors, cl->length might be NULL and in this case,
1750 the first element of the constructor is needed. expr is the original
1751 expression so we can access it but can be NULL if this is not needed. */
1754 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1758 gfc_init_se (&se
, NULL
);
1762 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1765 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1766 "flatten" array constructors by taking their first element; all elements
1767 should be the same length or a cl->length should be present. */
1770 gfc_expr
* expr_flat
;
1772 expr_flat
= gfc_copy_expr (expr
);
1773 flatten_array_ctors_without_strlen (expr_flat
);
1774 gfc_resolve_expr (expr_flat
);
1776 gfc_conv_expr (&se
, expr_flat
);
1777 gfc_add_block_to_block (pblock
, &se
.pre
);
1778 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1780 gfc_free_expr (expr_flat
);
1784 /* Convert cl->length. */
1786 gcc_assert (cl
->length
);
1788 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1789 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1790 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1791 gfc_add_block_to_block (pblock
, &se
.pre
);
1793 if (cl
->backend_decl
)
1794 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1796 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1801 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1802 const char *name
, locus
*where
)
1812 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1813 type
= build_pointer_type (type
);
1815 gfc_init_se (&start
, se
);
1816 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1817 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1819 if (integer_onep (start
.expr
))
1820 gfc_conv_string_parameter (se
);
1825 /* Avoid multiple evaluation of substring start. */
1826 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1827 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1829 /* Change the start of the string. */
1830 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1833 tmp
= build_fold_indirect_ref_loc (input_location
,
1835 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1836 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1839 /* Length = end + 1 - start. */
1840 gfc_init_se (&end
, se
);
1841 if (ref
->u
.ss
.end
== NULL
)
1842 end
.expr
= se
->string_length
;
1845 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1846 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1850 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1851 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1853 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1855 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1856 boolean_type_node
, start
.expr
,
1859 /* Check lower bound. */
1860 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1862 build_int_cst (gfc_charlen_type_node
, 1));
1863 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1864 boolean_type_node
, nonempty
, fault
);
1866 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
1867 "is less than one", name
);
1869 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
1870 "is less than one");
1871 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1872 fold_convert (long_integer_type_node
,
1876 /* Check upper bound. */
1877 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1878 end
.expr
, se
->string_length
);
1879 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1880 boolean_type_node
, nonempty
, fault
);
1882 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
1883 "exceeds string length (%%ld)", name
);
1885 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
1886 "exceeds string length (%%ld)");
1887 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1888 fold_convert (long_integer_type_node
, end
.expr
),
1889 fold_convert (long_integer_type_node
,
1890 se
->string_length
));
1894 /* Try to calculate the length from the start and end expressions. */
1896 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1900 i_len
= mpz_get_si (length
) + 1;
1904 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1905 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1909 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1910 end
.expr
, start
.expr
);
1911 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1912 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1913 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1914 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1917 se
->string_length
= tmp
;
1921 /* Convert a derived type component reference. */
1924 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1931 c
= ref
->u
.c
.component
;
1933 gcc_assert (c
->backend_decl
);
1935 field
= c
->backend_decl
;
1936 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1939 /* Components can correspond to fields of different containing
1940 types, as components are created without context, whereas
1941 a concrete use of a component has the type of decl as context.
1942 So, if the type doesn't match, we search the corresponding
1943 FIELD_DECL in the parent type. To not waste too much time
1944 we cache this result in norestrict_decl. */
1946 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1948 tree f2
= c
->norestrict_decl
;
1949 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1950 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1951 if (TREE_CODE (f2
) == FIELD_DECL
1952 && DECL_NAME (f2
) == DECL_NAME (field
))
1955 c
->norestrict_decl
= f2
;
1959 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1960 decl
, field
, NULL_TREE
);
1964 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
1965 strlen () conditional below. */
1966 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
1967 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
1969 tmp
= c
->ts
.u
.cl
->backend_decl
;
1970 /* Components must always be constant length. */
1971 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1972 se
->string_length
= tmp
;
1975 if (gfc_deferred_strlen (c
, &field
))
1977 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1979 decl
, field
, NULL_TREE
);
1980 se
->string_length
= tmp
;
1983 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1984 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1985 && c
->ts
.type
!= BT_CHARACTER
)
1986 || c
->attr
.proc_pointer
)
1987 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1992 /* This function deals with component references to components of the
1993 parent type for derived type extensions. */
1995 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2003 c
= ref
->u
.c
.component
;
2005 /* Return if the component is in the parent type. */
2006 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2007 if (strcmp (c
->name
, cmp
->name
) == 0)
2010 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2011 parent
.type
= REF_COMPONENT
;
2013 parent
.u
.c
.sym
= dt
;
2014 parent
.u
.c
.component
= dt
->components
;
2016 if (dt
->backend_decl
== NULL
)
2017 gfc_get_derived_type (dt
);
2019 /* Build the reference and call self. */
2020 gfc_conv_component_ref (se
, &parent
);
2021 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2022 parent
.u
.c
.component
= c
;
2023 conv_parent_component_references (se
, &parent
);
2026 /* Return the contents of a variable. Also handles reference/pointer
2027 variables (all Fortran pointer references are implicit). */
2030 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2035 tree parent_decl
= NULL_TREE
;
2038 bool alternate_entry
;
2041 sym
= expr
->symtree
->n
.sym
;
2045 gfc_ss_info
*ss_info
= ss
->info
;
2047 /* Check that something hasn't gone horribly wrong. */
2048 gcc_assert (ss
!= gfc_ss_terminator
);
2049 gcc_assert (ss_info
->expr
== expr
);
2051 /* A scalarized term. We already know the descriptor. */
2052 se
->expr
= ss_info
->data
.array
.descriptor
;
2053 se
->string_length
= ss_info
->string_length
;
2054 ref
= ss_info
->data
.array
.ref
;
2056 gcc_assert (ref
->type
== REF_ARRAY
2057 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2059 gfc_conv_tmp_array_ref (se
);
2063 tree se_expr
= NULL_TREE
;
2065 se
->expr
= gfc_get_symbol_decl (sym
);
2067 /* Deal with references to a parent results or entries by storing
2068 the current_function_decl and moving to the parent_decl. */
2069 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2070 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2071 && sym
->result
== sym
;
2072 entry_master
= sym
->attr
.result
2073 && sym
->ns
->proc_name
->attr
.entry_master
2074 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2075 if (current_function_decl
)
2076 parent_decl
= DECL_CONTEXT (current_function_decl
);
2078 if ((se
->expr
== parent_decl
&& return_value
)
2079 || (sym
->ns
&& sym
->ns
->proc_name
2081 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2082 && (alternate_entry
|| entry_master
)))
2087 /* Special case for assigning the return value of a function.
2088 Self recursive functions must have an explicit return value. */
2089 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2090 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2092 /* Similarly for alternate entry points. */
2093 else if (alternate_entry
2094 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2097 gfc_entry_list
*el
= NULL
;
2099 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2102 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2107 else if (entry_master
2108 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2110 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2115 /* Procedure actual arguments. */
2116 else if (sym
->attr
.flavor
== FL_PROCEDURE
2117 && se
->expr
!= current_function_decl
)
2119 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2121 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2122 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2128 /* Dereference the expression, where needed. Since characters
2129 are entirely different from other types, they are treated
2131 if (sym
->ts
.type
== BT_CHARACTER
)
2133 /* Dereference character pointer dummy arguments
2135 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2137 || sym
->attr
.function
2138 || sym
->attr
.result
))
2139 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2143 else if (!sym
->attr
.value
)
2145 /* Dereference non-character scalar dummy arguments. */
2146 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2147 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
2148 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2151 /* Dereference scalar hidden result. */
2152 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2153 && (sym
->attr
.function
|| sym
->attr
.result
)
2154 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2155 && !sym
->attr
.always_explicit
)
2156 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2159 /* Dereference non-character pointer variables.
2160 These must be dummies, results, or scalars. */
2161 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2162 || gfc_is_associate_pointer (sym
)
2163 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2165 || sym
->attr
.function
2167 || (!sym
->attr
.dimension
2168 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2169 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2176 /* For character variables, also get the length. */
2177 if (sym
->ts
.type
== BT_CHARACTER
)
2179 /* If the character length of an entry isn't set, get the length from
2180 the master function instead. */
2181 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2182 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2184 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2185 gcc_assert (se
->string_length
);
2193 /* Return the descriptor if that's what we want and this is an array
2194 section reference. */
2195 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2197 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2198 /* Return the descriptor for array pointers and allocations. */
2199 if (se
->want_pointer
2200 && ref
->next
== NULL
&& (se
->descriptor_only
))
2203 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2204 /* Return a pointer to an element. */
2208 if (ref
->u
.c
.sym
->attr
.extension
)
2209 conv_parent_component_references (se
, ref
);
2211 gfc_conv_component_ref (se
, ref
);
2212 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2213 && se
->want_pointer
&& se
->descriptor_only
)
2219 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2220 expr
->symtree
->name
, &expr
->where
);
2229 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2231 if (se
->want_pointer
)
2233 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2234 gfc_conv_string_parameter (se
);
2236 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2241 /* Unary ops are easy... Or they would be if ! was a valid op. */
2244 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2249 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2250 /* Initialize the operand. */
2251 gfc_init_se (&operand
, se
);
2252 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2253 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2255 type
= gfc_typenode_for_spec (&expr
->ts
);
2257 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2258 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2259 All other unary operators have an equivalent GIMPLE unary operator. */
2260 if (code
== TRUTH_NOT_EXPR
)
2261 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2262 build_int_cst (type
, 0));
2264 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2268 /* Expand power operator to optimal multiplications when a value is raised
2269 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2270 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2271 Programming", 3rd Edition, 1998. */
2273 /* This code is mostly duplicated from expand_powi in the backend.
2274 We establish the "optimal power tree" lookup table with the defined size.
2275 The items in the table are the exponents used to calculate the index
2276 exponents. Any integer n less than the value can get an "addition chain",
2277 with the first node being one. */
2278 #define POWI_TABLE_SIZE 256
2280 /* The table is from builtins.c. */
2281 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2283 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2284 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2285 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2286 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2287 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2288 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2289 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2290 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2291 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2292 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2293 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2294 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2295 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2296 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2297 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2298 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2299 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2300 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2301 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2302 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2303 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2304 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2305 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2306 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2307 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2308 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2309 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2310 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2311 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2312 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2313 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2314 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2317 /* If n is larger than lookup table's max index, we use the "window
2319 #define POWI_WINDOW_SIZE 3
2321 /* Recursive function to expand the power operator. The temporary
2322 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2324 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2331 if (n
< POWI_TABLE_SIZE
)
2336 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2337 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2341 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2342 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2343 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2347 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2351 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2352 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2354 if (n
< POWI_TABLE_SIZE
)
2361 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2362 return 1. Else return 0 and a call to runtime library functions
2363 will have to be built. */
2365 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2370 tree vartmp
[POWI_TABLE_SIZE
];
2372 unsigned HOST_WIDE_INT n
;
2374 wide_int wrhs
= rhs
;
2376 /* If exponent is too large, we won't expand it anyway, so don't bother
2377 with large integer values. */
2378 if (!wi::fits_shwi_p (wrhs
))
2381 m
= wrhs
.to_shwi ();
2382 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2383 of the asymmetric range of the integer type. */
2384 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2386 type
= TREE_TYPE (lhs
);
2387 sgn
= tree_int_cst_sgn (rhs
);
2389 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2390 || optimize_size
) && (m
> 2 || m
< -1))
2396 se
->expr
= gfc_build_const (type
, integer_one_node
);
2400 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2401 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2403 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2404 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2405 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2406 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2409 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2412 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2413 boolean_type_node
, tmp
, cond
);
2414 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2415 tmp
, build_int_cst (type
, 1),
2416 build_int_cst (type
, 0));
2420 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2421 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2422 build_int_cst (type
, -1),
2423 build_int_cst (type
, 0));
2424 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2425 cond
, build_int_cst (type
, 1), tmp
);
2429 memset (vartmp
, 0, sizeof (vartmp
));
2433 tmp
= gfc_build_const (type
, integer_one_node
);
2434 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2438 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2444 /* Power op (**). Constant integer exponent has special handling. */
2447 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2449 tree gfc_int4_type_node
;
2452 int res_ikind_1
, res_ikind_2
;
2457 gfc_init_se (&lse
, se
);
2458 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2459 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2460 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2462 gfc_init_se (&rse
, se
);
2463 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2464 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2466 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2467 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2468 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2471 gfc_int4_type_node
= gfc_get_int_type (4);
2473 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2474 library routine. But in the end, we have to convert the result back
2475 if this case applies -- with res_ikind_K, we keep track whether operand K
2476 falls into this case. */
2480 kind
= expr
->value
.op
.op1
->ts
.kind
;
2481 switch (expr
->value
.op
.op2
->ts
.type
)
2484 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2489 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2490 res_ikind_2
= ikind
;
2512 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2514 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2541 switch (expr
->value
.op
.op1
->ts
.type
)
2544 if (kind
== 3) /* Case 16 was not handled properly above. */
2546 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2550 /* Use builtins for real ** int4. */
2556 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2560 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2564 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2568 /* Use the __builtin_powil() only if real(kind=16) is
2569 actually the C long double type. */
2570 if (!gfc_real16_is_float128
)
2571 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2579 /* If we don't have a good builtin for this, go for the
2580 library function. */
2582 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2586 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2595 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2599 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2607 se
->expr
= build_call_expr_loc (input_location
,
2608 fndecl
, 2, lse
.expr
, rse
.expr
);
2610 /* Convert the result back if it is of wrong integer kind. */
2611 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2613 /* We want the maximum of both operand kinds as result. */
2614 if (res_ikind_1
< res_ikind_2
)
2615 res_ikind_1
= res_ikind_2
;
2616 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2621 /* Generate code to allocate a string temporary. */
2624 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2629 if (gfc_can_put_var_on_stack (len
))
2631 /* Create a temporary variable to hold the result. */
2632 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2633 gfc_charlen_type_node
, len
,
2634 build_int_cst (gfc_charlen_type_node
, 1));
2635 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2637 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2638 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2640 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2642 var
= gfc_create_var (tmp
, "str");
2643 var
= gfc_build_addr_expr (type
, var
);
2647 /* Allocate a temporary to hold the result. */
2648 var
= gfc_create_var (type
, "pstr");
2649 gcc_assert (POINTER_TYPE_P (type
));
2650 tmp
= TREE_TYPE (type
);
2651 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2652 tmp
= TREE_TYPE (tmp
);
2653 tmp
= TYPE_SIZE_UNIT (tmp
);
2654 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2655 fold_convert (size_type_node
, len
),
2656 fold_convert (size_type_node
, tmp
));
2657 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2658 gfc_add_modify (&se
->pre
, var
, tmp
);
2660 /* Free the temporary afterwards. */
2661 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2662 gfc_add_expr_to_block (&se
->post
, tmp
);
2669 /* Handle a string concatenation operation. A temporary will be allocated to
2673 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2676 tree len
, type
, var
, tmp
, fndecl
;
2678 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2679 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2680 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2682 gfc_init_se (&lse
, se
);
2683 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2684 gfc_conv_string_parameter (&lse
);
2685 gfc_init_se (&rse
, se
);
2686 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2687 gfc_conv_string_parameter (&rse
);
2689 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2690 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2692 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2693 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2694 if (len
== NULL_TREE
)
2696 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2697 TREE_TYPE (lse
.string_length
),
2698 lse
.string_length
, rse
.string_length
);
2701 type
= build_pointer_type (type
);
2703 var
= gfc_conv_string_tmp (se
, type
, len
);
2705 /* Do the actual concatenation. */
2706 if (expr
->ts
.kind
== 1)
2707 fndecl
= gfor_fndecl_concat_string
;
2708 else if (expr
->ts
.kind
== 4)
2709 fndecl
= gfor_fndecl_concat_string_char4
;
2713 tmp
= build_call_expr_loc (input_location
,
2714 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2715 rse
.string_length
, rse
.expr
);
2716 gfc_add_expr_to_block (&se
->pre
, tmp
);
2718 /* Add the cleanup for the operands. */
2719 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2720 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2723 se
->string_length
= len
;
2726 /* Translates an op expression. Common (binary) cases are handled by this
2727 function, others are passed on. Recursion is used in either case.
2728 We use the fact that (op1.ts == op2.ts) (except for the power
2730 Operators need no special handling for scalarized expressions as long as
2731 they call gfc_conv_simple_val to get their operands.
2732 Character strings get special handling. */
2735 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2737 enum tree_code code
;
2746 switch (expr
->value
.op
.op
)
2748 case INTRINSIC_PARENTHESES
:
2749 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
2750 && flag_protect_parens
)
2752 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2753 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2758 case INTRINSIC_UPLUS
:
2759 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2762 case INTRINSIC_UMINUS
:
2763 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2767 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2770 case INTRINSIC_PLUS
:
2774 case INTRINSIC_MINUS
:
2778 case INTRINSIC_TIMES
:
2782 case INTRINSIC_DIVIDE
:
2783 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2784 an integer, we must round towards zero, so we use a
2786 if (expr
->ts
.type
== BT_INTEGER
)
2787 code
= TRUNC_DIV_EXPR
;
2792 case INTRINSIC_POWER
:
2793 gfc_conv_power_op (se
, expr
);
2796 case INTRINSIC_CONCAT
:
2797 gfc_conv_concat_op (se
, expr
);
2801 code
= TRUTH_ANDIF_EXPR
;
2806 code
= TRUTH_ORIF_EXPR
;
2810 /* EQV and NEQV only work on logicals, but since we represent them
2811 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2813 case INTRINSIC_EQ_OS
:
2821 case INTRINSIC_NE_OS
:
2822 case INTRINSIC_NEQV
:
2829 case INTRINSIC_GT_OS
:
2836 case INTRINSIC_GE_OS
:
2843 case INTRINSIC_LT_OS
:
2850 case INTRINSIC_LE_OS
:
2856 case INTRINSIC_USER
:
2857 case INTRINSIC_ASSIGN
:
2858 /* These should be converted into function calls by the frontend. */
2862 fatal_error (input_location
, "Unknown intrinsic op");
2866 /* The only exception to this is **, which is handled separately anyway. */
2867 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2869 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2873 gfc_init_se (&lse
, se
);
2874 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2875 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2878 gfc_init_se (&rse
, se
);
2879 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2880 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2884 gfc_conv_string_parameter (&lse
);
2885 gfc_conv_string_parameter (&rse
);
2887 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2888 rse
.string_length
, rse
.expr
,
2889 expr
->value
.op
.op1
->ts
.kind
,
2891 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2892 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2895 type
= gfc_typenode_for_spec (&expr
->ts
);
2899 /* The result of logical ops is always boolean_type_node. */
2900 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2901 lse
.expr
, rse
.expr
);
2902 se
->expr
= convert (type
, tmp
);
2905 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2907 /* Add the post blocks. */
2908 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2909 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2912 /* If a string's length is one, we convert it to a single character. */
2915 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2919 || !tree_fits_uhwi_p (len
)
2920 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2923 if (TREE_INT_CST_LOW (len
) == 1)
2925 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2926 return build_fold_indirect_ref_loc (input_location
, str
);
2930 && TREE_CODE (str
) == ADDR_EXPR
2931 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2932 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2933 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2934 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2935 && TREE_INT_CST_LOW (len
) > 1
2936 && TREE_INT_CST_LOW (len
)
2937 == (unsigned HOST_WIDE_INT
)
2938 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2940 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2941 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2942 if (TREE_CODE (ret
) == INTEGER_CST
)
2944 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2945 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2946 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2948 for (i
= 1; i
< length
; i
++)
2961 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2964 if (sym
->backend_decl
)
2966 /* This becomes the nominal_type in
2967 function.c:assign_parm_find_data_types. */
2968 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2969 /* This becomes the passed_type in
2970 function.c:assign_parm_find_data_types. C promotes char to
2971 integer for argument passing. */
2972 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2974 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2979 /* If we have a constant character expression, make it into an
2981 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2986 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2987 (int)(*expr
)->value
.character
.string
[0]);
2988 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2990 /* The expr needs to be compatible with a C int. If the
2991 conversion fails, then the 2 causes an ICE. */
2992 ts
.type
= BT_INTEGER
;
2993 ts
.kind
= gfc_c_int_kind
;
2994 gfc_convert_type (*expr
, &ts
, 2);
2997 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2999 if ((*expr
)->ref
== NULL
)
3001 se
->expr
= gfc_string_to_single_character
3002 (build_int_cst (integer_type_node
, 1),
3003 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3005 ((*expr
)->symtree
->n
.sym
)),
3010 gfc_conv_variable (se
, *expr
);
3011 se
->expr
= gfc_string_to_single_character
3012 (build_int_cst (integer_type_node
, 1),
3013 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3021 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3022 if STR is a string literal, otherwise return -1. */
3025 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3028 && TREE_CODE (str
) == ADDR_EXPR
3029 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3030 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3031 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3032 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3033 && tree_fits_uhwi_p (len
)
3034 && tree_to_uhwi (len
) >= 1
3035 && tree_to_uhwi (len
)
3036 == (unsigned HOST_WIDE_INT
)
3037 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3039 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3040 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3041 if (TREE_CODE (folded
) == INTEGER_CST
)
3043 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3044 int length
= TREE_STRING_LENGTH (string_cst
);
3045 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3047 for (; length
> 0; length
--)
3048 if (ptr
[length
- 1] != ' ')
3057 /* Helper to build a call to memcmp. */
3060 build_memcmp_call (tree s1
, tree s2
, tree n
)
3064 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3065 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3067 s1
= fold_convert (pvoid_type_node
, s1
);
3069 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3070 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3072 s2
= fold_convert (pvoid_type_node
, s2
);
3074 n
= fold_convert (size_type_node
, n
);
3076 tmp
= build_call_expr_loc (input_location
,
3077 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3080 return fold_convert (integer_type_node
, tmp
);
3083 /* Compare two strings. If they are all single characters, the result is the
3084 subtraction of them. Otherwise, we build a library call. */
3087 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3088 enum tree_code code
)
3094 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3095 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3097 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3098 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3100 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3102 /* Deal with single character specially. */
3103 sc1
= fold_convert (integer_type_node
, sc1
);
3104 sc2
= fold_convert (integer_type_node
, sc2
);
3105 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3109 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3111 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3113 /* If one string is a string literal with LEN_TRIM longer
3114 than the length of the second string, the strings
3116 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3117 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3118 return integer_one_node
;
3119 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3120 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3121 return integer_one_node
;
3124 /* We can compare via memcpy if the strings are known to be equal
3125 in length and they are
3127 - kind=4 and the comparison is for (in)equality. */
3129 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3130 && tree_int_cst_equal (len1
, len2
)
3131 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3136 chartype
= gfc_get_char_type (kind
);
3137 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3138 fold_convert (TREE_TYPE(len1
),
3139 TYPE_SIZE_UNIT(chartype
)),
3141 return build_memcmp_call (str1
, str2
, tmp
);
3144 /* Build a call for the comparison. */
3146 fndecl
= gfor_fndecl_compare_string
;
3148 fndecl
= gfor_fndecl_compare_string_char4
;
3152 return build_call_expr_loc (input_location
, fndecl
, 4,
3153 len1
, str1
, len2
, str2
);
3157 /* Return the backend_decl for a procedure pointer component. */
3160 get_proc_ptr_comp (gfc_expr
*e
)
3166 gfc_init_se (&comp_se
, NULL
);
3167 e2
= gfc_copy_expr (e
);
3168 /* We have to restore the expr type later so that gfc_free_expr frees
3169 the exact same thing that was allocated.
3170 TODO: This is ugly. */
3171 old_type
= e2
->expr_type
;
3172 e2
->expr_type
= EXPR_VARIABLE
;
3173 gfc_conv_expr (&comp_se
, e2
);
3174 e2
->expr_type
= old_type
;
3176 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3180 /* Convert a typebound function reference from a class object. */
3182 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3187 if (TREE_CODE (base_object
) != VAR_DECL
)
3189 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3190 gfc_add_modify (&se
->pre
, var
, base_object
);
3192 se
->expr
= gfc_class_vptr_get (base_object
);
3193 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3195 while (ref
&& ref
->next
)
3197 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3198 if (ref
->u
.c
.sym
->attr
.extension
)
3199 conv_parent_component_references (se
, ref
);
3200 gfc_conv_component_ref (se
, ref
);
3201 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3206 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3210 if (gfc_is_proc_ptr_comp (expr
))
3211 tmp
= get_proc_ptr_comp (expr
);
3212 else if (sym
->attr
.dummy
)
3214 tmp
= gfc_get_symbol_decl (sym
);
3215 if (sym
->attr
.proc_pointer
)
3216 tmp
= build_fold_indirect_ref_loc (input_location
,
3218 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3219 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3223 if (!sym
->backend_decl
)
3224 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3226 TREE_USED (sym
->backend_decl
) = 1;
3228 tmp
= sym
->backend_decl
;
3230 if (sym
->attr
.cray_pointee
)
3232 /* TODO - make the cray pointee a pointer to a procedure,
3233 assign the pointer to it and use it for the call. This
3235 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3236 gfc_get_symbol_decl (sym
->cp_pointer
));
3237 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3240 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3242 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3243 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3250 /* Initialize MAPPING. */
3253 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3255 mapping
->syms
= NULL
;
3256 mapping
->charlens
= NULL
;
3260 /* Free all memory held by MAPPING (but not MAPPING itself). */
3263 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3265 gfc_interface_sym_mapping
*sym
;
3266 gfc_interface_sym_mapping
*nextsym
;
3268 gfc_charlen
*nextcl
;
3270 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3272 nextsym
= sym
->next
;
3273 sym
->new_sym
->n
.sym
->formal
= NULL
;
3274 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3275 gfc_free_expr (sym
->expr
);
3276 free (sym
->new_sym
);
3279 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3282 gfc_free_expr (cl
->length
);
3288 /* Return a copy of gfc_charlen CL. Add the returned structure to
3289 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3291 static gfc_charlen
*
3292 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3295 gfc_charlen
*new_charlen
;
3297 new_charlen
= gfc_get_charlen ();
3298 new_charlen
->next
= mapping
->charlens
;
3299 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3301 mapping
->charlens
= new_charlen
;
3306 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3307 array variable that can be used as the actual argument for dummy
3308 argument SYM. Add any initialization code to BLOCK. PACKED is as
3309 for gfc_get_nodesc_array_type and DATA points to the first element
3310 in the passed array. */
3313 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3314 gfc_packed packed
, tree data
)
3319 type
= gfc_typenode_for_spec (&sym
->ts
);
3320 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3321 !sym
->attr
.target
&& !sym
->attr
.pointer
3322 && !sym
->attr
.proc_pointer
);
3324 var
= gfc_create_var (type
, "ifm");
3325 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3331 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3332 and offset of descriptorless array type TYPE given that it has the same
3333 size as DESC. Add any set-up code to BLOCK. */
3336 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3343 offset
= gfc_index_zero_node
;
3344 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3346 dim
= gfc_rank_cst
[n
];
3347 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3348 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3350 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3351 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3352 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3353 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3355 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3357 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3358 gfc_array_index_type
,
3359 gfc_conv_descriptor_ubound_get (desc
, dim
),
3360 gfc_conv_descriptor_lbound_get (desc
, dim
));
3361 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3362 gfc_array_index_type
,
3363 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3364 tmp
= gfc_evaluate_now (tmp
, block
);
3365 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3367 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3368 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3369 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3370 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3371 gfc_array_index_type
, offset
, tmp
);
3373 offset
= gfc_evaluate_now (offset
, block
);
3374 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3378 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3379 in SE. The caller may still use se->expr and se->string_length after
3380 calling this function. */
3383 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3384 gfc_symbol
* sym
, gfc_se
* se
,
3387 gfc_interface_sym_mapping
*sm
;
3391 gfc_symbol
*new_sym
;
3393 gfc_symtree
*new_symtree
;
3395 /* Create a new symbol to represent the actual argument. */
3396 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3397 new_sym
->ts
= sym
->ts
;
3398 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3399 new_sym
->attr
.referenced
= 1;
3400 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3401 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3402 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3403 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3404 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3405 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3406 new_sym
->attr
.function
= sym
->attr
.function
;
3408 /* Ensure that the interface is available and that
3409 descriptors are passed for array actual arguments. */
3410 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3412 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3413 new_sym
->attr
.always_explicit
3414 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3417 /* Create a fake symtree for it. */
3419 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3420 new_symtree
->n
.sym
= new_sym
;
3421 gcc_assert (new_symtree
== root
);
3423 /* Create a dummy->actual mapping. */
3424 sm
= XCNEW (gfc_interface_sym_mapping
);
3425 sm
->next
= mapping
->syms
;
3427 sm
->new_sym
= new_symtree
;
3428 sm
->expr
= gfc_copy_expr (expr
);
3431 /* Stabilize the argument's value. */
3432 if (!sym
->attr
.function
&& se
)
3433 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3435 if (sym
->ts
.type
== BT_CHARACTER
)
3437 /* Create a copy of the dummy argument's length. */
3438 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3439 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3441 /* If the length is specified as "*", record the length that
3442 the caller is passing. We should use the callee's length
3443 in all other cases. */
3444 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3446 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3447 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3454 /* Use the passed value as-is if the argument is a function. */
3455 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3458 /* If the argument is either a string or a pointer to a string,
3459 convert it to a boundless character type. */
3460 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3462 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3463 tmp
= build_pointer_type (tmp
);
3464 if (sym
->attr
.pointer
)
3465 value
= build_fold_indirect_ref_loc (input_location
,
3469 value
= fold_convert (tmp
, value
);
3472 /* If the argument is a scalar, a pointer to an array or an allocatable,
3474 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3475 value
= build_fold_indirect_ref_loc (input_location
,
3478 /* For character(*), use the actual argument's descriptor. */
3479 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3480 value
= build_fold_indirect_ref_loc (input_location
,
3483 /* If the argument is an array descriptor, use it to determine
3484 information about the actual argument's shape. */
3485 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3486 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3488 /* Get the actual argument's descriptor. */
3489 desc
= build_fold_indirect_ref_loc (input_location
,
3492 /* Create the replacement variable. */
3493 tmp
= gfc_conv_descriptor_data_get (desc
);
3494 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3497 /* Use DESC to work out the upper bounds, strides and offset. */
3498 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3501 /* Otherwise we have a packed array. */
3502 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3503 PACKED_FULL
, se
->expr
);
3505 new_sym
->backend_decl
= value
;
3509 /* Called once all dummy argument mappings have been added to MAPPING,
3510 but before the mapping is used to evaluate expressions. Pre-evaluate
3511 the length of each argument, adding any initialization code to PRE and
3512 any finalization code to POST. */
3515 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3516 stmtblock_t
* pre
, stmtblock_t
* post
)
3518 gfc_interface_sym_mapping
*sym
;
3522 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3523 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3524 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3526 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3527 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3528 gfc_init_se (&se
, NULL
);
3529 gfc_conv_expr (&se
, expr
);
3530 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3531 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3532 gfc_add_block_to_block (pre
, &se
.pre
);
3533 gfc_add_block_to_block (post
, &se
.post
);
3535 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3540 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3544 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3545 gfc_constructor_base base
)
3548 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3550 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3553 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3554 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3555 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3561 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3565 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3570 for (; ref
; ref
= ref
->next
)
3574 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3576 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3577 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3578 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3586 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3587 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3593 /* Convert intrinsic function calls into result expressions. */
3596 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3604 arg1
= expr
->value
.function
.actual
->expr
;
3605 if (expr
->value
.function
.actual
->next
)
3606 arg2
= expr
->value
.function
.actual
->next
->expr
;
3610 sym
= arg1
->symtree
->n
.sym
;
3612 if (sym
->attr
.dummy
)
3617 switch (expr
->value
.function
.isym
->id
)
3620 /* TODO figure out why this condition is necessary. */
3621 if (sym
->attr
.function
3622 && (arg1
->ts
.u
.cl
->length
== NULL
3623 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3624 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3627 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3631 if (!sym
->as
|| sym
->as
->rank
== 0)
3634 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3636 dup
= mpz_get_si (arg2
->value
.integer
);
3641 dup
= sym
->as
->rank
;
3645 for (; d
< dup
; d
++)
3649 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3651 gfc_free_expr (new_expr
);
3655 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3656 gfc_get_int_expr (gfc_default_integer_kind
,
3658 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3660 new_expr
= gfc_multiply (new_expr
, tmp
);
3666 case GFC_ISYM_LBOUND
:
3667 case GFC_ISYM_UBOUND
:
3668 /* TODO These implementations of lbound and ubound do not limit if
3669 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3671 if (!sym
->as
|| sym
->as
->rank
== 0)
3674 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3675 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3677 /* TODO: If the need arises, this could produce an array of
3681 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3683 if (sym
->as
->lower
[d
])
3684 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3688 if (sym
->as
->upper
[d
])
3689 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3697 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3701 gfc_replace_expr (expr
, new_expr
);
3707 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3708 gfc_interface_mapping
* mapping
)
3710 gfc_formal_arglist
*f
;
3711 gfc_actual_arglist
*actual
;
3713 actual
= expr
->value
.function
.actual
;
3714 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3716 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3721 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3724 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3729 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3731 for (d
= 0; d
< as
->rank
; d
++)
3733 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3734 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3737 expr
->value
.function
.esym
->as
= as
;
3740 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3742 expr
->value
.function
.esym
->ts
.u
.cl
->length
3743 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3745 gfc_apply_interface_mapping_to_expr (mapping
,
3746 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3751 /* EXPR is a copy of an expression that appeared in the interface
3752 associated with MAPPING. Walk it recursively looking for references to
3753 dummy arguments that MAPPING maps to actual arguments. Replace each such
3754 reference with a reference to the associated actual argument. */
3757 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3760 gfc_interface_sym_mapping
*sym
;
3761 gfc_actual_arglist
*actual
;
3766 /* Copying an expression does not copy its length, so do that here. */
3767 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3769 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3770 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3773 /* Apply the mapping to any references. */
3774 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3776 /* ...and to the expression's symbol, if it has one. */
3777 /* TODO Find out why the condition on expr->symtree had to be moved into
3778 the loop rather than being outside it, as originally. */
3779 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3780 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3782 if (sym
->new_sym
->n
.sym
->backend_decl
)
3783 expr
->symtree
= sym
->new_sym
;
3785 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3788 /* ...and to subexpressions in expr->value. */
3789 switch (expr
->expr_type
)
3794 case EXPR_SUBSTRING
:
3798 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3799 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3803 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3804 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3806 if (expr
->value
.function
.esym
== NULL
3807 && expr
->value
.function
.isym
!= NULL
3808 && expr
->value
.function
.actual
->expr
->symtree
3809 && gfc_map_intrinsic_function (expr
, mapping
))
3812 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3813 if (sym
->old
== expr
->value
.function
.esym
)
3815 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3816 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3817 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3822 case EXPR_STRUCTURE
:
3823 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3836 /* Evaluate interface expression EXPR using MAPPING. Store the result
3840 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3841 gfc_se
* se
, gfc_expr
* expr
)
3843 expr
= gfc_copy_expr (expr
);
3844 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3845 gfc_conv_expr (se
, expr
);
3846 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3847 gfc_free_expr (expr
);
3851 /* Returns a reference to a temporary array into which a component of
3852 an actual argument derived type array is copied and then returned
3853 after the function call. */
3855 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3856 sym_intent intent
, bool formal_ptr
)
3864 gfc_array_info
*info
;
3874 gfc_init_se (&lse
, NULL
);
3875 gfc_init_se (&rse
, NULL
);
3877 /* Walk the argument expression. */
3878 rss
= gfc_walk_expr (expr
);
3880 gcc_assert (rss
!= gfc_ss_terminator
);
3882 /* Initialize the scalarizer. */
3883 gfc_init_loopinfo (&loop
);
3884 gfc_add_ss_to_loop (&loop
, rss
);
3886 /* Calculate the bounds of the scalarization. */
3887 gfc_conv_ss_startstride (&loop
);
3889 /* Build an ss for the temporary. */
3890 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3891 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3893 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3894 if (GFC_ARRAY_TYPE_P (base_type
)
3895 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3896 base_type
= gfc_get_element_type (base_type
);
3898 if (expr
->ts
.type
== BT_CLASS
)
3899 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3901 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3902 ? expr
->ts
.u
.cl
->backend_decl
3906 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3908 /* Associate the SS with the loop. */
3909 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3911 /* Setup the scalarizing loops. */
3912 gfc_conv_loop_setup (&loop
, &expr
->where
);
3914 /* Pass the temporary descriptor back to the caller. */
3915 info
= &loop
.temp_ss
->info
->data
.array
;
3916 parmse
->expr
= info
->descriptor
;
3918 /* Setup the gfc_se structures. */
3919 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3920 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3923 lse
.ss
= loop
.temp_ss
;
3924 gfc_mark_ss_chain_used (rss
, 1);
3925 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3927 /* Start the scalarized loop body. */
3928 gfc_start_scalarized_body (&loop
, &body
);
3930 /* Translate the expression. */
3931 gfc_conv_expr (&rse
, expr
);
3933 /* Reset the offset for the function call since the loop
3934 is zero based on the data pointer. Note that the temp
3935 comes first in the loop chain since it is added second. */
3936 if (gfc_is_alloc_class_array_function (expr
))
3938 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
3939 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
3940 gfc_index_zero_node
);
3943 gfc_conv_tmp_array_ref (&lse
);
3945 if (intent
!= INTENT_OUT
)
3947 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3948 gfc_add_expr_to_block (&body
, tmp
);
3949 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3950 gfc_trans_scalarizing_loops (&loop
, &body
);
3954 /* Make sure that the temporary declaration survives by merging
3955 all the loop declarations into the current context. */
3956 for (n
= 0; n
< loop
.dimen
; n
++)
3958 gfc_merge_block_scope (&body
);
3959 body
= loop
.code
[loop
.order
[n
]];
3961 gfc_merge_block_scope (&body
);
3964 /* Add the post block after the second loop, so that any
3965 freeing of allocated memory is done at the right time. */
3966 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3968 /**********Copy the temporary back again.*********/
3970 gfc_init_se (&lse
, NULL
);
3971 gfc_init_se (&rse
, NULL
);
3973 /* Walk the argument expression. */
3974 lss
= gfc_walk_expr (expr
);
3975 rse
.ss
= loop
.temp_ss
;
3978 /* Initialize the scalarizer. */
3979 gfc_init_loopinfo (&loop2
);
3980 gfc_add_ss_to_loop (&loop2
, lss
);
3982 dimen
= rse
.ss
->dimen
;
3984 /* Skip the write-out loop for this case. */
3985 if (gfc_is_alloc_class_array_function (expr
))
3986 goto class_array_fcn
;
3988 /* Calculate the bounds of the scalarization. */
3989 gfc_conv_ss_startstride (&loop2
);
3991 /* Setup the scalarizing loops. */
3992 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3994 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3995 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3997 gfc_mark_ss_chain_used (lss
, 1);
3998 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4000 /* Declare the variable to hold the temporary offset and start the
4001 scalarized loop body. */
4002 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4003 gfc_start_scalarized_body (&loop2
, &body
);
4005 /* Build the offsets for the temporary from the loop variables. The
4006 temporary array has lbounds of zero and strides of one in all
4007 dimensions, so this is very simple. The offset is only computed
4008 outside the innermost loop, so the overall transfer could be
4009 optimized further. */
4010 info
= &rse
.ss
->info
->data
.array
;
4012 tmp_index
= gfc_index_zero_node
;
4013 for (n
= dimen
- 1; n
> 0; n
--)
4016 tmp
= rse
.loop
->loopvar
[n
];
4017 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4018 tmp
, rse
.loop
->from
[n
]);
4019 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4022 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4023 gfc_array_index_type
,
4024 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4025 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4026 gfc_array_index_type
,
4027 tmp_str
, gfc_index_one_node
);
4029 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4030 gfc_array_index_type
, tmp
, tmp_str
);
4033 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4034 gfc_array_index_type
,
4035 tmp_index
, rse
.loop
->from
[0]);
4036 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4038 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4039 gfc_array_index_type
,
4040 rse
.loop
->loopvar
[0], offset
);
4042 /* Now use the offset for the reference. */
4043 tmp
= build_fold_indirect_ref_loc (input_location
,
4045 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4047 if (expr
->ts
.type
== BT_CHARACTER
)
4048 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4050 gfc_conv_expr (&lse
, expr
);
4052 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4054 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4055 gfc_add_expr_to_block (&body
, tmp
);
4057 /* Generate the copying loops. */
4058 gfc_trans_scalarizing_loops (&loop2
, &body
);
4060 /* Wrap the whole thing up by adding the second loop to the post-block
4061 and following it by the post-block of the first loop. In this way,
4062 if the temporary needs freeing, it is done after use! */
4063 if (intent
!= INTENT_IN
)
4065 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4066 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4071 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4073 gfc_cleanup_loop (&loop
);
4074 gfc_cleanup_loop (&loop2
);
4076 /* Pass the string length to the argument expression. */
4077 if (expr
->ts
.type
== BT_CHARACTER
)
4078 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4080 /* Determine the offset for pointer formal arguments and set the
4084 size
= gfc_index_one_node
;
4085 offset
= gfc_index_zero_node
;
4086 for (n
= 0; n
< dimen
; n
++)
4088 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4090 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4091 gfc_array_index_type
, tmp
,
4092 gfc_index_one_node
);
4093 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4097 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4100 gfc_index_one_node
);
4101 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4102 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4103 gfc_array_index_type
,
4105 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4106 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4107 gfc_array_index_type
,
4108 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4109 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4110 gfc_array_index_type
,
4111 tmp
, gfc_index_one_node
);
4112 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4113 gfc_array_index_type
, size
, tmp
);
4116 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4120 /* We want either the address for the data or the address of the descriptor,
4121 depending on the mode of passing array arguments. */
4123 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4125 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4131 /* Generate the code for argument list functions. */
4134 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4136 /* Pass by value for g77 %VAL(arg), pass the address
4137 indirectly for %LOC, else by reference. Thus %REF
4138 is a "do-nothing" and %LOC is the same as an F95
4140 if (strncmp (name
, "%VAL", 4) == 0)
4141 gfc_conv_expr (se
, expr
);
4142 else if (strncmp (name
, "%LOC", 4) == 0)
4144 gfc_conv_expr_reference (se
, expr
);
4145 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4147 else if (strncmp (name
, "%REF", 4) == 0)
4148 gfc_conv_expr_reference (se
, expr
);
4150 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4154 /* Generate code for a procedure call. Note can return se->post != NULL.
4155 If se->direct_byref is set then se->expr contains the return parameter.
4156 Return nonzero, if the call has alternate specifiers.
4157 'expr' is only needed for procedure pointer components. */
4160 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4161 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4162 vec
<tree
, va_gc
> *append_args
)
4164 gfc_interface_mapping mapping
;
4165 vec
<tree
, va_gc
> *arglist
;
4166 vec
<tree
, va_gc
> *retargs
;
4170 gfc_array_info
*info
;
4177 vec
<tree
, va_gc
> *stringargs
;
4178 vec
<tree
, va_gc
> *optionalargs
;
4180 gfc_formal_arglist
*formal
;
4181 gfc_actual_arglist
*arg
;
4182 int has_alternate_specifier
= 0;
4183 bool need_interface_mapping
;
4190 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4191 gfc_component
*comp
= NULL
;
4197 optionalargs
= NULL
;
4202 comp
= gfc_get_proc_ptr_comp (expr
);
4206 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4208 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4209 if (se
->ss
->info
->useflags
)
4211 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4212 && sym
->result
->attr
.dimension
)
4213 || (comp
&& comp
->attr
.dimension
)
4214 || gfc_is_alloc_class_array_function (expr
));
4215 gcc_assert (se
->loop
!= NULL
);
4216 /* Access the previously obtained result. */
4217 gfc_conv_tmp_array_ref (se
);
4221 info
= &se
->ss
->info
->data
.array
;
4226 gfc_init_block (&post
);
4227 gfc_init_interface_mapping (&mapping
);
4230 formal
= gfc_sym_get_dummy_args (sym
);
4231 need_interface_mapping
= sym
->attr
.dimension
||
4232 (sym
->ts
.type
== BT_CHARACTER
4233 && sym
->ts
.u
.cl
->length
4234 && sym
->ts
.u
.cl
->length
->expr_type
4239 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4240 need_interface_mapping
= comp
->attr
.dimension
||
4241 (comp
->ts
.type
== BT_CHARACTER
4242 && comp
->ts
.u
.cl
->length
4243 && comp
->ts
.u
.cl
->length
->expr_type
4247 base_object
= NULL_TREE
;
4249 /* Evaluate the arguments. */
4250 for (arg
= args
; arg
!= NULL
;
4251 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4254 fsym
= formal
? formal
->sym
: NULL
;
4255 parm_kind
= MISSING
;
4257 /* Class array expressions are sometimes coming completely unadorned
4258 with either arrayspec or _data component. Correct that here.
4259 OOP-TODO: Move this to the frontend. */
4260 if (e
&& e
->expr_type
== EXPR_VARIABLE
4262 && e
->ts
.type
== BT_CLASS
4263 && (CLASS_DATA (e
)->attr
.codimension
4264 || CLASS_DATA (e
)->attr
.dimension
))
4266 gfc_typespec temp_ts
= e
->ts
;
4267 gfc_add_class_array_ref (e
);
4273 if (se
->ignore_optional
)
4275 /* Some intrinsics have already been resolved to the correct
4279 else if (arg
->label
)
4281 has_alternate_specifier
= 1;
4286 gfc_init_se (&parmse
, NULL
);
4288 /* For scalar arguments with VALUE attribute which are passed by
4289 value, pass "0" and a hidden argument gives the optional
4291 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4292 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4293 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4295 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4297 vec_safe_push (optionalargs
, boolean_false_node
);
4301 /* Pass a NULL pointer for an absent arg. */
4302 parmse
.expr
= null_pointer_node
;
4303 if (arg
->missing_arg_type
== BT_CHARACTER
)
4304 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4309 else if (arg
->expr
->expr_type
== EXPR_NULL
4310 && fsym
&& !fsym
->attr
.pointer
4311 && (fsym
->ts
.type
!= BT_CLASS
4312 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4314 /* Pass a NULL pointer to denote an absent arg. */
4315 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4316 && (fsym
->ts
.type
!= BT_CLASS
4317 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4318 gfc_init_se (&parmse
, NULL
);
4319 parmse
.expr
= null_pointer_node
;
4320 if (arg
->missing_arg_type
== BT_CHARACTER
)
4321 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4323 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4324 && e
->ts
.type
== BT_DERIVED
)
4326 /* The derived type needs to be converted to a temporary
4328 gfc_init_se (&parmse
, se
);
4329 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4331 && e
->expr_type
== EXPR_VARIABLE
4332 && e
->symtree
->n
.sym
->attr
.optional
,
4333 CLASS_DATA (fsym
)->attr
.class_pointer
4334 || CLASS_DATA (fsym
)->attr
.allocatable
);
4336 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4338 /* The intrinsic type needs to be converted to a temporary
4339 CLASS object for the unlimited polymorphic formal. */
4340 gfc_init_se (&parmse
, se
);
4341 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4343 else if (se
->ss
&& se
->ss
->info
->useflags
)
4349 /* An elemental function inside a scalarized loop. */
4350 gfc_init_se (&parmse
, se
);
4351 parm_kind
= ELEMENTAL
;
4353 if (fsym
&& fsym
->attr
.value
)
4354 gfc_conv_expr (&parmse
, e
);
4356 gfc_conv_expr_reference (&parmse
, e
);
4358 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4359 && e
->expr_type
== EXPR_FUNCTION
)
4360 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4363 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4364 && gfc_is_class_container_ref (e
))
4366 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4368 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4369 && e
->symtree
->n
.sym
->attr
.optional
)
4371 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4372 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4373 TREE_TYPE (parmse
.expr
),
4375 fold_convert (TREE_TYPE (parmse
.expr
),
4376 null_pointer_node
));
4380 /* If we are passing an absent array as optional dummy to an
4381 elemental procedure, make sure that we pass NULL when the data
4382 pointer is NULL. We need this extra conditional because of
4383 scalarization which passes arrays elements to the procedure,
4384 ignoring the fact that the array can be absent/unallocated/... */
4385 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4387 tree descriptor_data
;
4389 descriptor_data
= ss
->info
->data
.array
.data
;
4390 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4392 fold_convert (TREE_TYPE (descriptor_data
),
4393 null_pointer_node
));
4395 = fold_build3_loc (input_location
, COND_EXPR
,
4396 TREE_TYPE (parmse
.expr
),
4397 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4398 fold_convert (TREE_TYPE (parmse
.expr
),
4403 /* The scalarizer does not repackage the reference to a class
4404 array - instead it returns a pointer to the data element. */
4405 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4406 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4407 fsym
->attr
.intent
!= INTENT_IN
4408 && (CLASS_DATA (fsym
)->attr
.class_pointer
4409 || CLASS_DATA (fsym
)->attr
.allocatable
),
4411 && e
->expr_type
== EXPR_VARIABLE
4412 && e
->symtree
->n
.sym
->attr
.optional
,
4413 CLASS_DATA (fsym
)->attr
.class_pointer
4414 || CLASS_DATA (fsym
)->attr
.allocatable
);
4421 gfc_init_se (&parmse
, NULL
);
4423 /* Check whether the expression is a scalar or not; we cannot use
4424 e->rank as it can be nonzero for functions arguments. */
4425 argss
= gfc_walk_expr (e
);
4426 scalar
= argss
== gfc_ss_terminator
;
4428 gfc_free_ss_chain (argss
);
4430 /* Special handling for passing scalar polymorphic coarrays;
4431 otherwise one passes "class->_data.data" instead of "&class". */
4432 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4433 && fsym
&& fsym
->ts
.type
== BT_CLASS
4434 && CLASS_DATA (fsym
)->attr
.codimension
4435 && !CLASS_DATA (fsym
)->attr
.dimension
)
4437 gfc_add_class_array_ref (e
);
4438 parmse
.want_coarray
= 1;
4442 /* A scalar or transformational function. */
4445 if (e
->expr_type
== EXPR_VARIABLE
4446 && e
->symtree
->n
.sym
->attr
.cray_pointee
4447 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4449 /* The Cray pointer needs to be converted to a pointer to
4450 a type given by the expression. */
4451 gfc_conv_expr (&parmse
, e
);
4452 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4453 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4454 parmse
.expr
= convert (type
, tmp
);
4456 else if (fsym
&& fsym
->attr
.value
)
4458 if (fsym
->ts
.type
== BT_CHARACTER
4459 && fsym
->ts
.is_c_interop
4460 && fsym
->ns
->proc_name
!= NULL
4461 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4464 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4465 if (parmse
.expr
== NULL
)
4466 gfc_conv_expr (&parmse
, e
);
4470 gfc_conv_expr (&parmse
, e
);
4471 if (fsym
->attr
.optional
4472 && fsym
->ts
.type
!= BT_CLASS
4473 && fsym
->ts
.type
!= BT_DERIVED
)
4475 if (e
->expr_type
!= EXPR_VARIABLE
4476 || !e
->symtree
->n
.sym
->attr
.optional
4478 vec_safe_push (optionalargs
, boolean_true_node
);
4481 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4482 if (!e
->symtree
->n
.sym
->attr
.value
)
4484 = fold_build3_loc (input_location
, COND_EXPR
,
4485 TREE_TYPE (parmse
.expr
),
4487 fold_convert (TREE_TYPE (parmse
.expr
),
4488 integer_zero_node
));
4490 vec_safe_push (optionalargs
, tmp
);
4495 else if (arg
->name
&& arg
->name
[0] == '%')
4496 /* Argument list functions %VAL, %LOC and %REF are signalled
4497 through arg->name. */
4498 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4499 else if ((e
->expr_type
== EXPR_FUNCTION
)
4500 && ((e
->value
.function
.esym
4501 && e
->value
.function
.esym
->result
->attr
.pointer
)
4502 || (!e
->value
.function
.esym
4503 && e
->symtree
->n
.sym
->attr
.pointer
))
4504 && fsym
&& fsym
->attr
.target
)
4506 gfc_conv_expr (&parmse
, e
);
4507 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4509 else if (e
->expr_type
== EXPR_FUNCTION
4510 && e
->symtree
->n
.sym
->result
4511 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4512 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4514 /* Functions returning procedure pointers. */
4515 gfc_conv_expr (&parmse
, e
);
4516 if (fsym
&& fsym
->attr
.proc_pointer
)
4517 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4521 if (e
->ts
.type
== BT_CLASS
&& fsym
4522 && fsym
->ts
.type
== BT_CLASS
4523 && (!CLASS_DATA (fsym
)->as
4524 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4525 && CLASS_DATA (e
)->attr
.codimension
)
4527 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4528 gcc_assert (!CLASS_DATA (fsym
)->as
);
4529 gfc_add_class_array_ref (e
);
4530 parmse
.want_coarray
= 1;
4531 gfc_conv_expr_reference (&parmse
, e
);
4532 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4534 && e
->expr_type
== EXPR_VARIABLE
);
4536 else if (e
->ts
.type
== BT_CLASS
&& fsym
4537 && fsym
->ts
.type
== BT_CLASS
4538 && !CLASS_DATA (fsym
)->as
4539 && !CLASS_DATA (e
)->as
4540 && strcmp (fsym
->ts
.u
.derived
->name
,
4541 e
->ts
.u
.derived
->name
))
4543 type
= gfc_typenode_for_spec (&fsym
->ts
);
4544 var
= gfc_create_var (type
, fsym
->name
);
4545 gfc_conv_expr (&parmse
, e
);
4546 if (fsym
->attr
.optional
4547 && e
->expr_type
== EXPR_VARIABLE
4548 && e
->symtree
->n
.sym
->attr
.optional
)
4552 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4553 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4554 boolean_type_node
, tmp
,
4555 fold_convert (TREE_TYPE (tmp
),
4556 null_pointer_node
));
4557 gfc_start_block (&block
);
4558 gfc_add_modify (&block
, var
,
4559 fold_build1_loc (input_location
,
4561 type
, parmse
.expr
));
4562 gfc_add_expr_to_block (&parmse
.pre
,
4563 fold_build3_loc (input_location
,
4564 COND_EXPR
, void_type_node
,
4565 cond
, gfc_finish_block (&block
),
4566 build_empty_stmt (input_location
)));
4567 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4568 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4569 TREE_TYPE (parmse
.expr
),
4571 fold_convert (TREE_TYPE (parmse
.expr
),
4572 null_pointer_node
));
4576 gfc_add_modify (&parmse
.pre
, var
,
4577 fold_build1_loc (input_location
,
4579 type
, parmse
.expr
));
4580 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4584 gfc_conv_expr_reference (&parmse
, e
);
4586 /* Catch base objects that are not variables. */
4587 if (e
->ts
.type
== BT_CLASS
4588 && e
->expr_type
!= EXPR_VARIABLE
4589 && expr
&& e
== expr
->base_expr
)
4590 base_object
= build_fold_indirect_ref_loc (input_location
,
4593 /* A class array element needs converting back to be a
4594 class object, if the formal argument is a class object. */
4595 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4596 && e
->ts
.type
== BT_CLASS
4597 && ((CLASS_DATA (fsym
)->as
4598 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4599 || CLASS_DATA (e
)->attr
.dimension
))
4600 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4601 fsym
->attr
.intent
!= INTENT_IN
4602 && (CLASS_DATA (fsym
)->attr
.class_pointer
4603 || CLASS_DATA (fsym
)->attr
.allocatable
),
4605 && e
->expr_type
== EXPR_VARIABLE
4606 && e
->symtree
->n
.sym
->attr
.optional
,
4607 CLASS_DATA (fsym
)->attr
.class_pointer
4608 || CLASS_DATA (fsym
)->attr
.allocatable
);
4610 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4611 allocated on entry, it must be deallocated. */
4612 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4613 && (fsym
->attr
.allocatable
4614 || (fsym
->ts
.type
== BT_CLASS
4615 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4620 gfc_init_block (&block
);
4622 if (e
->ts
.type
== BT_CLASS
)
4623 ptr
= gfc_class_data_get (ptr
);
4625 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4627 gfc_add_expr_to_block (&block
, tmp
);
4628 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4629 void_type_node
, ptr
,
4631 gfc_add_expr_to_block (&block
, tmp
);
4633 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4635 gfc_add_modify (&block
, ptr
,
4636 fold_convert (TREE_TYPE (ptr
),
4637 null_pointer_node
));
4638 gfc_add_expr_to_block (&block
, tmp
);
4640 else if (fsym
->ts
.type
== BT_CLASS
)
4643 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4644 tmp
= gfc_get_symbol_decl (vtab
);
4645 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4646 ptr
= gfc_class_vptr_get (parmse
.expr
);
4647 gfc_add_modify (&block
, ptr
,
4648 fold_convert (TREE_TYPE (ptr
), tmp
));
4649 gfc_add_expr_to_block (&block
, tmp
);
4652 if (fsym
->attr
.optional
4653 && e
->expr_type
== EXPR_VARIABLE
4654 && e
->symtree
->n
.sym
->attr
.optional
)
4656 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4658 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4659 gfc_finish_block (&block
),
4660 build_empty_stmt (input_location
));
4663 tmp
= gfc_finish_block (&block
);
4665 gfc_add_expr_to_block (&se
->pre
, tmp
);
4668 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4669 || fsym
->ts
.type
== BT_ASSUMED
)
4670 && e
->ts
.type
== BT_CLASS
4671 && !CLASS_DATA (e
)->attr
.dimension
4672 && !CLASS_DATA (e
)->attr
.codimension
)
4673 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4675 /* Wrap scalar variable in a descriptor. We need to convert
4676 the address of a pointer back to the pointer itself before,
4677 we can assign it to the data field. */
4679 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4680 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4683 if (TREE_CODE (tmp
) == ADDR_EXPR
4684 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4685 tmp
= TREE_OPERAND (tmp
, 0);
4686 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4688 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4691 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4692 && ((fsym
->attr
.pointer
4693 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4694 || (fsym
->attr
.proc_pointer
4695 && !(e
->expr_type
== EXPR_VARIABLE
4696 && e
->symtree
->n
.sym
->attr
.dummy
))
4697 || (fsym
->attr
.proc_pointer
4698 && e
->expr_type
== EXPR_VARIABLE
4699 && gfc_is_proc_ptr_comp (e
))
4700 || (fsym
->attr
.allocatable
4701 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4703 /* Scalar pointer dummy args require an extra level of
4704 indirection. The null pointer already contains
4705 this level of indirection. */
4706 parm_kind
= SCALAR_POINTER
;
4707 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4711 else if (e
->ts
.type
== BT_CLASS
4712 && fsym
&& fsym
->ts
.type
== BT_CLASS
4713 && (CLASS_DATA (fsym
)->attr
.dimension
4714 || CLASS_DATA (fsym
)->attr
.codimension
))
4716 /* Pass a class array. */
4717 parmse
.use_offset
= 1;
4718 gfc_conv_expr_descriptor (&parmse
, e
);
4720 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4721 allocated on entry, it must be deallocated. */
4722 if (fsym
->attr
.intent
== INTENT_OUT
4723 && CLASS_DATA (fsym
)->attr
.allocatable
)
4728 gfc_init_block (&block
);
4730 ptr
= gfc_class_data_get (ptr
);
4732 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4733 NULL_TREE
, NULL_TREE
,
4736 gfc_add_expr_to_block (&block
, tmp
);
4737 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4738 void_type_node
, ptr
,
4740 gfc_add_expr_to_block (&block
, tmp
);
4741 gfc_reset_vptr (&block
, e
);
4743 if (fsym
->attr
.optional
4744 && e
->expr_type
== EXPR_VARIABLE
4746 || (e
->ref
->type
== REF_ARRAY
4747 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4748 && e
->symtree
->n
.sym
->attr
.optional
)
4750 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4752 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4753 gfc_finish_block (&block
),
4754 build_empty_stmt (input_location
));
4757 tmp
= gfc_finish_block (&block
);
4759 gfc_add_expr_to_block (&se
->pre
, tmp
);
4762 /* The conversion does not repackage the reference to a class
4763 array - _data descriptor. */
4764 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4765 fsym
->attr
.intent
!= INTENT_IN
4766 && (CLASS_DATA (fsym
)->attr
.class_pointer
4767 || CLASS_DATA (fsym
)->attr
.allocatable
),
4769 && e
->expr_type
== EXPR_VARIABLE
4770 && e
->symtree
->n
.sym
->attr
.optional
,
4771 CLASS_DATA (fsym
)->attr
.class_pointer
4772 || CLASS_DATA (fsym
)->attr
.allocatable
);
4776 /* If the procedure requires an explicit interface, the actual
4777 argument is passed according to the corresponding formal
4778 argument. If the corresponding formal argument is a POINTER,
4779 ALLOCATABLE or assumed shape, we do not use g77's calling
4780 convention, and pass the address of the array descriptor
4781 instead. Otherwise we use g77's calling convention. */
4784 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4785 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4786 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4788 f
= f
|| !comp
->attr
.always_explicit
;
4790 f
= f
|| !sym
->attr
.always_explicit
;
4792 /* If the argument is a function call that may not create
4793 a temporary for the result, we have to check that we
4794 can do it, i.e. that there is no alias between this
4795 argument and another one. */
4796 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4802 intent
= fsym
->attr
.intent
;
4804 intent
= INTENT_UNKNOWN
;
4806 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4808 parmse
.force_tmp
= 1;
4810 iarg
= e
->value
.function
.actual
->expr
;
4812 /* Temporary needed if aliasing due to host association. */
4813 if (sym
->attr
.contained
4815 && !sym
->attr
.implicit_pure
4816 && !sym
->attr
.use_assoc
4817 && iarg
->expr_type
== EXPR_VARIABLE
4818 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4819 parmse
.force_tmp
= 1;
4821 /* Ditto within module. */
4822 if (sym
->attr
.use_assoc
4824 && !sym
->attr
.implicit_pure
4825 && iarg
->expr_type
== EXPR_VARIABLE
4826 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4827 parmse
.force_tmp
= 1;
4830 if (e
->expr_type
== EXPR_VARIABLE
4831 && is_subref_array (e
))
4832 /* The actual argument is a component reference to an
4833 array of derived types. In this case, the argument
4834 is converted to a temporary, which is passed and then
4835 written back after the procedure call. */
4836 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4837 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4838 fsym
&& fsym
->attr
.pointer
);
4839 else if (gfc_is_class_array_ref (e
, NULL
)
4840 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4841 /* The actual argument is a component reference to an
4842 array of derived types. In this case, the argument
4843 is converted to a temporary, which is passed and then
4844 written back after the procedure call.
4845 OOP-TODO: Insert code so that if the dynamic type is
4846 the same as the declared type, copy-in/copy-out does
4848 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4849 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4850 fsym
&& fsym
->attr
.pointer
);
4852 else if (gfc_is_alloc_class_array_function (e
)
4853 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4854 /* See previous comment. For function actual argument,
4855 the write out is not needed so the intent is set as
4858 e
->must_finalize
= 1;
4859 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4861 fsym
&& fsym
->attr
.pointer
);
4864 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4866 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4867 allocated on entry, it must be deallocated. */
4868 if (fsym
&& fsym
->attr
.allocatable
4869 && fsym
->attr
.intent
== INTENT_OUT
)
4871 tmp
= build_fold_indirect_ref_loc (input_location
,
4873 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4874 if (fsym
->attr
.optional
4875 && e
->expr_type
== EXPR_VARIABLE
4876 && e
->symtree
->n
.sym
->attr
.optional
)
4877 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4879 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4880 tmp
, build_empty_stmt (input_location
));
4881 gfc_add_expr_to_block (&se
->pre
, tmp
);
4886 /* The case with fsym->attr.optional is that of a user subroutine
4887 with an interface indicating an optional argument. When we call
4888 an intrinsic subroutine, however, fsym is NULL, but we might still
4889 have an optional argument, so we proceed to the substitution
4891 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4893 /* If an optional argument is itself an optional dummy argument,
4894 check its presence and substitute a null if absent. This is
4895 only needed when passing an array to an elemental procedure
4896 as then array elements are accessed - or no NULL pointer is
4897 allowed and a "1" or "0" should be passed if not present.
4898 When passing a non-array-descriptor full array to a
4899 non-array-descriptor dummy, no check is needed. For
4900 array-descriptor actual to array-descriptor dummy, see
4901 PR 41911 for why a check has to be inserted.
4902 fsym == NULL is checked as intrinsics required the descriptor
4903 but do not always set fsym. */
4904 if (e
->expr_type
== EXPR_VARIABLE
4905 && e
->symtree
->n
.sym
->attr
.optional
4906 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4907 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4911 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4912 || fsym
->as
->type
== AS_ASSUMED_RANK
4913 || fsym
->as
->type
== AS_DEFERRED
))))))
4914 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4915 e
->representation
.length
);
4920 /* Obtain the character length of an assumed character length
4921 length procedure from the typespec. */
4922 if (fsym
->ts
.type
== BT_CHARACTER
4923 && parmse
.string_length
== NULL_TREE
4924 && e
->ts
.type
== BT_PROCEDURE
4925 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4926 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4927 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4929 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4930 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4934 if (fsym
&& need_interface_mapping
&& e
)
4935 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4937 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4938 gfc_add_block_to_block (&post
, &parmse
.post
);
4940 /* Allocated allocatable components of derived types must be
4941 deallocated for non-variable scalars. Non-variable arrays are
4942 dealt with in trans-array.c(gfc_conv_array_parameter). */
4943 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4944 && e
->ts
.u
.derived
->attr
.alloc_comp
4945 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4946 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4949 tmp
= build_fold_indirect_ref_loc (input_location
,
4951 parm_rank
= e
->rank
;
4959 case (SCALAR_POINTER
):
4960 tmp
= build_fold_indirect_ref_loc (input_location
,
4965 if (e
->expr_type
== EXPR_OP
4966 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4967 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4970 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4971 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4972 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4975 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4977 /* The derived type is passed to gfc_deallocate_alloc_comp.
4978 Therefore, class actuals can handled correctly but derived
4979 types passed to class formals need the _data component. */
4980 tmp
= gfc_class_data_get (tmp
);
4981 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4982 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4985 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4987 gfc_add_expr_to_block (&se
->post
, tmp
);
4990 /* Add argument checking of passing an unallocated/NULL actual to
4991 a nonallocatable/nonpointer dummy. */
4993 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4995 symbol_attribute attr
;
4999 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5000 attr
= gfc_expr_attr (e
);
5002 goto end_pointer_check
;
5004 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5005 allocatable to an optional dummy, cf. 12.5.2.12. */
5006 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5007 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5008 goto end_pointer_check
;
5012 /* If the actual argument is an optional pointer/allocatable and
5013 the formal argument takes an nonpointer optional value,
5014 it is invalid to pass a non-present argument on, even
5015 though there is no technical reason for this in gfortran.
5016 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5017 tree present
, null_ptr
, type
;
5019 if (attr
.allocatable
5020 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5021 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5022 "allocated or not present",
5023 e
->symtree
->n
.sym
->name
);
5024 else if (attr
.pointer
5025 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5026 msg
= xasprintf ("Pointer actual argument '%s' is not "
5027 "associated or not present",
5028 e
->symtree
->n
.sym
->name
);
5029 else if (attr
.proc_pointer
5030 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5031 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5032 "associated or not present",
5033 e
->symtree
->n
.sym
->name
);
5035 goto end_pointer_check
;
5037 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5038 type
= TREE_TYPE (present
);
5039 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5040 boolean_type_node
, present
,
5042 null_pointer_node
));
5043 type
= TREE_TYPE (parmse
.expr
);
5044 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5045 boolean_type_node
, parmse
.expr
,
5047 null_pointer_node
));
5048 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5049 boolean_type_node
, present
, null_ptr
);
5053 if (attr
.allocatable
5054 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5055 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5056 "allocated", e
->symtree
->n
.sym
->name
);
5057 else if (attr
.pointer
5058 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5059 msg
= xasprintf ("Pointer actual argument '%s' is not "
5060 "associated", e
->symtree
->n
.sym
->name
);
5061 else if (attr
.proc_pointer
5062 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5063 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5064 "associated", e
->symtree
->n
.sym
->name
);
5066 goto end_pointer_check
;
5070 /* If the argument is passed by value, we need to strip the
5072 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5073 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5075 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5076 boolean_type_node
, tmp
,
5077 fold_convert (TREE_TYPE (tmp
),
5078 null_pointer_node
));
5081 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5087 /* Deferred length dummies pass the character length by reference
5088 so that the value can be returned. */
5089 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5091 if (INDIRECT_REF_P (parmse
.string_length
))
5092 /* In chains of functions/procedure calls the string_length already
5093 is a pointer to the variable holding the length. Therefore
5094 remove the deref on call. */
5095 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5098 tmp
= parmse
.string_length
;
5099 if (TREE_CODE (tmp
) != VAR_DECL
)
5100 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5101 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5105 /* Character strings are passed as two parameters, a length and a
5106 pointer - except for Bind(c) which only passes the pointer.
5107 An unlimited polymorphic formal argument likewise does not
5109 if (parmse
.string_length
!= NULL_TREE
5110 && !sym
->attr
.is_bind_c
5111 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5112 vec_safe_push (stringargs
, parmse
.string_length
);
5114 /* When calling __copy for character expressions to unlimited
5115 polymorphic entities, the dst argument needs a string length. */
5116 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5117 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5118 && arg
->next
&& arg
->next
->expr
5119 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5120 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5121 vec_safe_push (stringargs
, parmse
.string_length
);
5123 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5124 pass the token and the offset as additional arguments. */
5125 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5126 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5127 && !fsym
->attr
.allocatable
)
5128 || (fsym
->ts
.type
== BT_CLASS
5129 && CLASS_DATA (fsym
)->attr
.codimension
5130 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5132 /* Token and offset. */
5133 vec_safe_push (stringargs
, null_pointer_node
);
5134 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5135 gcc_assert (fsym
->attr
.optional
);
5137 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5138 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5139 && !fsym
->attr
.allocatable
)
5140 || (fsym
->ts
.type
== BT_CLASS
5141 && CLASS_DATA (fsym
)->attr
.codimension
5142 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5144 tree caf_decl
, caf_type
;
5147 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5148 caf_type
= TREE_TYPE (caf_decl
);
5150 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5151 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5152 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5153 tmp
= gfc_conv_descriptor_token (caf_decl
);
5154 else if (DECL_LANG_SPECIFIC (caf_decl
)
5155 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5156 tmp
= GFC_DECL_TOKEN (caf_decl
);
5159 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5160 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5161 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5164 vec_safe_push (stringargs
, tmp
);
5166 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5167 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5168 offset
= build_int_cst (gfc_array_index_type
, 0);
5169 else if (DECL_LANG_SPECIFIC (caf_decl
)
5170 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5171 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5172 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5173 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5175 offset
= build_int_cst (gfc_array_index_type
, 0);
5177 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5178 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5181 gcc_assert (POINTER_TYPE_P (caf_type
));
5185 tmp2
= fsym
->ts
.type
== BT_CLASS
5186 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5187 if ((fsym
->ts
.type
!= BT_CLASS
5188 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5189 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5190 || (fsym
->ts
.type
== BT_CLASS
5191 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5192 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5194 if (fsym
->ts
.type
== BT_CLASS
)
5195 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5198 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5199 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5201 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5202 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5204 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5205 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5208 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5211 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5212 gfc_array_index_type
,
5213 fold_convert (gfc_array_index_type
, tmp2
),
5214 fold_convert (gfc_array_index_type
, tmp
));
5215 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5216 gfc_array_index_type
, offset
, tmp
);
5218 vec_safe_push (stringargs
, offset
);
5221 vec_safe_push (arglist
, parmse
.expr
);
5223 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5230 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5231 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5232 else if (ts
.type
== BT_CHARACTER
)
5234 if (ts
.u
.cl
->length
== NULL
)
5236 /* Assumed character length results are not allowed by 5.1.1.5 of the
5237 standard and are trapped in resolve.c; except in the case of SPREAD
5238 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5239 we take the character length of the first argument for the result.
5240 For dummies, we have to look through the formal argument list for
5241 this function and use the character length found there.*/
5243 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5244 else if (!sym
->attr
.dummy
)
5245 cl
.backend_decl
= (*stringargs
)[0];
5248 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5249 for (; formal
; formal
= formal
->next
)
5250 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5251 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5253 len
= cl
.backend_decl
;
5259 /* Calculate the length of the returned string. */
5260 gfc_init_se (&parmse
, NULL
);
5261 if (need_interface_mapping
)
5262 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5264 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5265 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5266 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5268 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5269 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5270 gfc_charlen_type_node
, tmp
,
5271 build_int_cst (gfc_charlen_type_node
, 0));
5272 cl
.backend_decl
= tmp
;
5275 /* Set up a charlen structure for it. */
5280 len
= cl
.backend_decl
;
5283 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5284 || (!comp
&& gfc_return_by_reference (sym
));
5287 if (se
->direct_byref
)
5289 /* Sometimes, too much indirection can be applied; e.g. for
5290 function_result = array_valued_recursive_function. */
5291 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5292 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5293 && GFC_DESCRIPTOR_TYPE_P
5294 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5295 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5298 /* If the lhs of an assignment x = f(..) is allocatable and
5299 f2003 is allowed, we must do the automatic reallocation.
5300 TODO - deal with intrinsics, without using a temporary. */
5301 if (flag_realloc_lhs
5302 && se
->ss
&& se
->ss
->loop_chain
5303 && se
->ss
->loop_chain
->is_alloc_lhs
5304 && !expr
->value
.function
.isym
5305 && sym
->result
->as
!= NULL
)
5307 /* Evaluate the bounds of the result, if known. */
5308 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5311 /* Perform the automatic reallocation. */
5312 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5314 gfc_add_expr_to_block (&se
->pre
, tmp
);
5316 /* Pass the temporary as the first argument. */
5317 result
= info
->descriptor
;
5320 result
= build_fold_indirect_ref_loc (input_location
,
5322 vec_safe_push (retargs
, se
->expr
);
5324 else if (comp
&& comp
->attr
.dimension
)
5326 gcc_assert (se
->loop
&& info
);
5328 /* Set the type of the array. */
5329 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5330 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5332 /* Evaluate the bounds of the result, if known. */
5333 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5335 /* If the lhs of an assignment x = f(..) is allocatable and
5336 f2003 is allowed, we must not generate the function call
5337 here but should just send back the results of the mapping.
5338 This is signalled by the function ss being flagged. */
5339 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5341 gfc_free_interface_mapping (&mapping
);
5342 return has_alternate_specifier
;
5345 /* Create a temporary to store the result. In case the function
5346 returns a pointer, the temporary will be a shallow copy and
5347 mustn't be deallocated. */
5348 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5349 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5350 tmp
, NULL_TREE
, false,
5351 !comp
->attr
.pointer
, callee_alloc
,
5352 &se
->ss
->info
->expr
->where
);
5354 /* Pass the temporary as the first argument. */
5355 result
= info
->descriptor
;
5356 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5357 vec_safe_push (retargs
, tmp
);
5359 else if (!comp
&& sym
->result
->attr
.dimension
)
5361 gcc_assert (se
->loop
&& info
);
5363 /* Set the type of the array. */
5364 tmp
= gfc_typenode_for_spec (&ts
);
5365 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5367 /* Evaluate the bounds of the result, if known. */
5368 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5370 /* If the lhs of an assignment x = f(..) is allocatable and
5371 f2003 is allowed, we must not generate the function call
5372 here but should just send back the results of the mapping.
5373 This is signalled by the function ss being flagged. */
5374 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5376 gfc_free_interface_mapping (&mapping
);
5377 return has_alternate_specifier
;
5380 /* Create a temporary to store the result. In case the function
5381 returns a pointer, the temporary will be a shallow copy and
5382 mustn't be deallocated. */
5383 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5384 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5385 tmp
, NULL_TREE
, false,
5386 !sym
->attr
.pointer
, callee_alloc
,
5387 &se
->ss
->info
->expr
->where
);
5389 /* Pass the temporary as the first argument. */
5390 result
= info
->descriptor
;
5391 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5392 vec_safe_push (retargs
, tmp
);
5394 else if (ts
.type
== BT_CHARACTER
)
5396 /* Pass the string length. */
5397 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5398 type
= build_pointer_type (type
);
5400 /* Return an address to a char[0:len-1]* temporary for
5401 character pointers. */
5402 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5403 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5405 var
= gfc_create_var (type
, "pstr");
5407 if ((!comp
&& sym
->attr
.allocatable
)
5408 || (comp
&& comp
->attr
.allocatable
))
5410 gfc_add_modify (&se
->pre
, var
,
5411 fold_convert (TREE_TYPE (var
),
5412 null_pointer_node
));
5413 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5414 gfc_add_expr_to_block (&se
->post
, tmp
);
5417 /* Provide an address expression for the function arguments. */
5418 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5421 var
= gfc_conv_string_tmp (se
, type
, len
);
5423 vec_safe_push (retargs
, var
);
5427 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5429 type
= gfc_get_complex_type (ts
.kind
);
5430 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5431 vec_safe_push (retargs
, var
);
5434 /* Add the string length to the argument list. */
5435 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5438 if (TREE_CODE (tmp
) != VAR_DECL
)
5439 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5440 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5441 vec_safe_push (retargs
, tmp
);
5443 else if (ts
.type
== BT_CHARACTER
)
5444 vec_safe_push (retargs
, len
);
5446 gfc_free_interface_mapping (&mapping
);
5448 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5449 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5450 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5451 vec_safe_reserve (retargs
, arglen
);
5453 /* Add the return arguments. */
5454 retargs
->splice (arglist
);
5456 /* Add the hidden present status for optional+value to the arguments. */
5457 retargs
->splice (optionalargs
);
5459 /* Add the hidden string length parameters to the arguments. */
5460 retargs
->splice (stringargs
);
5462 /* We may want to append extra arguments here. This is used e.g. for
5463 calls to libgfortran_matmul_??, which need extra information. */
5464 if (!vec_safe_is_empty (append_args
))
5465 retargs
->splice (append_args
);
5468 /* Generate the actual call. */
5469 if (base_object
== NULL_TREE
)
5470 conv_function_val (se
, sym
, expr
);
5472 conv_base_obj_fcn_val (se
, base_object
, expr
);
5474 /* If there are alternate return labels, function type should be
5475 integer. Can't modify the type in place though, since it can be shared
5476 with other functions. For dummy arguments, the typing is done to
5477 this result, even if it has to be repeated for each call. */
5478 if (has_alternate_specifier
5479 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5481 if (!sym
->attr
.dummy
)
5483 TREE_TYPE (sym
->backend_decl
)
5484 = build_function_type (integer_type_node
,
5485 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5486 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5489 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5492 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5493 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5495 /* If we have a pointer function, but we don't want a pointer, e.g.
5498 where f is pointer valued, we have to dereference the result. */
5499 if (!se
->want_pointer
&& !byref
5500 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5501 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5502 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5504 /* f2c calling conventions require a scalar default real function to
5505 return a double precision result. Convert this back to default
5506 real. We only care about the cases that can happen in Fortran 77.
5508 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5509 && sym
->ts
.kind
== gfc_default_real_kind
5510 && !sym
->attr
.always_explicit
)
5511 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5513 /* A pure function may still have side-effects - it may modify its
5515 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5517 if (!sym
->attr
.pure
)
5518 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5523 /* Add the function call to the pre chain. There is no expression. */
5524 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5525 se
->expr
= NULL_TREE
;
5527 if (!se
->direct_byref
)
5529 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5531 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5533 /* Check the data pointer hasn't been modified. This would
5534 happen in a function returning a pointer. */
5535 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5536 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5539 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5542 se
->expr
= info
->descriptor
;
5543 /* Bundle in the string length. */
5544 se
->string_length
= len
;
5546 else if (ts
.type
== BT_CHARACTER
)
5548 /* Dereference for character pointer results. */
5549 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5550 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5551 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5555 se
->string_length
= len
;
5559 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5560 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5565 /* Follow the function call with the argument post block. */
5568 gfc_add_block_to_block (&se
->pre
, &post
);
5570 /* Transformational functions of derived types with allocatable
5571 components must have the result allocatable components copied. */
5572 arg
= expr
->value
.function
.actual
;
5573 if (result
&& arg
&& expr
->rank
5574 && expr
->value
.function
.isym
5575 && expr
->value
.function
.isym
->transformational
5576 && arg
->expr
->ts
.type
== BT_DERIVED
5577 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5580 /* Copy the allocatable components. We have to use a
5581 temporary here to prevent source allocatable components
5582 from being corrupted. */
5583 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5584 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5585 result
, tmp2
, expr
->rank
);
5586 gfc_add_expr_to_block (&se
->pre
, tmp
);
5587 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5589 gfc_add_expr_to_block (&se
->pre
, tmp
);
5591 /* Finally free the temporary's data field. */
5592 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5593 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5594 NULL_TREE
, NULL_TREE
, true,
5596 gfc_add_expr_to_block (&se
->pre
, tmp
);
5601 /* For a function with a class array result, save the result as
5602 a temporary, set the info fields needed by the scalarizer and
5603 call the finalization function of the temporary. Note that the
5604 nullification of allocatable components needed by the result
5605 is done in gfc_trans_assignment_1. */
5606 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
5607 && se
->ss
&& se
->ss
->loop
)
5608 || gfc_is_alloc_class_scalar_function (expr
))
5609 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
5610 && expr
->must_finalize
)
5615 if (se
->ss
&& se
->ss
->loop
)
5617 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
5618 tmp
= gfc_class_data_get (se
->expr
);
5619 info
->descriptor
= tmp
;
5620 info
->data
= gfc_conv_descriptor_data_get (tmp
);
5621 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
5622 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
5624 tree dim
= gfc_rank_cst
[n
];
5625 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
5626 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
5631 /* TODO Eliminate the doubling of temporaries. This
5632 one is necessary to ensure no memory leakage. */
5633 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
5634 tmp
= gfc_class_data_get (se
->expr
);
5635 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
5636 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
5639 final_fndecl
= gfc_vtable_final_get (se
->expr
);
5640 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
5643 fold_convert (TREE_TYPE (final_fndecl
),
5644 null_pointer_node
));
5645 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
5647 tmp
= build_call_expr_loc (input_location
,
5649 gfc_build_addr_expr (NULL
, tmp
),
5650 gfc_vtable_size_get (se
->expr
),
5651 boolean_false_node
);
5652 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5653 void_type_node
, is_final
, tmp
,
5654 build_empty_stmt (input_location
));
5656 if (se
->ss
&& se
->ss
->loop
)
5658 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
5659 tmp
= gfc_call_free (convert (pvoid_type_node
, info
->data
));
5660 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
5664 gfc_add_expr_to_block (&se
->post
, tmp
);
5665 tmp
= gfc_class_data_get (se
->expr
);
5666 tmp
= gfc_call_free (convert (pvoid_type_node
, tmp
));
5667 gfc_add_expr_to_block (&se
->post
, tmp
);
5669 expr
->must_finalize
= 0;
5672 gfc_add_block_to_block (&se
->post
, &post
);
5675 return has_alternate_specifier
;
5679 /* Fill a character string with spaces. */
5682 fill_with_spaces (tree start
, tree type
, tree size
)
5684 stmtblock_t block
, loop
;
5685 tree i
, el
, exit_label
, cond
, tmp
;
5687 /* For a simple char type, we can call memset(). */
5688 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5689 return build_call_expr_loc (input_location
,
5690 builtin_decl_explicit (BUILT_IN_MEMSET
),
5692 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5693 lang_hooks
.to_target_charset (' ')),
5696 /* Otherwise, we use a loop:
5697 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5701 /* Initialize variables. */
5702 gfc_init_block (&block
);
5703 i
= gfc_create_var (sizetype
, "i");
5704 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5705 el
= gfc_create_var (build_pointer_type (type
), "el");
5706 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5707 exit_label
= gfc_build_label_decl (NULL_TREE
);
5708 TREE_USED (exit_label
) = 1;
5712 gfc_init_block (&loop
);
5714 /* Exit condition. */
5715 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5716 build_zero_cst (sizetype
));
5717 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5718 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5719 build_empty_stmt (input_location
));
5720 gfc_add_expr_to_block (&loop
, tmp
);
5723 gfc_add_modify (&loop
,
5724 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5725 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5727 /* Increment loop variables. */
5728 gfc_add_modify (&loop
, i
,
5729 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5730 TYPE_SIZE_UNIT (type
)));
5731 gfc_add_modify (&loop
, el
,
5732 fold_build_pointer_plus_loc (input_location
,
5733 el
, TYPE_SIZE_UNIT (type
)));
5735 /* Making the loop... actually loop! */
5736 tmp
= gfc_finish_block (&loop
);
5737 tmp
= build1_v (LOOP_EXPR
, tmp
);
5738 gfc_add_expr_to_block (&block
, tmp
);
5740 /* The exit label. */
5741 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5742 gfc_add_expr_to_block (&block
, tmp
);
5745 return gfc_finish_block (&block
);
5749 /* Generate code to copy a string. */
5752 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5753 int dkind
, tree slength
, tree src
, int skind
)
5755 tree tmp
, dlen
, slen
;
5764 stmtblock_t tempblock
;
5766 gcc_assert (dkind
== skind
);
5768 if (slength
!= NULL_TREE
)
5770 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5771 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5775 slen
= build_int_cst (size_type_node
, 1);
5779 if (dlength
!= NULL_TREE
)
5781 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5782 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5786 dlen
= build_int_cst (size_type_node
, 1);
5790 /* Assign directly if the types are compatible. */
5791 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5792 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5794 gfc_add_modify (block
, dsc
, ssc
);
5798 /* Do nothing if the destination length is zero. */
5799 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5800 build_int_cst (size_type_node
, 0));
5802 /* The following code was previously in _gfortran_copy_string:
5804 // The two strings may overlap so we use memmove.
5806 copy_string (GFC_INTEGER_4 destlen, char * dest,
5807 GFC_INTEGER_4 srclen, const char * src)
5809 if (srclen >= destlen)
5811 // This will truncate if too long.
5812 memmove (dest, src, destlen);
5816 memmove (dest, src, srclen);
5818 memset (&dest[srclen], ' ', destlen - srclen);
5822 We're now doing it here for better optimization, but the logic
5825 /* For non-default character kinds, we have to multiply the string
5826 length by the base type size. */
5827 chartype
= gfc_get_char_type (dkind
);
5828 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5829 fold_convert (size_type_node
, slen
),
5830 fold_convert (size_type_node
,
5831 TYPE_SIZE_UNIT (chartype
)));
5832 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5833 fold_convert (size_type_node
, dlen
),
5834 fold_convert (size_type_node
,
5835 TYPE_SIZE_UNIT (chartype
)));
5837 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5838 dest
= fold_convert (pvoid_type_node
, dest
);
5840 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5842 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5843 src
= fold_convert (pvoid_type_node
, src
);
5845 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5847 /* Truncate string if source is too long. */
5848 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5850 tmp2
= build_call_expr_loc (input_location
,
5851 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5852 3, dest
, src
, dlen
);
5854 /* Else copy and pad with spaces. */
5855 tmp3
= build_call_expr_loc (input_location
,
5856 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5857 3, dest
, src
, slen
);
5859 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5860 tmp4
= fill_with_spaces (tmp4
, chartype
,
5861 fold_build2_loc (input_location
, MINUS_EXPR
,
5862 TREE_TYPE(dlen
), dlen
, slen
));
5864 gfc_init_block (&tempblock
);
5865 gfc_add_expr_to_block (&tempblock
, tmp3
);
5866 gfc_add_expr_to_block (&tempblock
, tmp4
);
5867 tmp3
= gfc_finish_block (&tempblock
);
5869 /* The whole copy_string function is there. */
5870 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5872 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5873 build_empty_stmt (input_location
));
5874 gfc_add_expr_to_block (block
, tmp
);
5878 /* Translate a statement function.
5879 The value of a statement function reference is obtained by evaluating the
5880 expression using the values of the actual arguments for the values of the
5881 corresponding dummy arguments. */
5884 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5888 gfc_formal_arglist
*fargs
;
5889 gfc_actual_arglist
*args
;
5892 gfc_saved_var
*saved_vars
;
5898 sym
= expr
->symtree
->n
.sym
;
5899 args
= expr
->value
.function
.actual
;
5900 gfc_init_se (&lse
, NULL
);
5901 gfc_init_se (&rse
, NULL
);
5904 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5906 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5907 temp_vars
= XCNEWVEC (tree
, n
);
5909 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5910 fargs
= fargs
->next
, n
++)
5912 /* Each dummy shall be specified, explicitly or implicitly, to be
5914 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5917 if (fsym
->ts
.type
== BT_CHARACTER
)
5919 /* Copy string arguments. */
5922 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5923 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5925 /* Create a temporary to hold the value. */
5926 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5927 fsym
->ts
.u
.cl
->backend_decl
5928 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5930 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5931 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5933 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5935 gfc_conv_expr (&rse
, args
->expr
);
5936 gfc_conv_string_parameter (&rse
);
5937 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5938 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5940 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5941 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5942 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5943 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5947 /* For everything else, just evaluate the expression. */
5949 /* Create a temporary to hold the value. */
5950 type
= gfc_typenode_for_spec (&fsym
->ts
);
5951 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5953 gfc_conv_expr (&lse
, args
->expr
);
5955 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5956 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5957 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5963 /* Use the temporary variables in place of the real ones. */
5964 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5965 fargs
= fargs
->next
, n
++)
5966 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5968 gfc_conv_expr (se
, sym
->value
);
5970 if (sym
->ts
.type
== BT_CHARACTER
)
5972 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5974 /* Force the expression to the correct length. */
5975 if (!INTEGER_CST_P (se
->string_length
)
5976 || tree_int_cst_lt (se
->string_length
,
5977 sym
->ts
.u
.cl
->backend_decl
))
5979 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5980 tmp
= gfc_create_var (type
, sym
->name
);
5981 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5982 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5983 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5987 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5990 /* Restore the original variables. */
5991 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5992 fargs
= fargs
->next
, n
++)
5993 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5999 /* Translate a function expression. */
6002 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6006 if (expr
->value
.function
.isym
)
6008 gfc_conv_intrinsic_function (se
, expr
);
6012 /* expr.value.function.esym is the resolved (specific) function symbol for
6013 most functions. However this isn't set for dummy procedures. */
6014 sym
= expr
->value
.function
.esym
;
6016 sym
= expr
->symtree
->n
.sym
;
6018 /* The IEEE_ARITHMETIC functions are caught here. */
6019 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6020 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6023 /* We distinguish statement functions from general functions to improve
6024 runtime performance. */
6025 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6027 gfc_conv_statement_function (se
, expr
);
6031 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6036 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6039 is_zero_initializer_p (gfc_expr
* expr
)
6041 if (expr
->expr_type
!= EXPR_CONSTANT
)
6044 /* We ignore constants with prescribed memory representations for now. */
6045 if (expr
->representation
.string
)
6048 switch (expr
->ts
.type
)
6051 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6054 return mpfr_zero_p (expr
->value
.real
)
6055 && MPFR_SIGN (expr
->value
.real
) >= 0;
6058 return expr
->value
.logical
== 0;
6061 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6062 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6063 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6064 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6074 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6079 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6080 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6082 gfc_conv_tmp_array_ref (se
);
6086 /* Build a static initializer. EXPR is the expression for the initial value.
6087 The other parameters describe the variable of the component being
6088 initialized. EXPR may be null. */
6091 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6092 bool array
, bool pointer
, bool procptr
)
6096 if (!(expr
|| pointer
|| procptr
))
6099 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6100 (these are the only two iso_c_binding derived types that can be
6101 used as initialization expressions). If so, we need to modify
6102 the 'expr' to be that for a (void *). */
6103 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6104 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6106 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6108 /* The derived symbol has already been converted to a (void *). Use
6110 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6111 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6113 gfc_init_se (&se
, NULL
);
6114 gfc_conv_constant (&se
, expr
);
6115 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6119 if (array
&& !procptr
)
6122 /* Arrays need special handling. */
6124 ctor
= gfc_build_null_descriptor (type
);
6125 /* Special case assigning an array to zero. */
6126 else if (is_zero_initializer_p (expr
))
6127 ctor
= build_constructor (type
, NULL
);
6129 ctor
= gfc_conv_array_initializer (type
, expr
);
6130 TREE_STATIC (ctor
) = 1;
6133 else if (pointer
|| procptr
)
6135 if (ts
->type
== BT_CLASS
&& !procptr
)
6137 gfc_init_se (&se
, NULL
);
6138 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6139 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6140 TREE_STATIC (se
.expr
) = 1;
6143 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6144 return fold_convert (type
, null_pointer_node
);
6147 gfc_init_se (&se
, NULL
);
6148 se
.want_pointer
= 1;
6149 gfc_conv_expr (&se
, expr
);
6150 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6160 gfc_init_se (&se
, NULL
);
6161 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6162 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6164 gfc_conv_structure (&se
, expr
, 1);
6165 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6166 TREE_STATIC (se
.expr
) = 1;
6171 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6172 TREE_STATIC (ctor
) = 1;
6177 gfc_init_se (&se
, NULL
);
6178 gfc_conv_constant (&se
, expr
);
6179 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6186 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6192 gfc_array_info
*lss_array
;
6199 gfc_start_block (&block
);
6201 /* Initialize the scalarizer. */
6202 gfc_init_loopinfo (&loop
);
6204 gfc_init_se (&lse
, NULL
);
6205 gfc_init_se (&rse
, NULL
);
6208 rss
= gfc_walk_expr (expr
);
6209 if (rss
== gfc_ss_terminator
)
6210 /* The rhs is scalar. Add a ss for the expression. */
6211 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6213 /* Create a SS for the destination. */
6214 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6216 lss_array
= &lss
->info
->data
.array
;
6217 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6218 lss_array
->descriptor
= dest
;
6219 lss_array
->data
= gfc_conv_array_data (dest
);
6220 lss_array
->offset
= gfc_conv_array_offset (dest
);
6221 for (n
= 0; n
< cm
->as
->rank
; n
++)
6223 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6224 lss_array
->stride
[n
] = gfc_index_one_node
;
6226 mpz_init (lss_array
->shape
[n
]);
6227 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6228 cm
->as
->lower
[n
]->value
.integer
);
6229 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6232 /* Associate the SS with the loop. */
6233 gfc_add_ss_to_loop (&loop
, lss
);
6234 gfc_add_ss_to_loop (&loop
, rss
);
6236 /* Calculate the bounds of the scalarization. */
6237 gfc_conv_ss_startstride (&loop
);
6239 /* Setup the scalarizing loops. */
6240 gfc_conv_loop_setup (&loop
, &expr
->where
);
6242 /* Setup the gfc_se structures. */
6243 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6244 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6247 gfc_mark_ss_chain_used (rss
, 1);
6249 gfc_mark_ss_chain_used (lss
, 1);
6251 /* Start the scalarized loop body. */
6252 gfc_start_scalarized_body (&loop
, &body
);
6254 gfc_conv_tmp_array_ref (&lse
);
6255 if (cm
->ts
.type
== BT_CHARACTER
)
6256 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6258 gfc_conv_expr (&rse
, expr
);
6260 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6261 gfc_add_expr_to_block (&body
, tmp
);
6263 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6265 /* Generate the copying loops. */
6266 gfc_trans_scalarizing_loops (&loop
, &body
);
6268 /* Wrap the whole thing up. */
6269 gfc_add_block_to_block (&block
, &loop
.pre
);
6270 gfc_add_block_to_block (&block
, &loop
.post
);
6272 gcc_assert (lss_array
->shape
!= NULL
);
6273 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6274 gfc_cleanup_loop (&loop
);
6276 return gfc_finish_block (&block
);
6281 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6291 gfc_expr
*arg
= NULL
;
6293 gfc_start_block (&block
);
6294 gfc_init_se (&se
, NULL
);
6296 /* Get the descriptor for the expressions. */
6297 se
.want_pointer
= 0;
6298 gfc_conv_expr_descriptor (&se
, expr
);
6299 gfc_add_block_to_block (&block
, &se
.pre
);
6300 gfc_add_modify (&block
, dest
, se
.expr
);
6302 /* Deal with arrays of derived types with allocatable components. */
6303 if (cm
->ts
.type
== BT_DERIVED
6304 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6305 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6308 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6309 && CLASS_DATA(cm
)->attr
.allocatable
)
6311 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6312 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6317 tmp
= TREE_TYPE (dest
);
6318 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6323 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6324 TREE_TYPE(cm
->backend_decl
),
6327 gfc_add_expr_to_block (&block
, tmp
);
6328 gfc_add_block_to_block (&block
, &se
.post
);
6330 if (expr
->expr_type
!= EXPR_VARIABLE
)
6331 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6334 /* We need to know if the argument of a conversion function is a
6335 variable, so that the correct lower bound can be used. */
6336 if (expr
->expr_type
== EXPR_FUNCTION
6337 && expr
->value
.function
.isym
6338 && expr
->value
.function
.isym
->conversion
6339 && expr
->value
.function
.actual
->expr
6340 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6341 arg
= expr
->value
.function
.actual
->expr
;
6343 /* Obtain the array spec of full array references. */
6345 as
= gfc_get_full_arrayspec_from_expr (arg
);
6347 as
= gfc_get_full_arrayspec_from_expr (expr
);
6349 /* Shift the lbound and ubound of temporaries to being unity,
6350 rather than zero, based. Always calculate the offset. */
6351 offset
= gfc_conv_descriptor_offset_get (dest
);
6352 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6353 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6355 for (n
= 0; n
< expr
->rank
; n
++)
6360 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6361 TODO It looks as if gfc_conv_expr_descriptor should return
6362 the correct bounds and that the following should not be
6363 necessary. This would simplify gfc_conv_intrinsic_bound
6365 if (as
&& as
->lower
[n
])
6368 gfc_init_se (&lbse
, NULL
);
6369 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6370 gfc_add_block_to_block (&block
, &lbse
.pre
);
6371 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6375 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6376 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6380 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6383 lbound
= gfc_index_one_node
;
6385 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6387 /* Shift the bounds and set the offset accordingly. */
6388 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6389 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6390 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6391 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6393 gfc_conv_descriptor_ubound_set (&block
, dest
,
6394 gfc_rank_cst
[n
], tmp
);
6395 gfc_conv_descriptor_lbound_set (&block
, dest
,
6396 gfc_rank_cst
[n
], lbound
);
6398 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6399 gfc_conv_descriptor_lbound_get (dest
,
6401 gfc_conv_descriptor_stride_get (dest
,
6403 gfc_add_modify (&block
, tmp2
, tmp
);
6404 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6406 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6411 /* If a conversion expression has a null data pointer
6412 argument, nullify the allocatable component. */
6416 if (arg
->symtree
->n
.sym
->attr
.allocatable
6417 || arg
->symtree
->n
.sym
->attr
.pointer
)
6419 non_null_expr
= gfc_finish_block (&block
);
6420 gfc_start_block (&block
);
6421 gfc_conv_descriptor_data_set (&block
, dest
,
6423 null_expr
= gfc_finish_block (&block
);
6424 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6425 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6426 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6427 return build3_v (COND_EXPR
, tmp
,
6428 null_expr
, non_null_expr
);
6432 return gfc_finish_block (&block
);
6436 /* Allocate or reallocate scalar component, as necessary. */
6439 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6449 tree lhs_cl_size
= NULL_TREE
;
6454 if (!expr2
|| expr2
->rank
)
6457 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6459 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6461 char name
[GFC_MAX_SYMBOL_LEN
+9];
6462 gfc_component
*strlen
;
6463 /* Use the rhs string length and the lhs element size. */
6464 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6465 if (!expr2
->ts
.u
.cl
->backend_decl
)
6467 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6468 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6471 size
= expr2
->ts
.u
.cl
->backend_decl
;
6473 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6475 sprintf (name
, "_%s_length", cm
->name
);
6476 strlen
= gfc_find_component (sym
, name
, true, true);
6477 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6478 gfc_charlen_type_node
,
6479 TREE_OPERAND (comp
, 0),
6480 strlen
->backend_decl
, NULL_TREE
);
6482 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6483 tmp
= TYPE_SIZE_UNIT (tmp
);
6484 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6485 TREE_TYPE (tmp
), tmp
,
6486 fold_convert (TREE_TYPE (tmp
), size
));
6490 /* Otherwise use the length in bytes of the rhs. */
6491 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6492 size_in_bytes
= size
;
6495 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6496 size_in_bytes
, size_one_node
);
6498 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6500 tmp
= build_call_expr_loc (input_location
,
6501 builtin_decl_explicit (BUILT_IN_CALLOC
),
6502 2, build_one_cst (size_type_node
),
6504 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6505 gfc_add_modify (block
, comp
, tmp
);
6509 tmp
= build_call_expr_loc (input_location
,
6510 builtin_decl_explicit (BUILT_IN_MALLOC
),
6512 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
6513 ptr
= gfc_class_data_get (comp
);
6516 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
6517 gfc_add_modify (block
, ptr
, tmp
);
6520 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6521 /* Update the lhs character length. */
6522 gfc_add_modify (block
, lhs_cl_size
, size
);
6526 /* Assign a single component of a derived type constructor. */
6529 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6530 gfc_symbol
*sym
, bool init
)
6538 gfc_start_block (&block
);
6540 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6542 /* Only care about pointers here, not about allocatables. */
6543 gfc_init_se (&se
, NULL
);
6544 /* Pointer component. */
6545 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6546 && !cm
->attr
.proc_pointer
)
6548 /* Array pointer. */
6549 if (expr
->expr_type
== EXPR_NULL
)
6550 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6553 se
.direct_byref
= 1;
6555 gfc_conv_expr_descriptor (&se
, expr
);
6556 gfc_add_block_to_block (&block
, &se
.pre
);
6557 gfc_add_block_to_block (&block
, &se
.post
);
6562 /* Scalar pointers. */
6563 se
.want_pointer
= 1;
6564 gfc_conv_expr (&se
, expr
);
6565 gfc_add_block_to_block (&block
, &se
.pre
);
6567 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6568 && expr
->symtree
->n
.sym
->attr
.dummy
)
6569 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6571 gfc_add_modify (&block
, dest
,
6572 fold_convert (TREE_TYPE (dest
), se
.expr
));
6573 gfc_add_block_to_block (&block
, &se
.post
);
6576 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6578 /* NULL initialization for CLASS components. */
6579 tmp
= gfc_trans_structure_assign (dest
,
6580 gfc_class_initializer (&cm
->ts
, expr
),
6582 gfc_add_expr_to_block (&block
, tmp
);
6584 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6585 && !cm
->attr
.proc_pointer
)
6587 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6588 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6589 else if (cm
->attr
.allocatable
)
6591 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6592 gfc_add_expr_to_block (&block
, tmp
);
6596 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6597 gfc_add_expr_to_block (&block
, tmp
);
6600 else if (cm
->ts
.type
== BT_CLASS
6601 && CLASS_DATA (cm
)->attr
.dimension
6602 && CLASS_DATA (cm
)->attr
.allocatable
6603 && expr
->ts
.type
== BT_DERIVED
)
6605 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
6606 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
6607 tmp
= gfc_class_vptr_get (dest
);
6608 gfc_add_modify (&block
, tmp
,
6609 fold_convert (TREE_TYPE (tmp
), vtab
));
6610 tmp
= gfc_class_data_get (dest
);
6611 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
6612 gfc_add_expr_to_block (&block
, tmp
);
6614 else if (init
&& (cm
->attr
.allocatable
6615 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
6617 /* Take care about non-array allocatable components here. The alloc_*
6618 routine below is motivated by the alloc_scalar_allocatable_for_
6619 assignment() routine, but with the realloc portions removed and
6621 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
6626 /* The remainder of these instructions follow the if (cm->attr.pointer)
6627 if (!cm->attr.dimension) part above. */
6628 gfc_init_se (&se
, NULL
);
6629 gfc_conv_expr (&se
, expr
);
6630 gfc_add_block_to_block (&block
, &se
.pre
);
6632 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6633 && expr
->symtree
->n
.sym
->attr
.dummy
)
6634 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6636 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
6638 tmp
= gfc_class_data_get (dest
);
6639 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
6640 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
6641 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
6642 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
6643 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
6646 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
6648 /* For deferred strings insert a memcpy. */
6649 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6652 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
6653 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
6655 : expr
->ts
.u
.cl
->backend_decl
);
6656 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
6657 gfc_add_expr_to_block (&block
, tmp
);
6660 gfc_add_modify (&block
, tmp
,
6661 fold_convert (TREE_TYPE (tmp
), se
.expr
));
6662 gfc_add_block_to_block (&block
, &se
.post
);
6664 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6666 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6668 gfc_init_se (&se
, NULL
);
6669 gfc_conv_expr (&se
, expr
);
6670 gfc_add_block_to_block (&block
, &se
.pre
);
6671 if (cm
->ts
.u
.derived
->attr
.alloc_comp
6672 && expr
->expr_type
== EXPR_VARIABLE
)
6674 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
6676 gfc_add_expr_to_block (&block
, tmp
);
6679 gfc_add_modify (&block
, dest
,
6680 fold_convert (TREE_TYPE (dest
), se
.expr
));
6681 gfc_add_block_to_block (&block
, &se
.post
);
6685 /* Nested constructors. */
6686 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
6687 gfc_add_expr_to_block (&block
, tmp
);
6690 else if (gfc_deferred_strlen (cm
, &tmp
))
6694 gcc_assert (strlen
);
6695 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6697 TREE_OPERAND (dest
, 0),
6700 if (expr
->expr_type
== EXPR_NULL
)
6702 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6703 gfc_add_modify (&block
, dest
, tmp
);
6704 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6705 gfc_add_modify (&block
, strlen
, tmp
);
6710 gfc_init_se (&se
, NULL
);
6711 gfc_conv_expr (&se
, expr
);
6712 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6713 tmp
= build_call_expr_loc (input_location
,
6714 builtin_decl_explicit (BUILT_IN_MALLOC
),
6716 gfc_add_modify (&block
, dest
,
6717 fold_convert (TREE_TYPE (dest
), tmp
));
6718 gfc_add_modify (&block
, strlen
, se
.string_length
);
6719 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6720 gfc_add_expr_to_block (&block
, tmp
);
6723 else if (!cm
->attr
.artificial
)
6725 /* Scalar component (excluding deferred parameters). */
6726 gfc_init_se (&se
, NULL
);
6727 gfc_init_se (&lse
, NULL
);
6729 gfc_conv_expr (&se
, expr
);
6730 if (cm
->ts
.type
== BT_CHARACTER
)
6731 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6733 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6734 gfc_add_expr_to_block (&block
, tmp
);
6736 return gfc_finish_block (&block
);
6739 /* Assign a derived type constructor to a variable. */
6742 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
6750 gfc_start_block (&block
);
6751 cm
= expr
->ts
.u
.derived
->components
;
6753 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6754 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6755 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6759 gcc_assert (cm
->backend_decl
== NULL
);
6760 gfc_init_se (&se
, NULL
);
6761 gfc_init_se (&lse
, NULL
);
6762 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6764 gfc_add_modify (&block
, lse
.expr
,
6765 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6767 return gfc_finish_block (&block
);
6770 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6771 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6773 /* Skip absent members in default initializers. */
6774 if (!c
->expr
&& !cm
->attr
.allocatable
)
6777 field
= cm
->backend_decl
;
6778 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6779 dest
, field
, NULL_TREE
);
6782 gfc_expr
*e
= gfc_get_null_expr (NULL
);
6783 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
6788 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
6789 expr
->ts
.u
.derived
, init
);
6790 gfc_add_expr_to_block (&block
, tmp
);
6792 return gfc_finish_block (&block
);
6795 /* Build an expression for a constructor. If init is nonzero then
6796 this is part of a static variable initializer. */
6799 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6806 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6808 gcc_assert (se
->ss
== NULL
);
6809 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6810 type
= gfc_typenode_for_spec (&expr
->ts
);
6814 /* Create a temporary variable and fill it in. */
6815 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6816 /* The symtree in expr is NULL, if the code to generate is for
6817 initializing the static members only. */
6818 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
6819 gfc_add_expr_to_block (&se
->pre
, tmp
);
6823 cm
= expr
->ts
.u
.derived
->components
;
6825 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6826 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6828 /* Skip absent members in default initializers and allocatable
6829 components. Although the latter have a default initializer
6830 of EXPR_NULL,... by default, the static nullify is not needed
6831 since this is done every time we come into scope. */
6832 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6835 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6836 && strcmp (cm
->name
, "_extends") == 0
6837 && cm
->initializer
->symtree
)
6841 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6842 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6843 vtab
= unshare_expr_without_location (vtab
);
6844 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6846 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6848 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6849 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6850 fold_convert (TREE_TYPE (cm
->backend_decl
),
6853 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
6855 gfc_expr
*e
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
6856 val
= gfc_conv_constant_to_tree (e
);
6857 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6858 fold_convert (TREE_TYPE (cm
->backend_decl
),
6863 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6864 TREE_TYPE (cm
->backend_decl
),
6865 cm
->attr
.dimension
, cm
->attr
.pointer
,
6866 cm
->attr
.proc_pointer
);
6867 val
= unshare_expr_without_location (val
);
6869 /* Append it to the constructor list. */
6870 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6873 se
->expr
= build_constructor (type
, v
);
6875 TREE_CONSTANT (se
->expr
) = 1;
6879 /* Translate a substring expression. */
6882 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6888 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6890 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6891 expr
->value
.character
.length
,
6892 expr
->value
.character
.string
);
6894 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6895 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6898 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6902 /* Entry point for expression translation. Evaluates a scalar quantity.
6903 EXPR is the expression to be translated, and SE is the state structure if
6904 called from within the scalarized. */
6907 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6912 if (ss
&& ss
->info
->expr
== expr
6913 && (ss
->info
->type
== GFC_SS_SCALAR
6914 || ss
->info
->type
== GFC_SS_REFERENCE
))
6916 gfc_ss_info
*ss_info
;
6919 /* Substitute a scalar expression evaluated outside the scalarization
6921 se
->expr
= ss_info
->data
.scalar
.value
;
6922 /* If the reference can be NULL, the value field contains the reference,
6923 not the value the reference points to (see gfc_add_loop_ss_code). */
6924 if (ss_info
->can_be_null_ref
)
6925 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6927 se
->string_length
= ss_info
->string_length
;
6928 gfc_advance_se_ss_chain (se
);
6932 /* We need to convert the expressions for the iso_c_binding derived types.
6933 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6934 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6935 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6936 updated to be an integer with a kind equal to the size of a (void *). */
6937 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
6938 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
6940 if (expr
->expr_type
== EXPR_VARIABLE
6941 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6942 || expr
->symtree
->n
.sym
->intmod_sym_id
6943 == ISOCBINDING_NULL_FUNPTR
))
6945 /* Set expr_type to EXPR_NULL, which will result in
6946 null_pointer_node being used below. */
6947 expr
->expr_type
= EXPR_NULL
;
6951 /* Update the type/kind of the expression to be what the new
6952 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6953 expr
->ts
.type
= BT_INTEGER
;
6954 expr
->ts
.f90_type
= BT_VOID
;
6955 expr
->ts
.kind
= gfc_index_integer_kind
;
6959 gfc_fix_class_refs (expr
);
6961 switch (expr
->expr_type
)
6964 gfc_conv_expr_op (se
, expr
);
6968 gfc_conv_function_expr (se
, expr
);
6972 gfc_conv_constant (se
, expr
);
6976 gfc_conv_variable (se
, expr
);
6980 se
->expr
= null_pointer_node
;
6983 case EXPR_SUBSTRING
:
6984 gfc_conv_substring_expr (se
, expr
);
6987 case EXPR_STRUCTURE
:
6988 gfc_conv_structure (se
, expr
, 0);
6992 gfc_conv_array_constructor_expr (se
, expr
);
7001 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7002 of an assignment. */
7004 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7006 gfc_conv_expr (se
, expr
);
7007 /* All numeric lvalues should have empty post chains. If not we need to
7008 figure out a way of rewriting an lvalue so that it has no post chain. */
7009 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7012 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7013 numeric expressions. Used for scalar values where inserting cleanup code
7016 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7020 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7021 gfc_conv_expr (se
, expr
);
7024 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7025 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7027 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7031 /* Helper to translate an expression and convert it to a particular type. */
7033 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7035 gfc_conv_expr_val (se
, expr
);
7036 se
->expr
= convert (type
, se
->expr
);
7040 /* Converts an expression so that it can be passed by reference. Scalar
7044 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7050 if (ss
&& ss
->info
->expr
== expr
7051 && ss
->info
->type
== GFC_SS_REFERENCE
)
7053 /* Returns a reference to the scalar evaluated outside the loop
7055 gfc_conv_expr (se
, expr
);
7057 if (expr
->ts
.type
== BT_CHARACTER
7058 && expr
->expr_type
!= EXPR_FUNCTION
)
7059 gfc_conv_string_parameter (se
);
7061 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7066 if (expr
->ts
.type
== BT_CHARACTER
)
7068 gfc_conv_expr (se
, expr
);
7069 gfc_conv_string_parameter (se
);
7073 if (expr
->expr_type
== EXPR_VARIABLE
)
7075 se
->want_pointer
= 1;
7076 gfc_conv_expr (se
, expr
);
7079 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7080 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7081 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7087 if (expr
->expr_type
== EXPR_FUNCTION
7088 && ((expr
->value
.function
.esym
7089 && expr
->value
.function
.esym
->result
->attr
.pointer
7090 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7091 || (!expr
->value
.function
.esym
&& !expr
->ref
7092 && expr
->symtree
->n
.sym
->attr
.pointer
7093 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7095 se
->want_pointer
= 1;
7096 gfc_conv_expr (se
, expr
);
7097 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7098 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7103 gfc_conv_expr (se
, expr
);
7105 /* Create a temporary var to hold the value. */
7106 if (TREE_CONSTANT (se
->expr
))
7108 tree tmp
= se
->expr
;
7109 STRIP_TYPE_NOPS (tmp
);
7110 var
= build_decl (input_location
,
7111 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7112 DECL_INITIAL (var
) = tmp
;
7113 TREE_STATIC (var
) = 1;
7118 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7119 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7121 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7123 /* Take the address of that value. */
7124 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7125 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
7126 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
7127 && expr
->ts
.u
.derived
->attr
.alloc_comp
7128 && expr
->expr_type
!= EXPR_VARIABLE
)
7132 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7133 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7135 /* The components shall be deallocated before
7136 their containing entity. */
7137 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7143 gfc_trans_pointer_assign (gfc_code
* code
)
7145 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7149 /* Generate code for a pointer assignment. */
7152 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7154 gfc_expr
*expr1_vptr
= NULL
;
7164 gfc_start_block (&block
);
7166 gfc_init_se (&lse
, NULL
);
7168 /* Check whether the expression is a scalar or not; we cannot use
7169 expr1->rank as it can be nonzero for proc pointers. */
7170 ss
= gfc_walk_expr (expr1
);
7171 scalar
= ss
== gfc_ss_terminator
;
7173 gfc_free_ss_chain (ss
);
7175 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7176 && expr2
->expr_type
!= EXPR_FUNCTION
)
7178 gfc_add_data_component (expr2
);
7179 /* The following is required as gfc_add_data_component doesn't
7180 update ts.type if there is a tailing REF_ARRAY. */
7181 expr2
->ts
.type
= BT_DERIVED
;
7186 /* Scalar pointers. */
7187 lse
.want_pointer
= 1;
7188 gfc_conv_expr (&lse
, expr1
);
7189 gfc_init_se (&rse
, NULL
);
7190 rse
.want_pointer
= 1;
7191 gfc_conv_expr (&rse
, expr2
);
7193 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7194 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7195 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7198 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7199 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7200 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7203 gfc_add_block_to_block (&block
, &lse
.pre
);
7204 gfc_add_block_to_block (&block
, &rse
.pre
);
7206 /* For string assignments to unlimited polymorphic pointers add an
7207 assignment of the string_length to the _len component of the
7209 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7210 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7211 && (expr2
->ts
.type
== BT_CHARACTER
||
7212 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7213 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7217 len_comp
= gfc_get_len_component (expr1
);
7218 gfc_init_se (&se
, NULL
);
7219 gfc_conv_expr (&se
, len_comp
);
7221 /* ptr % _len = len (str) */
7222 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7223 lse
.string_length
= se
.expr
;
7224 gfc_free_expr (len_comp
);
7227 /* Check character lengths if character expression. The test is only
7228 really added if -fbounds-check is enabled. Exclude deferred
7229 character length lefthand sides. */
7230 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7231 && !expr1
->ts
.deferred
7232 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7233 && !gfc_is_proc_ptr_comp (expr1
))
7235 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7236 gcc_assert (lse
.string_length
&& rse
.string_length
);
7237 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7238 lse
.string_length
, rse
.string_length
,
7242 /* The assignment to an deferred character length sets the string
7243 length to that of the rhs. */
7244 if (expr1
->ts
.deferred
)
7246 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7247 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7248 else if (lse
.string_length
!= NULL
)
7249 gfc_add_modify (&block
, lse
.string_length
,
7250 build_int_cst (gfc_charlen_type_node
, 0));
7253 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7254 rse
.expr
= gfc_class_data_get (rse
.expr
);
7256 gfc_add_modify (&block
, lse
.expr
,
7257 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7259 gfc_add_block_to_block (&block
, &rse
.post
);
7260 gfc_add_block_to_block (&block
, &lse
.post
);
7267 tree strlen_rhs
= NULL_TREE
;
7269 /* Array pointer. Find the last reference on the LHS and if it is an
7270 array section ref, we're dealing with bounds remapping. In this case,
7271 set it to AR_FULL so that gfc_conv_expr_descriptor does
7272 not see it and process the bounds remapping afterwards explicitly. */
7273 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7274 if (!remap
->next
&& remap
->type
== REF_ARRAY
7275 && remap
->u
.ar
.type
== AR_SECTION
)
7277 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7279 gfc_init_se (&lse
, NULL
);
7281 lse
.descriptor_only
= 1;
7282 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7283 && expr1
->ts
.type
== BT_CLASS
)
7284 expr1_vptr
= gfc_copy_expr (expr1
);
7285 gfc_conv_expr_descriptor (&lse
, expr1
);
7286 strlen_lhs
= lse
.string_length
;
7289 if (expr2
->expr_type
== EXPR_NULL
)
7291 /* Just set the data pointer to null. */
7292 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7294 else if (rank_remap
)
7296 /* If we are rank-remapping, just get the RHS's descriptor and
7297 process this later on. */
7298 gfc_init_se (&rse
, NULL
);
7299 rse
.direct_byref
= 1;
7300 rse
.byref_noassign
= 1;
7302 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7304 gfc_conv_function_expr (&rse
, expr2
);
7306 if (expr1
->ts
.type
!= BT_CLASS
)
7307 rse
.expr
= gfc_class_data_get (rse
.expr
);
7310 gfc_add_block_to_block (&block
, &rse
.pre
);
7311 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7312 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7314 gfc_add_vptr_component (expr1_vptr
);
7315 gfc_init_se (&rse
, NULL
);
7316 rse
.want_pointer
= 1;
7317 gfc_conv_expr (&rse
, expr1_vptr
);
7318 gfc_add_modify (&lse
.pre
, rse
.expr
,
7319 fold_convert (TREE_TYPE (rse
.expr
),
7320 gfc_class_vptr_get (tmp
)));
7321 rse
.expr
= gfc_class_data_get (tmp
);
7324 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7326 tree bound
[GFC_MAX_DIMENSIONS
];
7329 for (i
= 0; i
< expr2
->rank
; i
++)
7330 bound
[i
] = NULL_TREE
;
7331 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7332 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7334 GFC_ARRAY_POINTER_CONT
, false);
7335 tmp
= gfc_create_var (tmp
, "ptrtemp");
7337 lse
.direct_byref
= 1;
7338 gfc_conv_expr_descriptor (&lse
, expr2
);
7339 strlen_rhs
= lse
.string_length
;
7344 gfc_conv_expr_descriptor (&rse
, expr2
);
7345 strlen_rhs
= rse
.string_length
;
7348 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7350 /* Assign directly to the LHS's descriptor. */
7351 lse
.direct_byref
= 1;
7352 gfc_conv_expr_descriptor (&lse
, expr2
);
7353 strlen_rhs
= lse
.string_length
;
7355 /* If this is a subreference array pointer assignment, use the rhs
7356 descriptor element size for the lhs span. */
7357 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7359 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7360 gfc_init_se (&rse
, NULL
);
7361 rse
.descriptor_only
= 1;
7362 gfc_conv_expr (&rse
, expr2
);
7363 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7364 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7365 if (!INTEGER_CST_P (tmp
))
7366 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7367 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7370 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7372 gfc_init_se (&rse
, NULL
);
7373 rse
.want_pointer
= 1;
7374 gfc_conv_function_expr (&rse
, expr2
);
7375 if (expr1
->ts
.type
!= BT_CLASS
)
7377 rse
.expr
= gfc_class_data_get (rse
.expr
);
7378 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7382 gfc_add_block_to_block (&block
, &rse
.pre
);
7383 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7384 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7386 gfc_add_vptr_component (expr1_vptr
);
7387 gfc_init_se (&rse
, NULL
);
7388 rse
.want_pointer
= 1;
7389 gfc_conv_expr (&rse
, expr1_vptr
);
7390 gfc_add_modify (&lse
.pre
, rse
.expr
,
7391 fold_convert (TREE_TYPE (rse
.expr
),
7392 gfc_class_vptr_get (tmp
)));
7393 rse
.expr
= gfc_class_data_get (tmp
);
7394 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7399 /* Assign to a temporary descriptor and then copy that
7400 temporary to the pointer. */
7401 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7403 lse
.direct_byref
= 1;
7404 gfc_conv_expr_descriptor (&lse
, expr2
);
7405 strlen_rhs
= lse
.string_length
;
7406 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7410 gfc_free_expr (expr1_vptr
);
7412 gfc_add_block_to_block (&block
, &lse
.pre
);
7414 gfc_add_block_to_block (&block
, &rse
.pre
);
7416 /* If we do bounds remapping, update LHS descriptor accordingly. */
7420 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7424 /* Do rank remapping. We already have the RHS's descriptor
7425 converted in rse and now have to build the correct LHS
7426 descriptor for it. */
7430 tree lbound
, ubound
;
7433 dtype
= gfc_conv_descriptor_dtype (desc
);
7434 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7435 gfc_add_modify (&block
, dtype
, tmp
);
7437 /* Copy data pointer. */
7438 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7439 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7441 /* Copy offset but adjust it such that it would correspond
7442 to a lbound of zero. */
7443 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7444 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7446 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7448 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7450 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7451 gfc_array_index_type
, stride
, lbound
);
7452 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7453 gfc_array_index_type
, offs
, tmp
);
7455 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7457 /* Set the bounds as declared for the LHS and calculate strides as
7458 well as another offset update accordingly. */
7459 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7461 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7466 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7468 /* Convert declared bounds. */
7469 gfc_init_se (&lower_se
, NULL
);
7470 gfc_init_se (&upper_se
, NULL
);
7471 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7472 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7474 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7475 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7477 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7478 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7480 lbound
= gfc_evaluate_now (lbound
, &block
);
7481 ubound
= gfc_evaluate_now (ubound
, &block
);
7483 gfc_add_block_to_block (&block
, &lower_se
.post
);
7484 gfc_add_block_to_block (&block
, &upper_se
.post
);
7486 /* Set bounds in descriptor. */
7487 gfc_conv_descriptor_lbound_set (&block
, desc
,
7488 gfc_rank_cst
[dim
], lbound
);
7489 gfc_conv_descriptor_ubound_set (&block
, desc
,
7490 gfc_rank_cst
[dim
], ubound
);
7493 stride
= gfc_evaluate_now (stride
, &block
);
7494 gfc_conv_descriptor_stride_set (&block
, desc
,
7495 gfc_rank_cst
[dim
], stride
);
7497 /* Update offset. */
7498 offs
= gfc_conv_descriptor_offset_get (desc
);
7499 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7500 gfc_array_index_type
, lbound
, stride
);
7501 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7502 gfc_array_index_type
, offs
, tmp
);
7503 offs
= gfc_evaluate_now (offs
, &block
);
7504 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7506 /* Update stride. */
7507 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7508 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7509 gfc_array_index_type
, stride
, tmp
);
7514 /* Bounds remapping. Just shift the lower bounds. */
7516 gcc_assert (expr1
->rank
== expr2
->rank
);
7518 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7522 gcc_assert (remap
->u
.ar
.start
[dim
]);
7523 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7524 gfc_init_se (&lbound_se
, NULL
);
7525 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7527 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7528 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7529 dim
, lbound_se
.expr
);
7530 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7535 /* Check string lengths if applicable. The check is only really added
7536 to the output code if -fbounds-check is enabled. */
7537 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7539 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7540 gcc_assert (strlen_lhs
&& strlen_rhs
);
7541 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7542 strlen_lhs
, strlen_rhs
, &block
);
7545 /* If rank remapping was done, check with -fcheck=bounds that
7546 the target is at least as large as the pointer. */
7547 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7553 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7554 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7556 lsize
= gfc_evaluate_now (lsize
, &block
);
7557 rsize
= gfc_evaluate_now (rsize
, &block
);
7558 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7561 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7562 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7566 gfc_add_block_to_block (&block
, &lse
.post
);
7568 gfc_add_block_to_block (&block
, &rse
.post
);
7571 return gfc_finish_block (&block
);
7575 /* Makes sure se is suitable for passing as a function string parameter. */
7576 /* TODO: Need to check all callers of this function. It may be abused. */
7579 gfc_conv_string_parameter (gfc_se
* se
)
7583 if (TREE_CODE (se
->expr
) == STRING_CST
)
7585 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7586 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7590 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7592 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7594 type
= TREE_TYPE (se
->expr
);
7595 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7599 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7601 type
= build_pointer_type (type
);
7602 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7606 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
7610 /* Generate code for assignment of scalar variables. Includes character
7611 strings and derived types with allocatable components.
7612 If you know that the LHS has no allocations, set dealloc to false.
7614 DEEP_COPY has no effect if the typespec TS is not a derived type with
7615 allocatable components. Otherwise, if it is set, an explicit copy of each
7616 allocatable component is made. This is necessary as a simple copy of the
7617 whole object would copy array descriptors as is, so that the lhs's
7618 allocatable components would point to the rhs's after the assignment.
7619 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7620 necessary if the rhs is a non-pointer function, as the allocatable components
7621 are not accessible by other means than the function's result after the
7622 function has returned. It is even more subtle when temporaries are involved,
7623 as the two following examples show:
7624 1. When we evaluate an array constructor, a temporary is created. Thus
7625 there is theoretically no alias possible. However, no deep copy is
7626 made for this temporary, so that if the constructor is made of one or
7627 more variable with allocatable components, those components still point
7628 to the variable's: DEEP_COPY should be set for the assignment from the
7629 temporary to the lhs in that case.
7630 2. When assigning a scalar to an array, we evaluate the scalar value out
7631 of the loop, store it into a temporary variable, and assign from that.
7632 In that case, deep copying when assigning to the temporary would be a
7633 waste of resources; however deep copies should happen when assigning from
7634 the temporary to each array element: again DEEP_COPY should be set for
7635 the assignment from the temporary to the lhs. */
7638 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7639 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7645 gfc_init_block (&block
);
7647 if (ts
.type
== BT_CHARACTER
)
7652 if (lse
->string_length
!= NULL_TREE
)
7654 gfc_conv_string_parameter (lse
);
7655 gfc_add_block_to_block (&block
, &lse
->pre
);
7656 llen
= lse
->string_length
;
7659 if (rse
->string_length
!= NULL_TREE
)
7661 gcc_assert (rse
->string_length
!= NULL_TREE
);
7662 gfc_conv_string_parameter (rse
);
7663 gfc_add_block_to_block (&block
, &rse
->pre
);
7664 rlen
= rse
->string_length
;
7667 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7668 rse
->expr
, ts
.kind
);
7670 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7672 tree tmp_var
= NULL_TREE
;
7675 /* Are the rhs and the lhs the same? */
7678 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7679 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7680 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7681 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7684 /* Deallocate the lhs allocated components as long as it is not
7685 the same as the rhs. This must be done following the assignment
7686 to prevent deallocating data that could be used in the rhs
7688 if (!l_is_temp
&& dealloc
)
7690 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7691 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7693 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7695 gfc_add_expr_to_block (&lse
->post
, tmp
);
7698 gfc_add_block_to_block (&block
, &rse
->pre
);
7699 gfc_add_block_to_block (&block
, &lse
->pre
);
7701 gfc_add_modify (&block
, lse
->expr
,
7702 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7704 /* Restore pointer address of coarray components. */
7705 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7707 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7708 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7710 gfc_add_expr_to_block (&block
, tmp
);
7713 /* Do a deep copy if the rhs is a variable, if it is not the
7717 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7718 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7720 gfc_add_expr_to_block (&block
, tmp
);
7723 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7725 gfc_add_block_to_block (&block
, &lse
->pre
);
7726 gfc_add_block_to_block (&block
, &rse
->pre
);
7727 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7728 TREE_TYPE (lse
->expr
), rse
->expr
);
7729 gfc_add_modify (&block
, lse
->expr
, tmp
);
7733 gfc_add_block_to_block (&block
, &lse
->pre
);
7734 gfc_add_block_to_block (&block
, &rse
->pre
);
7736 gfc_add_modify (&block
, lse
->expr
,
7737 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7740 gfc_add_block_to_block (&block
, &lse
->post
);
7741 gfc_add_block_to_block (&block
, &rse
->post
);
7743 return gfc_finish_block (&block
);
7747 /* There are quite a lot of restrictions on the optimisation in using an
7748 array function assign without a temporary. */
7751 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7754 bool seen_array_ref
;
7756 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7758 /* Play it safe with class functions assigned to a derived type. */
7759 if (gfc_is_alloc_class_array_function (expr2
)
7760 && expr1
->ts
.type
== BT_DERIVED
)
7763 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7764 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7767 /* Elemental functions are scalarized so that they don't need a
7768 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7769 they would need special treatment in gfc_trans_arrayfunc_assign. */
7770 if (expr2
->value
.function
.esym
!= NULL
7771 && expr2
->value
.function
.esym
->attr
.elemental
)
7774 /* Need a temporary if rhs is not FULL or a contiguous section. */
7775 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7778 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7779 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7782 /* Functions returning pointers or allocatables need temporaries. */
7783 c
= expr2
->value
.function
.esym
7784 ? (expr2
->value
.function
.esym
->attr
.pointer
7785 || expr2
->value
.function
.esym
->attr
.allocatable
)
7786 : (expr2
->symtree
->n
.sym
->attr
.pointer
7787 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7791 /* Character array functions need temporaries unless the
7792 character lengths are the same. */
7793 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7795 if (expr1
->ts
.u
.cl
->length
== NULL
7796 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7799 if (expr2
->ts
.u
.cl
->length
== NULL
7800 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7803 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7804 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7808 /* Check that no LHS component references appear during an array
7809 reference. This is needed because we do not have the means to
7810 span any arbitrary stride with an array descriptor. This check
7811 is not needed for the rhs because the function result has to be
7813 seen_array_ref
= false;
7814 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7816 if (ref
->type
== REF_ARRAY
)
7817 seen_array_ref
= true;
7818 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7822 /* Check for a dependency. */
7823 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7824 expr2
->value
.function
.esym
,
7825 expr2
->value
.function
.actual
,
7829 /* If we have reached here with an intrinsic function, we do not
7830 need a temporary except in the particular case that reallocation
7831 on assignment is active and the lhs is allocatable and a target. */
7832 if (expr2
->value
.function
.isym
)
7833 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
7835 /* If the LHS is a dummy, we need a temporary if it is not
7837 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7840 /* If the lhs has been host_associated, is in common, a pointer or is
7841 a target and the function is not using a RESULT variable, aliasing
7842 can occur and a temporary is needed. */
7843 if ((sym
->attr
.host_assoc
7844 || sym
->attr
.in_common
7845 || sym
->attr
.pointer
7846 || sym
->attr
.cray_pointee
7847 || sym
->attr
.target
)
7848 && expr2
->symtree
!= NULL
7849 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7852 /* A PURE function can unconditionally be called without a temporary. */
7853 if (expr2
->value
.function
.esym
!= NULL
7854 && expr2
->value
.function
.esym
->attr
.pure
)
7857 /* Implicit_pure functions are those which could legally be declared
7859 if (expr2
->value
.function
.esym
!= NULL
7860 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7863 if (!sym
->attr
.use_assoc
7864 && !sym
->attr
.in_common
7865 && !sym
->attr
.pointer
7866 && !sym
->attr
.target
7867 && !sym
->attr
.cray_pointee
7868 && expr2
->value
.function
.esym
)
7870 /* A temporary is not needed if the function is not contained and
7871 the variable is local or host associated and not a pointer or
7873 if (!expr2
->value
.function
.esym
->attr
.contained
)
7876 /* A temporary is not needed if the lhs has never been host
7877 associated and the procedure is contained. */
7878 else if (!sym
->attr
.host_assoc
)
7881 /* A temporary is not needed if the variable is local and not
7882 a pointer, a target or a result. */
7884 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7888 /* Default to temporary use. */
7893 /* Provide the loop info so that the lhs descriptor can be built for
7894 reallocatable assignments from extrinsic function calls. */
7897 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7900 /* Signal that the function call should not be made by
7901 gfc_conv_loop_setup. */
7902 se
->ss
->is_alloc_lhs
= 1;
7903 gfc_init_loopinfo (loop
);
7904 gfc_add_ss_to_loop (loop
, *ss
);
7905 gfc_add_ss_to_loop (loop
, se
->ss
);
7906 gfc_conv_ss_startstride (loop
);
7907 gfc_conv_loop_setup (loop
, where
);
7908 gfc_copy_loopinfo_to_se (se
, loop
);
7909 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7910 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7911 se
->ss
->is_alloc_lhs
= 0;
7915 /* For assignment to a reallocatable lhs from intrinsic functions,
7916 replace the se.expr (ie. the result) with a temporary descriptor.
7917 Null the data field so that the library allocates space for the
7918 result. Free the data of the original descriptor after the function,
7919 in case it appears in an argument expression and transfer the
7920 result to the original descriptor. */
7923 fcncall_realloc_result (gfc_se
*se
, int rank
)
7932 /* Use the allocation done by the library. Substitute the lhs
7933 descriptor with a copy, whose data field is nulled.*/
7934 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7935 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7936 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7938 /* Unallocated, the descriptor does not have a dtype. */
7939 tmp
= gfc_conv_descriptor_dtype (desc
);
7940 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7942 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7943 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7944 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7946 /* Free the lhs after the function call and copy the result data to
7947 the lhs descriptor. */
7948 tmp
= gfc_conv_descriptor_data_get (desc
);
7949 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7950 boolean_type_node
, tmp
,
7951 build_int_cst (TREE_TYPE (tmp
), 0));
7952 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7953 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7954 gfc_add_expr_to_block (&se
->post
, tmp
);
7956 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7957 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7959 /* Check that the shapes are the same between lhs and expression. */
7960 for (n
= 0 ; n
< rank
; n
++)
7963 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7964 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7965 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7966 gfc_array_index_type
, tmp
, tmp1
);
7967 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7968 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7969 gfc_array_index_type
, tmp
, tmp1
);
7970 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7971 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7972 gfc_array_index_type
, tmp
, tmp1
);
7973 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7974 boolean_type_node
, tmp
,
7975 gfc_index_zero_node
);
7976 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7977 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7978 boolean_type_node
, tmp
,
7982 /* 'zero_cond' being true is equal to lhs not being allocated or the
7983 shapes being different. */
7984 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7986 /* Now reset the bounds returned from the function call to bounds based
7987 on the lhs lbounds, except where the lhs is not allocated or the shapes
7988 of 'variable and 'expr' are different. Set the offset accordingly. */
7989 offset
= gfc_index_zero_node
;
7990 for (n
= 0 ; n
< rank
; n
++)
7994 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7995 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7996 gfc_array_index_type
, zero_cond
,
7997 gfc_index_one_node
, lbound
);
7998 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8000 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8001 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8002 gfc_array_index_type
, tmp
, lbound
);
8003 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8004 gfc_rank_cst
[n
], lbound
);
8005 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8006 gfc_rank_cst
[n
], tmp
);
8008 /* Set stride and accumulate the offset. */
8009 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8010 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8011 gfc_rank_cst
[n
], tmp
);
8012 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8013 gfc_array_index_type
, lbound
, tmp
);
8014 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8015 gfc_array_index_type
, offset
, tmp
);
8016 offset
= gfc_evaluate_now (offset
, &se
->post
);
8019 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8024 /* Try to translate array(:) = func (...), where func is a transformational
8025 array function, without using a temporary. Returns NULL if this isn't the
8029 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8033 gfc_component
*comp
= NULL
;
8036 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8039 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8041 comp
= gfc_get_proc_ptr_comp (expr2
);
8042 gcc_assert (expr2
->value
.function
.isym
8043 || (comp
&& comp
->attr
.dimension
)
8044 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8045 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8047 gfc_init_se (&se
, NULL
);
8048 gfc_start_block (&se
.pre
);
8049 se
.want_pointer
= 1;
8051 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8053 if (expr1
->ts
.type
== BT_DERIVED
8054 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8057 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8059 gfc_add_expr_to_block (&se
.pre
, tmp
);
8062 se
.direct_byref
= 1;
8063 se
.ss
= gfc_walk_expr (expr2
);
8064 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8066 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8067 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8068 Clearly, this cannot be done for an allocatable function result, since
8069 the shape of the result is unknown and, in any case, the function must
8070 correctly take care of the reallocation internally. For intrinsic
8071 calls, the array data is freed and the library takes care of allocation.
8072 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8074 if (flag_realloc_lhs
8075 && gfc_is_reallocatable_lhs (expr1
)
8076 && !gfc_expr_attr (expr1
).codimension
8077 && !gfc_is_coindexed (expr1
)
8078 && !(expr2
->value
.function
.esym
8079 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8081 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8083 if (!expr2
->value
.function
.isym
)
8085 ss
= gfc_walk_expr (expr1
);
8086 gcc_assert (ss
!= gfc_ss_terminator
);
8088 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8089 ss
->is_alloc_lhs
= 1;
8092 fcncall_realloc_result (&se
, expr1
->rank
);
8095 gfc_conv_function_expr (&se
, expr2
);
8096 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8099 gfc_cleanup_loop (&loop
);
8101 gfc_free_ss_chain (se
.ss
);
8103 return gfc_finish_block (&se
.pre
);
8107 /* Try to efficiently translate array(:) = 0. Return NULL if this
8111 gfc_trans_zero_assign (gfc_expr
* expr
)
8113 tree dest
, len
, type
;
8117 sym
= expr
->symtree
->n
.sym
;
8118 dest
= gfc_get_symbol_decl (sym
);
8120 type
= TREE_TYPE (dest
);
8121 if (POINTER_TYPE_P (type
))
8122 type
= TREE_TYPE (type
);
8123 if (!GFC_ARRAY_TYPE_P (type
))
8126 /* Determine the length of the array. */
8127 len
= GFC_TYPE_ARRAY_SIZE (type
);
8128 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8131 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8132 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8133 fold_convert (gfc_array_index_type
, tmp
));
8135 /* If we are zeroing a local array avoid taking its address by emitting
8137 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8138 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8139 dest
, build_constructor (TREE_TYPE (dest
),
8142 /* Convert arguments to the correct types. */
8143 dest
= fold_convert (pvoid_type_node
, dest
);
8144 len
= fold_convert (size_type_node
, len
);
8146 /* Construct call to __builtin_memset. */
8147 tmp
= build_call_expr_loc (input_location
,
8148 builtin_decl_explicit (BUILT_IN_MEMSET
),
8149 3, dest
, integer_zero_node
, len
);
8150 return fold_convert (void_type_node
, tmp
);
8154 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8155 that constructs the call to __builtin_memcpy. */
8158 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8162 /* Convert arguments to the correct types. */
8163 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8164 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8166 dst
= fold_convert (pvoid_type_node
, dst
);
8168 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8169 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8171 src
= fold_convert (pvoid_type_node
, src
);
8173 len
= fold_convert (size_type_node
, len
);
8175 /* Construct call to __builtin_memcpy. */
8176 tmp
= build_call_expr_loc (input_location
,
8177 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8179 return fold_convert (void_type_node
, tmp
);
8183 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8184 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8185 source/rhs, both are gfc_full_array_ref_p which have been checked for
8189 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8191 tree dst
, dlen
, dtype
;
8192 tree src
, slen
, stype
;
8195 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8196 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8198 dtype
= TREE_TYPE (dst
);
8199 if (POINTER_TYPE_P (dtype
))
8200 dtype
= TREE_TYPE (dtype
);
8201 stype
= TREE_TYPE (src
);
8202 if (POINTER_TYPE_P (stype
))
8203 stype
= TREE_TYPE (stype
);
8205 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8208 /* Determine the lengths of the arrays. */
8209 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8210 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8212 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8213 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8214 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8216 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8217 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8219 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8220 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8221 slen
, fold_convert (gfc_array_index_type
, tmp
));
8223 /* Sanity check that they are the same. This should always be
8224 the case, as we should already have checked for conformance. */
8225 if (!tree_int_cst_equal (slen
, dlen
))
8228 return gfc_build_memcpy_call (dst
, src
, dlen
);
8232 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8233 this can't be done. EXPR1 is the destination/lhs for which
8234 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8237 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8239 unsigned HOST_WIDE_INT nelem
;
8245 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8249 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8250 dtype
= TREE_TYPE (dst
);
8251 if (POINTER_TYPE_P (dtype
))
8252 dtype
= TREE_TYPE (dtype
);
8253 if (!GFC_ARRAY_TYPE_P (dtype
))
8256 /* Determine the lengths of the array. */
8257 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8258 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8261 /* Confirm that the constructor is the same size. */
8262 if (compare_tree_int (len
, nelem
) != 0)
8265 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8266 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8267 fold_convert (gfc_array_index_type
, tmp
));
8269 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8270 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8272 stype
= TREE_TYPE (src
);
8273 if (POINTER_TYPE_P (stype
))
8274 stype
= TREE_TYPE (stype
);
8276 return gfc_build_memcpy_call (dst
, src
, len
);
8280 /* Tells whether the expression is to be treated as a variable reference. */
8283 expr_is_variable (gfc_expr
*expr
)
8286 gfc_component
*comp
;
8287 gfc_symbol
*func_ifc
;
8289 if (expr
->expr_type
== EXPR_VARIABLE
)
8292 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8295 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8296 return expr_is_variable (arg
);
8299 /* A data-pointer-returning function should be considered as a variable
8301 if (expr
->expr_type
== EXPR_FUNCTION
8302 && expr
->ref
== NULL
)
8304 if (expr
->value
.function
.isym
!= NULL
)
8307 if (expr
->value
.function
.esym
!= NULL
)
8309 func_ifc
= expr
->value
.function
.esym
;
8314 gcc_assert (expr
->symtree
);
8315 func_ifc
= expr
->symtree
->n
.sym
;
8322 comp
= gfc_get_proc_ptr_comp (expr
);
8323 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8326 func_ifc
= comp
->ts
.interface
;
8330 if (expr
->expr_type
== EXPR_COMPCALL
)
8332 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8333 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8340 gcc_assert (func_ifc
->attr
.function
8341 && func_ifc
->result
!= NULL
);
8342 return func_ifc
->result
->attr
.pointer
;
8346 /* Is the lhs OK for automatic reallocation? */
8349 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8353 /* An allocatable variable with no reference. */
8354 if (expr
->symtree
->n
.sym
->attr
.allocatable
8358 /* All that can be left are allocatable components. */
8359 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8360 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8361 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8364 /* Find an allocatable component ref last. */
8365 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8366 if (ref
->type
== REF_COMPONENT
8368 && ref
->u
.c
.component
->attr
.allocatable
)
8375 /* Allocate or reallocate scalar lhs, as necessary. */
8378 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8392 if (!expr1
|| expr1
->rank
)
8395 if (!expr2
|| expr2
->rank
)
8398 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8400 /* Since this is a scalar lhs, we can afford to do this. That is,
8401 there is no risk of side effects being repeated. */
8402 gfc_init_se (&lse
, NULL
);
8403 lse
.want_pointer
= 1;
8404 gfc_conv_expr (&lse
, expr1
);
8406 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8407 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8409 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8410 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8411 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8413 tmp
= build3_v (COND_EXPR
, cond
,
8414 build1_v (GOTO_EXPR
, jump_label1
),
8415 build_empty_stmt (input_location
));
8416 gfc_add_expr_to_block (block
, tmp
);
8418 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8420 /* Use the rhs string length and the lhs element size. */
8421 size
= string_length
;
8422 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8423 tmp
= TYPE_SIZE_UNIT (tmp
);
8424 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8425 TREE_TYPE (tmp
), tmp
,
8426 fold_convert (TREE_TYPE (tmp
), size
));
8430 /* Otherwise use the length in bytes of the rhs. */
8431 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8432 size_in_bytes
= size
;
8435 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8436 size_in_bytes
, size_one_node
);
8438 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8440 tmp
= build_call_expr_loc (input_location
,
8441 builtin_decl_explicit (BUILT_IN_CALLOC
),
8442 2, build_one_cst (size_type_node
),
8444 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8445 gfc_add_modify (block
, lse
.expr
, tmp
);
8449 tmp
= build_call_expr_loc (input_location
,
8450 builtin_decl_explicit (BUILT_IN_MALLOC
),
8452 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8453 gfc_add_modify (block
, lse
.expr
, tmp
);
8456 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8458 /* Deferred characters need checking for lhs and rhs string
8459 length. Other deferred parameter variables will have to
8461 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8462 gfc_add_expr_to_block (block
, tmp
);
8464 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8465 gfc_add_expr_to_block (block
, tmp
);
8467 /* For a deferred length character, reallocate if lengths of lhs and
8468 rhs are different. */
8469 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8471 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8472 expr1
->ts
.u
.cl
->backend_decl
, size
);
8473 /* Jump past the realloc if the lengths are the same. */
8474 tmp
= build3_v (COND_EXPR
, cond
,
8475 build1_v (GOTO_EXPR
, jump_label2
),
8476 build_empty_stmt (input_location
));
8477 gfc_add_expr_to_block (block
, tmp
);
8478 tmp
= build_call_expr_loc (input_location
,
8479 builtin_decl_explicit (BUILT_IN_REALLOC
),
8480 2, fold_convert (pvoid_type_node
, lse
.expr
),
8482 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8483 gfc_add_modify (block
, lse
.expr
, tmp
);
8484 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8485 gfc_add_expr_to_block (block
, tmp
);
8487 /* Update the lhs character length. */
8488 size
= string_length
;
8489 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8490 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
8492 gfc_add_modify (block
, lse
.string_length
, size
);
8496 /* Check for assignments of the type
8500 to make sure we do not check for reallocation unneccessarily. */
8504 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8506 gfc_actual_arglist
*a
;
8509 switch (expr2
->expr_type
)
8512 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8515 if (expr2
->value
.function
.esym
8516 && expr2
->value
.function
.esym
->attr
.elemental
)
8518 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8521 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8526 else if (expr2
->value
.function
.isym
8527 && expr2
->value
.function
.isym
->elemental
)
8529 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8532 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8541 switch (expr2
->value
.op
.op
)
8544 case INTRINSIC_UPLUS
:
8545 case INTRINSIC_UMINUS
:
8546 case INTRINSIC_PARENTHESES
:
8547 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8549 case INTRINSIC_PLUS
:
8550 case INTRINSIC_MINUS
:
8551 case INTRINSIC_TIMES
:
8552 case INTRINSIC_DIVIDE
:
8553 case INTRINSIC_POWER
:
8557 case INTRINSIC_NEQV
:
8564 case INTRINSIC_EQ_OS
:
8565 case INTRINSIC_NE_OS
:
8566 case INTRINSIC_GT_OS
:
8567 case INTRINSIC_GE_OS
:
8568 case INTRINSIC_LT_OS
:
8569 case INTRINSIC_LE_OS
:
8571 e1
= expr2
->value
.op
.op1
;
8572 e2
= expr2
->value
.op
.op2
;
8574 if (e1
->rank
== 0 && e2
->rank
> 0)
8575 return is_runtime_conformable (expr1
, e2
);
8576 else if (e1
->rank
> 0 && e2
->rank
== 0)
8577 return is_runtime_conformable (expr1
, e1
);
8578 else if (e1
->rank
> 0 && e2
->rank
> 0)
8579 return is_runtime_conformable (expr1
, e1
)
8580 && is_runtime_conformable (expr1
, e2
);
8596 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8597 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8598 init_flag indicates initialization expressions and dealloc that no
8599 deallocate prior assignment is needed (if in doubt, set true). */
8602 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8608 gfc_ss
*lss_section
;
8615 bool scalar_to_array
;
8619 /* Assignment of the form lhs = rhs. */
8620 gfc_start_block (&block
);
8622 gfc_init_se (&lse
, NULL
);
8623 gfc_init_se (&rse
, NULL
);
8626 lss
= gfc_walk_expr (expr1
);
8627 if (gfc_is_reallocatable_lhs (expr1
)
8628 && !(expr2
->expr_type
== EXPR_FUNCTION
8629 && expr2
->value
.function
.isym
!= NULL
))
8630 lss
->is_alloc_lhs
= 1;
8633 if ((expr1
->ts
.type
== BT_DERIVED
)
8634 && (gfc_is_alloc_class_array_function (expr2
)
8635 || gfc_is_alloc_class_scalar_function (expr2
)))
8636 expr2
->must_finalize
= 1;
8638 if (lss
!= gfc_ss_terminator
)
8640 /* The assignment needs scalarization. */
8643 /* Find a non-scalar SS from the lhs. */
8644 while (lss_section
!= gfc_ss_terminator
8645 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8646 lss_section
= lss_section
->next
;
8648 gcc_assert (lss_section
!= gfc_ss_terminator
);
8650 /* Initialize the scalarizer. */
8651 gfc_init_loopinfo (&loop
);
8654 rss
= gfc_walk_expr (expr2
);
8655 if (rss
== gfc_ss_terminator
)
8656 /* The rhs is scalar. Add a ss for the expression. */
8657 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8659 /* Associate the SS with the loop. */
8660 gfc_add_ss_to_loop (&loop
, lss
);
8661 gfc_add_ss_to_loop (&loop
, rss
);
8663 /* Calculate the bounds of the scalarization. */
8664 gfc_conv_ss_startstride (&loop
);
8665 /* Enable loop reversal. */
8666 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8667 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8668 /* Resolve any data dependencies in the statement. */
8669 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8670 /* Setup the scalarizing loops. */
8671 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8673 /* Setup the gfc_se structures. */
8674 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8675 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8678 gfc_mark_ss_chain_used (rss
, 1);
8679 if (loop
.temp_ss
== NULL
)
8682 gfc_mark_ss_chain_used (lss
, 1);
8686 lse
.ss
= loop
.temp_ss
;
8687 gfc_mark_ss_chain_used (lss
, 3);
8688 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8691 /* Allow the scalarizer to workshare array assignments. */
8692 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8693 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8695 /* Start the scalarized loop body. */
8696 gfc_start_scalarized_body (&loop
, &body
);
8699 gfc_init_block (&body
);
8701 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8703 /* Translate the expression. */
8704 gfc_conv_expr (&rse
, expr2
);
8706 /* Deal with the case of a scalar class function assigned to a derived type. */
8707 if (gfc_is_alloc_class_scalar_function (expr2
)
8708 && expr1
->ts
.type
== BT_DERIVED
)
8710 rse
.expr
= gfc_class_data_get (rse
.expr
);
8711 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
8714 /* Stabilize a string length for temporaries. */
8715 if (expr2
->ts
.type
== BT_CHARACTER
)
8716 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8718 string_length
= NULL_TREE
;
8722 gfc_conv_tmp_array_ref (&lse
);
8723 if (expr2
->ts
.type
== BT_CHARACTER
)
8724 lse
.string_length
= string_length
;
8727 gfc_conv_expr (&lse
, expr1
);
8729 /* Assignments of scalar derived types with allocatable components
8730 to arrays must be done with a deep copy and the rhs temporary
8731 must have its components deallocated afterwards. */
8732 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8733 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8734 && !expr_is_variable (expr2
)
8735 && !gfc_is_constant_expr (expr2
)
8736 && expr1
->rank
&& !expr2
->rank
);
8737 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
8739 && expr1
->ts
.u
.derived
->attr
.alloc_comp
8740 && gfc_is_alloc_class_scalar_function (expr2
));
8741 if (scalar_to_array
&& dealloc
)
8743 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8744 gfc_add_expr_to_block (&loop
.post
, tmp
);
8747 /* When assigning a character function result to a deferred-length variable,
8748 the function call must happen before the (re)allocation of the lhs -
8749 otherwise the character length of the result is not known.
8750 NOTE: This relies on having the exact dependence of the length type
8751 parameter available to the caller; gfortran saves it in the .mod files. */
8752 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8753 gfc_add_block_to_block (&block
, &rse
.pre
);
8755 /* Nullify the allocatable components corresponding to those of the lhs
8756 derived type, so that the finalization of the function result does not
8757 affect the lhs of the assignment. Prepend is used to ensure that the
8758 nullification occurs before the call to the finalizer. In the case of
8759 a scalar to array assignment, this is done in gfc_trans_scalar_assign
8760 as part of the deep copy. */
8761 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
8762 && (gfc_is_alloc_class_array_function (expr2
)
8763 || gfc_is_alloc_class_scalar_function (expr2
)))
8766 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
8767 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
8768 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
8769 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
8772 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8773 l_is_temp
|| init_flag
,
8774 expr_is_variable (expr2
) || scalar_to_array
8775 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8776 gfc_add_expr_to_block (&body
, tmp
);
8778 if (lss
== gfc_ss_terminator
)
8780 /* F2003: Add the code for reallocation on assignment. */
8781 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
8782 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8785 /* Use the scalar assignment as is. */
8786 gfc_add_block_to_block (&block
, &body
);
8790 gcc_assert (lse
.ss
== gfc_ss_terminator
8791 && rse
.ss
== gfc_ss_terminator
);
8795 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8797 /* We need to copy the temporary to the actual lhs. */
8798 gfc_init_se (&lse
, NULL
);
8799 gfc_init_se (&rse
, NULL
);
8800 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8801 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8803 rse
.ss
= loop
.temp_ss
;
8806 gfc_conv_tmp_array_ref (&rse
);
8807 gfc_conv_expr (&lse
, expr1
);
8809 gcc_assert (lse
.ss
== gfc_ss_terminator
8810 && rse
.ss
== gfc_ss_terminator
);
8812 if (expr2
->ts
.type
== BT_CHARACTER
)
8813 rse
.string_length
= string_length
;
8815 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8816 false, false, dealloc
);
8817 gfc_add_expr_to_block (&body
, tmp
);
8820 /* F2003: Allocate or reallocate lhs of allocatable array. */
8821 if (flag_realloc_lhs
8822 && gfc_is_reallocatable_lhs (expr1
)
8823 && !gfc_expr_attr (expr1
).codimension
8824 && !gfc_is_coindexed (expr1
)
8826 && !is_runtime_conformable (expr1
, expr2
))
8828 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8829 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8830 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8831 if (tmp
!= NULL_TREE
)
8832 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8835 /* Generate the copying loops. */
8836 gfc_trans_scalarizing_loops (&loop
, &body
);
8838 /* Wrap the whole thing up. */
8839 gfc_add_block_to_block (&block
, &loop
.pre
);
8840 gfc_add_block_to_block (&block
, &loop
.post
);
8842 gfc_cleanup_loop (&loop
);
8845 return gfc_finish_block (&block
);
8849 /* Check whether EXPR is a copyable array. */
8852 copyable_array_p (gfc_expr
* expr
)
8854 if (expr
->expr_type
!= EXPR_VARIABLE
)
8857 /* First check it's an array. */
8858 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8861 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8864 /* Next check that it's of a simple enough type. */
8865 switch (expr
->ts
.type
)
8877 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8886 /* Translate an assignment. */
8889 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8894 /* Special case a single function returning an array. */
8895 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8897 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8902 /* Special case assigning an array to zero. */
8903 if (copyable_array_p (expr1
)
8904 && is_zero_initializer_p (expr2
))
8906 tmp
= gfc_trans_zero_assign (expr1
);
8911 /* Special case copying one array to another. */
8912 if (copyable_array_p (expr1
)
8913 && copyable_array_p (expr2
)
8914 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8915 && !gfc_check_dependency (expr1
, expr2
, 0))
8917 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8922 /* Special case initializing an array from a constant array constructor. */
8923 if (copyable_array_p (expr1
)
8924 && expr2
->expr_type
== EXPR_ARRAY
8925 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8927 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8932 /* Fallback to the scalarizer to generate explicit loops. */
8933 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8937 gfc_trans_init_assign (gfc_code
* code
)
8939 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8943 gfc_trans_assign (gfc_code
* code
)
8945 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);