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
, 1,
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
));
3786 /* Replace base type for polymorphic arguments. */
3787 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3788 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3789 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3792 /* ...and to subexpressions in expr->value. */
3793 switch (expr
->expr_type
)
3798 case EXPR_SUBSTRING
:
3802 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3803 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3807 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3808 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3810 if (expr
->value
.function
.esym
== NULL
3811 && expr
->value
.function
.isym
!= NULL
3812 && expr
->value
.function
.actual
->expr
->symtree
3813 && gfc_map_intrinsic_function (expr
, mapping
))
3816 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3817 if (sym
->old
== expr
->value
.function
.esym
)
3819 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3820 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3821 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3826 case EXPR_STRUCTURE
:
3827 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3840 /* Evaluate interface expression EXPR using MAPPING. Store the result
3844 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3845 gfc_se
* se
, gfc_expr
* expr
)
3847 expr
= gfc_copy_expr (expr
);
3848 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3849 gfc_conv_expr (se
, expr
);
3850 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3851 gfc_free_expr (expr
);
3855 /* Returns a reference to a temporary array into which a component of
3856 an actual argument derived type array is copied and then returned
3857 after the function call. */
3859 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3860 sym_intent intent
, bool formal_ptr
)
3868 gfc_array_info
*info
;
3878 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3880 gfc_init_se (&lse
, NULL
);
3881 gfc_init_se (&rse
, NULL
);
3883 /* Walk the argument expression. */
3884 rss
= gfc_walk_expr (expr
);
3886 gcc_assert (rss
!= gfc_ss_terminator
);
3888 /* Initialize the scalarizer. */
3889 gfc_init_loopinfo (&loop
);
3890 gfc_add_ss_to_loop (&loop
, rss
);
3892 /* Calculate the bounds of the scalarization. */
3893 gfc_conv_ss_startstride (&loop
);
3895 /* Build an ss for the temporary. */
3896 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3897 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3899 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3900 if (GFC_ARRAY_TYPE_P (base_type
)
3901 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3902 base_type
= gfc_get_element_type (base_type
);
3904 if (expr
->ts
.type
== BT_CLASS
)
3905 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3907 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3908 ? expr
->ts
.u
.cl
->backend_decl
3912 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3914 /* Associate the SS with the loop. */
3915 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3917 /* Setup the scalarizing loops. */
3918 gfc_conv_loop_setup (&loop
, &expr
->where
);
3920 /* Pass the temporary descriptor back to the caller. */
3921 info
= &loop
.temp_ss
->info
->data
.array
;
3922 parmse
->expr
= info
->descriptor
;
3924 /* Setup the gfc_se structures. */
3925 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3926 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3929 lse
.ss
= loop
.temp_ss
;
3930 gfc_mark_ss_chain_used (rss
, 1);
3931 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3933 /* Start the scalarized loop body. */
3934 gfc_start_scalarized_body (&loop
, &body
);
3936 /* Translate the expression. */
3937 gfc_conv_expr (&rse
, expr
);
3939 gfc_conv_tmp_array_ref (&lse
);
3941 if (intent
!= INTENT_OUT
)
3943 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3944 gfc_add_expr_to_block (&body
, tmp
);
3945 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3946 gfc_trans_scalarizing_loops (&loop
, &body
);
3950 /* Make sure that the temporary declaration survives by merging
3951 all the loop declarations into the current context. */
3952 for (n
= 0; n
< loop
.dimen
; n
++)
3954 gfc_merge_block_scope (&body
);
3955 body
= loop
.code
[loop
.order
[n
]];
3957 gfc_merge_block_scope (&body
);
3960 /* Add the post block after the second loop, so that any
3961 freeing of allocated memory is done at the right time. */
3962 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3964 /**********Copy the temporary back again.*********/
3966 gfc_init_se (&lse
, NULL
);
3967 gfc_init_se (&rse
, NULL
);
3969 /* Walk the argument expression. */
3970 lss
= gfc_walk_expr (expr
);
3971 rse
.ss
= loop
.temp_ss
;
3974 /* Initialize the scalarizer. */
3975 gfc_init_loopinfo (&loop2
);
3976 gfc_add_ss_to_loop (&loop2
, lss
);
3978 /* Calculate the bounds of the scalarization. */
3979 gfc_conv_ss_startstride (&loop2
);
3981 /* Setup the scalarizing loops. */
3982 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3984 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3985 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3987 gfc_mark_ss_chain_used (lss
, 1);
3988 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3990 /* Declare the variable to hold the temporary offset and start the
3991 scalarized loop body. */
3992 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3993 gfc_start_scalarized_body (&loop2
, &body
);
3995 /* Build the offsets for the temporary from the loop variables. The
3996 temporary array has lbounds of zero and strides of one in all
3997 dimensions, so this is very simple. The offset is only computed
3998 outside the innermost loop, so the overall transfer could be
3999 optimized further. */
4000 info
= &rse
.ss
->info
->data
.array
;
4001 dimen
= rse
.ss
->dimen
;
4003 tmp_index
= gfc_index_zero_node
;
4004 for (n
= dimen
- 1; n
> 0; n
--)
4007 tmp
= rse
.loop
->loopvar
[n
];
4008 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4009 tmp
, rse
.loop
->from
[n
]);
4010 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4013 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4014 gfc_array_index_type
,
4015 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4016 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4017 gfc_array_index_type
,
4018 tmp_str
, gfc_index_one_node
);
4020 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4021 gfc_array_index_type
, tmp
, tmp_str
);
4024 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4025 gfc_array_index_type
,
4026 tmp_index
, rse
.loop
->from
[0]);
4027 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4029 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4030 gfc_array_index_type
,
4031 rse
.loop
->loopvar
[0], offset
);
4033 /* Now use the offset for the reference. */
4034 tmp
= build_fold_indirect_ref_loc (input_location
,
4036 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4038 if (expr
->ts
.type
== BT_CHARACTER
)
4039 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4041 gfc_conv_expr (&lse
, expr
);
4043 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4045 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4046 gfc_add_expr_to_block (&body
, tmp
);
4048 /* Generate the copying loops. */
4049 gfc_trans_scalarizing_loops (&loop2
, &body
);
4051 /* Wrap the whole thing up by adding the second loop to the post-block
4052 and following it by the post-block of the first loop. In this way,
4053 if the temporary needs freeing, it is done after use! */
4054 if (intent
!= INTENT_IN
)
4056 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4057 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4060 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4062 gfc_cleanup_loop (&loop
);
4063 gfc_cleanup_loop (&loop2
);
4065 /* Pass the string length to the argument expression. */
4066 if (expr
->ts
.type
== BT_CHARACTER
)
4067 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4069 /* Determine the offset for pointer formal arguments and set the
4073 size
= gfc_index_one_node
;
4074 offset
= gfc_index_zero_node
;
4075 for (n
= 0; n
< dimen
; n
++)
4077 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4079 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4080 gfc_array_index_type
, tmp
,
4081 gfc_index_one_node
);
4082 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4086 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4089 gfc_index_one_node
);
4090 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4091 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4092 gfc_array_index_type
,
4094 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4095 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4096 gfc_array_index_type
,
4097 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4098 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4099 gfc_array_index_type
,
4100 tmp
, gfc_index_one_node
);
4101 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4102 gfc_array_index_type
, size
, tmp
);
4105 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4109 /* We want either the address for the data or the address of the descriptor,
4110 depending on the mode of passing array arguments. */
4112 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4114 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4120 /* Generate the code for argument list functions. */
4123 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4125 /* Pass by value for g77 %VAL(arg), pass the address
4126 indirectly for %LOC, else by reference. Thus %REF
4127 is a "do-nothing" and %LOC is the same as an F95
4129 if (strncmp (name
, "%VAL", 4) == 0)
4130 gfc_conv_expr (se
, expr
);
4131 else if (strncmp (name
, "%LOC", 4) == 0)
4133 gfc_conv_expr_reference (se
, expr
);
4134 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4136 else if (strncmp (name
, "%REF", 4) == 0)
4137 gfc_conv_expr_reference (se
, expr
);
4139 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4143 /* Generate code for a procedure call. Note can return se->post != NULL.
4144 If se->direct_byref is set then se->expr contains the return parameter.
4145 Return nonzero, if the call has alternate specifiers.
4146 'expr' is only needed for procedure pointer components. */
4149 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4150 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4151 vec
<tree
, va_gc
> *append_args
)
4153 gfc_interface_mapping mapping
;
4154 vec
<tree
, va_gc
> *arglist
;
4155 vec
<tree
, va_gc
> *retargs
;
4159 gfc_array_info
*info
;
4166 vec
<tree
, va_gc
> *stringargs
;
4167 vec
<tree
, va_gc
> *optionalargs
;
4169 gfc_formal_arglist
*formal
;
4170 gfc_actual_arglist
*arg
;
4171 int has_alternate_specifier
= 0;
4172 bool need_interface_mapping
;
4179 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4180 gfc_component
*comp
= NULL
;
4186 optionalargs
= NULL
;
4191 comp
= gfc_get_proc_ptr_comp (expr
);
4195 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4197 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4198 if (se
->ss
->info
->useflags
)
4200 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4201 && sym
->result
->attr
.dimension
)
4202 || (comp
&& comp
->attr
.dimension
));
4203 gcc_assert (se
->loop
!= NULL
);
4205 /* Access the previously obtained result. */
4206 gfc_conv_tmp_array_ref (se
);
4210 info
= &se
->ss
->info
->data
.array
;
4215 gfc_init_block (&post
);
4216 gfc_init_interface_mapping (&mapping
);
4219 formal
= gfc_sym_get_dummy_args (sym
);
4220 need_interface_mapping
= sym
->attr
.dimension
||
4221 (sym
->ts
.type
== BT_CHARACTER
4222 && sym
->ts
.u
.cl
->length
4223 && sym
->ts
.u
.cl
->length
->expr_type
4228 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4229 need_interface_mapping
= comp
->attr
.dimension
||
4230 (comp
->ts
.type
== BT_CHARACTER
4231 && comp
->ts
.u
.cl
->length
4232 && comp
->ts
.u
.cl
->length
->expr_type
4236 base_object
= NULL_TREE
;
4238 /* Evaluate the arguments. */
4239 for (arg
= args
; arg
!= NULL
;
4240 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4243 fsym
= formal
? formal
->sym
: NULL
;
4244 parm_kind
= MISSING
;
4246 /* Class array expressions are sometimes coming completely unadorned
4247 with either arrayspec or _data component. Correct that here.
4248 OOP-TODO: Move this to the frontend. */
4249 if (e
&& e
->expr_type
== EXPR_VARIABLE
4251 && e
->ts
.type
== BT_CLASS
4252 && (CLASS_DATA (e
)->attr
.codimension
4253 || CLASS_DATA (e
)->attr
.dimension
))
4255 gfc_typespec temp_ts
= e
->ts
;
4256 gfc_add_class_array_ref (e
);
4262 if (se
->ignore_optional
)
4264 /* Some intrinsics have already been resolved to the correct
4268 else if (arg
->label
)
4270 has_alternate_specifier
= 1;
4275 gfc_init_se (&parmse
, NULL
);
4277 /* For scalar arguments with VALUE attribute which are passed by
4278 value, pass "0" and a hidden argument gives the optional
4280 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4281 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4282 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4284 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4286 vec_safe_push (optionalargs
, boolean_false_node
);
4290 /* Pass a NULL pointer for an absent arg. */
4291 parmse
.expr
= null_pointer_node
;
4292 if (arg
->missing_arg_type
== BT_CHARACTER
)
4293 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4298 else if (arg
->expr
->expr_type
== EXPR_NULL
4299 && fsym
&& !fsym
->attr
.pointer
4300 && (fsym
->ts
.type
!= BT_CLASS
4301 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4303 /* Pass a NULL pointer to denote an absent arg. */
4304 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4305 && (fsym
->ts
.type
!= BT_CLASS
4306 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4307 gfc_init_se (&parmse
, NULL
);
4308 parmse
.expr
= null_pointer_node
;
4309 if (arg
->missing_arg_type
== BT_CHARACTER
)
4310 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4312 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4313 && e
->ts
.type
== BT_DERIVED
)
4315 /* The derived type needs to be converted to a temporary
4317 gfc_init_se (&parmse
, se
);
4318 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4320 && e
->expr_type
== EXPR_VARIABLE
4321 && e
->symtree
->n
.sym
->attr
.optional
,
4322 CLASS_DATA (fsym
)->attr
.class_pointer
4323 || CLASS_DATA (fsym
)->attr
.allocatable
);
4325 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4327 /* The intrinsic type needs to be converted to a temporary
4328 CLASS object for the unlimited polymorphic formal. */
4329 gfc_init_se (&parmse
, se
);
4330 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4332 else if (se
->ss
&& se
->ss
->info
->useflags
)
4338 /* An elemental function inside a scalarized loop. */
4339 gfc_init_se (&parmse
, se
);
4340 parm_kind
= ELEMENTAL
;
4342 if (fsym
&& fsym
->attr
.value
)
4343 gfc_conv_expr (&parmse
, e
);
4345 gfc_conv_expr_reference (&parmse
, e
);
4347 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4348 && e
->expr_type
== EXPR_FUNCTION
)
4349 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4352 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4353 && gfc_is_class_container_ref (e
))
4355 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4357 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4358 && e
->symtree
->n
.sym
->attr
.optional
)
4360 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4361 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4362 TREE_TYPE (parmse
.expr
),
4364 fold_convert (TREE_TYPE (parmse
.expr
),
4365 null_pointer_node
));
4369 /* If we are passing an absent array as optional dummy to an
4370 elemental procedure, make sure that we pass NULL when the data
4371 pointer is NULL. We need this extra conditional because of
4372 scalarization which passes arrays elements to the procedure,
4373 ignoring the fact that the array can be absent/unallocated/... */
4374 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4376 tree descriptor_data
;
4378 descriptor_data
= ss
->info
->data
.array
.data
;
4379 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4381 fold_convert (TREE_TYPE (descriptor_data
),
4382 null_pointer_node
));
4384 = fold_build3_loc (input_location
, COND_EXPR
,
4385 TREE_TYPE (parmse
.expr
),
4386 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4387 fold_convert (TREE_TYPE (parmse
.expr
),
4392 /* The scalarizer does not repackage the reference to a class
4393 array - instead it returns a pointer to the data element. */
4394 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4395 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4396 fsym
->attr
.intent
!= INTENT_IN
4397 && (CLASS_DATA (fsym
)->attr
.class_pointer
4398 || CLASS_DATA (fsym
)->attr
.allocatable
),
4400 && e
->expr_type
== EXPR_VARIABLE
4401 && e
->symtree
->n
.sym
->attr
.optional
,
4402 CLASS_DATA (fsym
)->attr
.class_pointer
4403 || CLASS_DATA (fsym
)->attr
.allocatable
);
4410 gfc_init_se (&parmse
, NULL
);
4412 /* Check whether the expression is a scalar or not; we cannot use
4413 e->rank as it can be nonzero for functions arguments. */
4414 argss
= gfc_walk_expr (e
);
4415 scalar
= argss
== gfc_ss_terminator
;
4417 gfc_free_ss_chain (argss
);
4419 /* Special handling for passing scalar polymorphic coarrays;
4420 otherwise one passes "class->_data.data" instead of "&class". */
4421 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4422 && fsym
&& fsym
->ts
.type
== BT_CLASS
4423 && CLASS_DATA (fsym
)->attr
.codimension
4424 && !CLASS_DATA (fsym
)->attr
.dimension
)
4426 gfc_add_class_array_ref (e
);
4427 parmse
.want_coarray
= 1;
4431 /* A scalar or transformational function. */
4434 if (e
->expr_type
== EXPR_VARIABLE
4435 && e
->symtree
->n
.sym
->attr
.cray_pointee
4436 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4438 /* The Cray pointer needs to be converted to a pointer to
4439 a type given by the expression. */
4440 gfc_conv_expr (&parmse
, e
);
4441 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4442 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4443 parmse
.expr
= convert (type
, tmp
);
4445 else if (fsym
&& fsym
->attr
.value
)
4447 if (fsym
->ts
.type
== BT_CHARACTER
4448 && fsym
->ts
.is_c_interop
4449 && fsym
->ns
->proc_name
!= NULL
4450 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4453 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4454 if (parmse
.expr
== NULL
)
4455 gfc_conv_expr (&parmse
, e
);
4459 gfc_conv_expr (&parmse
, e
);
4460 if (fsym
->attr
.optional
4461 && fsym
->ts
.type
!= BT_CLASS
4462 && fsym
->ts
.type
!= BT_DERIVED
)
4464 if (e
->expr_type
!= EXPR_VARIABLE
4465 || !e
->symtree
->n
.sym
->attr
.optional
4467 vec_safe_push (optionalargs
, boolean_true_node
);
4470 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4471 if (!e
->symtree
->n
.sym
->attr
.value
)
4473 = fold_build3_loc (input_location
, COND_EXPR
,
4474 TREE_TYPE (parmse
.expr
),
4476 fold_convert (TREE_TYPE (parmse
.expr
),
4477 integer_zero_node
));
4479 vec_safe_push (optionalargs
, tmp
);
4484 else if (arg
->name
&& arg
->name
[0] == '%')
4485 /* Argument list functions %VAL, %LOC and %REF are signalled
4486 through arg->name. */
4487 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4488 else if ((e
->expr_type
== EXPR_FUNCTION
)
4489 && ((e
->value
.function
.esym
4490 && e
->value
.function
.esym
->result
->attr
.pointer
)
4491 || (!e
->value
.function
.esym
4492 && e
->symtree
->n
.sym
->attr
.pointer
))
4493 && fsym
&& fsym
->attr
.target
)
4495 gfc_conv_expr (&parmse
, e
);
4496 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4498 else if (e
->expr_type
== EXPR_FUNCTION
4499 && e
->symtree
->n
.sym
->result
4500 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4501 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4503 /* Functions returning procedure pointers. */
4504 gfc_conv_expr (&parmse
, e
);
4505 if (fsym
&& fsym
->attr
.proc_pointer
)
4506 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4510 if (e
->ts
.type
== BT_CLASS
&& fsym
4511 && fsym
->ts
.type
== BT_CLASS
4512 && (!CLASS_DATA (fsym
)->as
4513 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4514 && CLASS_DATA (e
)->attr
.codimension
)
4516 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4517 gcc_assert (!CLASS_DATA (fsym
)->as
);
4518 gfc_add_class_array_ref (e
);
4519 parmse
.want_coarray
= 1;
4520 gfc_conv_expr_reference (&parmse
, e
);
4521 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4523 && e
->expr_type
== EXPR_VARIABLE
);
4525 else if (e
->ts
.type
== BT_CLASS
&& fsym
4526 && fsym
->ts
.type
== BT_CLASS
4527 && !CLASS_DATA (fsym
)->as
4528 && !CLASS_DATA (e
)->as
4529 && (CLASS_DATA (fsym
)->attr
.class_pointer
4530 != CLASS_DATA (e
)->attr
.class_pointer
4531 || CLASS_DATA (fsym
)->attr
.allocatable
4532 != CLASS_DATA (e
)->attr
.allocatable
))
4534 type
= gfc_typenode_for_spec (&fsym
->ts
);
4535 var
= gfc_create_var (type
, fsym
->name
);
4536 gfc_conv_expr (&parmse
, e
);
4537 if (fsym
->attr
.optional
4538 && e
->expr_type
== EXPR_VARIABLE
4539 && e
->symtree
->n
.sym
->attr
.optional
)
4543 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4544 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4545 boolean_type_node
, tmp
,
4546 fold_convert (TREE_TYPE (tmp
),
4547 null_pointer_node
));
4548 gfc_start_block (&block
);
4549 gfc_add_modify (&block
, var
,
4550 fold_build1_loc (input_location
,
4552 type
, parmse
.expr
));
4553 gfc_add_expr_to_block (&parmse
.pre
,
4554 fold_build3_loc (input_location
,
4555 COND_EXPR
, void_type_node
,
4556 cond
, gfc_finish_block (&block
),
4557 build_empty_stmt (input_location
)));
4558 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4559 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4560 TREE_TYPE (parmse
.expr
),
4562 fold_convert (TREE_TYPE (parmse
.expr
),
4563 null_pointer_node
));
4567 gfc_add_modify (&parmse
.pre
, var
,
4568 fold_build1_loc (input_location
,
4570 type
, parmse
.expr
));
4571 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4575 gfc_conv_expr_reference (&parmse
, e
);
4577 /* Catch base objects that are not variables. */
4578 if (e
->ts
.type
== BT_CLASS
4579 && e
->expr_type
!= EXPR_VARIABLE
4580 && expr
&& e
== expr
->base_expr
)
4581 base_object
= build_fold_indirect_ref_loc (input_location
,
4584 /* A class array element needs converting back to be a
4585 class object, if the formal argument is a class object. */
4586 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4587 && e
->ts
.type
== BT_CLASS
4588 && ((CLASS_DATA (fsym
)->as
4589 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4590 || CLASS_DATA (e
)->attr
.dimension
))
4591 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4592 fsym
->attr
.intent
!= INTENT_IN
4593 && (CLASS_DATA (fsym
)->attr
.class_pointer
4594 || CLASS_DATA (fsym
)->attr
.allocatable
),
4596 && e
->expr_type
== EXPR_VARIABLE
4597 && e
->symtree
->n
.sym
->attr
.optional
,
4598 CLASS_DATA (fsym
)->attr
.class_pointer
4599 || CLASS_DATA (fsym
)->attr
.allocatable
);
4601 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4602 allocated on entry, it must be deallocated. */
4603 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4604 && (fsym
->attr
.allocatable
4605 || (fsym
->ts
.type
== BT_CLASS
4606 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4611 gfc_init_block (&block
);
4613 if (e
->ts
.type
== BT_CLASS
)
4614 ptr
= gfc_class_data_get (ptr
);
4616 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4618 gfc_add_expr_to_block (&block
, tmp
);
4619 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4620 void_type_node
, ptr
,
4622 gfc_add_expr_to_block (&block
, tmp
);
4624 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4626 gfc_add_modify (&block
, ptr
,
4627 fold_convert (TREE_TYPE (ptr
),
4628 null_pointer_node
));
4629 gfc_add_expr_to_block (&block
, tmp
);
4631 else if (fsym
->ts
.type
== BT_CLASS
)
4634 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4635 tmp
= gfc_get_symbol_decl (vtab
);
4636 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4637 ptr
= gfc_class_vptr_get (parmse
.expr
);
4638 gfc_add_modify (&block
, ptr
,
4639 fold_convert (TREE_TYPE (ptr
), tmp
));
4640 gfc_add_expr_to_block (&block
, tmp
);
4643 if (fsym
->attr
.optional
4644 && e
->expr_type
== EXPR_VARIABLE
4645 && e
->symtree
->n
.sym
->attr
.optional
)
4647 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4649 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4650 gfc_finish_block (&block
),
4651 build_empty_stmt (input_location
));
4654 tmp
= gfc_finish_block (&block
);
4656 gfc_add_expr_to_block (&se
->pre
, tmp
);
4659 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4660 || fsym
->ts
.type
== BT_ASSUMED
)
4661 && e
->ts
.type
== BT_CLASS
4662 && !CLASS_DATA (e
)->attr
.dimension
4663 && !CLASS_DATA (e
)->attr
.codimension
)
4664 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4666 /* Wrap scalar variable in a descriptor. We need to convert
4667 the address of a pointer back to the pointer itself before,
4668 we can assign it to the data field. */
4670 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4671 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4674 if (TREE_CODE (tmp
) == ADDR_EXPR
4675 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4676 tmp
= TREE_OPERAND (tmp
, 0);
4677 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4679 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4682 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4683 && ((fsym
->attr
.pointer
4684 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4685 || (fsym
->attr
.proc_pointer
4686 && !(e
->expr_type
== EXPR_VARIABLE
4687 && e
->symtree
->n
.sym
->attr
.dummy
))
4688 || (fsym
->attr
.proc_pointer
4689 && e
->expr_type
== EXPR_VARIABLE
4690 && gfc_is_proc_ptr_comp (e
))
4691 || (fsym
->attr
.allocatable
4692 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4694 /* Scalar pointer dummy args require an extra level of
4695 indirection. The null pointer already contains
4696 this level of indirection. */
4697 parm_kind
= SCALAR_POINTER
;
4698 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4702 else if (e
->ts
.type
== BT_CLASS
4703 && fsym
&& fsym
->ts
.type
== BT_CLASS
4704 && (CLASS_DATA (fsym
)->attr
.dimension
4705 || CLASS_DATA (fsym
)->attr
.codimension
))
4707 /* Pass a class array. */
4708 parmse
.use_offset
= 1;
4709 gfc_conv_expr_descriptor (&parmse
, e
);
4711 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4712 allocated on entry, it must be deallocated. */
4713 if (fsym
->attr
.intent
== INTENT_OUT
4714 && CLASS_DATA (fsym
)->attr
.allocatable
)
4719 gfc_init_block (&block
);
4721 ptr
= gfc_class_data_get (ptr
);
4723 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4724 NULL_TREE
, NULL_TREE
,
4727 gfc_add_expr_to_block (&block
, tmp
);
4728 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4729 void_type_node
, ptr
,
4731 gfc_add_expr_to_block (&block
, tmp
);
4732 gfc_reset_vptr (&block
, e
);
4734 if (fsym
->attr
.optional
4735 && e
->expr_type
== EXPR_VARIABLE
4737 || (e
->ref
->type
== REF_ARRAY
4738 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4739 && e
->symtree
->n
.sym
->attr
.optional
)
4741 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4743 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4744 gfc_finish_block (&block
),
4745 build_empty_stmt (input_location
));
4748 tmp
= gfc_finish_block (&block
);
4750 gfc_add_expr_to_block (&se
->pre
, tmp
);
4753 /* The conversion does not repackage the reference to a class
4754 array - _data descriptor. */
4755 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4756 fsym
->attr
.intent
!= INTENT_IN
4757 && (CLASS_DATA (fsym
)->attr
.class_pointer
4758 || CLASS_DATA (fsym
)->attr
.allocatable
),
4760 && e
->expr_type
== EXPR_VARIABLE
4761 && e
->symtree
->n
.sym
->attr
.optional
,
4762 CLASS_DATA (fsym
)->attr
.class_pointer
4763 || CLASS_DATA (fsym
)->attr
.allocatable
);
4767 /* If the procedure requires an explicit interface, the actual
4768 argument is passed according to the corresponding formal
4769 argument. If the corresponding formal argument is a POINTER,
4770 ALLOCATABLE or assumed shape, we do not use g77's calling
4771 convention, and pass the address of the array descriptor
4772 instead. Otherwise we use g77's calling convention. */
4775 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4776 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4777 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4779 f
= f
|| !comp
->attr
.always_explicit
;
4781 f
= f
|| !sym
->attr
.always_explicit
;
4783 /* If the argument is a function call that may not create
4784 a temporary for the result, we have to check that we
4785 can do it, i.e. that there is no alias between this
4786 argument and another one. */
4787 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4793 intent
= fsym
->attr
.intent
;
4795 intent
= INTENT_UNKNOWN
;
4797 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4799 parmse
.force_tmp
= 1;
4801 iarg
= e
->value
.function
.actual
->expr
;
4803 /* Temporary needed if aliasing due to host association. */
4804 if (sym
->attr
.contained
4806 && !sym
->attr
.implicit_pure
4807 && !sym
->attr
.use_assoc
4808 && iarg
->expr_type
== EXPR_VARIABLE
4809 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4810 parmse
.force_tmp
= 1;
4812 /* Ditto within module. */
4813 if (sym
->attr
.use_assoc
4815 && !sym
->attr
.implicit_pure
4816 && iarg
->expr_type
== EXPR_VARIABLE
4817 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4818 parmse
.force_tmp
= 1;
4821 if (e
->expr_type
== EXPR_VARIABLE
4822 && is_subref_array (e
))
4823 /* The actual argument is a component reference to an
4824 array of derived types. In this case, the argument
4825 is converted to a temporary, which is passed and then
4826 written back after the procedure call. */
4827 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4828 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4829 fsym
&& fsym
->attr
.pointer
);
4830 else if (gfc_is_class_array_ref (e
, NULL
)
4831 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
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 OOP-TODO: Insert code so that if the dynamic type is
4837 the same as the declared type, copy-in/copy-out does
4839 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4840 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4841 fsym
&& fsym
->attr
.pointer
);
4843 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4845 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4846 allocated on entry, it must be deallocated. */
4847 if (fsym
&& fsym
->attr
.allocatable
4848 && fsym
->attr
.intent
== INTENT_OUT
)
4850 tmp
= build_fold_indirect_ref_loc (input_location
,
4852 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4853 if (fsym
->attr
.optional
4854 && e
->expr_type
== EXPR_VARIABLE
4855 && e
->symtree
->n
.sym
->attr
.optional
)
4856 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4858 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4859 tmp
, build_empty_stmt (input_location
));
4860 gfc_add_expr_to_block (&se
->pre
, tmp
);
4865 /* The case with fsym->attr.optional is that of a user subroutine
4866 with an interface indicating an optional argument. When we call
4867 an intrinsic subroutine, however, fsym is NULL, but we might still
4868 have an optional argument, so we proceed to the substitution
4870 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4872 /* If an optional argument is itself an optional dummy argument,
4873 check its presence and substitute a null if absent. This is
4874 only needed when passing an array to an elemental procedure
4875 as then array elements are accessed - or no NULL pointer is
4876 allowed and a "1" or "0" should be passed if not present.
4877 When passing a non-array-descriptor full array to a
4878 non-array-descriptor dummy, no check is needed. For
4879 array-descriptor actual to array-descriptor dummy, see
4880 PR 41911 for why a check has to be inserted.
4881 fsym == NULL is checked as intrinsics required the descriptor
4882 but do not always set fsym. */
4883 if (e
->expr_type
== EXPR_VARIABLE
4884 && e
->symtree
->n
.sym
->attr
.optional
4885 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4886 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4890 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4891 || fsym
->as
->type
== AS_ASSUMED_RANK
4892 || fsym
->as
->type
== AS_DEFERRED
))))))
4893 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4894 e
->representation
.length
);
4899 /* Obtain the character length of an assumed character length
4900 length procedure from the typespec. */
4901 if (fsym
->ts
.type
== BT_CHARACTER
4902 && parmse
.string_length
== NULL_TREE
4903 && e
->ts
.type
== BT_PROCEDURE
4904 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4905 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4906 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4908 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4909 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4913 if (fsym
&& need_interface_mapping
&& e
)
4914 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4916 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4917 gfc_add_block_to_block (&post
, &parmse
.post
);
4919 /* Allocated allocatable components of derived types must be
4920 deallocated for non-variable scalars. Non-variable arrays are
4921 dealt with in trans-array.c(gfc_conv_array_parameter). */
4922 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4923 && e
->ts
.u
.derived
->attr
.alloc_comp
4924 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4925 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4928 tmp
= build_fold_indirect_ref_loc (input_location
,
4930 parm_rank
= e
->rank
;
4938 case (SCALAR_POINTER
):
4939 tmp
= build_fold_indirect_ref_loc (input_location
,
4944 if (e
->expr_type
== EXPR_OP
4945 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4946 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4949 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4950 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4951 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4954 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4956 /* The derived type is passed to gfc_deallocate_alloc_comp.
4957 Therefore, class actuals can handled correctly but derived
4958 types passed to class formals need the _data component. */
4959 tmp
= gfc_class_data_get (tmp
);
4960 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4961 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4964 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4966 gfc_add_expr_to_block (&se
->post
, tmp
);
4969 /* Add argument checking of passing an unallocated/NULL actual to
4970 a nonallocatable/nonpointer dummy. */
4972 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4974 symbol_attribute attr
;
4978 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4979 attr
= gfc_expr_attr (e
);
4981 goto end_pointer_check
;
4983 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4984 allocatable to an optional dummy, cf. 12.5.2.12. */
4985 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4986 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4987 goto end_pointer_check
;
4991 /* If the actual argument is an optional pointer/allocatable and
4992 the formal argument takes an nonpointer optional value,
4993 it is invalid to pass a non-present argument on, even
4994 though there is no technical reason for this in gfortran.
4995 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4996 tree present
, null_ptr
, type
;
4998 if (attr
.allocatable
4999 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5000 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5001 "allocated or not present",
5002 e
->symtree
->n
.sym
->name
);
5003 else if (attr
.pointer
5004 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5005 msg
= xasprintf ("Pointer actual argument '%s' is not "
5006 "associated or not present",
5007 e
->symtree
->n
.sym
->name
);
5008 else if (attr
.proc_pointer
5009 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5010 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5011 "associated or not present",
5012 e
->symtree
->n
.sym
->name
);
5014 goto end_pointer_check
;
5016 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5017 type
= TREE_TYPE (present
);
5018 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5019 boolean_type_node
, present
,
5021 null_pointer_node
));
5022 type
= TREE_TYPE (parmse
.expr
);
5023 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5024 boolean_type_node
, parmse
.expr
,
5026 null_pointer_node
));
5027 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5028 boolean_type_node
, present
, null_ptr
);
5032 if (attr
.allocatable
5033 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5034 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5035 "allocated", e
->symtree
->n
.sym
->name
);
5036 else if (attr
.pointer
5037 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5038 msg
= xasprintf ("Pointer actual argument '%s' is not "
5039 "associated", e
->symtree
->n
.sym
->name
);
5040 else if (attr
.proc_pointer
5041 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5042 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5043 "associated", e
->symtree
->n
.sym
->name
);
5045 goto end_pointer_check
;
5049 /* If the argument is passed by value, we need to strip the
5051 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5052 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5054 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5055 boolean_type_node
, tmp
,
5056 fold_convert (TREE_TYPE (tmp
),
5057 null_pointer_node
));
5060 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5066 /* Deferred length dummies pass the character length by reference
5067 so that the value can be returned. */
5068 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5070 if (INDIRECT_REF_P (parmse
.string_length
))
5071 /* In chains of functions/procedure calls the string_length already
5072 is a pointer to the variable holding the length. Therefore
5073 remove the deref on call. */
5074 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5077 tmp
= parmse
.string_length
;
5078 if (TREE_CODE (tmp
) != VAR_DECL
)
5079 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5080 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5084 /* Character strings are passed as two parameters, a length and a
5085 pointer - except for Bind(c) which only passes the pointer.
5086 An unlimited polymorphic formal argument likewise does not
5088 if (parmse
.string_length
!= NULL_TREE
5089 && !sym
->attr
.is_bind_c
5090 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5091 vec_safe_push (stringargs
, parmse
.string_length
);
5093 /* When calling __copy for character expressions to unlimited
5094 polymorphic entities, the dst argument needs a string length. */
5095 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5096 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5097 && arg
->next
&& arg
->next
->expr
5098 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5099 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5100 vec_safe_push (stringargs
, parmse
.string_length
);
5102 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5103 pass the token and the offset as additional arguments. */
5104 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5105 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5106 && !fsym
->attr
.allocatable
)
5107 || (fsym
->ts
.type
== BT_CLASS
5108 && CLASS_DATA (fsym
)->attr
.codimension
5109 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5111 /* Token and offset. */
5112 vec_safe_push (stringargs
, null_pointer_node
);
5113 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5114 gcc_assert (fsym
->attr
.optional
);
5116 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5117 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5118 && !fsym
->attr
.allocatable
)
5119 || (fsym
->ts
.type
== BT_CLASS
5120 && CLASS_DATA (fsym
)->attr
.codimension
5121 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5123 tree caf_decl
, caf_type
;
5126 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5127 caf_type
= TREE_TYPE (caf_decl
);
5129 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5130 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5131 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5132 tmp
= gfc_conv_descriptor_token (caf_decl
);
5133 else if (DECL_LANG_SPECIFIC (caf_decl
)
5134 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5135 tmp
= GFC_DECL_TOKEN (caf_decl
);
5138 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5139 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5140 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5143 vec_safe_push (stringargs
, tmp
);
5145 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5146 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5147 offset
= build_int_cst (gfc_array_index_type
, 0);
5148 else if (DECL_LANG_SPECIFIC (caf_decl
)
5149 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5150 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5151 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5152 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5154 offset
= build_int_cst (gfc_array_index_type
, 0);
5156 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5157 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5160 gcc_assert (POINTER_TYPE_P (caf_type
));
5164 tmp2
= fsym
->ts
.type
== BT_CLASS
5165 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5166 if ((fsym
->ts
.type
!= BT_CLASS
5167 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5168 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5169 || (fsym
->ts
.type
== BT_CLASS
5170 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5171 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5173 if (fsym
->ts
.type
== BT_CLASS
)
5174 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5177 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5178 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5180 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5181 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5183 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5184 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5187 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5190 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5191 gfc_array_index_type
,
5192 fold_convert (gfc_array_index_type
, tmp2
),
5193 fold_convert (gfc_array_index_type
, tmp
));
5194 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5195 gfc_array_index_type
, offset
, tmp
);
5197 vec_safe_push (stringargs
, offset
);
5200 vec_safe_push (arglist
, parmse
.expr
);
5202 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5209 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5210 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5211 else if (ts
.type
== BT_CHARACTER
)
5213 if (ts
.u
.cl
->length
== NULL
)
5215 /* Assumed character length results are not allowed by 5.1.1.5 of the
5216 standard and are trapped in resolve.c; except in the case of SPREAD
5217 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5218 we take the character length of the first argument for the result.
5219 For dummies, we have to look through the formal argument list for
5220 this function and use the character length found there.*/
5222 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5223 else if (!sym
->attr
.dummy
)
5224 cl
.backend_decl
= (*stringargs
)[0];
5227 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5228 for (; formal
; formal
= formal
->next
)
5229 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5230 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5232 len
= cl
.backend_decl
;
5238 /* Calculate the length of the returned string. */
5239 gfc_init_se (&parmse
, NULL
);
5240 if (need_interface_mapping
)
5241 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5243 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5244 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5245 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5247 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5248 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5249 gfc_charlen_type_node
, tmp
,
5250 build_int_cst (gfc_charlen_type_node
, 0));
5251 cl
.backend_decl
= tmp
;
5254 /* Set up a charlen structure for it. */
5259 len
= cl
.backend_decl
;
5262 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5263 || (!comp
&& gfc_return_by_reference (sym
));
5266 if (se
->direct_byref
)
5268 /* Sometimes, too much indirection can be applied; e.g. for
5269 function_result = array_valued_recursive_function. */
5270 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5271 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5272 && GFC_DESCRIPTOR_TYPE_P
5273 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5274 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5277 /* If the lhs of an assignment x = f(..) is allocatable and
5278 f2003 is allowed, we must do the automatic reallocation.
5279 TODO - deal with intrinsics, without using a temporary. */
5280 if (flag_realloc_lhs
5281 && se
->ss
&& se
->ss
->loop_chain
5282 && se
->ss
->loop_chain
->is_alloc_lhs
5283 && !expr
->value
.function
.isym
5284 && sym
->result
->as
!= NULL
)
5286 /* Evaluate the bounds of the result, if known. */
5287 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5290 /* Perform the automatic reallocation. */
5291 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5293 gfc_add_expr_to_block (&se
->pre
, tmp
);
5295 /* Pass the temporary as the first argument. */
5296 result
= info
->descriptor
;
5299 result
= build_fold_indirect_ref_loc (input_location
,
5301 vec_safe_push (retargs
, se
->expr
);
5303 else if (comp
&& comp
->attr
.dimension
)
5305 gcc_assert (se
->loop
&& info
);
5307 /* Set the type of the array. */
5308 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5309 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5311 /* Evaluate the bounds of the result, if known. */
5312 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5314 /* If the lhs of an assignment x = f(..) is allocatable and
5315 f2003 is allowed, we must not generate the function call
5316 here but should just send back the results of the mapping.
5317 This is signalled by the function ss being flagged. */
5318 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5320 gfc_free_interface_mapping (&mapping
);
5321 return has_alternate_specifier
;
5324 /* Create a temporary to store the result. In case the function
5325 returns a pointer, the temporary will be a shallow copy and
5326 mustn't be deallocated. */
5327 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5328 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5329 tmp
, NULL_TREE
, false,
5330 !comp
->attr
.pointer
, callee_alloc
,
5331 &se
->ss
->info
->expr
->where
);
5333 /* Pass the temporary as the first argument. */
5334 result
= info
->descriptor
;
5335 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5336 vec_safe_push (retargs
, tmp
);
5338 else if (!comp
&& sym
->result
->attr
.dimension
)
5340 gcc_assert (se
->loop
&& info
);
5342 /* Set the type of the array. */
5343 tmp
= gfc_typenode_for_spec (&ts
);
5344 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5346 /* Evaluate the bounds of the result, if known. */
5347 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5349 /* If the lhs of an assignment x = f(..) is allocatable and
5350 f2003 is allowed, we must not generate the function call
5351 here but should just send back the results of the mapping.
5352 This is signalled by the function ss being flagged. */
5353 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5355 gfc_free_interface_mapping (&mapping
);
5356 return has_alternate_specifier
;
5359 /* Create a temporary to store the result. In case the function
5360 returns a pointer, the temporary will be a shallow copy and
5361 mustn't be deallocated. */
5362 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5363 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5364 tmp
, NULL_TREE
, false,
5365 !sym
->attr
.pointer
, callee_alloc
,
5366 &se
->ss
->info
->expr
->where
);
5368 /* Pass the temporary as the first argument. */
5369 result
= info
->descriptor
;
5370 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5371 vec_safe_push (retargs
, tmp
);
5373 else if (ts
.type
== BT_CHARACTER
)
5375 /* Pass the string length. */
5376 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5377 type
= build_pointer_type (type
);
5379 /* Return an address to a char[0:len-1]* temporary for
5380 character pointers. */
5381 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5382 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5384 var
= gfc_create_var (type
, "pstr");
5386 if ((!comp
&& sym
->attr
.allocatable
)
5387 || (comp
&& comp
->attr
.allocatable
))
5389 gfc_add_modify (&se
->pre
, var
,
5390 fold_convert (TREE_TYPE (var
),
5391 null_pointer_node
));
5392 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5393 gfc_add_expr_to_block (&se
->post
, tmp
);
5396 /* Provide an address expression for the function arguments. */
5397 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5400 var
= gfc_conv_string_tmp (se
, type
, len
);
5402 vec_safe_push (retargs
, var
);
5406 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5408 type
= gfc_get_complex_type (ts
.kind
);
5409 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5410 vec_safe_push (retargs
, var
);
5413 /* Add the string length to the argument list. */
5414 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5417 if (TREE_CODE (tmp
) != VAR_DECL
)
5418 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5419 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5420 vec_safe_push (retargs
, tmp
);
5422 else if (ts
.type
== BT_CHARACTER
)
5423 vec_safe_push (retargs
, len
);
5425 gfc_free_interface_mapping (&mapping
);
5427 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5428 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5429 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5430 vec_safe_reserve (retargs
, arglen
);
5432 /* Add the return arguments. */
5433 retargs
->splice (arglist
);
5435 /* Add the hidden present status for optional+value to the arguments. */
5436 retargs
->splice (optionalargs
);
5438 /* Add the hidden string length parameters to the arguments. */
5439 retargs
->splice (stringargs
);
5441 /* We may want to append extra arguments here. This is used e.g. for
5442 calls to libgfortran_matmul_??, which need extra information. */
5443 if (!vec_safe_is_empty (append_args
))
5444 retargs
->splice (append_args
);
5447 /* Generate the actual call. */
5448 if (base_object
== NULL_TREE
)
5449 conv_function_val (se
, sym
, expr
);
5451 conv_base_obj_fcn_val (se
, base_object
, expr
);
5453 /* If there are alternate return labels, function type should be
5454 integer. Can't modify the type in place though, since it can be shared
5455 with other functions. For dummy arguments, the typing is done to
5456 this result, even if it has to be repeated for each call. */
5457 if (has_alternate_specifier
5458 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5460 if (!sym
->attr
.dummy
)
5462 TREE_TYPE (sym
->backend_decl
)
5463 = build_function_type (integer_type_node
,
5464 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5465 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5468 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5471 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5472 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5474 /* If we have a pointer function, but we don't want a pointer, e.g.
5477 where f is pointer valued, we have to dereference the result. */
5478 if (!se
->want_pointer
&& !byref
5479 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5480 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5481 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5483 /* f2c calling conventions require a scalar default real function to
5484 return a double precision result. Convert this back to default
5485 real. We only care about the cases that can happen in Fortran 77.
5487 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5488 && sym
->ts
.kind
== gfc_default_real_kind
5489 && !sym
->attr
.always_explicit
)
5490 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5492 /* A pure function may still have side-effects - it may modify its
5494 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5496 if (!sym
->attr
.pure
)
5497 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5502 /* Add the function call to the pre chain. There is no expression. */
5503 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5504 se
->expr
= NULL_TREE
;
5506 if (!se
->direct_byref
)
5508 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5510 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5512 /* Check the data pointer hasn't been modified. This would
5513 happen in a function returning a pointer. */
5514 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5515 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5518 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5521 se
->expr
= info
->descriptor
;
5522 /* Bundle in the string length. */
5523 se
->string_length
= len
;
5525 else if (ts
.type
== BT_CHARACTER
)
5527 /* Dereference for character pointer results. */
5528 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5529 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5530 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5534 se
->string_length
= len
;
5538 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5539 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5544 /* Follow the function call with the argument post block. */
5547 gfc_add_block_to_block (&se
->pre
, &post
);
5549 /* Transformational functions of derived types with allocatable
5550 components must have the result allocatable components copied. */
5551 arg
= expr
->value
.function
.actual
;
5552 if (result
&& arg
&& expr
->rank
5553 && expr
->value
.function
.isym
5554 && expr
->value
.function
.isym
->transformational
5555 && arg
->expr
->ts
.type
== BT_DERIVED
5556 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5559 /* Copy the allocatable components. We have to use a
5560 temporary here to prevent source allocatable components
5561 from being corrupted. */
5562 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5563 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5564 result
, tmp2
, expr
->rank
);
5565 gfc_add_expr_to_block (&se
->pre
, tmp
);
5566 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5568 gfc_add_expr_to_block (&se
->pre
, tmp
);
5570 /* Finally free the temporary's data field. */
5571 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5572 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5573 NULL_TREE
, NULL_TREE
, true,
5575 gfc_add_expr_to_block (&se
->pre
, tmp
);
5579 gfc_add_block_to_block (&se
->post
, &post
);
5581 return has_alternate_specifier
;
5585 /* Fill a character string with spaces. */
5588 fill_with_spaces (tree start
, tree type
, tree size
)
5590 stmtblock_t block
, loop
;
5591 tree i
, el
, exit_label
, cond
, tmp
;
5593 /* For a simple char type, we can call memset(). */
5594 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5595 return build_call_expr_loc (input_location
,
5596 builtin_decl_explicit (BUILT_IN_MEMSET
),
5598 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5599 lang_hooks
.to_target_charset (' ')),
5602 /* Otherwise, we use a loop:
5603 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5607 /* Initialize variables. */
5608 gfc_init_block (&block
);
5609 i
= gfc_create_var (sizetype
, "i");
5610 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5611 el
= gfc_create_var (build_pointer_type (type
), "el");
5612 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5613 exit_label
= gfc_build_label_decl (NULL_TREE
);
5614 TREE_USED (exit_label
) = 1;
5618 gfc_init_block (&loop
);
5620 /* Exit condition. */
5621 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5622 build_zero_cst (sizetype
));
5623 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5624 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5625 build_empty_stmt (input_location
));
5626 gfc_add_expr_to_block (&loop
, tmp
);
5629 gfc_add_modify (&loop
,
5630 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5631 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5633 /* Increment loop variables. */
5634 gfc_add_modify (&loop
, i
,
5635 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5636 TYPE_SIZE_UNIT (type
)));
5637 gfc_add_modify (&loop
, el
,
5638 fold_build_pointer_plus_loc (input_location
,
5639 el
, TYPE_SIZE_UNIT (type
)));
5641 /* Making the loop... actually loop! */
5642 tmp
= gfc_finish_block (&loop
);
5643 tmp
= build1_v (LOOP_EXPR
, tmp
);
5644 gfc_add_expr_to_block (&block
, tmp
);
5646 /* The exit label. */
5647 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5648 gfc_add_expr_to_block (&block
, tmp
);
5651 return gfc_finish_block (&block
);
5655 /* Generate code to copy a string. */
5658 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5659 int dkind
, tree slength
, tree src
, int skind
)
5661 tree tmp
, dlen
, slen
;
5670 stmtblock_t tempblock
;
5672 gcc_assert (dkind
== skind
);
5674 if (slength
!= NULL_TREE
)
5676 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5677 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5681 slen
= build_int_cst (size_type_node
, 1);
5685 if (dlength
!= NULL_TREE
)
5687 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5688 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5692 dlen
= build_int_cst (size_type_node
, 1);
5696 /* Assign directly if the types are compatible. */
5697 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5698 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5700 gfc_add_modify (block
, dsc
, ssc
);
5704 /* Do nothing if the destination length is zero. */
5705 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5706 build_int_cst (size_type_node
, 0));
5708 /* The following code was previously in _gfortran_copy_string:
5710 // The two strings may overlap so we use memmove.
5712 copy_string (GFC_INTEGER_4 destlen, char * dest,
5713 GFC_INTEGER_4 srclen, const char * src)
5715 if (srclen >= destlen)
5717 // This will truncate if too long.
5718 memmove (dest, src, destlen);
5722 memmove (dest, src, srclen);
5724 memset (&dest[srclen], ' ', destlen - srclen);
5728 We're now doing it here for better optimization, but the logic
5731 /* For non-default character kinds, we have to multiply the string
5732 length by the base type size. */
5733 chartype
= gfc_get_char_type (dkind
);
5734 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5735 fold_convert (size_type_node
, slen
),
5736 fold_convert (size_type_node
,
5737 TYPE_SIZE_UNIT (chartype
)));
5738 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5739 fold_convert (size_type_node
, dlen
),
5740 fold_convert (size_type_node
,
5741 TYPE_SIZE_UNIT (chartype
)));
5743 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5744 dest
= fold_convert (pvoid_type_node
, dest
);
5746 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5748 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5749 src
= fold_convert (pvoid_type_node
, src
);
5751 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5753 /* Truncate string if source is too long. */
5754 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5756 tmp2
= build_call_expr_loc (input_location
,
5757 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5758 3, dest
, src
, dlen
);
5760 /* Else copy and pad with spaces. */
5761 tmp3
= build_call_expr_loc (input_location
,
5762 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5763 3, dest
, src
, slen
);
5765 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5766 tmp4
= fill_with_spaces (tmp4
, chartype
,
5767 fold_build2_loc (input_location
, MINUS_EXPR
,
5768 TREE_TYPE(dlen
), dlen
, slen
));
5770 gfc_init_block (&tempblock
);
5771 gfc_add_expr_to_block (&tempblock
, tmp3
);
5772 gfc_add_expr_to_block (&tempblock
, tmp4
);
5773 tmp3
= gfc_finish_block (&tempblock
);
5775 /* The whole copy_string function is there. */
5776 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5778 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5779 build_empty_stmt (input_location
));
5780 gfc_add_expr_to_block (block
, tmp
);
5784 /* Translate a statement function.
5785 The value of a statement function reference is obtained by evaluating the
5786 expression using the values of the actual arguments for the values of the
5787 corresponding dummy arguments. */
5790 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5794 gfc_formal_arglist
*fargs
;
5795 gfc_actual_arglist
*args
;
5798 gfc_saved_var
*saved_vars
;
5804 sym
= expr
->symtree
->n
.sym
;
5805 args
= expr
->value
.function
.actual
;
5806 gfc_init_se (&lse
, NULL
);
5807 gfc_init_se (&rse
, NULL
);
5810 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5812 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5813 temp_vars
= XCNEWVEC (tree
, n
);
5815 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5816 fargs
= fargs
->next
, n
++)
5818 /* Each dummy shall be specified, explicitly or implicitly, to be
5820 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5823 if (fsym
->ts
.type
== BT_CHARACTER
)
5825 /* Copy string arguments. */
5828 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5829 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5831 /* Create a temporary to hold the value. */
5832 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5833 fsym
->ts
.u
.cl
->backend_decl
5834 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5836 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5837 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5839 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5841 gfc_conv_expr (&rse
, args
->expr
);
5842 gfc_conv_string_parameter (&rse
);
5843 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5844 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5846 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5847 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5848 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5849 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5853 /* For everything else, just evaluate the expression. */
5855 /* Create a temporary to hold the value. */
5856 type
= gfc_typenode_for_spec (&fsym
->ts
);
5857 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5859 gfc_conv_expr (&lse
, args
->expr
);
5861 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5862 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5863 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5869 /* Use the temporary variables in place of the real ones. */
5870 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5871 fargs
= fargs
->next
, n
++)
5872 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5874 gfc_conv_expr (se
, sym
->value
);
5876 if (sym
->ts
.type
== BT_CHARACTER
)
5878 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5880 /* Force the expression to the correct length. */
5881 if (!INTEGER_CST_P (se
->string_length
)
5882 || tree_int_cst_lt (se
->string_length
,
5883 sym
->ts
.u
.cl
->backend_decl
))
5885 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5886 tmp
= gfc_create_var (type
, sym
->name
);
5887 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5888 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5889 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5893 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5896 /* Restore the original variables. */
5897 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5898 fargs
= fargs
->next
, n
++)
5899 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5905 /* Translate a function expression. */
5908 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5912 if (expr
->value
.function
.isym
)
5914 gfc_conv_intrinsic_function (se
, expr
);
5918 /* expr.value.function.esym is the resolved (specific) function symbol for
5919 most functions. However this isn't set for dummy procedures. */
5920 sym
= expr
->value
.function
.esym
;
5922 sym
= expr
->symtree
->n
.sym
;
5924 /* The IEEE_ARITHMETIC functions are caught here. */
5925 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
5926 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
5929 /* We distinguish statement functions from general functions to improve
5930 runtime performance. */
5931 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5933 gfc_conv_statement_function (se
, expr
);
5937 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5942 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5945 is_zero_initializer_p (gfc_expr
* expr
)
5947 if (expr
->expr_type
!= EXPR_CONSTANT
)
5950 /* We ignore constants with prescribed memory representations for now. */
5951 if (expr
->representation
.string
)
5954 switch (expr
->ts
.type
)
5957 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5960 return mpfr_zero_p (expr
->value
.real
)
5961 && MPFR_SIGN (expr
->value
.real
) >= 0;
5964 return expr
->value
.logical
== 0;
5967 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5968 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5969 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5970 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5980 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5985 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5986 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5988 gfc_conv_tmp_array_ref (se
);
5992 /* Build a static initializer. EXPR is the expression for the initial value.
5993 The other parameters describe the variable of the component being
5994 initialized. EXPR may be null. */
5997 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5998 bool array
, bool pointer
, bool procptr
)
6002 if (!(expr
|| pointer
|| procptr
))
6005 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6006 (these are the only two iso_c_binding derived types that can be
6007 used as initialization expressions). If so, we need to modify
6008 the 'expr' to be that for a (void *). */
6009 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6010 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6012 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6014 /* The derived symbol has already been converted to a (void *). Use
6016 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6017 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6019 gfc_init_se (&se
, NULL
);
6020 gfc_conv_constant (&se
, expr
);
6021 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6025 if (array
&& !procptr
)
6028 /* Arrays need special handling. */
6030 ctor
= gfc_build_null_descriptor (type
);
6031 /* Special case assigning an array to zero. */
6032 else if (is_zero_initializer_p (expr
))
6033 ctor
= build_constructor (type
, NULL
);
6035 ctor
= gfc_conv_array_initializer (type
, expr
);
6036 TREE_STATIC (ctor
) = 1;
6039 else if (pointer
|| procptr
)
6041 if (ts
->type
== BT_CLASS
&& !procptr
)
6043 gfc_init_se (&se
, NULL
);
6044 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6045 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6046 TREE_STATIC (se
.expr
) = 1;
6049 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6050 return fold_convert (type
, null_pointer_node
);
6053 gfc_init_se (&se
, NULL
);
6054 se
.want_pointer
= 1;
6055 gfc_conv_expr (&se
, expr
);
6056 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6066 gfc_init_se (&se
, NULL
);
6067 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6068 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6070 gfc_conv_structure (&se
, expr
, 1);
6071 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6072 TREE_STATIC (se
.expr
) = 1;
6077 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6078 TREE_STATIC (ctor
) = 1;
6083 gfc_init_se (&se
, NULL
);
6084 gfc_conv_constant (&se
, expr
);
6085 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6092 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6098 gfc_array_info
*lss_array
;
6105 gfc_start_block (&block
);
6107 /* Initialize the scalarizer. */
6108 gfc_init_loopinfo (&loop
);
6110 gfc_init_se (&lse
, NULL
);
6111 gfc_init_se (&rse
, NULL
);
6114 rss
= gfc_walk_expr (expr
);
6115 if (rss
== gfc_ss_terminator
)
6116 /* The rhs is scalar. Add a ss for the expression. */
6117 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6119 /* Create a SS for the destination. */
6120 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6122 lss_array
= &lss
->info
->data
.array
;
6123 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6124 lss_array
->descriptor
= dest
;
6125 lss_array
->data
= gfc_conv_array_data (dest
);
6126 lss_array
->offset
= gfc_conv_array_offset (dest
);
6127 for (n
= 0; n
< cm
->as
->rank
; n
++)
6129 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6130 lss_array
->stride
[n
] = gfc_index_one_node
;
6132 mpz_init (lss_array
->shape
[n
]);
6133 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6134 cm
->as
->lower
[n
]->value
.integer
);
6135 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6138 /* Associate the SS with the loop. */
6139 gfc_add_ss_to_loop (&loop
, lss
);
6140 gfc_add_ss_to_loop (&loop
, rss
);
6142 /* Calculate the bounds of the scalarization. */
6143 gfc_conv_ss_startstride (&loop
);
6145 /* Setup the scalarizing loops. */
6146 gfc_conv_loop_setup (&loop
, &expr
->where
);
6148 /* Setup the gfc_se structures. */
6149 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6150 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6153 gfc_mark_ss_chain_used (rss
, 1);
6155 gfc_mark_ss_chain_used (lss
, 1);
6157 /* Start the scalarized loop body. */
6158 gfc_start_scalarized_body (&loop
, &body
);
6160 gfc_conv_tmp_array_ref (&lse
);
6161 if (cm
->ts
.type
== BT_CHARACTER
)
6162 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6164 gfc_conv_expr (&rse
, expr
);
6166 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6167 gfc_add_expr_to_block (&body
, tmp
);
6169 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6171 /* Generate the copying loops. */
6172 gfc_trans_scalarizing_loops (&loop
, &body
);
6174 /* Wrap the whole thing up. */
6175 gfc_add_block_to_block (&block
, &loop
.pre
);
6176 gfc_add_block_to_block (&block
, &loop
.post
);
6178 gcc_assert (lss_array
->shape
!= NULL
);
6179 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6180 gfc_cleanup_loop (&loop
);
6182 return gfc_finish_block (&block
);
6187 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6197 gfc_expr
*arg
= NULL
;
6199 gfc_start_block (&block
);
6200 gfc_init_se (&se
, NULL
);
6202 /* Get the descriptor for the expressions. */
6203 se
.want_pointer
= 0;
6204 gfc_conv_expr_descriptor (&se
, expr
);
6205 gfc_add_block_to_block (&block
, &se
.pre
);
6206 gfc_add_modify (&block
, dest
, se
.expr
);
6208 /* Deal with arrays of derived types with allocatable components. */
6209 if (cm
->ts
.type
== BT_DERIVED
6210 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6211 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6215 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6216 TREE_TYPE(cm
->backend_decl
),
6219 gfc_add_expr_to_block (&block
, tmp
);
6220 gfc_add_block_to_block (&block
, &se
.post
);
6222 if (expr
->expr_type
!= EXPR_VARIABLE
)
6223 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6226 /* We need to know if the argument of a conversion function is a
6227 variable, so that the correct lower bound can be used. */
6228 if (expr
->expr_type
== EXPR_FUNCTION
6229 && expr
->value
.function
.isym
6230 && expr
->value
.function
.isym
->conversion
6231 && expr
->value
.function
.actual
->expr
6232 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6233 arg
= expr
->value
.function
.actual
->expr
;
6235 /* Obtain the array spec of full array references. */
6237 as
= gfc_get_full_arrayspec_from_expr (arg
);
6239 as
= gfc_get_full_arrayspec_from_expr (expr
);
6241 /* Shift the lbound and ubound of temporaries to being unity,
6242 rather than zero, based. Always calculate the offset. */
6243 offset
= gfc_conv_descriptor_offset_get (dest
);
6244 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6245 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6247 for (n
= 0; n
< expr
->rank
; n
++)
6252 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6253 TODO It looks as if gfc_conv_expr_descriptor should return
6254 the correct bounds and that the following should not be
6255 necessary. This would simplify gfc_conv_intrinsic_bound
6257 if (as
&& as
->lower
[n
])
6260 gfc_init_se (&lbse
, NULL
);
6261 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6262 gfc_add_block_to_block (&block
, &lbse
.pre
);
6263 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6267 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6268 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6272 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6275 lbound
= gfc_index_one_node
;
6277 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6279 /* Shift the bounds and set the offset accordingly. */
6280 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6281 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6282 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6283 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6285 gfc_conv_descriptor_ubound_set (&block
, dest
,
6286 gfc_rank_cst
[n
], tmp
);
6287 gfc_conv_descriptor_lbound_set (&block
, dest
,
6288 gfc_rank_cst
[n
], lbound
);
6290 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6291 gfc_conv_descriptor_lbound_get (dest
,
6293 gfc_conv_descriptor_stride_get (dest
,
6295 gfc_add_modify (&block
, tmp2
, tmp
);
6296 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6298 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6303 /* If a conversion expression has a null data pointer
6304 argument, nullify the allocatable component. */
6308 if (arg
->symtree
->n
.sym
->attr
.allocatable
6309 || arg
->symtree
->n
.sym
->attr
.pointer
)
6311 non_null_expr
= gfc_finish_block (&block
);
6312 gfc_start_block (&block
);
6313 gfc_conv_descriptor_data_set (&block
, dest
,
6315 null_expr
= gfc_finish_block (&block
);
6316 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6317 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6318 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6319 return build3_v (COND_EXPR
, tmp
,
6320 null_expr
, non_null_expr
);
6324 return gfc_finish_block (&block
);
6328 /* Allocate or reallocate scalar component, as necessary. */
6331 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6340 tree lhs_cl_size
= NULL_TREE
;
6345 if (!expr2
|| expr2
->rank
)
6348 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6350 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6352 char name
[GFC_MAX_SYMBOL_LEN
+9];
6353 gfc_component
*strlen
;
6354 /* Use the rhs string length and the lhs element size. */
6355 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6356 if (!expr2
->ts
.u
.cl
->backend_decl
)
6358 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6359 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6362 size
= expr2
->ts
.u
.cl
->backend_decl
;
6364 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6366 sprintf (name
, "_%s_length", cm
->name
);
6367 strlen
= gfc_find_component (sym
, name
, true, true);
6368 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6369 gfc_charlen_type_node
,
6370 TREE_OPERAND (comp
, 0),
6371 strlen
->backend_decl
, NULL_TREE
);
6373 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6374 tmp
= TYPE_SIZE_UNIT (tmp
);
6375 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6376 TREE_TYPE (tmp
), tmp
,
6377 fold_convert (TREE_TYPE (tmp
), size
));
6381 /* Otherwise use the length in bytes of the rhs. */
6382 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6383 size_in_bytes
= size
;
6386 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6387 size_in_bytes
, size_one_node
);
6389 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6391 tmp
= build_call_expr_loc (input_location
,
6392 builtin_decl_explicit (BUILT_IN_CALLOC
),
6393 2, build_one_cst (size_type_node
),
6395 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6396 gfc_add_modify (block
, comp
, tmp
);
6400 tmp
= build_call_expr_loc (input_location
,
6401 builtin_decl_explicit (BUILT_IN_MALLOC
),
6403 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6404 gfc_add_modify (block
, comp
, tmp
);
6407 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6408 /* Update the lhs character length. */
6409 gfc_add_modify (block
, lhs_cl_size
, size
);
6413 /* Assign a single component of a derived type constructor. */
6416 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6417 gfc_symbol
*sym
, bool init
)
6424 gfc_start_block (&block
);
6426 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6428 /* Only care about pointers here, not about allocatables. */
6429 gfc_init_se (&se
, NULL
);
6430 /* Pointer component. */
6431 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6432 && !cm
->attr
.proc_pointer
)
6434 /* Array pointer. */
6435 if (expr
->expr_type
== EXPR_NULL
)
6436 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6439 se
.direct_byref
= 1;
6441 gfc_conv_expr_descriptor (&se
, expr
);
6442 gfc_add_block_to_block (&block
, &se
.pre
);
6443 gfc_add_block_to_block (&block
, &se
.post
);
6448 /* Scalar pointers. */
6449 se
.want_pointer
= 1;
6450 gfc_conv_expr (&se
, expr
);
6451 gfc_add_block_to_block (&block
, &se
.pre
);
6453 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6454 && expr
->symtree
->n
.sym
->attr
.dummy
)
6455 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6457 gfc_add_modify (&block
, dest
,
6458 fold_convert (TREE_TYPE (dest
), se
.expr
));
6459 gfc_add_block_to_block (&block
, &se
.post
);
6462 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6464 /* NULL initialization for CLASS components. */
6465 tmp
= gfc_trans_structure_assign (dest
,
6466 gfc_class_initializer (&cm
->ts
, expr
),
6468 gfc_add_expr_to_block (&block
, tmp
);
6470 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6471 && !cm
->attr
.proc_pointer
)
6473 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6474 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6475 else if (cm
->attr
.allocatable
)
6477 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6478 gfc_add_expr_to_block (&block
, tmp
);
6482 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6483 gfc_add_expr_to_block (&block
, tmp
);
6486 else if (init
&& (cm
->attr
.allocatable
6487 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
6489 /* Take care about non-array allocatable components here. The alloc_*
6490 routine below is motivated by the alloc_scalar_allocatable_for_
6491 assignment() routine, but with the realloc portions removed and
6493 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
6498 /* The remainder of these instructions follow the if (cm->attr.pointer)
6499 if (!cm->attr.dimension) part above. */
6500 gfc_init_se (&se
, NULL
);
6501 gfc_conv_expr (&se
, expr
);
6502 gfc_add_block_to_block (&block
, &se
.pre
);
6504 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6505 && expr
->symtree
->n
.sym
->attr
.dummy
)
6506 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6507 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
6508 /* For deferred strings insert a memcpy. */
6509 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6512 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
6513 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
6515 : expr
->ts
.u
.cl
->backend_decl
);
6516 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
6517 gfc_add_expr_to_block (&block
, tmp
);
6520 gfc_add_modify (&block
, tmp
,
6521 fold_convert (TREE_TYPE (tmp
), se
.expr
));
6522 gfc_add_block_to_block (&block
, &se
.post
);
6524 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6526 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6528 gfc_init_se (&se
, NULL
);
6529 gfc_conv_expr (&se
, expr
);
6530 gfc_add_block_to_block (&block
, &se
.pre
);
6531 if (cm
->ts
.u
.derived
->attr
.alloc_comp
6532 && expr
->expr_type
== EXPR_VARIABLE
)
6534 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
6536 gfc_add_expr_to_block (&block
, tmp
);
6539 gfc_add_modify (&block
, dest
,
6540 fold_convert (TREE_TYPE (dest
), se
.expr
));
6541 gfc_add_block_to_block (&block
, &se
.post
);
6545 /* Nested constructors. */
6546 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
6547 gfc_add_expr_to_block (&block
, tmp
);
6550 else if (gfc_deferred_strlen (cm
, &tmp
))
6554 gcc_assert (strlen
);
6555 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6557 TREE_OPERAND (dest
, 0),
6560 if (expr
->expr_type
== EXPR_NULL
)
6562 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6563 gfc_add_modify (&block
, dest
, tmp
);
6564 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6565 gfc_add_modify (&block
, strlen
, tmp
);
6570 gfc_init_se (&se
, NULL
);
6571 gfc_conv_expr (&se
, expr
);
6572 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6573 tmp
= build_call_expr_loc (input_location
,
6574 builtin_decl_explicit (BUILT_IN_MALLOC
),
6576 gfc_add_modify (&block
, dest
,
6577 fold_convert (TREE_TYPE (dest
), tmp
));
6578 gfc_add_modify (&block
, strlen
, se
.string_length
);
6579 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6580 gfc_add_expr_to_block (&block
, tmp
);
6583 else if (!cm
->attr
.artificial
)
6585 /* Scalar component (excluding deferred parameters). */
6586 gfc_init_se (&se
, NULL
);
6587 gfc_init_se (&lse
, NULL
);
6589 gfc_conv_expr (&se
, expr
);
6590 if (cm
->ts
.type
== BT_CHARACTER
)
6591 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6593 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6594 gfc_add_expr_to_block (&block
, tmp
);
6596 return gfc_finish_block (&block
);
6599 /* Assign a derived type constructor to a variable. */
6602 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
6610 gfc_start_block (&block
);
6611 cm
= expr
->ts
.u
.derived
->components
;
6613 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6614 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6615 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6619 gcc_assert (cm
->backend_decl
== NULL
);
6620 gfc_init_se (&se
, NULL
);
6621 gfc_init_se (&lse
, NULL
);
6622 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6624 gfc_add_modify (&block
, lse
.expr
,
6625 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6627 return gfc_finish_block (&block
);
6630 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6631 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6633 /* Skip absent members in default initializers. */
6634 if (!c
->expr
&& !cm
->attr
.allocatable
)
6637 field
= cm
->backend_decl
;
6638 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6639 dest
, field
, NULL_TREE
);
6642 gfc_expr
*e
= gfc_get_null_expr (NULL
);
6643 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
6648 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
6649 expr
->ts
.u
.derived
, init
);
6650 gfc_add_expr_to_block (&block
, tmp
);
6652 return gfc_finish_block (&block
);
6655 /* Build an expression for a constructor. If init is nonzero then
6656 this is part of a static variable initializer. */
6659 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6666 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6668 gcc_assert (se
->ss
== NULL
);
6669 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6670 type
= gfc_typenode_for_spec (&expr
->ts
);
6674 /* Create a temporary variable and fill it in. */
6675 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6676 /* The symtree in expr is NULL, if the code to generate is for
6677 initializing the static members only. */
6678 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
6679 gfc_add_expr_to_block (&se
->pre
, tmp
);
6683 cm
= expr
->ts
.u
.derived
->components
;
6685 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6686 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6688 /* Skip absent members in default initializers and allocatable
6689 components. Although the latter have a default initializer
6690 of EXPR_NULL,... by default, the static nullify is not needed
6691 since this is done every time we come into scope. */
6692 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6695 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6696 && strcmp (cm
->name
, "_extends") == 0
6697 && cm
->initializer
->symtree
)
6701 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6702 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6703 vtab
= unshare_expr_without_location (vtab
);
6704 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6706 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6708 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6709 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6710 fold_convert (TREE_TYPE (cm
->backend_decl
),
6713 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
6715 gfc_expr
*e
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
6716 val
= gfc_conv_constant_to_tree (e
);
6717 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6718 fold_convert (TREE_TYPE (cm
->backend_decl
),
6723 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6724 TREE_TYPE (cm
->backend_decl
),
6725 cm
->attr
.dimension
, cm
->attr
.pointer
,
6726 cm
->attr
.proc_pointer
);
6727 val
= unshare_expr_without_location (val
);
6729 /* Append it to the constructor list. */
6730 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6733 se
->expr
= build_constructor (type
, v
);
6735 TREE_CONSTANT (se
->expr
) = 1;
6739 /* Translate a substring expression. */
6742 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6748 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6750 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6751 expr
->value
.character
.length
,
6752 expr
->value
.character
.string
);
6754 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6755 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6758 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6762 /* Entry point for expression translation. Evaluates a scalar quantity.
6763 EXPR is the expression to be translated, and SE is the state structure if
6764 called from within the scalarized. */
6767 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6772 if (ss
&& ss
->info
->expr
== expr
6773 && (ss
->info
->type
== GFC_SS_SCALAR
6774 || ss
->info
->type
== GFC_SS_REFERENCE
))
6776 gfc_ss_info
*ss_info
;
6779 /* Substitute a scalar expression evaluated outside the scalarization
6781 se
->expr
= ss_info
->data
.scalar
.value
;
6782 /* If the reference can be NULL, the value field contains the reference,
6783 not the value the reference points to (see gfc_add_loop_ss_code). */
6784 if (ss_info
->can_be_null_ref
)
6785 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6787 se
->string_length
= ss_info
->string_length
;
6788 gfc_advance_se_ss_chain (se
);
6792 /* We need to convert the expressions for the iso_c_binding derived types.
6793 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6794 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6795 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6796 updated to be an integer with a kind equal to the size of a (void *). */
6797 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
6798 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
6800 if (expr
->expr_type
== EXPR_VARIABLE
6801 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6802 || expr
->symtree
->n
.sym
->intmod_sym_id
6803 == ISOCBINDING_NULL_FUNPTR
))
6805 /* Set expr_type to EXPR_NULL, which will result in
6806 null_pointer_node being used below. */
6807 expr
->expr_type
= EXPR_NULL
;
6811 /* Update the type/kind of the expression to be what the new
6812 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6813 expr
->ts
.type
= BT_INTEGER
;
6814 expr
->ts
.f90_type
= BT_VOID
;
6815 expr
->ts
.kind
= gfc_index_integer_kind
;
6819 gfc_fix_class_refs (expr
);
6821 switch (expr
->expr_type
)
6824 gfc_conv_expr_op (se
, expr
);
6828 gfc_conv_function_expr (se
, expr
);
6832 gfc_conv_constant (se
, expr
);
6836 gfc_conv_variable (se
, expr
);
6840 se
->expr
= null_pointer_node
;
6843 case EXPR_SUBSTRING
:
6844 gfc_conv_substring_expr (se
, expr
);
6847 case EXPR_STRUCTURE
:
6848 gfc_conv_structure (se
, expr
, 0);
6852 gfc_conv_array_constructor_expr (se
, expr
);
6861 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6862 of an assignment. */
6864 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6866 gfc_conv_expr (se
, expr
);
6867 /* All numeric lvalues should have empty post chains. If not we need to
6868 figure out a way of rewriting an lvalue so that it has no post chain. */
6869 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6872 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6873 numeric expressions. Used for scalar values where inserting cleanup code
6876 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6880 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6881 gfc_conv_expr (se
, expr
);
6884 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6885 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6887 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6891 /* Helper to translate an expression and convert it to a particular type. */
6893 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6895 gfc_conv_expr_val (se
, expr
);
6896 se
->expr
= convert (type
, se
->expr
);
6900 /* Converts an expression so that it can be passed by reference. Scalar
6904 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6910 if (ss
&& ss
->info
->expr
== expr
6911 && ss
->info
->type
== GFC_SS_REFERENCE
)
6913 /* Returns a reference to the scalar evaluated outside the loop
6915 gfc_conv_expr (se
, expr
);
6917 if (expr
->ts
.type
== BT_CHARACTER
6918 && expr
->expr_type
!= EXPR_FUNCTION
)
6919 gfc_conv_string_parameter (se
);
6921 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6926 if (expr
->ts
.type
== BT_CHARACTER
)
6928 gfc_conv_expr (se
, expr
);
6929 gfc_conv_string_parameter (se
);
6933 if (expr
->expr_type
== EXPR_VARIABLE
)
6935 se
->want_pointer
= 1;
6936 gfc_conv_expr (se
, expr
);
6939 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6940 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6941 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6947 if (expr
->expr_type
== EXPR_FUNCTION
6948 && ((expr
->value
.function
.esym
6949 && expr
->value
.function
.esym
->result
->attr
.pointer
6950 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6951 || (!expr
->value
.function
.esym
&& !expr
->ref
6952 && expr
->symtree
->n
.sym
->attr
.pointer
6953 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6955 se
->want_pointer
= 1;
6956 gfc_conv_expr (se
, expr
);
6957 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6958 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6963 gfc_conv_expr (se
, expr
);
6965 /* Create a temporary var to hold the value. */
6966 if (TREE_CONSTANT (se
->expr
))
6968 tree tmp
= se
->expr
;
6969 STRIP_TYPE_NOPS (tmp
);
6970 var
= build_decl (input_location
,
6971 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6972 DECL_INITIAL (var
) = tmp
;
6973 TREE_STATIC (var
) = 1;
6978 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6979 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6981 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6983 /* Take the address of that value. */
6984 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6985 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6986 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6987 && expr
->ts
.u
.derived
->attr
.alloc_comp
6988 && expr
->expr_type
!= EXPR_VARIABLE
)
6992 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6993 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6995 /* The components shall be deallocated before
6996 their containing entity. */
6997 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7003 gfc_trans_pointer_assign (gfc_code
* code
)
7005 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7009 /* Generate code for a pointer assignment. */
7012 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7014 gfc_expr
*expr1_vptr
= NULL
;
7024 gfc_start_block (&block
);
7026 gfc_init_se (&lse
, NULL
);
7028 /* Check whether the expression is a scalar or not; we cannot use
7029 expr1->rank as it can be nonzero for proc pointers. */
7030 ss
= gfc_walk_expr (expr1
);
7031 scalar
= ss
== gfc_ss_terminator
;
7033 gfc_free_ss_chain (ss
);
7035 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7036 && expr2
->expr_type
!= EXPR_FUNCTION
)
7038 gfc_add_data_component (expr2
);
7039 /* The following is required as gfc_add_data_component doesn't
7040 update ts.type if there is a tailing REF_ARRAY. */
7041 expr2
->ts
.type
= BT_DERIVED
;
7046 /* Scalar pointers. */
7047 lse
.want_pointer
= 1;
7048 gfc_conv_expr (&lse
, expr1
);
7049 gfc_init_se (&rse
, NULL
);
7050 rse
.want_pointer
= 1;
7051 gfc_conv_expr (&rse
, expr2
);
7053 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7054 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7055 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7058 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7059 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7060 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7063 gfc_add_block_to_block (&block
, &lse
.pre
);
7064 gfc_add_block_to_block (&block
, &rse
.pre
);
7066 /* For string assignments to unlimited polymorphic pointers add an
7067 assignment of the string_length to the _len component of the
7069 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7070 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7071 && (expr2
->ts
.type
== BT_CHARACTER
||
7072 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7073 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7077 len_comp
= gfc_get_len_component (expr1
);
7078 gfc_init_se (&se
, NULL
);
7079 gfc_conv_expr (&se
, len_comp
);
7081 /* ptr % _len = len (str) */
7082 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7083 lse
.string_length
= se
.expr
;
7084 gfc_free_expr (len_comp
);
7087 /* Check character lengths if character expression. The test is only
7088 really added if -fbounds-check is enabled. Exclude deferred
7089 character length lefthand sides. */
7090 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7091 && !expr1
->ts
.deferred
7092 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7093 && !gfc_is_proc_ptr_comp (expr1
))
7095 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7096 gcc_assert (lse
.string_length
&& rse
.string_length
);
7097 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7098 lse
.string_length
, rse
.string_length
,
7102 /* The assignment to an deferred character length sets the string
7103 length to that of the rhs. */
7104 if (expr1
->ts
.deferred
)
7106 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7107 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7108 else if (lse
.string_length
!= NULL
)
7109 gfc_add_modify (&block
, lse
.string_length
,
7110 build_int_cst (gfc_charlen_type_node
, 0));
7113 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7114 rse
.expr
= gfc_class_data_get (rse
.expr
);
7116 gfc_add_modify (&block
, lse
.expr
,
7117 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7119 gfc_add_block_to_block (&block
, &rse
.post
);
7120 gfc_add_block_to_block (&block
, &lse
.post
);
7127 tree strlen_rhs
= NULL_TREE
;
7129 /* Array pointer. Find the last reference on the LHS and if it is an
7130 array section ref, we're dealing with bounds remapping. In this case,
7131 set it to AR_FULL so that gfc_conv_expr_descriptor does
7132 not see it and process the bounds remapping afterwards explicitly. */
7133 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7134 if (!remap
->next
&& remap
->type
== REF_ARRAY
7135 && remap
->u
.ar
.type
== AR_SECTION
)
7137 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7139 gfc_init_se (&lse
, NULL
);
7141 lse
.descriptor_only
= 1;
7142 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7143 && expr1
->ts
.type
== BT_CLASS
)
7144 expr1_vptr
= gfc_copy_expr (expr1
);
7145 gfc_conv_expr_descriptor (&lse
, expr1
);
7146 strlen_lhs
= lse
.string_length
;
7149 if (expr2
->expr_type
== EXPR_NULL
)
7151 /* Just set the data pointer to null. */
7152 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7154 else if (rank_remap
)
7156 /* If we are rank-remapping, just get the RHS's descriptor and
7157 process this later on. */
7158 gfc_init_se (&rse
, NULL
);
7159 rse
.direct_byref
= 1;
7160 rse
.byref_noassign
= 1;
7162 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7164 gfc_conv_function_expr (&rse
, expr2
);
7166 if (expr1
->ts
.type
!= BT_CLASS
)
7167 rse
.expr
= gfc_class_data_get (rse
.expr
);
7170 gfc_add_block_to_block (&block
, &rse
.pre
);
7171 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7172 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7174 gfc_add_vptr_component (expr1_vptr
);
7175 gfc_init_se (&rse
, NULL
);
7176 rse
.want_pointer
= 1;
7177 gfc_conv_expr (&rse
, expr1_vptr
);
7178 gfc_add_modify (&lse
.pre
, rse
.expr
,
7179 fold_convert (TREE_TYPE (rse
.expr
),
7180 gfc_class_vptr_get (tmp
)));
7181 rse
.expr
= gfc_class_data_get (tmp
);
7184 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7186 tree bound
[GFC_MAX_DIMENSIONS
];
7189 for (i
= 0; i
< expr2
->rank
; i
++)
7190 bound
[i
] = NULL_TREE
;
7191 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7192 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7194 GFC_ARRAY_POINTER_CONT
, false);
7195 tmp
= gfc_create_var (tmp
, "ptrtemp");
7197 lse
.direct_byref
= 1;
7198 gfc_conv_expr_descriptor (&lse
, expr2
);
7199 strlen_rhs
= lse
.string_length
;
7204 gfc_conv_expr_descriptor (&rse
, expr2
);
7205 strlen_rhs
= rse
.string_length
;
7208 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7210 /* Assign directly to the LHS's descriptor. */
7211 lse
.direct_byref
= 1;
7212 gfc_conv_expr_descriptor (&lse
, expr2
);
7213 strlen_rhs
= lse
.string_length
;
7215 /* If this is a subreference array pointer assignment, use the rhs
7216 descriptor element size for the lhs span. */
7217 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7219 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7220 gfc_init_se (&rse
, NULL
);
7221 rse
.descriptor_only
= 1;
7222 gfc_conv_expr (&rse
, expr2
);
7223 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7224 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7225 if (!INTEGER_CST_P (tmp
))
7226 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7227 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7230 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7232 gfc_init_se (&rse
, NULL
);
7233 rse
.want_pointer
= 1;
7234 gfc_conv_function_expr (&rse
, expr2
);
7235 if (expr1
->ts
.type
!= BT_CLASS
)
7237 rse
.expr
= gfc_class_data_get (rse
.expr
);
7238 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7242 gfc_add_block_to_block (&block
, &rse
.pre
);
7243 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7244 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7246 gfc_add_vptr_component (expr1_vptr
);
7247 gfc_init_se (&rse
, NULL
);
7248 rse
.want_pointer
= 1;
7249 gfc_conv_expr (&rse
, expr1_vptr
);
7250 gfc_add_modify (&lse
.pre
, rse
.expr
,
7251 fold_convert (TREE_TYPE (rse
.expr
),
7252 gfc_class_vptr_get (tmp
)));
7253 rse
.expr
= gfc_class_data_get (tmp
);
7254 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7259 /* Assign to a temporary descriptor and then copy that
7260 temporary to the pointer. */
7261 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7263 lse
.direct_byref
= 1;
7264 gfc_conv_expr_descriptor (&lse
, expr2
);
7265 strlen_rhs
= lse
.string_length
;
7266 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7270 gfc_free_expr (expr1_vptr
);
7272 gfc_add_block_to_block (&block
, &lse
.pre
);
7274 gfc_add_block_to_block (&block
, &rse
.pre
);
7276 /* If we do bounds remapping, update LHS descriptor accordingly. */
7280 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7284 /* Do rank remapping. We already have the RHS's descriptor
7285 converted in rse and now have to build the correct LHS
7286 descriptor for it. */
7290 tree lbound
, ubound
;
7293 dtype
= gfc_conv_descriptor_dtype (desc
);
7294 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7295 gfc_add_modify (&block
, dtype
, tmp
);
7297 /* Copy data pointer. */
7298 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7299 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7301 /* Copy offset but adjust it such that it would correspond
7302 to a lbound of zero. */
7303 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7304 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7306 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7308 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7310 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7311 gfc_array_index_type
, stride
, lbound
);
7312 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7313 gfc_array_index_type
, offs
, tmp
);
7315 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7317 /* Set the bounds as declared for the LHS and calculate strides as
7318 well as another offset update accordingly. */
7319 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7321 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7326 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7328 /* Convert declared bounds. */
7329 gfc_init_se (&lower_se
, NULL
);
7330 gfc_init_se (&upper_se
, NULL
);
7331 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7332 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7334 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7335 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7337 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7338 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7340 lbound
= gfc_evaluate_now (lbound
, &block
);
7341 ubound
= gfc_evaluate_now (ubound
, &block
);
7343 gfc_add_block_to_block (&block
, &lower_se
.post
);
7344 gfc_add_block_to_block (&block
, &upper_se
.post
);
7346 /* Set bounds in descriptor. */
7347 gfc_conv_descriptor_lbound_set (&block
, desc
,
7348 gfc_rank_cst
[dim
], lbound
);
7349 gfc_conv_descriptor_ubound_set (&block
, desc
,
7350 gfc_rank_cst
[dim
], ubound
);
7353 stride
= gfc_evaluate_now (stride
, &block
);
7354 gfc_conv_descriptor_stride_set (&block
, desc
,
7355 gfc_rank_cst
[dim
], stride
);
7357 /* Update offset. */
7358 offs
= gfc_conv_descriptor_offset_get (desc
);
7359 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7360 gfc_array_index_type
, lbound
, stride
);
7361 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7362 gfc_array_index_type
, offs
, tmp
);
7363 offs
= gfc_evaluate_now (offs
, &block
);
7364 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7366 /* Update stride. */
7367 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7368 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7369 gfc_array_index_type
, stride
, tmp
);
7374 /* Bounds remapping. Just shift the lower bounds. */
7376 gcc_assert (expr1
->rank
== expr2
->rank
);
7378 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7382 gcc_assert (remap
->u
.ar
.start
[dim
]);
7383 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7384 gfc_init_se (&lbound_se
, NULL
);
7385 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7387 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7388 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7389 dim
, lbound_se
.expr
);
7390 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7395 /* Check string lengths if applicable. The check is only really added
7396 to the output code if -fbounds-check is enabled. */
7397 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7399 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7400 gcc_assert (strlen_lhs
&& strlen_rhs
);
7401 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7402 strlen_lhs
, strlen_rhs
, &block
);
7405 /* If rank remapping was done, check with -fcheck=bounds that
7406 the target is at least as large as the pointer. */
7407 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7413 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7414 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7416 lsize
= gfc_evaluate_now (lsize
, &block
);
7417 rsize
= gfc_evaluate_now (rsize
, &block
);
7418 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7421 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7422 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7426 gfc_add_block_to_block (&block
, &lse
.post
);
7428 gfc_add_block_to_block (&block
, &rse
.post
);
7431 return gfc_finish_block (&block
);
7435 /* Makes sure se is suitable for passing as a function string parameter. */
7436 /* TODO: Need to check all callers of this function. It may be abused. */
7439 gfc_conv_string_parameter (gfc_se
* se
)
7443 if (TREE_CODE (se
->expr
) == STRING_CST
)
7445 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7446 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7450 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7452 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7454 type
= TREE_TYPE (se
->expr
);
7455 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7459 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7461 type
= build_pointer_type (type
);
7462 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7466 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
7470 /* Generate code for assignment of scalar variables. Includes character
7471 strings and derived types with allocatable components.
7472 If you know that the LHS has no allocations, set dealloc to false.
7474 DEEP_COPY has no effect if the typespec TS is not a derived type with
7475 allocatable components. Otherwise, if it is set, an explicit copy of each
7476 allocatable component is made. This is necessary as a simple copy of the
7477 whole object would copy array descriptors as is, so that the lhs's
7478 allocatable components would point to the rhs's after the assignment.
7479 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7480 necessary if the rhs is a non-pointer function, as the allocatable components
7481 are not accessible by other means than the function's result after the
7482 function has returned. It is even more subtle when temporaries are involved,
7483 as the two following examples show:
7484 1. When we evaluate an array constructor, a temporary is created. Thus
7485 there is theoretically no alias possible. However, no deep copy is
7486 made for this temporary, so that if the constructor is made of one or
7487 more variable with allocatable components, those components still point
7488 to the variable's: DEEP_COPY should be set for the assignment from the
7489 temporary to the lhs in that case.
7490 2. When assigning a scalar to an array, we evaluate the scalar value out
7491 of the loop, store it into a temporary variable, and assign from that.
7492 In that case, deep copying when assigning to the temporary would be a
7493 waste of resources; however deep copies should happen when assigning from
7494 the temporary to each array element: again DEEP_COPY should be set for
7495 the assignment from the temporary to the lhs. */
7498 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7499 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7505 gfc_init_block (&block
);
7507 if (ts
.type
== BT_CHARACTER
)
7512 if (lse
->string_length
!= NULL_TREE
)
7514 gfc_conv_string_parameter (lse
);
7515 gfc_add_block_to_block (&block
, &lse
->pre
);
7516 llen
= lse
->string_length
;
7519 if (rse
->string_length
!= NULL_TREE
)
7521 gcc_assert (rse
->string_length
!= NULL_TREE
);
7522 gfc_conv_string_parameter (rse
);
7523 gfc_add_block_to_block (&block
, &rse
->pre
);
7524 rlen
= rse
->string_length
;
7527 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7528 rse
->expr
, ts
.kind
);
7530 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7532 tree tmp_var
= NULL_TREE
;
7535 /* Are the rhs and the lhs the same? */
7538 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7539 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7540 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7541 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7544 /* Deallocate the lhs allocated components as long as it is not
7545 the same as the rhs. This must be done following the assignment
7546 to prevent deallocating data that could be used in the rhs
7548 if (!l_is_temp
&& dealloc
)
7550 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7551 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7553 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7555 gfc_add_expr_to_block (&lse
->post
, tmp
);
7558 gfc_add_block_to_block (&block
, &rse
->pre
);
7559 gfc_add_block_to_block (&block
, &lse
->pre
);
7561 gfc_add_modify (&block
, lse
->expr
,
7562 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7564 /* Restore pointer address of coarray components. */
7565 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7567 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7568 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7570 gfc_add_expr_to_block (&block
, tmp
);
7573 /* Do a deep copy if the rhs is a variable, if it is not the
7577 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7578 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7580 gfc_add_expr_to_block (&block
, tmp
);
7583 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7585 gfc_add_block_to_block (&block
, &lse
->pre
);
7586 gfc_add_block_to_block (&block
, &rse
->pre
);
7587 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7588 TREE_TYPE (lse
->expr
), rse
->expr
);
7589 gfc_add_modify (&block
, lse
->expr
, tmp
);
7593 gfc_add_block_to_block (&block
, &lse
->pre
);
7594 gfc_add_block_to_block (&block
, &rse
->pre
);
7596 gfc_add_modify (&block
, lse
->expr
,
7597 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7600 gfc_add_block_to_block (&block
, &lse
->post
);
7601 gfc_add_block_to_block (&block
, &rse
->post
);
7603 return gfc_finish_block (&block
);
7607 /* There are quite a lot of restrictions on the optimisation in using an
7608 array function assign without a temporary. */
7611 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7614 bool seen_array_ref
;
7616 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7618 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7619 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7622 /* Elemental functions are scalarized so that they don't need a
7623 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7624 they would need special treatment in gfc_trans_arrayfunc_assign. */
7625 if (expr2
->value
.function
.esym
!= NULL
7626 && expr2
->value
.function
.esym
->attr
.elemental
)
7629 /* Need a temporary if rhs is not FULL or a contiguous section. */
7630 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7633 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7634 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7637 /* Functions returning pointers or allocatables need temporaries. */
7638 c
= expr2
->value
.function
.esym
7639 ? (expr2
->value
.function
.esym
->attr
.pointer
7640 || expr2
->value
.function
.esym
->attr
.allocatable
)
7641 : (expr2
->symtree
->n
.sym
->attr
.pointer
7642 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7646 /* Character array functions need temporaries unless the
7647 character lengths are the same. */
7648 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7650 if (expr1
->ts
.u
.cl
->length
== NULL
7651 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7654 if (expr2
->ts
.u
.cl
->length
== NULL
7655 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7658 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7659 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7663 /* Check that no LHS component references appear during an array
7664 reference. This is needed because we do not have the means to
7665 span any arbitrary stride with an array descriptor. This check
7666 is not needed for the rhs because the function result has to be
7668 seen_array_ref
= false;
7669 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7671 if (ref
->type
== REF_ARRAY
)
7672 seen_array_ref
= true;
7673 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7677 /* Check for a dependency. */
7678 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7679 expr2
->value
.function
.esym
,
7680 expr2
->value
.function
.actual
,
7684 /* If we have reached here with an intrinsic function, we do not
7685 need a temporary except in the particular case that reallocation
7686 on assignment is active and the lhs is allocatable and a target. */
7687 if (expr2
->value
.function
.isym
)
7688 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
7690 /* If the LHS is a dummy, we need a temporary if it is not
7692 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7695 /* If the lhs has been host_associated, is in common, a pointer or is
7696 a target and the function is not using a RESULT variable, aliasing
7697 can occur and a temporary is needed. */
7698 if ((sym
->attr
.host_assoc
7699 || sym
->attr
.in_common
7700 || sym
->attr
.pointer
7701 || sym
->attr
.cray_pointee
7702 || sym
->attr
.target
)
7703 && expr2
->symtree
!= NULL
7704 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7707 /* A PURE function can unconditionally be called without a temporary. */
7708 if (expr2
->value
.function
.esym
!= NULL
7709 && expr2
->value
.function
.esym
->attr
.pure
)
7712 /* Implicit_pure functions are those which could legally be declared
7714 if (expr2
->value
.function
.esym
!= NULL
7715 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7718 if (!sym
->attr
.use_assoc
7719 && !sym
->attr
.in_common
7720 && !sym
->attr
.pointer
7721 && !sym
->attr
.target
7722 && !sym
->attr
.cray_pointee
7723 && expr2
->value
.function
.esym
)
7725 /* A temporary is not needed if the function is not contained and
7726 the variable is local or host associated and not a pointer or
7728 if (!expr2
->value
.function
.esym
->attr
.contained
)
7731 /* A temporary is not needed if the lhs has never been host
7732 associated and the procedure is contained. */
7733 else if (!sym
->attr
.host_assoc
)
7736 /* A temporary is not needed if the variable is local and not
7737 a pointer, a target or a result. */
7739 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7743 /* Default to temporary use. */
7748 /* Provide the loop info so that the lhs descriptor can be built for
7749 reallocatable assignments from extrinsic function calls. */
7752 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7755 /* Signal that the function call should not be made by
7756 gfc_conv_loop_setup. */
7757 se
->ss
->is_alloc_lhs
= 1;
7758 gfc_init_loopinfo (loop
);
7759 gfc_add_ss_to_loop (loop
, *ss
);
7760 gfc_add_ss_to_loop (loop
, se
->ss
);
7761 gfc_conv_ss_startstride (loop
);
7762 gfc_conv_loop_setup (loop
, where
);
7763 gfc_copy_loopinfo_to_se (se
, loop
);
7764 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7765 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7766 se
->ss
->is_alloc_lhs
= 0;
7770 /* For assignment to a reallocatable lhs from intrinsic functions,
7771 replace the se.expr (ie. the result) with a temporary descriptor.
7772 Null the data field so that the library allocates space for the
7773 result. Free the data of the original descriptor after the function,
7774 in case it appears in an argument expression and transfer the
7775 result to the original descriptor. */
7778 fcncall_realloc_result (gfc_se
*se
, int rank
)
7787 /* Use the allocation done by the library. Substitute the lhs
7788 descriptor with a copy, whose data field is nulled.*/
7789 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7790 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7791 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7793 /* Unallocated, the descriptor does not have a dtype. */
7794 tmp
= gfc_conv_descriptor_dtype (desc
);
7795 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7797 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7798 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7799 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7801 /* Free the lhs after the function call and copy the result data to
7802 the lhs descriptor. */
7803 tmp
= gfc_conv_descriptor_data_get (desc
);
7804 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7805 boolean_type_node
, tmp
,
7806 build_int_cst (TREE_TYPE (tmp
), 0));
7807 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7808 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7809 gfc_add_expr_to_block (&se
->post
, tmp
);
7811 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7812 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7814 /* Check that the shapes are the same between lhs and expression. */
7815 for (n
= 0 ; n
< rank
; n
++)
7818 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7819 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7820 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7821 gfc_array_index_type
, tmp
, tmp1
);
7822 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7823 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7824 gfc_array_index_type
, tmp
, tmp1
);
7825 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7826 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7827 gfc_array_index_type
, tmp
, tmp1
);
7828 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7829 boolean_type_node
, tmp
,
7830 gfc_index_zero_node
);
7831 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7832 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7833 boolean_type_node
, tmp
,
7837 /* 'zero_cond' being true is equal to lhs not being allocated or the
7838 shapes being different. */
7839 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7841 /* Now reset the bounds returned from the function call to bounds based
7842 on the lhs lbounds, except where the lhs is not allocated or the shapes
7843 of 'variable and 'expr' are different. Set the offset accordingly. */
7844 offset
= gfc_index_zero_node
;
7845 for (n
= 0 ; n
< rank
; n
++)
7849 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7850 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7851 gfc_array_index_type
, zero_cond
,
7852 gfc_index_one_node
, lbound
);
7853 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7855 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7856 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7857 gfc_array_index_type
, tmp
, lbound
);
7858 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7859 gfc_rank_cst
[n
], lbound
);
7860 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7861 gfc_rank_cst
[n
], tmp
);
7863 /* Set stride and accumulate the offset. */
7864 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7865 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7866 gfc_rank_cst
[n
], tmp
);
7867 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7868 gfc_array_index_type
, lbound
, tmp
);
7869 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7870 gfc_array_index_type
, offset
, tmp
);
7871 offset
= gfc_evaluate_now (offset
, &se
->post
);
7874 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7879 /* Try to translate array(:) = func (...), where func is a transformational
7880 array function, without using a temporary. Returns NULL if this isn't the
7884 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7888 gfc_component
*comp
= NULL
;
7891 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7894 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7896 comp
= gfc_get_proc_ptr_comp (expr2
);
7897 gcc_assert (expr2
->value
.function
.isym
7898 || (comp
&& comp
->attr
.dimension
)
7899 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7900 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7902 gfc_init_se (&se
, NULL
);
7903 gfc_start_block (&se
.pre
);
7904 se
.want_pointer
= 1;
7906 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7908 if (expr1
->ts
.type
== BT_DERIVED
7909 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7912 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7914 gfc_add_expr_to_block (&se
.pre
, tmp
);
7917 se
.direct_byref
= 1;
7918 se
.ss
= gfc_walk_expr (expr2
);
7919 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7921 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7922 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7923 Clearly, this cannot be done for an allocatable function result, since
7924 the shape of the result is unknown and, in any case, the function must
7925 correctly take care of the reallocation internally. For intrinsic
7926 calls, the array data is freed and the library takes care of allocation.
7927 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7929 if (flag_realloc_lhs
7930 && gfc_is_reallocatable_lhs (expr1
)
7931 && !gfc_expr_attr (expr1
).codimension
7932 && !gfc_is_coindexed (expr1
)
7933 && !(expr2
->value
.function
.esym
7934 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7936 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7938 if (!expr2
->value
.function
.isym
)
7940 ss
= gfc_walk_expr (expr1
);
7941 gcc_assert (ss
!= gfc_ss_terminator
);
7943 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7944 ss
->is_alloc_lhs
= 1;
7947 fcncall_realloc_result (&se
, expr1
->rank
);
7950 gfc_conv_function_expr (&se
, expr2
);
7951 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7954 gfc_cleanup_loop (&loop
);
7956 gfc_free_ss_chain (se
.ss
);
7958 return gfc_finish_block (&se
.pre
);
7962 /* Try to efficiently translate array(:) = 0. Return NULL if this
7966 gfc_trans_zero_assign (gfc_expr
* expr
)
7968 tree dest
, len
, type
;
7972 sym
= expr
->symtree
->n
.sym
;
7973 dest
= gfc_get_symbol_decl (sym
);
7975 type
= TREE_TYPE (dest
);
7976 if (POINTER_TYPE_P (type
))
7977 type
= TREE_TYPE (type
);
7978 if (!GFC_ARRAY_TYPE_P (type
))
7981 /* Determine the length of the array. */
7982 len
= GFC_TYPE_ARRAY_SIZE (type
);
7983 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7986 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7987 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7988 fold_convert (gfc_array_index_type
, tmp
));
7990 /* If we are zeroing a local array avoid taking its address by emitting
7992 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7993 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7994 dest
, build_constructor (TREE_TYPE (dest
),
7997 /* Convert arguments to the correct types. */
7998 dest
= fold_convert (pvoid_type_node
, dest
);
7999 len
= fold_convert (size_type_node
, len
);
8001 /* Construct call to __builtin_memset. */
8002 tmp
= build_call_expr_loc (input_location
,
8003 builtin_decl_explicit (BUILT_IN_MEMSET
),
8004 3, dest
, integer_zero_node
, len
);
8005 return fold_convert (void_type_node
, tmp
);
8009 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8010 that constructs the call to __builtin_memcpy. */
8013 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8017 /* Convert arguments to the correct types. */
8018 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8019 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8021 dst
= fold_convert (pvoid_type_node
, dst
);
8023 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8024 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8026 src
= fold_convert (pvoid_type_node
, src
);
8028 len
= fold_convert (size_type_node
, len
);
8030 /* Construct call to __builtin_memcpy. */
8031 tmp
= build_call_expr_loc (input_location
,
8032 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8034 return fold_convert (void_type_node
, tmp
);
8038 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8039 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8040 source/rhs, both are gfc_full_array_ref_p which have been checked for
8044 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8046 tree dst
, dlen
, dtype
;
8047 tree src
, slen
, stype
;
8050 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8051 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8053 dtype
= TREE_TYPE (dst
);
8054 if (POINTER_TYPE_P (dtype
))
8055 dtype
= TREE_TYPE (dtype
);
8056 stype
= TREE_TYPE (src
);
8057 if (POINTER_TYPE_P (stype
))
8058 stype
= TREE_TYPE (stype
);
8060 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8063 /* Determine the lengths of the arrays. */
8064 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8065 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8067 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8068 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8069 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8071 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8072 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8074 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8075 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8076 slen
, fold_convert (gfc_array_index_type
, tmp
));
8078 /* Sanity check that they are the same. This should always be
8079 the case, as we should already have checked for conformance. */
8080 if (!tree_int_cst_equal (slen
, dlen
))
8083 return gfc_build_memcpy_call (dst
, src
, dlen
);
8087 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8088 this can't be done. EXPR1 is the destination/lhs for which
8089 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8092 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8094 unsigned HOST_WIDE_INT nelem
;
8100 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8104 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8105 dtype
= TREE_TYPE (dst
);
8106 if (POINTER_TYPE_P (dtype
))
8107 dtype
= TREE_TYPE (dtype
);
8108 if (!GFC_ARRAY_TYPE_P (dtype
))
8111 /* Determine the lengths of the array. */
8112 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8113 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8116 /* Confirm that the constructor is the same size. */
8117 if (compare_tree_int (len
, nelem
) != 0)
8120 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8121 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8122 fold_convert (gfc_array_index_type
, tmp
));
8124 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8125 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8127 stype
= TREE_TYPE (src
);
8128 if (POINTER_TYPE_P (stype
))
8129 stype
= TREE_TYPE (stype
);
8131 return gfc_build_memcpy_call (dst
, src
, len
);
8135 /* Tells whether the expression is to be treated as a variable reference. */
8138 expr_is_variable (gfc_expr
*expr
)
8141 gfc_component
*comp
;
8142 gfc_symbol
*func_ifc
;
8144 if (expr
->expr_type
== EXPR_VARIABLE
)
8147 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8150 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8151 return expr_is_variable (arg
);
8154 /* A data-pointer-returning function should be considered as a variable
8156 if (expr
->expr_type
== EXPR_FUNCTION
8157 && expr
->ref
== NULL
)
8159 if (expr
->value
.function
.isym
!= NULL
)
8162 if (expr
->value
.function
.esym
!= NULL
)
8164 func_ifc
= expr
->value
.function
.esym
;
8169 gcc_assert (expr
->symtree
);
8170 func_ifc
= expr
->symtree
->n
.sym
;
8177 comp
= gfc_get_proc_ptr_comp (expr
);
8178 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8181 func_ifc
= comp
->ts
.interface
;
8185 if (expr
->expr_type
== EXPR_COMPCALL
)
8187 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8188 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8195 gcc_assert (func_ifc
->attr
.function
8196 && func_ifc
->result
!= NULL
);
8197 return func_ifc
->result
->attr
.pointer
;
8201 /* Is the lhs OK for automatic reallocation? */
8204 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8208 /* An allocatable variable with no reference. */
8209 if (expr
->symtree
->n
.sym
->attr
.allocatable
8213 /* All that can be left are allocatable components. */
8214 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8215 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8216 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8219 /* Find an allocatable component ref last. */
8220 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8221 if (ref
->type
== REF_COMPONENT
8223 && ref
->u
.c
.component
->attr
.allocatable
)
8230 /* Allocate or reallocate scalar lhs, as necessary. */
8233 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8247 if (!expr1
|| expr1
->rank
)
8250 if (!expr2
|| expr2
->rank
)
8253 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8255 /* Since this is a scalar lhs, we can afford to do this. That is,
8256 there is no risk of side effects being repeated. */
8257 gfc_init_se (&lse
, NULL
);
8258 lse
.want_pointer
= 1;
8259 gfc_conv_expr (&lse
, expr1
);
8261 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8262 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8264 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8265 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8266 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8268 tmp
= build3_v (COND_EXPR
, cond
,
8269 build1_v (GOTO_EXPR
, jump_label1
),
8270 build_empty_stmt (input_location
));
8271 gfc_add_expr_to_block (block
, tmp
);
8273 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8275 /* Use the rhs string length and the lhs element size. */
8276 size
= string_length
;
8277 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8278 tmp
= TYPE_SIZE_UNIT (tmp
);
8279 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8280 TREE_TYPE (tmp
), tmp
,
8281 fold_convert (TREE_TYPE (tmp
), size
));
8285 /* Otherwise use the length in bytes of the rhs. */
8286 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8287 size_in_bytes
= size
;
8290 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8291 size_in_bytes
, size_one_node
);
8293 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8295 tmp
= build_call_expr_loc (input_location
,
8296 builtin_decl_explicit (BUILT_IN_CALLOC
),
8297 2, build_one_cst (size_type_node
),
8299 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8300 gfc_add_modify (block
, lse
.expr
, tmp
);
8304 tmp
= build_call_expr_loc (input_location
,
8305 builtin_decl_explicit (BUILT_IN_MALLOC
),
8307 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8308 gfc_add_modify (block
, lse
.expr
, tmp
);
8311 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8313 /* Deferred characters need checking for lhs and rhs string
8314 length. Other deferred parameter variables will have to
8316 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8317 gfc_add_expr_to_block (block
, tmp
);
8319 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8320 gfc_add_expr_to_block (block
, tmp
);
8322 /* For a deferred length character, reallocate if lengths of lhs and
8323 rhs are different. */
8324 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8326 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8327 expr1
->ts
.u
.cl
->backend_decl
, size
);
8328 /* Jump past the realloc if the lengths are the same. */
8329 tmp
= build3_v (COND_EXPR
, cond
,
8330 build1_v (GOTO_EXPR
, jump_label2
),
8331 build_empty_stmt (input_location
));
8332 gfc_add_expr_to_block (block
, tmp
);
8333 tmp
= build_call_expr_loc (input_location
,
8334 builtin_decl_explicit (BUILT_IN_REALLOC
),
8335 2, fold_convert (pvoid_type_node
, lse
.expr
),
8337 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8338 gfc_add_modify (block
, lse
.expr
, tmp
);
8339 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8340 gfc_add_expr_to_block (block
, tmp
);
8342 /* Update the lhs character length. */
8343 size
= string_length
;
8344 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8345 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
8347 gfc_add_modify (block
, lse
.string_length
, size
);
8351 /* Check for assignments of the type
8355 to make sure we do not check for reallocation unneccessarily. */
8359 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8361 gfc_actual_arglist
*a
;
8364 switch (expr2
->expr_type
)
8367 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8370 if (expr2
->value
.function
.esym
8371 && expr2
->value
.function
.esym
->attr
.elemental
)
8373 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8376 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8381 else if (expr2
->value
.function
.isym
8382 && expr2
->value
.function
.isym
->elemental
)
8384 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8387 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8396 switch (expr2
->value
.op
.op
)
8399 case INTRINSIC_UPLUS
:
8400 case INTRINSIC_UMINUS
:
8401 case INTRINSIC_PARENTHESES
:
8402 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8404 case INTRINSIC_PLUS
:
8405 case INTRINSIC_MINUS
:
8406 case INTRINSIC_TIMES
:
8407 case INTRINSIC_DIVIDE
:
8408 case INTRINSIC_POWER
:
8412 case INTRINSIC_NEQV
:
8419 case INTRINSIC_EQ_OS
:
8420 case INTRINSIC_NE_OS
:
8421 case INTRINSIC_GT_OS
:
8422 case INTRINSIC_GE_OS
:
8423 case INTRINSIC_LT_OS
:
8424 case INTRINSIC_LE_OS
:
8426 e1
= expr2
->value
.op
.op1
;
8427 e2
= expr2
->value
.op
.op2
;
8429 if (e1
->rank
== 0 && e2
->rank
> 0)
8430 return is_runtime_conformable (expr1
, e2
);
8431 else if (e1
->rank
> 0 && e2
->rank
== 0)
8432 return is_runtime_conformable (expr1
, e1
);
8433 else if (e1
->rank
> 0 && e2
->rank
> 0)
8434 return is_runtime_conformable (expr1
, e1
)
8435 && is_runtime_conformable (expr1
, e2
);
8451 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8452 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8453 init_flag indicates initialization expressions and dealloc that no
8454 deallocate prior assignment is needed (if in doubt, set true). */
8457 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8463 gfc_ss
*lss_section
;
8470 bool scalar_to_array
;
8474 /* Assignment of the form lhs = rhs. */
8475 gfc_start_block (&block
);
8477 gfc_init_se (&lse
, NULL
);
8478 gfc_init_se (&rse
, NULL
);
8481 lss
= gfc_walk_expr (expr1
);
8482 if (gfc_is_reallocatable_lhs (expr1
)
8483 && !(expr2
->expr_type
== EXPR_FUNCTION
8484 && expr2
->value
.function
.isym
!= NULL
))
8485 lss
->is_alloc_lhs
= 1;
8487 if (lss
!= gfc_ss_terminator
)
8489 /* The assignment needs scalarization. */
8492 /* Find a non-scalar SS from the lhs. */
8493 while (lss_section
!= gfc_ss_terminator
8494 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8495 lss_section
= lss_section
->next
;
8497 gcc_assert (lss_section
!= gfc_ss_terminator
);
8499 /* Initialize the scalarizer. */
8500 gfc_init_loopinfo (&loop
);
8503 rss
= gfc_walk_expr (expr2
);
8504 if (rss
== gfc_ss_terminator
)
8505 /* The rhs is scalar. Add a ss for the expression. */
8506 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8508 /* Associate the SS with the loop. */
8509 gfc_add_ss_to_loop (&loop
, lss
);
8510 gfc_add_ss_to_loop (&loop
, rss
);
8512 /* Calculate the bounds of the scalarization. */
8513 gfc_conv_ss_startstride (&loop
);
8514 /* Enable loop reversal. */
8515 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8516 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8517 /* Resolve any data dependencies in the statement. */
8518 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8519 /* Setup the scalarizing loops. */
8520 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8522 /* Setup the gfc_se structures. */
8523 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8524 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8527 gfc_mark_ss_chain_used (rss
, 1);
8528 if (loop
.temp_ss
== NULL
)
8531 gfc_mark_ss_chain_used (lss
, 1);
8535 lse
.ss
= loop
.temp_ss
;
8536 gfc_mark_ss_chain_used (lss
, 3);
8537 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8540 /* Allow the scalarizer to workshare array assignments. */
8541 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8542 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8544 /* Start the scalarized loop body. */
8545 gfc_start_scalarized_body (&loop
, &body
);
8548 gfc_init_block (&body
);
8550 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8552 /* Translate the expression. */
8553 gfc_conv_expr (&rse
, expr2
);
8555 /* Stabilize a string length for temporaries. */
8556 if (expr2
->ts
.type
== BT_CHARACTER
)
8557 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8559 string_length
= NULL_TREE
;
8563 gfc_conv_tmp_array_ref (&lse
);
8564 if (expr2
->ts
.type
== BT_CHARACTER
)
8565 lse
.string_length
= string_length
;
8568 gfc_conv_expr (&lse
, expr1
);
8570 /* Assignments of scalar derived types with allocatable components
8571 to arrays must be done with a deep copy and the rhs temporary
8572 must have its components deallocated afterwards. */
8573 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8574 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8575 && !expr_is_variable (expr2
)
8576 && !gfc_is_constant_expr (expr2
)
8577 && expr1
->rank
&& !expr2
->rank
);
8578 if (scalar_to_array
&& dealloc
)
8580 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8581 gfc_add_expr_to_block (&loop
.post
, tmp
);
8584 /* When assigning a character function result to a deferred-length variable,
8585 the function call must happen before the (re)allocation of the lhs -
8586 otherwise the character length of the result is not known.
8587 NOTE: This relies on having the exact dependence of the length type
8588 parameter available to the caller; gfortran saves it in the .mod files. */
8589 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8590 gfc_add_block_to_block (&block
, &rse
.pre
);
8592 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8593 l_is_temp
|| init_flag
,
8594 expr_is_variable (expr2
) || scalar_to_array
8595 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8596 gfc_add_expr_to_block (&body
, tmp
);
8598 if (lss
== gfc_ss_terminator
)
8600 /* F2003: Add the code for reallocation on assignment. */
8601 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
8602 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8605 /* Use the scalar assignment as is. */
8606 gfc_add_block_to_block (&block
, &body
);
8610 gcc_assert (lse
.ss
== gfc_ss_terminator
8611 && rse
.ss
== gfc_ss_terminator
);
8615 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8617 /* We need to copy the temporary to the actual lhs. */
8618 gfc_init_se (&lse
, NULL
);
8619 gfc_init_se (&rse
, NULL
);
8620 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8621 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8623 rse
.ss
= loop
.temp_ss
;
8626 gfc_conv_tmp_array_ref (&rse
);
8627 gfc_conv_expr (&lse
, expr1
);
8629 gcc_assert (lse
.ss
== gfc_ss_terminator
8630 && rse
.ss
== gfc_ss_terminator
);
8632 if (expr2
->ts
.type
== BT_CHARACTER
)
8633 rse
.string_length
= string_length
;
8635 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8636 false, false, dealloc
);
8637 gfc_add_expr_to_block (&body
, tmp
);
8640 /* F2003: Allocate or reallocate lhs of allocatable array. */
8641 if (flag_realloc_lhs
8642 && gfc_is_reallocatable_lhs (expr1
)
8643 && !gfc_expr_attr (expr1
).codimension
8644 && !gfc_is_coindexed (expr1
)
8646 && !is_runtime_conformable (expr1
, expr2
))
8648 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8649 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8650 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8651 if (tmp
!= NULL_TREE
)
8652 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8655 /* Generate the copying loops. */
8656 gfc_trans_scalarizing_loops (&loop
, &body
);
8658 /* Wrap the whole thing up. */
8659 gfc_add_block_to_block (&block
, &loop
.pre
);
8660 gfc_add_block_to_block (&block
, &loop
.post
);
8662 gfc_cleanup_loop (&loop
);
8665 return gfc_finish_block (&block
);
8669 /* Check whether EXPR is a copyable array. */
8672 copyable_array_p (gfc_expr
* expr
)
8674 if (expr
->expr_type
!= EXPR_VARIABLE
)
8677 /* First check it's an array. */
8678 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8681 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8684 /* Next check that it's of a simple enough type. */
8685 switch (expr
->ts
.type
)
8697 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8706 /* Translate an assignment. */
8709 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8714 /* Special case a single function returning an array. */
8715 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8717 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8722 /* Special case assigning an array to zero. */
8723 if (copyable_array_p (expr1
)
8724 && is_zero_initializer_p (expr2
))
8726 tmp
= gfc_trans_zero_assign (expr1
);
8731 /* Special case copying one array to another. */
8732 if (copyable_array_p (expr1
)
8733 && copyable_array_p (expr2
)
8734 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8735 && !gfc_check_dependency (expr1
, expr2
, 0))
8737 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8742 /* Special case initializing an array from a constant array constructor. */
8743 if (copyable_array_p (expr1
)
8744 && expr2
->expr_type
== EXPR_ARRAY
8745 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8747 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8752 /* Fallback to the scalarizer to generate explicit loops. */
8753 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8757 gfc_trans_init_assign (gfc_code
* code
)
8759 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8763 gfc_trans_assign (gfc_code
* code
)
8765 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);