1 /* Expression translation
2 Copyright (C) 2002-2013 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"
28 #include "diagnostic-core.h" /* For fatal_error. */
29 #include "langhooks.h"
33 #include "constructor.h"
35 #include "trans-const.h"
36 #include "trans-types.h"
37 #include "trans-array.h"
38 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
39 #include "trans-stmt.h"
40 #include "dependency.h"
43 /* Convert a scalar to an array descriptor. To be used for assumed-rank
47 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
49 enum gfc_array_kind akind
;
52 akind
= GFC_ARRAY_POINTER_CONT
;
53 else if (attr
.allocatable
)
54 akind
= GFC_ARRAY_ALLOCATABLE
;
56 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
58 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
59 akind
, !(attr
.pointer
|| attr
.target
));
63 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
67 type
= get_scalar_to_descriptor_type (scalar
, attr
);
68 desc
= gfc_create_var (type
, "desc");
69 DECL_ARTIFICIAL (desc
) = 1;
70 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
71 gfc_get_dtype (type
));
72 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
74 /* Copy pointer address back - but only if it could have changed and
75 if the actual argument is a pointer and not, e.g., NULL(). */
76 if ((attr
.pointer
|| attr
.allocatable
)
77 && attr
.intent
!= INTENT_IN
&& POINTER_TYPE_P (TREE_TYPE (scalar
)))
78 gfc_add_modify (&se
->post
, scalar
,
79 fold_convert (TREE_TYPE (scalar
),
80 gfc_conv_descriptor_data_get (desc
)));
85 /* This is the seed for an eventual trans-class.c
87 The following parameters should not be used directly since they might
88 in future implementations. Use the corresponding APIs. */
89 #define CLASS_DATA_FIELD 0
90 #define CLASS_VPTR_FIELD 1
91 #define VTABLE_HASH_FIELD 0
92 #define VTABLE_SIZE_FIELD 1
93 #define VTABLE_EXTENDS_FIELD 2
94 #define VTABLE_DEF_INIT_FIELD 3
95 #define VTABLE_COPY_FIELD 4
96 #define VTABLE_FINAL_FIELD 5
100 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
104 vec
<constructor_elt
, va_gc
> *init
= NULL
;
106 field
= TYPE_FIELDS (TREE_TYPE (decl
));
107 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
108 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
110 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
111 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
113 return build_constructor (TREE_TYPE (decl
), init
);
118 gfc_class_data_get (tree decl
)
121 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
122 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
123 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
125 return fold_build3_loc (input_location
, COMPONENT_REF
,
126 TREE_TYPE (data
), decl
, data
,
132 gfc_class_vptr_get (tree decl
)
135 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
136 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
137 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
139 return fold_build3_loc (input_location
, COMPONENT_REF
,
140 TREE_TYPE (vptr
), decl
, vptr
,
146 gfc_vtable_field_get (tree decl
, int field
)
150 vptr
= gfc_class_vptr_get (decl
);
151 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
152 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
154 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
155 TREE_TYPE (size
), vptr
, size
,
157 /* Always return size as an array index type. */
158 if (field
== VTABLE_SIZE_FIELD
)
159 size
= fold_convert (gfc_array_index_type
, size
);
166 gfc_vtable_hash_get (tree decl
)
168 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
173 gfc_vtable_size_get (tree decl
)
175 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
180 gfc_vtable_extends_get (tree decl
)
182 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
187 gfc_vtable_def_init_get (tree decl
)
189 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
194 gfc_vtable_copy_get (tree decl
)
196 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
201 gfc_vtable_final_get (tree decl
)
203 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
207 #undef CLASS_DATA_FIELD
208 #undef CLASS_VPTR_FIELD
209 #undef VTABLE_HASH_FIELD
210 #undef VTABLE_SIZE_FIELD
211 #undef VTABLE_EXTENDS_FIELD
212 #undef VTABLE_DEF_INIT_FIELD
213 #undef VTABLE_COPY_FIELD
214 #undef VTABLE_FINAL_FIELD
217 /* Reset the vptr to the declared type, e.g. after deallocation. */
220 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
222 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
227 /* If we have a class array, we need go back to the class
229 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
230 && lhs
->ref
->next
->type
== REF_ARRAY
231 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
232 && lhs
->ref
->type
== REF_COMPONENT
233 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
235 gfc_free_ref_list (lhs
->ref
);
239 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
240 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
241 && ref
->next
->next
->type
== REF_ARRAY
242 && ref
->next
->next
->u
.ar
.type
== AR_FULL
243 && ref
->next
->type
== REF_COMPONENT
244 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
246 gfc_free_ref_list (ref
->next
);
250 gfc_add_vptr_component (lhs
);
252 if (UNLIMITED_POLY (e
))
253 rhs
= gfc_get_null_expr (NULL
);
256 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
257 rhs
= gfc_lval_expr_from_sym (vtab
);
259 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
260 gfc_add_expr_to_block (block
, tmp
);
266 /* Obtain the vptr of the last class reference in an expression.
267 Return NULL_TREE if no class reference is found. */
270 gfc_get_vptr_from_expr (tree expr
)
275 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
277 type
= TREE_TYPE (tmp
);
280 if (GFC_CLASS_TYPE_P (type
))
281 return gfc_class_vptr_get (tmp
);
282 if (type
!= TYPE_CANONICAL (type
))
283 type
= TYPE_CANONICAL (type
);
287 if (TREE_CODE (tmp
) == VAR_DECL
)
295 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
298 tree tmp
, tmp2
, type
;
300 gfc_conv_descriptor_data_set (block
, lhs_desc
,
301 gfc_conv_descriptor_data_get (rhs_desc
));
302 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
303 gfc_conv_descriptor_offset_get (rhs_desc
));
305 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
306 gfc_conv_descriptor_dtype (rhs_desc
));
308 /* Assign the dimension as range-ref. */
309 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
310 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
312 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
313 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
314 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
315 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
316 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
317 gfc_add_modify (block
, tmp
, tmp2
);
321 /* Takes a derived type expression and returns the address of a temporary
322 class object of the 'declared' type. If vptr is not NULL, this is
323 used for the temporary class object.
324 optional_alloc_ptr is false when the dummy is neither allocatable
325 nor a pointer; that's only relevant for the optional handling. */
327 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
328 gfc_typespec class_ts
, tree vptr
, bool optional
,
329 bool optional_alloc_ptr
)
332 tree cond_optional
= NULL_TREE
;
338 /* The derived type needs to be converted to a temporary
340 tmp
= gfc_typenode_for_spec (&class_ts
);
341 var
= gfc_create_var (tmp
, "class");
344 ctree
= gfc_class_vptr_get (var
);
346 if (vptr
!= NULL_TREE
)
348 /* Use the dynamic vptr. */
353 /* In this case the vtab corresponds to the derived type and the
354 vptr must point to it. */
355 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
357 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
359 gfc_add_modify (&parmse
->pre
, ctree
,
360 fold_convert (TREE_TYPE (ctree
), tmp
));
362 /* Now set the data field. */
363 ctree
= gfc_class_data_get (var
);
366 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
368 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
370 /* For an array reference in an elemental procedure call we need
371 to retain the ss to provide the scalarized array reference. */
372 gfc_conv_expr_reference (parmse
, e
);
373 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
375 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
377 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
378 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
383 ss
= gfc_walk_expr (e
);
384 if (ss
== gfc_ss_terminator
)
387 gfc_conv_expr_reference (parmse
, e
);
389 /* Scalar to an assumed-rank array. */
390 if (class_ts
.u
.derived
->components
->as
)
393 type
= get_scalar_to_descriptor_type (parmse
->expr
,
395 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
396 gfc_get_dtype (type
));
398 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
399 TREE_TYPE (parmse
->expr
),
400 cond_optional
, parmse
->expr
,
401 fold_convert (TREE_TYPE (parmse
->expr
),
403 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
407 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
409 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
411 fold_convert (TREE_TYPE (tmp
),
413 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
419 gfc_init_block (&block
);
422 gfc_conv_expr_descriptor (parmse
, e
);
424 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
425 class_array_data_assign (&block
, ctree
, parmse
->expr
, true);
428 if (gfc_expr_attr (e
).codimension
)
429 parmse
->expr
= fold_build1_loc (input_location
,
433 gfc_add_modify (&block
, ctree
, parmse
->expr
);
438 tmp
= gfc_finish_block (&block
);
440 gfc_init_block (&block
);
441 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
443 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
444 gfc_finish_block (&block
));
445 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
448 gfc_add_block_to_block (&parmse
->pre
, &block
);
452 /* Pass the address of the class object. */
453 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
455 if (optional
&& optional_alloc_ptr
)
456 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
457 TREE_TYPE (parmse
->expr
),
458 cond_optional
, parmse
->expr
,
459 fold_convert (TREE_TYPE (parmse
->expr
),
464 /* Create a new class container, which is required as scalar coarrays
465 have an array descriptor while normal scalars haven't. Optionally,
466 NULL pointer checks are added if the argument is OPTIONAL. */
469 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
470 gfc_typespec class_ts
, bool optional
)
472 tree var
, ctree
, tmp
;
477 gfc_init_block (&block
);
480 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
482 if (ref
->type
== REF_COMPONENT
483 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
487 if (class_ref
== NULL
488 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
489 tmp
= e
->symtree
->n
.sym
->backend_decl
;
492 /* Remove everything after the last class reference, convert the
493 expression and then recover its tailend once more. */
495 ref
= class_ref
->next
;
496 class_ref
->next
= NULL
;
497 gfc_init_se (&tmpse
, NULL
);
498 gfc_conv_expr (&tmpse
, e
);
499 class_ref
->next
= ref
;
503 var
= gfc_typenode_for_spec (&class_ts
);
504 var
= gfc_create_var (var
, "class");
506 ctree
= gfc_class_vptr_get (var
);
507 gfc_add_modify (&block
, ctree
,
508 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
510 ctree
= gfc_class_data_get (var
);
511 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
512 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
514 /* Pass the address of the class object. */
515 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
519 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
522 tmp
= gfc_finish_block (&block
);
524 gfc_init_block (&block
);
525 tmp2
= gfc_class_data_get (var
);
526 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
528 tmp2
= gfc_finish_block (&block
);
530 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
532 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
535 gfc_add_block_to_block (&parmse
->pre
, &block
);
539 /* Takes an intrinsic type expression and returns the address of a temporary
540 class object of the 'declared' type. */
542 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
543 gfc_typespec class_ts
)
551 /* The intrinsic type needs to be converted to a temporary
553 tmp
= gfc_typenode_for_spec (&class_ts
);
554 var
= gfc_create_var (tmp
, "class");
557 ctree
= gfc_class_vptr_get (var
);
559 vtab
= gfc_find_intrinsic_vtab (&e
->ts
);
561 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
562 gfc_add_modify (&parmse
->pre
, ctree
,
563 fold_convert (TREE_TYPE (ctree
), tmp
));
565 /* Now set the data field. */
566 ctree
= gfc_class_data_get (var
);
567 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
569 /* For an array reference in an elemental procedure call we need
570 to retain the ss to provide the scalarized array reference. */
571 gfc_conv_expr_reference (parmse
, e
);
572 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
573 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
577 ss
= gfc_walk_expr (e
);
578 if (ss
== gfc_ss_terminator
)
581 gfc_conv_expr_reference (parmse
, e
);
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
588 gfc_conv_expr_descriptor (parmse
, e
);
589 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
593 /* Pass the address of the class object. */
594 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
598 /* Takes a scalarized class array expression and returns the
599 address of a temporary scalar class object of the 'declared'
601 OOP-TODO: This could be improved by adding code that branched on
602 the dynamic type being the same as the declared type. In this case
603 the original class expression can be passed directly.
604 optional_alloc_ptr is false when the dummy is neither allocatable
605 nor a pointer; that's relevant for the optional handling.
606 Set copyback to true if class container's _data and _vtab pointers
607 might get modified. */
610 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
611 bool elemental
, bool copyback
, bool optional
,
612 bool optional_alloc_ptr
)
618 tree cond
= NULL_TREE
;
622 bool full_array
= false;
624 gfc_init_block (&block
);
627 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
629 if (ref
->type
== REF_COMPONENT
630 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
633 if (ref
->next
== NULL
)
637 if ((ref
== NULL
|| class_ref
== ref
)
638 && (!class_ts
.u
.derived
->components
->as
639 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
642 /* Test for FULL_ARRAY. */
643 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
644 && gfc_expr_attr (e
).dimension
)
647 gfc_is_class_array_ref (e
, &full_array
);
649 /* The derived type needs to be converted to a temporary
651 tmp
= gfc_typenode_for_spec (&class_ts
);
652 var
= gfc_create_var (tmp
, "class");
655 ctree
= gfc_class_data_get (var
);
656 if (class_ts
.u
.derived
->components
->as
657 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
661 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
663 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
664 gfc_get_dtype (type
));
666 tmp
= gfc_class_data_get (parmse
->expr
);
667 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
668 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
670 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
673 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
677 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
678 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
679 TREE_TYPE (ctree
), parmse
->expr
);
680 gfc_add_modify (&block
, ctree
, parmse
->expr
);
683 /* Return the data component, except in the case of scalarized array
684 references, where nullification of the cannot occur and so there
686 if (!elemental
&& full_array
&& copyback
)
688 if (class_ts
.u
.derived
->components
->as
689 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
692 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
693 gfc_conv_descriptor_data_get (ctree
));
695 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
698 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
702 ctree
= gfc_class_vptr_get (var
);
704 /* The vptr is the second field of the actual argument.
705 First we have to find the corresponding class reference. */
708 if (class_ref
== NULL
709 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
710 tmp
= e
->symtree
->n
.sym
->backend_decl
;
713 /* Remove everything after the last class reference, convert the
714 expression and then recover its tailend once more. */
716 ref
= class_ref
->next
;
717 class_ref
->next
= NULL
;
718 gfc_init_se (&tmpse
, NULL
);
719 gfc_conv_expr (&tmpse
, e
);
720 class_ref
->next
= ref
;
724 gcc_assert (tmp
!= NULL_TREE
);
726 /* Dereference if needs be. */
727 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
728 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
730 vptr
= gfc_class_vptr_get (tmp
);
731 gfc_add_modify (&block
, ctree
,
732 fold_convert (TREE_TYPE (ctree
), vptr
));
734 /* Return the vptr component, except in the case of scalarized array
735 references, where the dynamic type cannot change. */
736 if (!elemental
&& full_array
&& copyback
)
737 gfc_add_modify (&parmse
->post
, vptr
,
738 fold_convert (TREE_TYPE (vptr
), ctree
));
740 gcc_assert (!optional
|| (optional
&& !copyback
));
745 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
746 tmp
= gfc_finish_block (&block
);
748 if (optional_alloc_ptr
)
749 tmp2
= build_empty_stmt (input_location
);
752 gfc_init_block (&block
);
754 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
755 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
757 tmp2
= gfc_finish_block (&block
);
760 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
762 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
765 gfc_add_block_to_block (&parmse
->pre
, &block
);
767 /* Pass the address of the class object. */
768 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
770 if (optional
&& optional_alloc_ptr
)
771 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
772 TREE_TYPE (parmse
->expr
),
774 fold_convert (TREE_TYPE (parmse
->expr
),
779 /* Given a class array declaration and an index, returns the address
780 of the referenced element. */
783 gfc_get_class_array_ref (tree index
, tree class_decl
)
785 tree data
= gfc_class_data_get (class_decl
);
786 tree size
= gfc_vtable_size_get (class_decl
);
787 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
788 gfc_array_index_type
,
791 data
= gfc_conv_descriptor_data_get (data
);
792 ptr
= fold_convert (pvoid_type_node
, data
);
793 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
794 return fold_convert (TREE_TYPE (data
), ptr
);
798 /* Copies one class expression to another, assuming that if either
799 'to' or 'from' are arrays they are packed. Should 'from' be
800 NULL_TREE, the initialization expression for 'to' is used, assuming
801 that the _vptr is set. */
804 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
812 vec
<tree
, va_gc
> *args
;
815 stmtblock_t loopbody
;
821 if (from
!= NULL_TREE
)
822 fcn
= gfc_vtable_copy_get (from
);
824 fcn
= gfc_vtable_copy_get (to
);
826 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
828 if (from
!= NULL_TREE
)
829 from_data
= gfc_class_data_get (from
);
831 from_data
= gfc_vtable_def_init_get (to
);
833 to_data
= gfc_class_data_get (to
);
835 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
837 gfc_init_block (&body
);
838 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
839 gfc_array_index_type
, nelems
,
841 nelems
= gfc_evaluate_now (tmp
, &body
);
842 index
= gfc_create_var (gfc_array_index_type
, "S");
844 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
846 from_ref
= gfc_get_class_array_ref (index
, from
);
847 vec_safe_push (args
, from_ref
);
850 vec_safe_push (args
, from_data
);
852 to_ref
= gfc_get_class_array_ref (index
, to
);
853 vec_safe_push (args
, to_ref
);
855 tmp
= build_call_vec (fcn_type
, fcn
, args
);
857 /* Build the body of the loop. */
858 gfc_init_block (&loopbody
);
859 gfc_add_expr_to_block (&loopbody
, tmp
);
861 /* Build the loop and return. */
862 gfc_init_loopinfo (&loop
);
864 loop
.from
[0] = gfc_index_zero_node
;
865 loop
.loopvar
[0] = index
;
867 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
868 gfc_add_block_to_block (&body
, &loop
.pre
);
869 tmp
= gfc_finish_block (&body
);
870 gfc_cleanup_loop (&loop
);
874 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
875 vec_safe_push (args
, from_data
);
876 vec_safe_push (args
, to_data
);
877 tmp
= build_call_vec (fcn_type
, fcn
, args
);
884 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
886 gfc_actual_arglist
*actual
;
891 actual
= gfc_get_actual_arglist ();
892 actual
->expr
= gfc_copy_expr (rhs
);
893 actual
->next
= gfc_get_actual_arglist ();
894 actual
->next
->expr
= gfc_copy_expr (lhs
);
895 ppc
= gfc_copy_expr (obj
);
896 gfc_add_vptr_component (ppc
);
897 gfc_add_component_ref (ppc
, "_copy");
898 ppc_code
= gfc_get_code ();
899 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
900 /* Although '_copy' is set to be elemental in class.c, it is
901 not staying that way. Find out why, sometime.... */
902 ppc_code
->resolved_sym
->attr
.elemental
= 1;
903 ppc_code
->ext
.actual
= actual
;
904 ppc_code
->expr1
= ppc
;
905 ppc_code
->op
= EXEC_CALL
;
906 /* Since '_copy' is elemental, the scalarizer will take care
907 of arrays in gfc_trans_call. */
908 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
909 gfc_free_statements (ppc_code
);
913 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
914 A MEMCPY is needed to copy the full data from the default initializer
915 of the dynamic type. */
918 gfc_trans_class_init_assign (gfc_code
*code
)
922 gfc_se dst
,src
,memsz
;
923 gfc_expr
*lhs
, *rhs
, *sz
;
925 gfc_start_block (&block
);
927 lhs
= gfc_copy_expr (code
->expr1
);
928 gfc_add_data_component (lhs
);
930 rhs
= gfc_copy_expr (code
->expr1
);
931 gfc_add_vptr_component (rhs
);
933 /* Make sure that the component backend_decls have been built, which
934 will not have happened if the derived types concerned have not
936 gfc_get_derived_type (rhs
->ts
.u
.derived
);
937 gfc_add_def_init_component (rhs
);
939 if (code
->expr1
->ts
.type
== BT_CLASS
940 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
941 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
944 sz
= gfc_copy_expr (code
->expr1
);
945 gfc_add_vptr_component (sz
);
946 gfc_add_size_component (sz
);
948 gfc_init_se (&dst
, NULL
);
949 gfc_init_se (&src
, NULL
);
950 gfc_init_se (&memsz
, NULL
);
951 gfc_conv_expr (&dst
, lhs
);
952 gfc_conv_expr (&src
, rhs
);
953 gfc_conv_expr (&memsz
, sz
);
954 gfc_add_block_to_block (&block
, &src
.pre
);
955 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
957 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
960 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
961 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
963 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
964 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
966 build_empty_stmt (input_location
));
969 gfc_add_expr_to_block (&block
, tmp
);
971 return gfc_finish_block (&block
);
975 /* Translate an assignment to a CLASS object
976 (pointer or ordinary assignment). */
979 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
987 gfc_start_block (&block
);
990 while (ref
&& ref
->next
)
993 /* Class valued proc_pointer assignments do not need any further
995 if (ref
&& ref
->type
== REF_COMPONENT
996 && ref
->u
.c
.component
->attr
.proc_pointer
997 && expr2
->expr_type
== EXPR_VARIABLE
998 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
999 && op
== EXEC_POINTER_ASSIGN
)
1002 if (expr2
->ts
.type
!= BT_CLASS
)
1004 /* Insert an additional assignment which sets the '_vptr' field. */
1005 gfc_symbol
*vtab
= NULL
;
1008 lhs
= gfc_copy_expr (expr1
);
1009 gfc_add_vptr_component (lhs
);
1011 if (UNLIMITED_POLY (expr1
)
1012 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1014 rhs
= gfc_get_null_expr (&expr2
->where
);
1018 if (expr2
->ts
.type
== BT_DERIVED
)
1019 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
1020 else if (expr2
->expr_type
== EXPR_NULL
)
1021 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
1023 vtab
= gfc_find_intrinsic_vtab (&expr2
->ts
);
1026 rhs
= gfc_get_expr ();
1027 rhs
->expr_type
= EXPR_VARIABLE
;
1028 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1032 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1033 gfc_add_expr_to_block (&block
, tmp
);
1035 gfc_free_expr (lhs
);
1036 gfc_free_expr (rhs
);
1038 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1040 /* F2003:C717 only sequence and bind-C types can come here. */
1041 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1042 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1043 gfc_add_data_component (expr2
);
1046 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1048 /* Insert an additional assignment which sets the '_vptr' field. */
1049 lhs
= gfc_copy_expr (expr1
);
1050 gfc_add_vptr_component (lhs
);
1052 rhs
= gfc_copy_expr (expr2
);
1053 gfc_add_vptr_component (rhs
);
1055 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1056 gfc_add_expr_to_block (&block
, tmp
);
1058 gfc_free_expr (lhs
);
1059 gfc_free_expr (rhs
);
1062 /* Do the actual CLASS assignment. */
1063 if (expr2
->ts
.type
== BT_CLASS
1064 && !CLASS_DATA (expr2
)->attr
.dimension
)
1066 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1067 || !CLASS_DATA (expr2
)->attr
.dimension
)
1068 gfc_add_data_component (expr1
);
1072 if (op
== EXEC_ASSIGN
)
1073 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1074 else if (op
== EXEC_POINTER_ASSIGN
)
1075 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1079 gfc_add_expr_to_block (&block
, tmp
);
1081 return gfc_finish_block (&block
);
1085 /* End of prototype trans-class.c */
1089 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1091 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1092 && gfc_option
.warn_realloc_lhs
)
1093 gfc_warning ("Code for reallocating the allocatable array at %L will "
1095 else if (gfc_option
.warn_realloc_lhs_all
)
1096 gfc_warning ("Code for reallocating the allocatable variable at %L "
1097 "will be added", where
);
1101 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1102 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1105 /* Copy the scalarization loop variables. */
1108 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1111 dest
->loop
= src
->loop
;
1115 /* Initialize a simple expression holder.
1117 Care must be taken when multiple se are created with the same parent.
1118 The child se must be kept in sync. The easiest way is to delay creation
1119 of a child se until after after the previous se has been translated. */
1122 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1124 memset (se
, 0, sizeof (gfc_se
));
1125 gfc_init_block (&se
->pre
);
1126 gfc_init_block (&se
->post
);
1128 se
->parent
= parent
;
1131 gfc_copy_se_loopvars (se
, parent
);
1135 /* Advances to the next SS in the chain. Use this rather than setting
1136 se->ss = se->ss->next because all the parents needs to be kept in sync.
1140 gfc_advance_se_ss_chain (gfc_se
* se
)
1145 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1148 /* Walk down the parent chain. */
1151 /* Simple consistency check. */
1152 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1153 || p
->parent
->ss
->nested_ss
== p
->ss
);
1155 /* If we were in a nested loop, the next scalarized expression can be
1156 on the parent ss' next pointer. Thus we should not take the next
1157 pointer blindly, but rather go up one nest level as long as next
1158 is the end of chain. */
1160 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1170 /* Ensures the result of the expression as either a temporary variable
1171 or a constant so that it can be used repeatedly. */
1174 gfc_make_safe_expr (gfc_se
* se
)
1178 if (CONSTANT_CLASS_P (se
->expr
))
1181 /* We need a temporary for this result. */
1182 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1183 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1188 /* Return an expression which determines if a dummy parameter is present.
1189 Also used for arguments to procedures with multiple entry points. */
1192 gfc_conv_expr_present (gfc_symbol
* sym
)
1196 gcc_assert (sym
->attr
.dummy
);
1197 decl
= gfc_get_symbol_decl (sym
);
1199 /* Intrinsic scalars with VALUE attribute which are passed by value
1200 use a hidden argument to denote the present status. */
1201 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1202 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1203 && !sym
->attr
.dimension
)
1205 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1208 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1210 strcpy (&name
[1], sym
->name
);
1211 tree_name
= get_identifier (name
);
1213 /* Walk function argument list to find hidden arg. */
1214 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1215 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1216 if (DECL_NAME (cond
) == tree_name
)
1223 if (TREE_CODE (decl
) != PARM_DECL
)
1225 /* Array parameters use a temporary descriptor, we want the real
1227 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1228 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1229 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1232 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1233 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1235 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1236 as actual argument to denote absent dummies. For array descriptors,
1237 we thus also need to check the array descriptor. For BT_CLASS, it
1238 can also occur for scalars and F2003 due to type->class wrapping and
1239 class->class wrapping. Note further that BT_CLASS always uses an
1240 array descriptor for arrays, also for explicit-shape/assumed-size. */
1242 if (!sym
->attr
.allocatable
1243 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1244 || (sym
->ts
.type
== BT_CLASS
1245 && !CLASS_DATA (sym
)->attr
.allocatable
1246 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1247 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1248 || sym
->ts
.type
== BT_CLASS
))
1252 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1253 || sym
->as
->type
== AS_ASSUMED_RANK
1254 || sym
->attr
.codimension
))
1255 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1257 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1258 if (sym
->ts
.type
== BT_CLASS
)
1259 tmp
= gfc_class_data_get (tmp
);
1260 tmp
= gfc_conv_array_data (tmp
);
1262 else if (sym
->ts
.type
== BT_CLASS
)
1263 tmp
= gfc_class_data_get (decl
);
1267 if (tmp
!= NULL_TREE
)
1269 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1270 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1271 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1272 boolean_type_node
, cond
, tmp
);
1280 /* Converts a missing, dummy argument into a null or zero. */
1283 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1288 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1292 /* Create a temporary and convert it to the correct type. */
1293 tmp
= gfc_get_int_type (kind
);
1294 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1297 /* Test for a NULL value. */
1298 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1299 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1300 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1301 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1305 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1307 build_zero_cst (TREE_TYPE (se
->expr
)));
1308 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1312 if (ts
.type
== BT_CHARACTER
)
1314 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1315 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1316 present
, se
->string_length
, tmp
);
1317 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1318 se
->string_length
= tmp
;
1324 /* Get the character length of an expression, looking through gfc_refs
1328 gfc_get_expr_charlen (gfc_expr
*e
)
1333 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1334 && e
->ts
.type
== BT_CHARACTER
);
1336 length
= NULL
; /* To silence compiler warning. */
1338 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1341 gfc_init_se (&tmpse
, NULL
);
1342 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1343 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1347 /* First candidate: if the variable is of type CHARACTER, the
1348 expression's length could be the length of the character
1350 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1351 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1353 /* Look through the reference chain for component references. */
1354 for (r
= e
->ref
; r
; r
= r
->next
)
1359 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1360 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1368 /* We should never got substring references here. These will be
1369 broken down by the scalarizer. */
1375 gcc_assert (length
!= NULL
);
1380 /* Return for an expression the backend decl of the coarray. */
1383 get_tree_for_caf_expr (gfc_expr
*expr
)
1385 tree caf_decl
= NULL_TREE
;
1388 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1389 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1390 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1392 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1393 if (ref
->type
== REF_COMPONENT
)
1395 gfc_component
*comp
= ref
->u
.c
.component
;
1396 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
1397 caf_decl
= NULL_TREE
;
1398 if (comp
->attr
.codimension
)
1399 caf_decl
= comp
->backend_decl
;
1402 gcc_assert (caf_decl
!= NULL_TREE
);
1407 /* For each character array constructor subexpression without a ts.u.cl->length,
1408 replace it by its first element (if there aren't any elements, the length
1409 should already be set to zero). */
1412 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1414 gfc_actual_arglist
* arg
;
1420 switch (e
->expr_type
)
1424 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1425 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1429 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1433 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1434 flatten_array_ctors_without_strlen (arg
->expr
);
1439 /* We've found what we're looking for. */
1440 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1445 gcc_assert (e
->value
.constructor
);
1447 c
= gfc_constructor_first (e
->value
.constructor
);
1451 flatten_array_ctors_without_strlen (new_expr
);
1452 gfc_replace_expr (e
, new_expr
);
1456 /* Otherwise, fall through to handle constructor elements. */
1457 case EXPR_STRUCTURE
:
1458 for (c
= gfc_constructor_first (e
->value
.constructor
);
1459 c
; c
= gfc_constructor_next (c
))
1460 flatten_array_ctors_without_strlen (c
->expr
);
1470 /* Generate code to initialize a string length variable. Returns the
1471 value. For array constructors, cl->length might be NULL and in this case,
1472 the first element of the constructor is needed. expr is the original
1473 expression so we can access it but can be NULL if this is not needed. */
1476 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1480 gfc_init_se (&se
, NULL
);
1484 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1487 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1488 "flatten" array constructors by taking their first element; all elements
1489 should be the same length or a cl->length should be present. */
1492 gfc_expr
* expr_flat
;
1494 expr_flat
= gfc_copy_expr (expr
);
1495 flatten_array_ctors_without_strlen (expr_flat
);
1496 gfc_resolve_expr (expr_flat
);
1498 gfc_conv_expr (&se
, expr_flat
);
1499 gfc_add_block_to_block (pblock
, &se
.pre
);
1500 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1502 gfc_free_expr (expr_flat
);
1506 /* Convert cl->length. */
1508 gcc_assert (cl
->length
);
1510 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1511 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1512 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1513 gfc_add_block_to_block (pblock
, &se
.pre
);
1515 if (cl
->backend_decl
)
1516 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1518 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1523 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1524 const char *name
, locus
*where
)
1534 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1535 type
= build_pointer_type (type
);
1537 gfc_init_se (&start
, se
);
1538 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1539 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1541 if (integer_onep (start
.expr
))
1542 gfc_conv_string_parameter (se
);
1547 /* Avoid multiple evaluation of substring start. */
1548 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1549 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1551 /* Change the start of the string. */
1552 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1555 tmp
= build_fold_indirect_ref_loc (input_location
,
1557 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1558 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1561 /* Length = end + 1 - start. */
1562 gfc_init_se (&end
, se
);
1563 if (ref
->u
.ss
.end
== NULL
)
1564 end
.expr
= se
->string_length
;
1567 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1568 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1572 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1573 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1575 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1577 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1578 boolean_type_node
, start
.expr
,
1581 /* Check lower bound. */
1582 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1584 build_int_cst (gfc_charlen_type_node
, 1));
1585 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1586 boolean_type_node
, nonempty
, fault
);
1588 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1589 "is less than one", name
);
1591 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1592 "is less than one");
1593 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1594 fold_convert (long_integer_type_node
,
1598 /* Check upper bound. */
1599 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1600 end
.expr
, se
->string_length
);
1601 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1602 boolean_type_node
, nonempty
, fault
);
1604 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1605 "exceeds string length (%%ld)", name
);
1607 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1608 "exceeds string length (%%ld)");
1609 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1610 fold_convert (long_integer_type_node
, end
.expr
),
1611 fold_convert (long_integer_type_node
,
1612 se
->string_length
));
1616 /* Try to calculate the length from the start and end expressions. */
1618 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1622 i_len
= mpz_get_si (length
) + 1;
1626 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1627 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1631 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1632 end
.expr
, start
.expr
);
1633 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1634 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1635 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1636 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1639 se
->string_length
= tmp
;
1643 /* Convert a derived type component reference. */
1646 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1653 c
= ref
->u
.c
.component
;
1655 gcc_assert (c
->backend_decl
);
1657 field
= c
->backend_decl
;
1658 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1661 /* Components can correspond to fields of different containing
1662 types, as components are created without context, whereas
1663 a concrete use of a component has the type of decl as context.
1664 So, if the type doesn't match, we search the corresponding
1665 FIELD_DECL in the parent type. To not waste too much time
1666 we cache this result in norestrict_decl. */
1668 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1670 tree f2
= c
->norestrict_decl
;
1671 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1672 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1673 if (TREE_CODE (f2
) == FIELD_DECL
1674 && DECL_NAME (f2
) == DECL_NAME (field
))
1677 c
->norestrict_decl
= f2
;
1681 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1682 decl
, field
, NULL_TREE
);
1686 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1688 tmp
= c
->ts
.u
.cl
->backend_decl
;
1689 /* Components must always be constant length. */
1690 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1691 se
->string_length
= tmp
;
1694 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1695 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1696 && c
->ts
.type
!= BT_CHARACTER
)
1697 || c
->attr
.proc_pointer
)
1698 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1703 /* This function deals with component references to components of the
1704 parent type for derived type extensions. */
1706 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1714 c
= ref
->u
.c
.component
;
1716 /* Return if the component is in the parent type. */
1717 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1718 if (strcmp (c
->name
, cmp
->name
) == 0)
1721 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1722 parent
.type
= REF_COMPONENT
;
1724 parent
.u
.c
.sym
= dt
;
1725 parent
.u
.c
.component
= dt
->components
;
1727 if (dt
->backend_decl
== NULL
)
1728 gfc_get_derived_type (dt
);
1730 /* Build the reference and call self. */
1731 gfc_conv_component_ref (se
, &parent
);
1732 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1733 parent
.u
.c
.component
= c
;
1734 conv_parent_component_references (se
, &parent
);
1737 /* Return the contents of a variable. Also handles reference/pointer
1738 variables (all Fortran pointer references are implicit). */
1741 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1746 tree parent_decl
= NULL_TREE
;
1749 bool alternate_entry
;
1752 sym
= expr
->symtree
->n
.sym
;
1756 gfc_ss_info
*ss_info
= ss
->info
;
1758 /* Check that something hasn't gone horribly wrong. */
1759 gcc_assert (ss
!= gfc_ss_terminator
);
1760 gcc_assert (ss_info
->expr
== expr
);
1762 /* A scalarized term. We already know the descriptor. */
1763 se
->expr
= ss_info
->data
.array
.descriptor
;
1764 se
->string_length
= ss_info
->string_length
;
1765 ref
= ss_info
->data
.array
.ref
;
1767 gcc_assert (ref
->type
== REF_ARRAY
1768 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1770 gfc_conv_tmp_array_ref (se
);
1774 tree se_expr
= NULL_TREE
;
1776 se
->expr
= gfc_get_symbol_decl (sym
);
1778 /* Deal with references to a parent results or entries by storing
1779 the current_function_decl and moving to the parent_decl. */
1780 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1781 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1782 && sym
->result
== sym
;
1783 entry_master
= sym
->attr
.result
1784 && sym
->ns
->proc_name
->attr
.entry_master
1785 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1786 if (current_function_decl
)
1787 parent_decl
= DECL_CONTEXT (current_function_decl
);
1789 if ((se
->expr
== parent_decl
&& return_value
)
1790 || (sym
->ns
&& sym
->ns
->proc_name
1792 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1793 && (alternate_entry
|| entry_master
)))
1798 /* Special case for assigning the return value of a function.
1799 Self recursive functions must have an explicit return value. */
1800 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1801 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1803 /* Similarly for alternate entry points. */
1804 else if (alternate_entry
1805 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1808 gfc_entry_list
*el
= NULL
;
1810 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1813 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1818 else if (entry_master
1819 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1821 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1826 /* Procedure actual arguments. */
1827 else if (sym
->attr
.flavor
== FL_PROCEDURE
1828 && se
->expr
!= current_function_decl
)
1830 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1832 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1833 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1839 /* Dereference the expression, where needed. Since characters
1840 are entirely different from other types, they are treated
1842 if (sym
->ts
.type
== BT_CHARACTER
)
1844 /* Dereference character pointer dummy arguments
1846 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1848 || sym
->attr
.function
1849 || sym
->attr
.result
))
1850 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1854 else if (!sym
->attr
.value
)
1856 /* Dereference non-character scalar dummy arguments. */
1857 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1858 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1859 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1862 /* Dereference scalar hidden result. */
1863 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1864 && (sym
->attr
.function
|| sym
->attr
.result
)
1865 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1866 && !sym
->attr
.always_explicit
)
1867 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1870 /* Dereference non-character pointer variables.
1871 These must be dummies, results, or scalars. */
1872 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1873 || gfc_is_associate_pointer (sym
)
1874 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1876 || sym
->attr
.function
1878 || (!sym
->attr
.dimension
1879 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1880 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1887 /* For character variables, also get the length. */
1888 if (sym
->ts
.type
== BT_CHARACTER
)
1890 /* If the character length of an entry isn't set, get the length from
1891 the master function instead. */
1892 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1893 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1895 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1896 gcc_assert (se
->string_length
);
1904 /* Return the descriptor if that's what we want and this is an array
1905 section reference. */
1906 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1908 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1909 /* Return the descriptor for array pointers and allocations. */
1910 if (se
->want_pointer
1911 && ref
->next
== NULL
&& (se
->descriptor_only
))
1914 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1915 /* Return a pointer to an element. */
1919 if (ref
->u
.c
.sym
->attr
.extension
)
1920 conv_parent_component_references (se
, ref
);
1922 gfc_conv_component_ref (se
, ref
);
1923 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1924 && se
->want_pointer
&& se
->descriptor_only
)
1930 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1931 expr
->symtree
->name
, &expr
->where
);
1940 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1942 if (se
->want_pointer
)
1944 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1945 gfc_conv_string_parameter (se
);
1947 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1952 /* Unary ops are easy... Or they would be if ! was a valid op. */
1955 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1960 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1961 /* Initialize the operand. */
1962 gfc_init_se (&operand
, se
);
1963 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1964 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1966 type
= gfc_typenode_for_spec (&expr
->ts
);
1968 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1969 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1970 All other unary operators have an equivalent GIMPLE unary operator. */
1971 if (code
== TRUTH_NOT_EXPR
)
1972 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1973 build_int_cst (type
, 0));
1975 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1979 /* Expand power operator to optimal multiplications when a value is raised
1980 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1981 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1982 Programming", 3rd Edition, 1998. */
1984 /* This code is mostly duplicated from expand_powi in the backend.
1985 We establish the "optimal power tree" lookup table with the defined size.
1986 The items in the table are the exponents used to calculate the index
1987 exponents. Any integer n less than the value can get an "addition chain",
1988 with the first node being one. */
1989 #define POWI_TABLE_SIZE 256
1991 /* The table is from builtins.c. */
1992 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1994 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1995 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1996 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1997 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1998 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1999 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2000 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2001 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2002 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2003 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2004 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2005 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2006 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2007 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2008 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2009 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2010 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2011 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2012 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2013 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2014 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2015 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2016 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2017 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2018 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2019 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2020 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2021 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2022 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2023 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2024 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2025 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2028 /* If n is larger than lookup table's max index, we use the "window
2030 #define POWI_WINDOW_SIZE 3
2032 /* Recursive function to expand the power operator. The temporary
2033 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2035 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2042 if (n
< POWI_TABLE_SIZE
)
2047 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2048 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2052 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2053 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2054 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2058 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2062 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2063 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2065 if (n
< POWI_TABLE_SIZE
)
2072 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2073 return 1. Else return 0 and a call to runtime library functions
2074 will have to be built. */
2076 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2081 tree vartmp
[POWI_TABLE_SIZE
];
2083 unsigned HOST_WIDE_INT n
;
2086 /* If exponent is too large, we won't expand it anyway, so don't bother
2087 with large integer values. */
2088 if (!TREE_INT_CST (rhs
).fits_shwi ())
2091 m
= TREE_INT_CST (rhs
).to_shwi ();
2092 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2093 of the asymmetric range of the integer type. */
2094 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2096 type
= TREE_TYPE (lhs
);
2097 sgn
= tree_int_cst_sgn (rhs
);
2099 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2100 || optimize_size
) && (m
> 2 || m
< -1))
2106 se
->expr
= gfc_build_const (type
, integer_one_node
);
2110 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2111 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2113 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2114 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2115 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2116 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2119 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2122 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2123 boolean_type_node
, tmp
, cond
);
2124 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2125 tmp
, build_int_cst (type
, 1),
2126 build_int_cst (type
, 0));
2130 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2131 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2132 build_int_cst (type
, -1),
2133 build_int_cst (type
, 0));
2134 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2135 cond
, build_int_cst (type
, 1), tmp
);
2139 memset (vartmp
, 0, sizeof (vartmp
));
2143 tmp
= gfc_build_const (type
, integer_one_node
);
2144 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2148 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2154 /* Power op (**). Constant integer exponent has special handling. */
2157 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2159 tree gfc_int4_type_node
;
2162 int res_ikind_1
, res_ikind_2
;
2167 gfc_init_se (&lse
, se
);
2168 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2169 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2170 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2172 gfc_init_se (&rse
, se
);
2173 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2174 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2176 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2177 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2178 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2181 gfc_int4_type_node
= gfc_get_int_type (4);
2183 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2184 library routine. But in the end, we have to convert the result back
2185 if this case applies -- with res_ikind_K, we keep track whether operand K
2186 falls into this case. */
2190 kind
= expr
->value
.op
.op1
->ts
.kind
;
2191 switch (expr
->value
.op
.op2
->ts
.type
)
2194 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2199 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2200 res_ikind_2
= ikind
;
2222 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2224 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2251 switch (expr
->value
.op
.op1
->ts
.type
)
2254 if (kind
== 3) /* Case 16 was not handled properly above. */
2256 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2260 /* Use builtins for real ** int4. */
2266 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2270 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2274 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2278 /* Use the __builtin_powil() only if real(kind=16) is
2279 actually the C long double type. */
2280 if (!gfc_real16_is_float128
)
2281 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2289 /* If we don't have a good builtin for this, go for the
2290 library function. */
2292 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2296 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2305 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2309 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2317 se
->expr
= build_call_expr_loc (input_location
,
2318 fndecl
, 2, lse
.expr
, rse
.expr
);
2320 /* Convert the result back if it is of wrong integer kind. */
2321 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2323 /* We want the maximum of both operand kinds as result. */
2324 if (res_ikind_1
< res_ikind_2
)
2325 res_ikind_1
= res_ikind_2
;
2326 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2331 /* Generate code to allocate a string temporary. */
2334 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2339 if (gfc_can_put_var_on_stack (len
))
2341 /* Create a temporary variable to hold the result. */
2342 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2343 gfc_charlen_type_node
, len
,
2344 build_int_cst (gfc_charlen_type_node
, 1));
2345 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2347 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2348 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2350 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2352 var
= gfc_create_var (tmp
, "str");
2353 var
= gfc_build_addr_expr (type
, var
);
2357 /* Allocate a temporary to hold the result. */
2358 var
= gfc_create_var (type
, "pstr");
2359 tmp
= gfc_call_malloc (&se
->pre
, type
,
2360 fold_build2_loc (input_location
, MULT_EXPR
,
2361 TREE_TYPE (len
), len
,
2362 fold_convert (TREE_TYPE (len
),
2363 TYPE_SIZE (type
))));
2364 gfc_add_modify (&se
->pre
, var
, tmp
);
2366 /* Free the temporary afterwards. */
2367 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2368 gfc_add_expr_to_block (&se
->post
, tmp
);
2375 /* Handle a string concatenation operation. A temporary will be allocated to
2379 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2382 tree len
, type
, var
, tmp
, fndecl
;
2384 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2385 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2386 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2388 gfc_init_se (&lse
, se
);
2389 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2390 gfc_conv_string_parameter (&lse
);
2391 gfc_init_se (&rse
, se
);
2392 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2393 gfc_conv_string_parameter (&rse
);
2395 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2396 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2398 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2399 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2400 if (len
== NULL_TREE
)
2402 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2403 TREE_TYPE (lse
.string_length
),
2404 lse
.string_length
, rse
.string_length
);
2407 type
= build_pointer_type (type
);
2409 var
= gfc_conv_string_tmp (se
, type
, len
);
2411 /* Do the actual concatenation. */
2412 if (expr
->ts
.kind
== 1)
2413 fndecl
= gfor_fndecl_concat_string
;
2414 else if (expr
->ts
.kind
== 4)
2415 fndecl
= gfor_fndecl_concat_string_char4
;
2419 tmp
= build_call_expr_loc (input_location
,
2420 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2421 rse
.string_length
, rse
.expr
);
2422 gfc_add_expr_to_block (&se
->pre
, tmp
);
2424 /* Add the cleanup for the operands. */
2425 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2426 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2429 se
->string_length
= len
;
2432 /* Translates an op expression. Common (binary) cases are handled by this
2433 function, others are passed on. Recursion is used in either case.
2434 We use the fact that (op1.ts == op2.ts) (except for the power
2436 Operators need no special handling for scalarized expressions as long as
2437 they call gfc_conv_simple_val to get their operands.
2438 Character strings get special handling. */
2441 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2443 enum tree_code code
;
2452 switch (expr
->value
.op
.op
)
2454 case INTRINSIC_PARENTHESES
:
2455 if ((expr
->ts
.type
== BT_REAL
2456 || expr
->ts
.type
== BT_COMPLEX
)
2457 && gfc_option
.flag_protect_parens
)
2459 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2460 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2465 case INTRINSIC_UPLUS
:
2466 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2469 case INTRINSIC_UMINUS
:
2470 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2474 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2477 case INTRINSIC_PLUS
:
2481 case INTRINSIC_MINUS
:
2485 case INTRINSIC_TIMES
:
2489 case INTRINSIC_DIVIDE
:
2490 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2491 an integer, we must round towards zero, so we use a
2493 if (expr
->ts
.type
== BT_INTEGER
)
2494 code
= TRUNC_DIV_EXPR
;
2499 case INTRINSIC_POWER
:
2500 gfc_conv_power_op (se
, expr
);
2503 case INTRINSIC_CONCAT
:
2504 gfc_conv_concat_op (se
, expr
);
2508 code
= TRUTH_ANDIF_EXPR
;
2513 code
= TRUTH_ORIF_EXPR
;
2517 /* EQV and NEQV only work on logicals, but since we represent them
2518 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2520 case INTRINSIC_EQ_OS
:
2528 case INTRINSIC_NE_OS
:
2529 case INTRINSIC_NEQV
:
2536 case INTRINSIC_GT_OS
:
2543 case INTRINSIC_GE_OS
:
2550 case INTRINSIC_LT_OS
:
2557 case INTRINSIC_LE_OS
:
2563 case INTRINSIC_USER
:
2564 case INTRINSIC_ASSIGN
:
2565 /* These should be converted into function calls by the frontend. */
2569 fatal_error ("Unknown intrinsic op");
2573 /* The only exception to this is **, which is handled separately anyway. */
2574 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2576 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2580 gfc_init_se (&lse
, se
);
2581 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2582 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2585 gfc_init_se (&rse
, se
);
2586 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2587 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2591 gfc_conv_string_parameter (&lse
);
2592 gfc_conv_string_parameter (&rse
);
2594 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2595 rse
.string_length
, rse
.expr
,
2596 expr
->value
.op
.op1
->ts
.kind
,
2598 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2599 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2602 type
= gfc_typenode_for_spec (&expr
->ts
);
2606 /* The result of logical ops is always boolean_type_node. */
2607 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2608 lse
.expr
, rse
.expr
);
2609 se
->expr
= convert (type
, tmp
);
2612 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2614 /* Add the post blocks. */
2615 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2616 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2619 /* If a string's length is one, we convert it to a single character. */
2622 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2626 || !INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2627 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2630 if (TREE_INT_CST_LOW (len
) == 1)
2632 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2633 return build_fold_indirect_ref_loc (input_location
, str
);
2637 && TREE_CODE (str
) == ADDR_EXPR
2638 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2639 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2640 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2641 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2642 && TREE_INT_CST_LOW (len
) > 1
2643 && TREE_INT_CST_LOW (len
)
2644 == (unsigned HOST_WIDE_INT
)
2645 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2647 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2648 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2649 if (TREE_CODE (ret
) == INTEGER_CST
)
2651 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2652 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2653 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2655 for (i
= 1; i
< length
; i
++)
2668 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2671 if (sym
->backend_decl
)
2673 /* This becomes the nominal_type in
2674 function.c:assign_parm_find_data_types. */
2675 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2676 /* This becomes the passed_type in
2677 function.c:assign_parm_find_data_types. C promotes char to
2678 integer for argument passing. */
2679 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2681 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2686 /* If we have a constant character expression, make it into an
2688 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2693 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2694 (int)(*expr
)->value
.character
.string
[0]);
2695 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2697 /* The expr needs to be compatible with a C int. If the
2698 conversion fails, then the 2 causes an ICE. */
2699 ts
.type
= BT_INTEGER
;
2700 ts
.kind
= gfc_c_int_kind
;
2701 gfc_convert_type (*expr
, &ts
, 2);
2704 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2706 if ((*expr
)->ref
== NULL
)
2708 se
->expr
= gfc_string_to_single_character
2709 (build_int_cst (integer_type_node
, 1),
2710 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2712 ((*expr
)->symtree
->n
.sym
)),
2717 gfc_conv_variable (se
, *expr
);
2718 se
->expr
= gfc_string_to_single_character
2719 (build_int_cst (integer_type_node
, 1),
2720 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2728 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2729 if STR is a string literal, otherwise return -1. */
2732 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2735 && TREE_CODE (str
) == ADDR_EXPR
2736 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2737 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2738 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2739 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2740 && TREE_INT_CST_LOW (len
) >= 1
2741 && TREE_INT_CST_LOW (len
)
2742 == (unsigned HOST_WIDE_INT
)
2743 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2745 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2746 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2747 if (TREE_CODE (folded
) == INTEGER_CST
)
2749 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2750 int length
= TREE_STRING_LENGTH (string_cst
);
2751 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2753 for (; length
> 0; length
--)
2754 if (ptr
[length
- 1] != ' ')
2763 /* Helper to build a call to memcmp. */
2766 build_memcmp_call (tree s1
, tree s2
, tree n
)
2770 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2771 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2773 s1
= fold_convert (pvoid_type_node
, s1
);
2775 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2776 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2778 s2
= fold_convert (pvoid_type_node
, s2
);
2780 n
= fold_convert (size_type_node
, n
);
2782 tmp
= build_call_expr_loc (input_location
,
2783 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2786 return fold_convert (integer_type_node
, tmp
);
2789 /* Compare two strings. If they are all single characters, the result is the
2790 subtraction of them. Otherwise, we build a library call. */
2793 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2794 enum tree_code code
)
2800 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2801 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2803 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2804 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2806 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2808 /* Deal with single character specially. */
2809 sc1
= fold_convert (integer_type_node
, sc1
);
2810 sc2
= fold_convert (integer_type_node
, sc2
);
2811 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2815 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2817 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2819 /* If one string is a string literal with LEN_TRIM longer
2820 than the length of the second string, the strings
2822 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2823 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2824 return integer_one_node
;
2825 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2826 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2827 return integer_one_node
;
2830 /* We can compare via memcpy if the strings are known to be equal
2831 in length and they are
2833 - kind=4 and the comparison is for (in)equality. */
2835 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2836 && tree_int_cst_equal (len1
, len2
)
2837 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2842 chartype
= gfc_get_char_type (kind
);
2843 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2844 fold_convert (TREE_TYPE(len1
),
2845 TYPE_SIZE_UNIT(chartype
)),
2847 return build_memcmp_call (str1
, str2
, tmp
);
2850 /* Build a call for the comparison. */
2852 fndecl
= gfor_fndecl_compare_string
;
2854 fndecl
= gfor_fndecl_compare_string_char4
;
2858 return build_call_expr_loc (input_location
, fndecl
, 4,
2859 len1
, str1
, len2
, str2
);
2863 /* Return the backend_decl for a procedure pointer component. */
2866 get_proc_ptr_comp (gfc_expr
*e
)
2872 gfc_init_se (&comp_se
, NULL
);
2873 e2
= gfc_copy_expr (e
);
2874 /* We have to restore the expr type later so that gfc_free_expr frees
2875 the exact same thing that was allocated.
2876 TODO: This is ugly. */
2877 old_type
= e2
->expr_type
;
2878 e2
->expr_type
= EXPR_VARIABLE
;
2879 gfc_conv_expr (&comp_se
, e2
);
2880 e2
->expr_type
= old_type
;
2882 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2886 /* Convert a typebound function reference from a class object. */
2888 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2893 if (TREE_CODE (base_object
) != VAR_DECL
)
2895 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2896 gfc_add_modify (&se
->pre
, var
, base_object
);
2898 se
->expr
= gfc_class_vptr_get (base_object
);
2899 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2901 while (ref
&& ref
->next
)
2903 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2904 if (ref
->u
.c
.sym
->attr
.extension
)
2905 conv_parent_component_references (se
, ref
);
2906 gfc_conv_component_ref (se
, ref
);
2907 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2912 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2916 if (gfc_is_proc_ptr_comp (expr
))
2917 tmp
= get_proc_ptr_comp (expr
);
2918 else if (sym
->attr
.dummy
)
2920 tmp
= gfc_get_symbol_decl (sym
);
2921 if (sym
->attr
.proc_pointer
)
2922 tmp
= build_fold_indirect_ref_loc (input_location
,
2924 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2925 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2929 if (!sym
->backend_decl
)
2930 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2932 TREE_USED (sym
->backend_decl
) = 1;
2934 tmp
= sym
->backend_decl
;
2936 if (sym
->attr
.cray_pointee
)
2938 /* TODO - make the cray pointee a pointer to a procedure,
2939 assign the pointer to it and use it for the call. This
2941 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2942 gfc_get_symbol_decl (sym
->cp_pointer
));
2943 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2946 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2948 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2949 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2956 /* Initialize MAPPING. */
2959 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2961 mapping
->syms
= NULL
;
2962 mapping
->charlens
= NULL
;
2966 /* Free all memory held by MAPPING (but not MAPPING itself). */
2969 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2971 gfc_interface_sym_mapping
*sym
;
2972 gfc_interface_sym_mapping
*nextsym
;
2974 gfc_charlen
*nextcl
;
2976 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2978 nextsym
= sym
->next
;
2979 sym
->new_sym
->n
.sym
->formal
= NULL
;
2980 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2981 gfc_free_expr (sym
->expr
);
2982 free (sym
->new_sym
);
2985 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2988 gfc_free_expr (cl
->length
);
2994 /* Return a copy of gfc_charlen CL. Add the returned structure to
2995 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2997 static gfc_charlen
*
2998 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3001 gfc_charlen
*new_charlen
;
3003 new_charlen
= gfc_get_charlen ();
3004 new_charlen
->next
= mapping
->charlens
;
3005 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3007 mapping
->charlens
= new_charlen
;
3012 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3013 array variable that can be used as the actual argument for dummy
3014 argument SYM. Add any initialization code to BLOCK. PACKED is as
3015 for gfc_get_nodesc_array_type and DATA points to the first element
3016 in the passed array. */
3019 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3020 gfc_packed packed
, tree data
)
3025 type
= gfc_typenode_for_spec (&sym
->ts
);
3026 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3027 !sym
->attr
.target
&& !sym
->attr
.pointer
3028 && !sym
->attr
.proc_pointer
);
3030 var
= gfc_create_var (type
, "ifm");
3031 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3037 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3038 and offset of descriptorless array type TYPE given that it has the same
3039 size as DESC. Add any set-up code to BLOCK. */
3042 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3049 offset
= gfc_index_zero_node
;
3050 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3052 dim
= gfc_rank_cst
[n
];
3053 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3054 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3056 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3057 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3058 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3059 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3061 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3063 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3064 gfc_array_index_type
,
3065 gfc_conv_descriptor_ubound_get (desc
, dim
),
3066 gfc_conv_descriptor_lbound_get (desc
, dim
));
3067 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3068 gfc_array_index_type
,
3069 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3070 tmp
= gfc_evaluate_now (tmp
, block
);
3071 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3073 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3074 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3075 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3076 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3077 gfc_array_index_type
, offset
, tmp
);
3079 offset
= gfc_evaluate_now (offset
, block
);
3080 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3084 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3085 in SE. The caller may still use se->expr and se->string_length after
3086 calling this function. */
3089 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3090 gfc_symbol
* sym
, gfc_se
* se
,
3093 gfc_interface_sym_mapping
*sm
;
3097 gfc_symbol
*new_sym
;
3099 gfc_symtree
*new_symtree
;
3101 /* Create a new symbol to represent the actual argument. */
3102 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3103 new_sym
->ts
= sym
->ts
;
3104 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3105 new_sym
->attr
.referenced
= 1;
3106 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3107 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3108 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3109 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3110 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3111 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3112 new_sym
->attr
.function
= sym
->attr
.function
;
3114 /* Ensure that the interface is available and that
3115 descriptors are passed for array actual arguments. */
3116 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3118 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3119 new_sym
->attr
.always_explicit
3120 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3123 /* Create a fake symtree for it. */
3125 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3126 new_symtree
->n
.sym
= new_sym
;
3127 gcc_assert (new_symtree
== root
);
3129 /* Create a dummy->actual mapping. */
3130 sm
= XCNEW (gfc_interface_sym_mapping
);
3131 sm
->next
= mapping
->syms
;
3133 sm
->new_sym
= new_symtree
;
3134 sm
->expr
= gfc_copy_expr (expr
);
3137 /* Stabilize the argument's value. */
3138 if (!sym
->attr
.function
&& se
)
3139 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3141 if (sym
->ts
.type
== BT_CHARACTER
)
3143 /* Create a copy of the dummy argument's length. */
3144 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3145 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3147 /* If the length is specified as "*", record the length that
3148 the caller is passing. We should use the callee's length
3149 in all other cases. */
3150 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3152 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3153 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3160 /* Use the passed value as-is if the argument is a function. */
3161 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3164 /* If the argument is either a string or a pointer to a string,
3165 convert it to a boundless character type. */
3166 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3168 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3169 tmp
= build_pointer_type (tmp
);
3170 if (sym
->attr
.pointer
)
3171 value
= build_fold_indirect_ref_loc (input_location
,
3175 value
= fold_convert (tmp
, value
);
3178 /* If the argument is a scalar, a pointer to an array or an allocatable,
3180 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3181 value
= build_fold_indirect_ref_loc (input_location
,
3184 /* For character(*), use the actual argument's descriptor. */
3185 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3186 value
= build_fold_indirect_ref_loc (input_location
,
3189 /* If the argument is an array descriptor, use it to determine
3190 information about the actual argument's shape. */
3191 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3192 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3194 /* Get the actual argument's descriptor. */
3195 desc
= build_fold_indirect_ref_loc (input_location
,
3198 /* Create the replacement variable. */
3199 tmp
= gfc_conv_descriptor_data_get (desc
);
3200 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3203 /* Use DESC to work out the upper bounds, strides and offset. */
3204 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3207 /* Otherwise we have a packed array. */
3208 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3209 PACKED_FULL
, se
->expr
);
3211 new_sym
->backend_decl
= value
;
3215 /* Called once all dummy argument mappings have been added to MAPPING,
3216 but before the mapping is used to evaluate expressions. Pre-evaluate
3217 the length of each argument, adding any initialization code to PRE and
3218 any finalization code to POST. */
3221 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3222 stmtblock_t
* pre
, stmtblock_t
* post
)
3224 gfc_interface_sym_mapping
*sym
;
3228 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3229 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3230 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3232 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3233 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3234 gfc_init_se (&se
, NULL
);
3235 gfc_conv_expr (&se
, expr
);
3236 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3237 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3238 gfc_add_block_to_block (pre
, &se
.pre
);
3239 gfc_add_block_to_block (post
, &se
.post
);
3241 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3246 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3250 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3251 gfc_constructor_base base
)
3254 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3256 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3259 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3260 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3261 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3267 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3271 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3276 for (; ref
; ref
= ref
->next
)
3280 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3282 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3283 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3284 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3292 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3293 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3299 /* Convert intrinsic function calls into result expressions. */
3302 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3310 arg1
= expr
->value
.function
.actual
->expr
;
3311 if (expr
->value
.function
.actual
->next
)
3312 arg2
= expr
->value
.function
.actual
->next
->expr
;
3316 sym
= arg1
->symtree
->n
.sym
;
3318 if (sym
->attr
.dummy
)
3323 switch (expr
->value
.function
.isym
->id
)
3326 /* TODO figure out why this condition is necessary. */
3327 if (sym
->attr
.function
3328 && (arg1
->ts
.u
.cl
->length
== NULL
3329 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3330 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3333 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3337 if (!sym
->as
|| sym
->as
->rank
== 0)
3340 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3342 dup
= mpz_get_si (arg2
->value
.integer
);
3347 dup
= sym
->as
->rank
;
3351 for (; d
< dup
; d
++)
3355 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3357 gfc_free_expr (new_expr
);
3361 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3362 gfc_get_int_expr (gfc_default_integer_kind
,
3364 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3366 new_expr
= gfc_multiply (new_expr
, tmp
);
3372 case GFC_ISYM_LBOUND
:
3373 case GFC_ISYM_UBOUND
:
3374 /* TODO These implementations of lbound and ubound do not limit if
3375 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3377 if (!sym
->as
|| sym
->as
->rank
== 0)
3380 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3381 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3383 /* TODO: If the need arises, this could produce an array of
3387 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3389 if (sym
->as
->lower
[d
])
3390 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3394 if (sym
->as
->upper
[d
])
3395 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3403 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3407 gfc_replace_expr (expr
, new_expr
);
3413 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3414 gfc_interface_mapping
* mapping
)
3416 gfc_formal_arglist
*f
;
3417 gfc_actual_arglist
*actual
;
3419 actual
= expr
->value
.function
.actual
;
3420 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3422 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3427 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3430 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3435 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3437 for (d
= 0; d
< as
->rank
; d
++)
3439 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3440 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3443 expr
->value
.function
.esym
->as
= as
;
3446 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3448 expr
->value
.function
.esym
->ts
.u
.cl
->length
3449 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3451 gfc_apply_interface_mapping_to_expr (mapping
,
3452 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3457 /* EXPR is a copy of an expression that appeared in the interface
3458 associated with MAPPING. Walk it recursively looking for references to
3459 dummy arguments that MAPPING maps to actual arguments. Replace each such
3460 reference with a reference to the associated actual argument. */
3463 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3466 gfc_interface_sym_mapping
*sym
;
3467 gfc_actual_arglist
*actual
;
3472 /* Copying an expression does not copy its length, so do that here. */
3473 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3475 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3476 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3479 /* Apply the mapping to any references. */
3480 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3482 /* ...and to the expression's symbol, if it has one. */
3483 /* TODO Find out why the condition on expr->symtree had to be moved into
3484 the loop rather than being outside it, as originally. */
3485 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3486 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3488 if (sym
->new_sym
->n
.sym
->backend_decl
)
3489 expr
->symtree
= sym
->new_sym
;
3491 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3492 /* Replace base type for polymorphic arguments. */
3493 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3494 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3495 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3498 /* ...and to subexpressions in expr->value. */
3499 switch (expr
->expr_type
)
3504 case EXPR_SUBSTRING
:
3508 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3509 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3513 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3514 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3516 if (expr
->value
.function
.esym
== NULL
3517 && expr
->value
.function
.isym
!= NULL
3518 && expr
->value
.function
.actual
->expr
->symtree
3519 && gfc_map_intrinsic_function (expr
, mapping
))
3522 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3523 if (sym
->old
== expr
->value
.function
.esym
)
3525 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3526 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3527 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3532 case EXPR_STRUCTURE
:
3533 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3546 /* Evaluate interface expression EXPR using MAPPING. Store the result
3550 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3551 gfc_se
* se
, gfc_expr
* expr
)
3553 expr
= gfc_copy_expr (expr
);
3554 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3555 gfc_conv_expr (se
, expr
);
3556 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3557 gfc_free_expr (expr
);
3561 /* Returns a reference to a temporary array into which a component of
3562 an actual argument derived type array is copied and then returned
3563 after the function call. */
3565 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3566 sym_intent intent
, bool formal_ptr
)
3574 gfc_array_info
*info
;
3584 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3586 gfc_init_se (&lse
, NULL
);
3587 gfc_init_se (&rse
, NULL
);
3589 /* Walk the argument expression. */
3590 rss
= gfc_walk_expr (expr
);
3592 gcc_assert (rss
!= gfc_ss_terminator
);
3594 /* Initialize the scalarizer. */
3595 gfc_init_loopinfo (&loop
);
3596 gfc_add_ss_to_loop (&loop
, rss
);
3598 /* Calculate the bounds of the scalarization. */
3599 gfc_conv_ss_startstride (&loop
);
3601 /* Build an ss for the temporary. */
3602 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3603 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3605 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3606 if (GFC_ARRAY_TYPE_P (base_type
)
3607 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3608 base_type
= gfc_get_element_type (base_type
);
3610 if (expr
->ts
.type
== BT_CLASS
)
3611 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3613 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3614 ? expr
->ts
.u
.cl
->backend_decl
3618 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3620 /* Associate the SS with the loop. */
3621 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3623 /* Setup the scalarizing loops. */
3624 gfc_conv_loop_setup (&loop
, &expr
->where
);
3626 /* Pass the temporary descriptor back to the caller. */
3627 info
= &loop
.temp_ss
->info
->data
.array
;
3628 parmse
->expr
= info
->descriptor
;
3630 /* Setup the gfc_se structures. */
3631 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3632 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3635 lse
.ss
= loop
.temp_ss
;
3636 gfc_mark_ss_chain_used (rss
, 1);
3637 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3639 /* Start the scalarized loop body. */
3640 gfc_start_scalarized_body (&loop
, &body
);
3642 /* Translate the expression. */
3643 gfc_conv_expr (&rse
, expr
);
3645 gfc_conv_tmp_array_ref (&lse
);
3647 if (intent
!= INTENT_OUT
)
3649 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3650 gfc_add_expr_to_block (&body
, tmp
);
3651 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3652 gfc_trans_scalarizing_loops (&loop
, &body
);
3656 /* Make sure that the temporary declaration survives by merging
3657 all the loop declarations into the current context. */
3658 for (n
= 0; n
< loop
.dimen
; n
++)
3660 gfc_merge_block_scope (&body
);
3661 body
= loop
.code
[loop
.order
[n
]];
3663 gfc_merge_block_scope (&body
);
3666 /* Add the post block after the second loop, so that any
3667 freeing of allocated memory is done at the right time. */
3668 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3670 /**********Copy the temporary back again.*********/
3672 gfc_init_se (&lse
, NULL
);
3673 gfc_init_se (&rse
, NULL
);
3675 /* Walk the argument expression. */
3676 lss
= gfc_walk_expr (expr
);
3677 rse
.ss
= loop
.temp_ss
;
3680 /* Initialize the scalarizer. */
3681 gfc_init_loopinfo (&loop2
);
3682 gfc_add_ss_to_loop (&loop2
, lss
);
3684 /* Calculate the bounds of the scalarization. */
3685 gfc_conv_ss_startstride (&loop2
);
3687 /* Setup the scalarizing loops. */
3688 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3690 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3691 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3693 gfc_mark_ss_chain_used (lss
, 1);
3694 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3696 /* Declare the variable to hold the temporary offset and start the
3697 scalarized loop body. */
3698 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3699 gfc_start_scalarized_body (&loop2
, &body
);
3701 /* Build the offsets for the temporary from the loop variables. The
3702 temporary array has lbounds of zero and strides of one in all
3703 dimensions, so this is very simple. The offset is only computed
3704 outside the innermost loop, so the overall transfer could be
3705 optimized further. */
3706 info
= &rse
.ss
->info
->data
.array
;
3707 dimen
= rse
.ss
->dimen
;
3709 tmp_index
= gfc_index_zero_node
;
3710 for (n
= dimen
- 1; n
> 0; n
--)
3713 tmp
= rse
.loop
->loopvar
[n
];
3714 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3715 tmp
, rse
.loop
->from
[n
]);
3716 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3719 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3720 gfc_array_index_type
,
3721 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3722 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3723 gfc_array_index_type
,
3724 tmp_str
, gfc_index_one_node
);
3726 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3727 gfc_array_index_type
, tmp
, tmp_str
);
3730 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3731 gfc_array_index_type
,
3732 tmp_index
, rse
.loop
->from
[0]);
3733 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3735 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3736 gfc_array_index_type
,
3737 rse
.loop
->loopvar
[0], offset
);
3739 /* Now use the offset for the reference. */
3740 tmp
= build_fold_indirect_ref_loc (input_location
,
3742 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3744 if (expr
->ts
.type
== BT_CHARACTER
)
3745 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3747 gfc_conv_expr (&lse
, expr
);
3749 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3751 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3752 gfc_add_expr_to_block (&body
, tmp
);
3754 /* Generate the copying loops. */
3755 gfc_trans_scalarizing_loops (&loop2
, &body
);
3757 /* Wrap the whole thing up by adding the second loop to the post-block
3758 and following it by the post-block of the first loop. In this way,
3759 if the temporary needs freeing, it is done after use! */
3760 if (intent
!= INTENT_IN
)
3762 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3763 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3766 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3768 gfc_cleanup_loop (&loop
);
3769 gfc_cleanup_loop (&loop2
);
3771 /* Pass the string length to the argument expression. */
3772 if (expr
->ts
.type
== BT_CHARACTER
)
3773 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3775 /* Determine the offset for pointer formal arguments and set the
3779 size
= gfc_index_one_node
;
3780 offset
= gfc_index_zero_node
;
3781 for (n
= 0; n
< dimen
; n
++)
3783 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3785 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3786 gfc_array_index_type
, tmp
,
3787 gfc_index_one_node
);
3788 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3792 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3795 gfc_index_one_node
);
3796 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3797 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3798 gfc_array_index_type
,
3800 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3801 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3802 gfc_array_index_type
,
3803 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3804 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3805 gfc_array_index_type
,
3806 tmp
, gfc_index_one_node
);
3807 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3808 gfc_array_index_type
, size
, tmp
);
3811 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3815 /* We want either the address for the data or the address of the descriptor,
3816 depending on the mode of passing array arguments. */
3818 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3820 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3826 /* Generate the code for argument list functions. */
3829 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3831 /* Pass by value for g77 %VAL(arg), pass the address
3832 indirectly for %LOC, else by reference. Thus %REF
3833 is a "do-nothing" and %LOC is the same as an F95
3835 if (strncmp (name
, "%VAL", 4) == 0)
3836 gfc_conv_expr (se
, expr
);
3837 else if (strncmp (name
, "%LOC", 4) == 0)
3839 gfc_conv_expr_reference (se
, expr
);
3840 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3842 else if (strncmp (name
, "%REF", 4) == 0)
3843 gfc_conv_expr_reference (se
, expr
);
3845 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3849 /* Generate code for a procedure call. Note can return se->post != NULL.
3850 If se->direct_byref is set then se->expr contains the return parameter.
3851 Return nonzero, if the call has alternate specifiers.
3852 'expr' is only needed for procedure pointer components. */
3855 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3856 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3857 vec
<tree
, va_gc
> *append_args
)
3859 gfc_interface_mapping mapping
;
3860 vec
<tree
, va_gc
> *arglist
;
3861 vec
<tree
, va_gc
> *retargs
;
3865 gfc_array_info
*info
;
3872 vec
<tree
, va_gc
> *stringargs
;
3873 vec
<tree
, va_gc
> *optionalargs
;
3875 gfc_formal_arglist
*formal
;
3876 gfc_actual_arglist
*arg
;
3877 int has_alternate_specifier
= 0;
3878 bool need_interface_mapping
;
3885 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3886 gfc_component
*comp
= NULL
;
3892 optionalargs
= NULL
;
3897 comp
= gfc_get_proc_ptr_comp (expr
);
3901 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3903 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3904 if (se
->ss
->info
->useflags
)
3906 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3907 && sym
->result
->attr
.dimension
)
3908 || (comp
&& comp
->attr
.dimension
));
3909 gcc_assert (se
->loop
!= NULL
);
3911 /* Access the previously obtained result. */
3912 gfc_conv_tmp_array_ref (se
);
3916 info
= &se
->ss
->info
->data
.array
;
3921 gfc_init_block (&post
);
3922 gfc_init_interface_mapping (&mapping
);
3925 formal
= gfc_sym_get_dummy_args (sym
);
3926 need_interface_mapping
= sym
->attr
.dimension
||
3927 (sym
->ts
.type
== BT_CHARACTER
3928 && sym
->ts
.u
.cl
->length
3929 && sym
->ts
.u
.cl
->length
->expr_type
3934 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3935 need_interface_mapping
= comp
->attr
.dimension
||
3936 (comp
->ts
.type
== BT_CHARACTER
3937 && comp
->ts
.u
.cl
->length
3938 && comp
->ts
.u
.cl
->length
->expr_type
3942 base_object
= NULL_TREE
;
3944 /* Evaluate the arguments. */
3945 for (arg
= args
; arg
!= NULL
;
3946 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3949 fsym
= formal
? formal
->sym
: NULL
;
3950 parm_kind
= MISSING
;
3952 /* Class array expressions are sometimes coming completely unadorned
3953 with either arrayspec or _data component. Correct that here.
3954 OOP-TODO: Move this to the frontend. */
3955 if (e
&& e
->expr_type
== EXPR_VARIABLE
3957 && e
->ts
.type
== BT_CLASS
3958 && (CLASS_DATA (e
)->attr
.codimension
3959 || CLASS_DATA (e
)->attr
.dimension
))
3961 gfc_typespec temp_ts
= e
->ts
;
3962 gfc_add_class_array_ref (e
);
3968 if (se
->ignore_optional
)
3970 /* Some intrinsics have already been resolved to the correct
3974 else if (arg
->label
)
3976 has_alternate_specifier
= 1;
3981 gfc_init_se (&parmse
, NULL
);
3983 /* For scalar arguments with VALUE attribute which are passed by
3984 value, pass "0" and a hidden argument gives the optional
3986 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
3987 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
3988 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
3990 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
3992 vec_safe_push (optionalargs
, boolean_false_node
);
3996 /* Pass a NULL pointer for an absent arg. */
3997 parmse
.expr
= null_pointer_node
;
3998 if (arg
->missing_arg_type
== BT_CHARACTER
)
3999 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4004 else if (arg
->expr
->expr_type
== EXPR_NULL
4005 && fsym
&& !fsym
->attr
.pointer
4006 && (fsym
->ts
.type
!= BT_CLASS
4007 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4009 /* Pass a NULL pointer to denote an absent arg. */
4010 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4011 && (fsym
->ts
.type
!= BT_CLASS
4012 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4013 gfc_init_se (&parmse
, NULL
);
4014 parmse
.expr
= null_pointer_node
;
4015 if (arg
->missing_arg_type
== BT_CHARACTER
)
4016 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4018 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4019 && e
->ts
.type
== BT_DERIVED
)
4021 /* The derived type needs to be converted to a temporary
4023 gfc_init_se (&parmse
, se
);
4024 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4026 && e
->expr_type
== EXPR_VARIABLE
4027 && e
->symtree
->n
.sym
->attr
.optional
,
4028 CLASS_DATA (fsym
)->attr
.class_pointer
4029 || CLASS_DATA (fsym
)->attr
.allocatable
);
4031 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4033 /* The intrinsic type needs to be converted to a temporary
4034 CLASS object for the unlimited polymorphic formal. */
4035 gfc_init_se (&parmse
, se
);
4036 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4038 else if (se
->ss
&& se
->ss
->info
->useflags
)
4044 /* An elemental function inside a scalarized loop. */
4045 gfc_init_se (&parmse
, se
);
4046 parm_kind
= ELEMENTAL
;
4048 gfc_conv_expr_reference (&parmse
, e
);
4049 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4050 && e
->expr_type
== EXPR_FUNCTION
)
4051 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4054 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4055 && gfc_is_class_container_ref (e
))
4057 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4059 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4060 && e
->symtree
->n
.sym
->attr
.optional
)
4062 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4063 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4064 TREE_TYPE (parmse
.expr
),
4066 fold_convert (TREE_TYPE (parmse
.expr
),
4067 null_pointer_node
));
4071 /* If we are passing an absent array as optional dummy to an
4072 elemental procedure, make sure that we pass NULL when the data
4073 pointer is NULL. We need this extra conditional because of
4074 scalarization which passes arrays elements to the procedure,
4075 ignoring the fact that the array can be absent/unallocated/... */
4076 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4078 tree descriptor_data
;
4080 descriptor_data
= ss
->info
->data
.array
.data
;
4081 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4083 fold_convert (TREE_TYPE (descriptor_data
),
4084 null_pointer_node
));
4086 = fold_build3_loc (input_location
, COND_EXPR
,
4087 TREE_TYPE (parmse
.expr
),
4089 fold_convert (TREE_TYPE (parmse
.expr
),
4094 /* The scalarizer does not repackage the reference to a class
4095 array - instead it returns a pointer to the data element. */
4096 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4097 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4098 fsym
->attr
.intent
!= INTENT_IN
4099 && (CLASS_DATA (fsym
)->attr
.class_pointer
4100 || CLASS_DATA (fsym
)->attr
.allocatable
),
4102 && e
->expr_type
== EXPR_VARIABLE
4103 && e
->symtree
->n
.sym
->attr
.optional
,
4104 CLASS_DATA (fsym
)->attr
.class_pointer
4105 || CLASS_DATA (fsym
)->attr
.allocatable
);
4112 gfc_init_se (&parmse
, NULL
);
4114 /* Check whether the expression is a scalar or not; we cannot use
4115 e->rank as it can be nonzero for functions arguments. */
4116 argss
= gfc_walk_expr (e
);
4117 scalar
= argss
== gfc_ss_terminator
;
4119 gfc_free_ss_chain (argss
);
4121 /* Special handling for passing scalar polymorphic coarrays;
4122 otherwise one passes "class->_data.data" instead of "&class". */
4123 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4124 && fsym
&& fsym
->ts
.type
== BT_CLASS
4125 && CLASS_DATA (fsym
)->attr
.codimension
4126 && !CLASS_DATA (fsym
)->attr
.dimension
)
4128 gfc_add_class_array_ref (e
);
4129 parmse
.want_coarray
= 1;
4133 /* A scalar or transformational function. */
4136 if (e
->expr_type
== EXPR_VARIABLE
4137 && e
->symtree
->n
.sym
->attr
.cray_pointee
4138 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4140 /* The Cray pointer needs to be converted to a pointer to
4141 a type given by the expression. */
4142 gfc_conv_expr (&parmse
, e
);
4143 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4144 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4145 parmse
.expr
= convert (type
, tmp
);
4147 else if (fsym
&& fsym
->attr
.value
)
4149 if (fsym
->ts
.type
== BT_CHARACTER
4150 && fsym
->ts
.is_c_interop
4151 && fsym
->ns
->proc_name
!= NULL
4152 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4155 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4156 if (parmse
.expr
== NULL
)
4157 gfc_conv_expr (&parmse
, e
);
4161 gfc_conv_expr (&parmse
, e
);
4162 if (fsym
->attr
.optional
4163 && fsym
->ts
.type
!= BT_CLASS
4164 && fsym
->ts
.type
!= BT_DERIVED
)
4166 if (e
->expr_type
!= EXPR_VARIABLE
4167 || !e
->symtree
->n
.sym
->attr
.optional
4169 vec_safe_push (optionalargs
, boolean_true_node
);
4172 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4173 if (!e
->symtree
->n
.sym
->attr
.value
)
4175 = fold_build3_loc (input_location
, COND_EXPR
,
4176 TREE_TYPE (parmse
.expr
),
4178 fold_convert (TREE_TYPE (parmse
.expr
),
4179 integer_zero_node
));
4181 vec_safe_push (optionalargs
, tmp
);
4186 else if (arg
->name
&& arg
->name
[0] == '%')
4187 /* Argument list functions %VAL, %LOC and %REF are signalled
4188 through arg->name. */
4189 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4190 else if ((e
->expr_type
== EXPR_FUNCTION
)
4191 && ((e
->value
.function
.esym
4192 && e
->value
.function
.esym
->result
->attr
.pointer
)
4193 || (!e
->value
.function
.esym
4194 && e
->symtree
->n
.sym
->attr
.pointer
))
4195 && fsym
&& fsym
->attr
.target
)
4197 gfc_conv_expr (&parmse
, e
);
4198 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4200 else if (e
->expr_type
== EXPR_FUNCTION
4201 && e
->symtree
->n
.sym
->result
4202 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4203 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4205 /* Functions returning procedure pointers. */
4206 gfc_conv_expr (&parmse
, e
);
4207 if (fsym
&& fsym
->attr
.proc_pointer
)
4208 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4212 if (e
->ts
.type
== BT_CLASS
&& fsym
4213 && fsym
->ts
.type
== BT_CLASS
4214 && (!CLASS_DATA (fsym
)->as
4215 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4216 && CLASS_DATA (e
)->attr
.codimension
)
4218 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4219 gcc_assert (!CLASS_DATA (fsym
)->as
);
4220 gfc_add_class_array_ref (e
);
4221 parmse
.want_coarray
= 1;
4222 gfc_conv_expr_reference (&parmse
, e
);
4223 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4225 && e
->expr_type
== EXPR_VARIABLE
);
4228 gfc_conv_expr_reference (&parmse
, e
);
4230 /* Catch base objects that are not variables. */
4231 if (e
->ts
.type
== BT_CLASS
4232 && e
->expr_type
!= EXPR_VARIABLE
4233 && expr
&& e
== expr
->base_expr
)
4234 base_object
= build_fold_indirect_ref_loc (input_location
,
4237 /* A class array element needs converting back to be a
4238 class object, if the formal argument is a class object. */
4239 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4240 && e
->ts
.type
== BT_CLASS
4241 && ((CLASS_DATA (fsym
)->as
4242 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4243 || CLASS_DATA (e
)->attr
.dimension
))
4244 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4245 fsym
->attr
.intent
!= INTENT_IN
4246 && (CLASS_DATA (fsym
)->attr
.class_pointer
4247 || CLASS_DATA (fsym
)->attr
.allocatable
),
4249 && e
->expr_type
== EXPR_VARIABLE
4250 && e
->symtree
->n
.sym
->attr
.optional
,
4251 CLASS_DATA (fsym
)->attr
.class_pointer
4252 || CLASS_DATA (fsym
)->attr
.allocatable
);
4254 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4255 allocated on entry, it must be deallocated. */
4256 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4257 && (fsym
->attr
.allocatable
4258 || (fsym
->ts
.type
== BT_CLASS
4259 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4264 gfc_init_block (&block
);
4266 if (e
->ts
.type
== BT_CLASS
)
4267 ptr
= gfc_class_data_get (ptr
);
4269 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4271 gfc_add_expr_to_block (&block
, tmp
);
4272 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4273 void_type_node
, ptr
,
4275 gfc_add_expr_to_block (&block
, tmp
);
4277 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4279 gfc_add_modify (&block
, ptr
,
4280 fold_convert (TREE_TYPE (ptr
),
4281 null_pointer_node
));
4282 gfc_add_expr_to_block (&block
, tmp
);
4284 else if (fsym
->ts
.type
== BT_CLASS
)
4287 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4288 tmp
= gfc_get_symbol_decl (vtab
);
4289 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4290 ptr
= gfc_class_vptr_get (parmse
.expr
);
4291 gfc_add_modify (&block
, ptr
,
4292 fold_convert (TREE_TYPE (ptr
), tmp
));
4293 gfc_add_expr_to_block (&block
, tmp
);
4296 if (fsym
->attr
.optional
4297 && e
->expr_type
== EXPR_VARIABLE
4298 && e
->symtree
->n
.sym
->attr
.optional
)
4300 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4302 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4303 gfc_finish_block (&block
),
4304 build_empty_stmt (input_location
));
4307 tmp
= gfc_finish_block (&block
);
4309 gfc_add_expr_to_block (&se
->pre
, tmp
);
4312 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4313 || fsym
->ts
.type
== BT_ASSUMED
)
4314 && e
->ts
.type
== BT_CLASS
4315 && !CLASS_DATA (e
)->attr
.dimension
4316 && !CLASS_DATA (e
)->attr
.codimension
)
4317 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4319 /* Wrap scalar variable in a descriptor. We need to convert
4320 the address of a pointer back to the pointer itself before,
4321 we can assign it to the data field. */
4323 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4324 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4327 if (TREE_CODE (tmp
) == ADDR_EXPR
4328 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4329 tmp
= TREE_OPERAND (tmp
, 0);
4330 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4332 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4335 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4336 && ((fsym
->attr
.pointer
4337 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4338 || (fsym
->attr
.proc_pointer
4339 && !(e
->expr_type
== EXPR_VARIABLE
4340 && e
->symtree
->n
.sym
->attr
.dummy
))
4341 || (fsym
->attr
.proc_pointer
4342 && e
->expr_type
== EXPR_VARIABLE
4343 && gfc_is_proc_ptr_comp (e
))
4344 || (fsym
->attr
.allocatable
4345 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4347 /* Scalar pointer dummy args require an extra level of
4348 indirection. The null pointer already contains
4349 this level of indirection. */
4350 parm_kind
= SCALAR_POINTER
;
4351 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4355 else if (e
->ts
.type
== BT_CLASS
4356 && fsym
&& fsym
->ts
.type
== BT_CLASS
4357 && (CLASS_DATA (fsym
)->attr
.dimension
4358 || CLASS_DATA (fsym
)->attr
.codimension
))
4360 /* Pass a class array. */
4361 gfc_conv_expr_descriptor (&parmse
, e
);
4363 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4364 allocated on entry, it must be deallocated. */
4365 if (fsym
->attr
.intent
== INTENT_OUT
4366 && CLASS_DATA (fsym
)->attr
.allocatable
)
4371 gfc_init_block (&block
);
4373 ptr
= gfc_class_data_get (ptr
);
4375 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4376 NULL_TREE
, NULL_TREE
,
4379 gfc_add_expr_to_block (&block
, tmp
);
4380 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4381 void_type_node
, ptr
,
4383 gfc_add_expr_to_block (&block
, tmp
);
4384 gfc_reset_vptr (&block
, e
);
4386 if (fsym
->attr
.optional
4387 && e
->expr_type
== EXPR_VARIABLE
4389 || (e
->ref
->type
== REF_ARRAY
4390 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4391 && e
->symtree
->n
.sym
->attr
.optional
)
4393 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4395 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4396 gfc_finish_block (&block
),
4397 build_empty_stmt (input_location
));
4400 tmp
= gfc_finish_block (&block
);
4402 gfc_add_expr_to_block (&se
->pre
, tmp
);
4405 /* The conversion does not repackage the reference to a class
4406 array - _data descriptor. */
4407 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4408 fsym
->attr
.intent
!= INTENT_IN
4409 && (CLASS_DATA (fsym
)->attr
.class_pointer
4410 || CLASS_DATA (fsym
)->attr
.allocatable
),
4412 && e
->expr_type
== EXPR_VARIABLE
4413 && e
->symtree
->n
.sym
->attr
.optional
,
4414 CLASS_DATA (fsym
)->attr
.class_pointer
4415 || CLASS_DATA (fsym
)->attr
.allocatable
);
4419 /* If the procedure requires an explicit interface, the actual
4420 argument is passed according to the corresponding formal
4421 argument. If the corresponding formal argument is a POINTER,
4422 ALLOCATABLE or assumed shape, we do not use g77's calling
4423 convention, and pass the address of the array descriptor
4424 instead. Otherwise we use g77's calling convention. */
4427 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4428 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4429 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4431 f
= f
|| !comp
->attr
.always_explicit
;
4433 f
= f
|| !sym
->attr
.always_explicit
;
4435 /* If the argument is a function call that may not create
4436 a temporary for the result, we have to check that we
4437 can do it, i.e. that there is no alias between this
4438 argument and another one. */
4439 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4445 intent
= fsym
->attr
.intent
;
4447 intent
= INTENT_UNKNOWN
;
4449 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4451 parmse
.force_tmp
= 1;
4453 iarg
= e
->value
.function
.actual
->expr
;
4455 /* Temporary needed if aliasing due to host association. */
4456 if (sym
->attr
.contained
4458 && !sym
->attr
.implicit_pure
4459 && !sym
->attr
.use_assoc
4460 && iarg
->expr_type
== EXPR_VARIABLE
4461 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4462 parmse
.force_tmp
= 1;
4464 /* Ditto within module. */
4465 if (sym
->attr
.use_assoc
4467 && !sym
->attr
.implicit_pure
4468 && iarg
->expr_type
== EXPR_VARIABLE
4469 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4470 parmse
.force_tmp
= 1;
4473 if (e
->expr_type
== EXPR_VARIABLE
4474 && is_subref_array (e
))
4475 /* The actual argument is a component reference to an
4476 array of derived types. In this case, the argument
4477 is converted to a temporary, which is passed and then
4478 written back after the procedure call. */
4479 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4480 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4481 fsym
&& fsym
->attr
.pointer
);
4482 else if (gfc_is_class_array_ref (e
, NULL
)
4483 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4484 /* The actual argument is a component reference to an
4485 array of derived types. In this case, the argument
4486 is converted to a temporary, which is passed and then
4487 written back after the procedure call.
4488 OOP-TODO: Insert code so that if the dynamic type is
4489 the same as the declared type, copy-in/copy-out does
4491 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4492 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4493 fsym
&& fsym
->attr
.pointer
);
4495 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4497 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4498 allocated on entry, it must be deallocated. */
4499 if (fsym
&& fsym
->attr
.allocatable
4500 && fsym
->attr
.intent
== INTENT_OUT
)
4502 tmp
= build_fold_indirect_ref_loc (input_location
,
4504 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4505 if (fsym
->attr
.optional
4506 && e
->expr_type
== EXPR_VARIABLE
4507 && e
->symtree
->n
.sym
->attr
.optional
)
4508 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4510 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4511 tmp
, build_empty_stmt (input_location
));
4512 gfc_add_expr_to_block (&se
->pre
, tmp
);
4517 /* The case with fsym->attr.optional is that of a user subroutine
4518 with an interface indicating an optional argument. When we call
4519 an intrinsic subroutine, however, fsym is NULL, but we might still
4520 have an optional argument, so we proceed to the substitution
4522 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4524 /* If an optional argument is itself an optional dummy argument,
4525 check its presence and substitute a null if absent. This is
4526 only needed when passing an array to an elemental procedure
4527 as then array elements are accessed - or no NULL pointer is
4528 allowed and a "1" or "0" should be passed if not present.
4529 When passing a non-array-descriptor full array to a
4530 non-array-descriptor dummy, no check is needed. For
4531 array-descriptor actual to array-descriptor dummy, see
4532 PR 41911 for why a check has to be inserted.
4533 fsym == NULL is checked as intrinsics required the descriptor
4534 but do not always set fsym. */
4535 if (e
->expr_type
== EXPR_VARIABLE
4536 && e
->symtree
->n
.sym
->attr
.optional
4537 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4538 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4542 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4543 || fsym
->as
->type
== AS_ASSUMED_RANK
4544 || fsym
->as
->type
== AS_DEFERRED
))))))
4545 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4546 e
->representation
.length
);
4551 /* Obtain the character length of an assumed character length
4552 length procedure from the typespec. */
4553 if (fsym
->ts
.type
== BT_CHARACTER
4554 && parmse
.string_length
== NULL_TREE
4555 && e
->ts
.type
== BT_PROCEDURE
4556 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4557 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4558 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4560 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4561 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4565 if (fsym
&& need_interface_mapping
&& e
)
4566 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4568 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4569 gfc_add_block_to_block (&post
, &parmse
.post
);
4571 /* Allocated allocatable components of derived types must be
4572 deallocated for non-variable scalars. Non-variable arrays are
4573 dealt with in trans-array.c(gfc_conv_array_parameter). */
4574 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4575 && e
->ts
.u
.derived
->attr
.alloc_comp
4576 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4577 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4580 tmp
= build_fold_indirect_ref_loc (input_location
,
4582 parm_rank
= e
->rank
;
4590 case (SCALAR_POINTER
):
4591 tmp
= build_fold_indirect_ref_loc (input_location
,
4596 if (e
->expr_type
== EXPR_OP
4597 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4598 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4601 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4602 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4603 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4606 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4608 /* The derived type is passed to gfc_deallocate_alloc_comp.
4609 Therefore, class actuals can handled correctly but derived
4610 types passed to class formals need the _data component. */
4611 tmp
= gfc_class_data_get (tmp
);
4612 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4613 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4616 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4618 gfc_add_expr_to_block (&se
->post
, tmp
);
4621 /* Add argument checking of passing an unallocated/NULL actual to
4622 a nonallocatable/nonpointer dummy. */
4624 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4626 symbol_attribute attr
;
4630 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4631 attr
= gfc_expr_attr (e
);
4633 goto end_pointer_check
;
4635 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4636 allocatable to an optional dummy, cf. 12.5.2.12. */
4637 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4638 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4639 goto end_pointer_check
;
4643 /* If the actual argument is an optional pointer/allocatable and
4644 the formal argument takes an nonpointer optional value,
4645 it is invalid to pass a non-present argument on, even
4646 though there is no technical reason for this in gfortran.
4647 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4648 tree present
, null_ptr
, type
;
4650 if (attr
.allocatable
4651 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4652 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4653 "allocated or not present", e
->symtree
->n
.sym
->name
);
4654 else if (attr
.pointer
4655 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4656 asprintf (&msg
, "Pointer actual argument '%s' is not "
4657 "associated or not present",
4658 e
->symtree
->n
.sym
->name
);
4659 else if (attr
.proc_pointer
4660 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4661 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4662 "associated or not present",
4663 e
->symtree
->n
.sym
->name
);
4665 goto end_pointer_check
;
4667 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4668 type
= TREE_TYPE (present
);
4669 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4670 boolean_type_node
, present
,
4672 null_pointer_node
));
4673 type
= TREE_TYPE (parmse
.expr
);
4674 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4675 boolean_type_node
, parmse
.expr
,
4677 null_pointer_node
));
4678 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4679 boolean_type_node
, present
, null_ptr
);
4683 if (attr
.allocatable
4684 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4685 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4686 "allocated", e
->symtree
->n
.sym
->name
);
4687 else if (attr
.pointer
4688 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4689 asprintf (&msg
, "Pointer actual argument '%s' is not "
4690 "associated", e
->symtree
->n
.sym
->name
);
4691 else if (attr
.proc_pointer
4692 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4693 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4694 "associated", e
->symtree
->n
.sym
->name
);
4696 goto end_pointer_check
;
4700 /* If the argument is passed by value, we need to strip the
4702 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4703 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4705 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4706 boolean_type_node
, tmp
,
4707 fold_convert (TREE_TYPE (tmp
),
4708 null_pointer_node
));
4711 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4717 /* Deferred length dummies pass the character length by reference
4718 so that the value can be returned. */
4719 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4721 tmp
= parmse
.string_length
;
4722 if (TREE_CODE (tmp
) != VAR_DECL
)
4723 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4724 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4727 /* Character strings are passed as two parameters, a length and a
4728 pointer - except for Bind(c) which only passes the pointer.
4729 An unlimited polymorphic formal argument likewise does not
4731 if (parmse
.string_length
!= NULL_TREE
4732 && !sym
->attr
.is_bind_c
4733 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4734 vec_safe_push (stringargs
, parmse
.string_length
);
4736 /* When calling __copy for character expressions to unlimited
4737 polymorphic entities, the dst argument needs a string length. */
4738 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4739 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4740 && arg
->next
&& arg
->next
->expr
4741 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4742 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4743 vec_safe_push (stringargs
, parmse
.string_length
);
4745 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4746 pass the token and the offset as additional arguments. */
4747 if (fsym
&& fsym
->attr
.codimension
4748 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4749 && !fsym
->attr
.allocatable
4752 /* Token and offset. */
4753 vec_safe_push (stringargs
, null_pointer_node
);
4754 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4755 gcc_assert (fsym
->attr
.optional
);
4757 else if (fsym
&& fsym
->attr
.codimension
4758 && !fsym
->attr
.allocatable
4759 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4761 tree caf_decl
, caf_type
;
4764 caf_decl
= get_tree_for_caf_expr (e
);
4765 caf_type
= TREE_TYPE (caf_decl
);
4767 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4768 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4769 tmp
= gfc_conv_descriptor_token (caf_decl
);
4770 else if (DECL_LANG_SPECIFIC (caf_decl
)
4771 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4772 tmp
= GFC_DECL_TOKEN (caf_decl
);
4775 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4776 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4777 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4780 vec_safe_push (stringargs
, tmp
);
4782 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4783 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4784 offset
= build_int_cst (gfc_array_index_type
, 0);
4785 else if (DECL_LANG_SPECIFIC (caf_decl
)
4786 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4787 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4788 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4789 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4791 offset
= build_int_cst (gfc_array_index_type
, 0);
4793 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4794 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4797 gcc_assert (POINTER_TYPE_P (caf_type
));
4801 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4802 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4803 && !fsym
->attr
.allocatable
))
4805 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4806 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4807 (TREE_TYPE (parmse
.expr
))));
4808 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4809 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4811 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4812 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4815 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4819 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4820 gfc_array_index_type
,
4821 fold_convert (gfc_array_index_type
, tmp2
),
4822 fold_convert (gfc_array_index_type
, tmp
));
4823 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4824 gfc_array_index_type
, offset
, tmp
);
4826 vec_safe_push (stringargs
, offset
);
4829 vec_safe_push (arglist
, parmse
.expr
);
4831 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4838 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4839 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4840 else if (ts
.type
== BT_CHARACTER
)
4842 if (ts
.u
.cl
->length
== NULL
)
4844 /* Assumed character length results are not allowed by 5.1.1.5 of the
4845 standard and are trapped in resolve.c; except in the case of SPREAD
4846 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4847 we take the character length of the first argument for the result.
4848 For dummies, we have to look through the formal argument list for
4849 this function and use the character length found there.*/
4851 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4852 else if (!sym
->attr
.dummy
)
4853 cl
.backend_decl
= (*stringargs
)[0];
4856 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4857 for (; formal
; formal
= formal
->next
)
4858 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4859 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4861 len
= cl
.backend_decl
;
4867 /* Calculate the length of the returned string. */
4868 gfc_init_se (&parmse
, NULL
);
4869 if (need_interface_mapping
)
4870 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4872 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4873 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4874 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4876 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4877 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4878 gfc_charlen_type_node
, tmp
,
4879 build_int_cst (gfc_charlen_type_node
, 0));
4880 cl
.backend_decl
= tmp
;
4883 /* Set up a charlen structure for it. */
4888 len
= cl
.backend_decl
;
4891 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4892 || (!comp
&& gfc_return_by_reference (sym
));
4895 if (se
->direct_byref
)
4897 /* Sometimes, too much indirection can be applied; e.g. for
4898 function_result = array_valued_recursive_function. */
4899 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4900 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4901 && GFC_DESCRIPTOR_TYPE_P
4902 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4903 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4906 /* If the lhs of an assignment x = f(..) is allocatable and
4907 f2003 is allowed, we must do the automatic reallocation.
4908 TODO - deal with intrinsics, without using a temporary. */
4909 if (gfc_option
.flag_realloc_lhs
4910 && se
->ss
&& se
->ss
->loop_chain
4911 && se
->ss
->loop_chain
->is_alloc_lhs
4912 && !expr
->value
.function
.isym
4913 && sym
->result
->as
!= NULL
)
4915 /* Evaluate the bounds of the result, if known. */
4916 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4919 /* Perform the automatic reallocation. */
4920 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4922 gfc_add_expr_to_block (&se
->pre
, tmp
);
4924 /* Pass the temporary as the first argument. */
4925 result
= info
->descriptor
;
4928 result
= build_fold_indirect_ref_loc (input_location
,
4930 vec_safe_push (retargs
, se
->expr
);
4932 else if (comp
&& comp
->attr
.dimension
)
4934 gcc_assert (se
->loop
&& info
);
4936 /* Set the type of the array. */
4937 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4938 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4940 /* Evaluate the bounds of the result, if known. */
4941 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4943 /* If the lhs of an assignment x = f(..) is allocatable and
4944 f2003 is allowed, we must not generate the function call
4945 here but should just send back the results of the mapping.
4946 This is signalled by the function ss being flagged. */
4947 if (gfc_option
.flag_realloc_lhs
4948 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4950 gfc_free_interface_mapping (&mapping
);
4951 return has_alternate_specifier
;
4954 /* Create a temporary to store the result. In case the function
4955 returns a pointer, the temporary will be a shallow copy and
4956 mustn't be deallocated. */
4957 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4958 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4959 tmp
, NULL_TREE
, false,
4960 !comp
->attr
.pointer
, callee_alloc
,
4961 &se
->ss
->info
->expr
->where
);
4963 /* Pass the temporary as the first argument. */
4964 result
= info
->descriptor
;
4965 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4966 vec_safe_push (retargs
, tmp
);
4968 else if (!comp
&& sym
->result
->attr
.dimension
)
4970 gcc_assert (se
->loop
&& info
);
4972 /* Set the type of the array. */
4973 tmp
= gfc_typenode_for_spec (&ts
);
4974 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4976 /* Evaluate the bounds of the result, if known. */
4977 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
4979 /* If the lhs of an assignment x = f(..) is allocatable and
4980 f2003 is allowed, we must not generate the function call
4981 here but should just send back the results of the mapping.
4982 This is signalled by the function ss being flagged. */
4983 if (gfc_option
.flag_realloc_lhs
4984 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4986 gfc_free_interface_mapping (&mapping
);
4987 return has_alternate_specifier
;
4990 /* Create a temporary to store the result. In case the function
4991 returns a pointer, the temporary will be a shallow copy and
4992 mustn't be deallocated. */
4993 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
4994 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4995 tmp
, NULL_TREE
, false,
4996 !sym
->attr
.pointer
, callee_alloc
,
4997 &se
->ss
->info
->expr
->where
);
4999 /* Pass the temporary as the first argument. */
5000 result
= info
->descriptor
;
5001 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5002 vec_safe_push (retargs
, tmp
);
5004 else if (ts
.type
== BT_CHARACTER
)
5006 /* Pass the string length. */
5007 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5008 type
= build_pointer_type (type
);
5010 /* Return an address to a char[0:len-1]* temporary for
5011 character pointers. */
5012 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5013 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5015 var
= gfc_create_var (type
, "pstr");
5017 if ((!comp
&& sym
->attr
.allocatable
)
5018 || (comp
&& comp
->attr
.allocatable
))
5020 gfc_add_modify (&se
->pre
, var
,
5021 fold_convert (TREE_TYPE (var
),
5022 null_pointer_node
));
5023 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5024 gfc_add_expr_to_block (&se
->post
, tmp
);
5027 /* Provide an address expression for the function arguments. */
5028 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5031 var
= gfc_conv_string_tmp (se
, type
, len
);
5033 vec_safe_push (retargs
, var
);
5037 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5039 type
= gfc_get_complex_type (ts
.kind
);
5040 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5041 vec_safe_push (retargs
, var
);
5044 /* Add the string length to the argument list. */
5045 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5048 if (TREE_CODE (tmp
) != VAR_DECL
)
5049 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5050 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5051 vec_safe_push (retargs
, tmp
);
5053 else if (ts
.type
== BT_CHARACTER
)
5054 vec_safe_push (retargs
, len
);
5056 gfc_free_interface_mapping (&mapping
);
5058 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5059 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5060 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5061 vec_safe_reserve (retargs
, arglen
);
5063 /* Add the return arguments. */
5064 retargs
->splice (arglist
);
5066 /* Add the hidden present status for optional+value to the arguments. */
5067 retargs
->splice (optionalargs
);
5069 /* Add the hidden string length parameters to the arguments. */
5070 retargs
->splice (stringargs
);
5072 /* We may want to append extra arguments here. This is used e.g. for
5073 calls to libgfortran_matmul_??, which need extra information. */
5074 if (!vec_safe_is_empty (append_args
))
5075 retargs
->splice (append_args
);
5078 /* Generate the actual call. */
5079 if (base_object
== NULL_TREE
)
5080 conv_function_val (se
, sym
, expr
);
5082 conv_base_obj_fcn_val (se
, base_object
, expr
);
5084 /* If there are alternate return labels, function type should be
5085 integer. Can't modify the type in place though, since it can be shared
5086 with other functions. For dummy arguments, the typing is done to
5087 this result, even if it has to be repeated for each call. */
5088 if (has_alternate_specifier
5089 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5091 if (!sym
->attr
.dummy
)
5093 TREE_TYPE (sym
->backend_decl
)
5094 = build_function_type (integer_type_node
,
5095 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5096 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5099 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5102 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5103 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5105 /* If we have a pointer function, but we don't want a pointer, e.g.
5108 where f is pointer valued, we have to dereference the result. */
5109 if (!se
->want_pointer
&& !byref
5110 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5111 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5112 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5114 /* f2c calling conventions require a scalar default real function to
5115 return a double precision result. Convert this back to default
5116 real. We only care about the cases that can happen in Fortran 77.
5118 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5119 && sym
->ts
.kind
== gfc_default_real_kind
5120 && !sym
->attr
.always_explicit
)
5121 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5123 /* A pure function may still have side-effects - it may modify its
5125 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5127 if (!sym
->attr
.pure
)
5128 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5133 /* Add the function call to the pre chain. There is no expression. */
5134 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5135 se
->expr
= NULL_TREE
;
5137 if (!se
->direct_byref
)
5139 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5141 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5143 /* Check the data pointer hasn't been modified. This would
5144 happen in a function returning a pointer. */
5145 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5146 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5149 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5152 se
->expr
= info
->descriptor
;
5153 /* Bundle in the string length. */
5154 se
->string_length
= len
;
5156 else if (ts
.type
== BT_CHARACTER
)
5158 /* Dereference for character pointer results. */
5159 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5160 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5161 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5165 se
->string_length
= len
;
5169 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5170 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5175 /* Follow the function call with the argument post block. */
5178 gfc_add_block_to_block (&se
->pre
, &post
);
5180 /* Transformational functions of derived types with allocatable
5181 components must have the result allocatable components copied. */
5182 arg
= expr
->value
.function
.actual
;
5183 if (result
&& arg
&& expr
->rank
5184 && expr
->value
.function
.isym
5185 && expr
->value
.function
.isym
->transformational
5186 && arg
->expr
->ts
.type
== BT_DERIVED
5187 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5190 /* Copy the allocatable components. We have to use a
5191 temporary here to prevent source allocatable components
5192 from being corrupted. */
5193 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5194 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5195 result
, tmp2
, expr
->rank
);
5196 gfc_add_expr_to_block (&se
->pre
, tmp
);
5197 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5199 gfc_add_expr_to_block (&se
->pre
, tmp
);
5201 /* Finally free the temporary's data field. */
5202 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5203 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5204 NULL_TREE
, NULL_TREE
, true,
5206 gfc_add_expr_to_block (&se
->pre
, tmp
);
5210 gfc_add_block_to_block (&se
->post
, &post
);
5212 return has_alternate_specifier
;
5216 /* Fill a character string with spaces. */
5219 fill_with_spaces (tree start
, tree type
, tree size
)
5221 stmtblock_t block
, loop
;
5222 tree i
, el
, exit_label
, cond
, tmp
;
5224 /* For a simple char type, we can call memset(). */
5225 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5226 return build_call_expr_loc (input_location
,
5227 builtin_decl_explicit (BUILT_IN_MEMSET
),
5229 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5230 lang_hooks
.to_target_charset (' ')),
5233 /* Otherwise, we use a loop:
5234 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5238 /* Initialize variables. */
5239 gfc_init_block (&block
);
5240 i
= gfc_create_var (sizetype
, "i");
5241 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5242 el
= gfc_create_var (build_pointer_type (type
), "el");
5243 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5244 exit_label
= gfc_build_label_decl (NULL_TREE
);
5245 TREE_USED (exit_label
) = 1;
5249 gfc_init_block (&loop
);
5251 /* Exit condition. */
5252 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5253 build_zero_cst (sizetype
));
5254 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5255 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5256 build_empty_stmt (input_location
));
5257 gfc_add_expr_to_block (&loop
, tmp
);
5260 gfc_add_modify (&loop
,
5261 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5262 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5264 /* Increment loop variables. */
5265 gfc_add_modify (&loop
, i
,
5266 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5267 TYPE_SIZE_UNIT (type
)));
5268 gfc_add_modify (&loop
, el
,
5269 fold_build_pointer_plus_loc (input_location
,
5270 el
, TYPE_SIZE_UNIT (type
)));
5272 /* Making the loop... actually loop! */
5273 tmp
= gfc_finish_block (&loop
);
5274 tmp
= build1_v (LOOP_EXPR
, tmp
);
5275 gfc_add_expr_to_block (&block
, tmp
);
5277 /* The exit label. */
5278 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5279 gfc_add_expr_to_block (&block
, tmp
);
5282 return gfc_finish_block (&block
);
5286 /* Generate code to copy a string. */
5289 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5290 int dkind
, tree slength
, tree src
, int skind
)
5292 tree tmp
, dlen
, slen
;
5301 stmtblock_t tempblock
;
5303 gcc_assert (dkind
== skind
);
5305 if (slength
!= NULL_TREE
)
5307 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5308 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5312 slen
= build_int_cst (size_type_node
, 1);
5316 if (dlength
!= NULL_TREE
)
5318 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5319 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5323 dlen
= build_int_cst (size_type_node
, 1);
5327 /* Assign directly if the types are compatible. */
5328 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5329 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5331 gfc_add_modify (block
, dsc
, ssc
);
5335 /* Do nothing if the destination length is zero. */
5336 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5337 build_int_cst (size_type_node
, 0));
5339 /* The following code was previously in _gfortran_copy_string:
5341 // The two strings may overlap so we use memmove.
5343 copy_string (GFC_INTEGER_4 destlen, char * dest,
5344 GFC_INTEGER_4 srclen, const char * src)
5346 if (srclen >= destlen)
5348 // This will truncate if too long.
5349 memmove (dest, src, destlen);
5353 memmove (dest, src, srclen);
5355 memset (&dest[srclen], ' ', destlen - srclen);
5359 We're now doing it here for better optimization, but the logic
5362 /* For non-default character kinds, we have to multiply the string
5363 length by the base type size. */
5364 chartype
= gfc_get_char_type (dkind
);
5365 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5366 fold_convert (size_type_node
, slen
),
5367 fold_convert (size_type_node
,
5368 TYPE_SIZE_UNIT (chartype
)));
5369 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5370 fold_convert (size_type_node
, dlen
),
5371 fold_convert (size_type_node
,
5372 TYPE_SIZE_UNIT (chartype
)));
5374 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5375 dest
= fold_convert (pvoid_type_node
, dest
);
5377 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5379 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5380 src
= fold_convert (pvoid_type_node
, src
);
5382 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5384 /* Truncate string if source is too long. */
5385 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5387 tmp2
= build_call_expr_loc (input_location
,
5388 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5389 3, dest
, src
, dlen
);
5391 /* Else copy and pad with spaces. */
5392 tmp3
= build_call_expr_loc (input_location
,
5393 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5394 3, dest
, src
, slen
);
5396 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5397 tmp4
= fill_with_spaces (tmp4
, chartype
,
5398 fold_build2_loc (input_location
, MINUS_EXPR
,
5399 TREE_TYPE(dlen
), dlen
, slen
));
5401 gfc_init_block (&tempblock
);
5402 gfc_add_expr_to_block (&tempblock
, tmp3
);
5403 gfc_add_expr_to_block (&tempblock
, tmp4
);
5404 tmp3
= gfc_finish_block (&tempblock
);
5406 /* The whole copy_string function is there. */
5407 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5409 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5410 build_empty_stmt (input_location
));
5411 gfc_add_expr_to_block (block
, tmp
);
5415 /* Translate a statement function.
5416 The value of a statement function reference is obtained by evaluating the
5417 expression using the values of the actual arguments for the values of the
5418 corresponding dummy arguments. */
5421 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5425 gfc_formal_arglist
*fargs
;
5426 gfc_actual_arglist
*args
;
5429 gfc_saved_var
*saved_vars
;
5435 sym
= expr
->symtree
->n
.sym
;
5436 args
= expr
->value
.function
.actual
;
5437 gfc_init_se (&lse
, NULL
);
5438 gfc_init_se (&rse
, NULL
);
5441 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5443 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5444 temp_vars
= XCNEWVEC (tree
, n
);
5446 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5447 fargs
= fargs
->next
, n
++)
5449 /* Each dummy shall be specified, explicitly or implicitly, to be
5451 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5454 if (fsym
->ts
.type
== BT_CHARACTER
)
5456 /* Copy string arguments. */
5459 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5460 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5462 /* Create a temporary to hold the value. */
5463 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5464 fsym
->ts
.u
.cl
->backend_decl
5465 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5467 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5468 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5470 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5472 gfc_conv_expr (&rse
, args
->expr
);
5473 gfc_conv_string_parameter (&rse
);
5474 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5475 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5477 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5478 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5479 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5480 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5484 /* For everything else, just evaluate the expression. */
5486 /* Create a temporary to hold the value. */
5487 type
= gfc_typenode_for_spec (&fsym
->ts
);
5488 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5490 gfc_conv_expr (&lse
, args
->expr
);
5492 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5493 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5494 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5500 /* Use the temporary variables in place of the real ones. */
5501 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5502 fargs
= fargs
->next
, n
++)
5503 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5505 gfc_conv_expr (se
, sym
->value
);
5507 if (sym
->ts
.type
== BT_CHARACTER
)
5509 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5511 /* Force the expression to the correct length. */
5512 if (!INTEGER_CST_P (se
->string_length
)
5513 || tree_int_cst_lt (se
->string_length
,
5514 sym
->ts
.u
.cl
->backend_decl
))
5516 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5517 tmp
= gfc_create_var (type
, sym
->name
);
5518 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5519 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5520 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5524 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5527 /* Restore the original variables. */
5528 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5529 fargs
= fargs
->next
, n
++)
5530 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5536 /* Translate a function expression. */
5539 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5543 if (expr
->value
.function
.isym
)
5545 gfc_conv_intrinsic_function (se
, expr
);
5549 /* expr.value.function.esym is the resolved (specific) function symbol for
5550 most functions. However this isn't set for dummy procedures. */
5551 sym
= expr
->value
.function
.esym
;
5553 sym
= expr
->symtree
->n
.sym
;
5555 /* We distinguish statement functions from general functions to improve
5556 runtime performance. */
5557 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5559 gfc_conv_statement_function (se
, expr
);
5563 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5568 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5571 is_zero_initializer_p (gfc_expr
* expr
)
5573 if (expr
->expr_type
!= EXPR_CONSTANT
)
5576 /* We ignore constants with prescribed memory representations for now. */
5577 if (expr
->representation
.string
)
5580 switch (expr
->ts
.type
)
5583 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5586 return mpfr_zero_p (expr
->value
.real
)
5587 && MPFR_SIGN (expr
->value
.real
) >= 0;
5590 return expr
->value
.logical
== 0;
5593 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5594 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5595 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5596 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5606 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5611 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5612 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5614 gfc_conv_tmp_array_ref (se
);
5618 /* Build a static initializer. EXPR is the expression for the initial value.
5619 The other parameters describe the variable of the component being
5620 initialized. EXPR may be null. */
5623 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5624 bool array
, bool pointer
, bool procptr
)
5628 if (!(expr
|| pointer
|| procptr
))
5631 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5632 (these are the only two iso_c_binding derived types that can be
5633 used as initialization expressions). If so, we need to modify
5634 the 'expr' to be that for a (void *). */
5635 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5636 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5638 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5640 /* The derived symbol has already been converted to a (void *). Use
5642 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5643 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5645 gfc_init_se (&se
, NULL
);
5646 gfc_conv_constant (&se
, expr
);
5647 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5651 if (array
&& !procptr
)
5654 /* Arrays need special handling. */
5656 ctor
= gfc_build_null_descriptor (type
);
5657 /* Special case assigning an array to zero. */
5658 else if (is_zero_initializer_p (expr
))
5659 ctor
= build_constructor (type
, NULL
);
5661 ctor
= gfc_conv_array_initializer (type
, expr
);
5662 TREE_STATIC (ctor
) = 1;
5665 else if (pointer
|| procptr
)
5667 if (ts
->type
== BT_CLASS
&& !procptr
)
5669 gfc_init_se (&se
, NULL
);
5670 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5671 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5672 TREE_STATIC (se
.expr
) = 1;
5675 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5676 return fold_convert (type
, null_pointer_node
);
5679 gfc_init_se (&se
, NULL
);
5680 se
.want_pointer
= 1;
5681 gfc_conv_expr (&se
, expr
);
5682 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5692 gfc_init_se (&se
, NULL
);
5693 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5694 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5696 gfc_conv_structure (&se
, expr
, 1);
5697 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5698 TREE_STATIC (se
.expr
) = 1;
5703 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5704 TREE_STATIC (ctor
) = 1;
5709 gfc_init_se (&se
, NULL
);
5710 gfc_conv_constant (&se
, expr
);
5711 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5718 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5724 gfc_array_info
*lss_array
;
5731 gfc_start_block (&block
);
5733 /* Initialize the scalarizer. */
5734 gfc_init_loopinfo (&loop
);
5736 gfc_init_se (&lse
, NULL
);
5737 gfc_init_se (&rse
, NULL
);
5740 rss
= gfc_walk_expr (expr
);
5741 if (rss
== gfc_ss_terminator
)
5742 /* The rhs is scalar. Add a ss for the expression. */
5743 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5745 /* Create a SS for the destination. */
5746 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5748 lss_array
= &lss
->info
->data
.array
;
5749 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5750 lss_array
->descriptor
= dest
;
5751 lss_array
->data
= gfc_conv_array_data (dest
);
5752 lss_array
->offset
= gfc_conv_array_offset (dest
);
5753 for (n
= 0; n
< cm
->as
->rank
; n
++)
5755 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5756 lss_array
->stride
[n
] = gfc_index_one_node
;
5758 mpz_init (lss_array
->shape
[n
]);
5759 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5760 cm
->as
->lower
[n
]->value
.integer
);
5761 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5764 /* Associate the SS with the loop. */
5765 gfc_add_ss_to_loop (&loop
, lss
);
5766 gfc_add_ss_to_loop (&loop
, rss
);
5768 /* Calculate the bounds of the scalarization. */
5769 gfc_conv_ss_startstride (&loop
);
5771 /* Setup the scalarizing loops. */
5772 gfc_conv_loop_setup (&loop
, &expr
->where
);
5774 /* Setup the gfc_se structures. */
5775 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5776 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5779 gfc_mark_ss_chain_used (rss
, 1);
5781 gfc_mark_ss_chain_used (lss
, 1);
5783 /* Start the scalarized loop body. */
5784 gfc_start_scalarized_body (&loop
, &body
);
5786 gfc_conv_tmp_array_ref (&lse
);
5787 if (cm
->ts
.type
== BT_CHARACTER
)
5788 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5790 gfc_conv_expr (&rse
, expr
);
5792 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5793 gfc_add_expr_to_block (&body
, tmp
);
5795 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5797 /* Generate the copying loops. */
5798 gfc_trans_scalarizing_loops (&loop
, &body
);
5800 /* Wrap the whole thing up. */
5801 gfc_add_block_to_block (&block
, &loop
.pre
);
5802 gfc_add_block_to_block (&block
, &loop
.post
);
5804 gcc_assert (lss_array
->shape
!= NULL
);
5805 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5806 gfc_cleanup_loop (&loop
);
5808 return gfc_finish_block (&block
);
5813 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5823 gfc_expr
*arg
= NULL
;
5825 gfc_start_block (&block
);
5826 gfc_init_se (&se
, NULL
);
5828 /* Get the descriptor for the expressions. */
5829 se
.want_pointer
= 0;
5830 gfc_conv_expr_descriptor (&se
, expr
);
5831 gfc_add_block_to_block (&block
, &se
.pre
);
5832 gfc_add_modify (&block
, dest
, se
.expr
);
5834 /* Deal with arrays of derived types with allocatable components. */
5835 if (cm
->ts
.type
== BT_DERIVED
5836 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5837 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5841 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5842 TREE_TYPE(cm
->backend_decl
),
5845 gfc_add_expr_to_block (&block
, tmp
);
5846 gfc_add_block_to_block (&block
, &se
.post
);
5848 if (expr
->expr_type
!= EXPR_VARIABLE
)
5849 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5852 /* We need to know if the argument of a conversion function is a
5853 variable, so that the correct lower bound can be used. */
5854 if (expr
->expr_type
== EXPR_FUNCTION
5855 && expr
->value
.function
.isym
5856 && expr
->value
.function
.isym
->conversion
5857 && expr
->value
.function
.actual
->expr
5858 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5859 arg
= expr
->value
.function
.actual
->expr
;
5861 /* Obtain the array spec of full array references. */
5863 as
= gfc_get_full_arrayspec_from_expr (arg
);
5865 as
= gfc_get_full_arrayspec_from_expr (expr
);
5867 /* Shift the lbound and ubound of temporaries to being unity,
5868 rather than zero, based. Always calculate the offset. */
5869 offset
= gfc_conv_descriptor_offset_get (dest
);
5870 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5871 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5873 for (n
= 0; n
< expr
->rank
; n
++)
5878 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5879 TODO It looks as if gfc_conv_expr_descriptor should return
5880 the correct bounds and that the following should not be
5881 necessary. This would simplify gfc_conv_intrinsic_bound
5883 if (as
&& as
->lower
[n
])
5886 gfc_init_se (&lbse
, NULL
);
5887 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5888 gfc_add_block_to_block (&block
, &lbse
.pre
);
5889 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5893 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5894 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5898 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5901 lbound
= gfc_index_one_node
;
5903 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5905 /* Shift the bounds and set the offset accordingly. */
5906 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5907 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5908 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5909 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5911 gfc_conv_descriptor_ubound_set (&block
, dest
,
5912 gfc_rank_cst
[n
], tmp
);
5913 gfc_conv_descriptor_lbound_set (&block
, dest
,
5914 gfc_rank_cst
[n
], lbound
);
5916 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5917 gfc_conv_descriptor_lbound_get (dest
,
5919 gfc_conv_descriptor_stride_get (dest
,
5921 gfc_add_modify (&block
, tmp2
, tmp
);
5922 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5924 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5929 /* If a conversion expression has a null data pointer
5930 argument, nullify the allocatable component. */
5934 if (arg
->symtree
->n
.sym
->attr
.allocatable
5935 || arg
->symtree
->n
.sym
->attr
.pointer
)
5937 non_null_expr
= gfc_finish_block (&block
);
5938 gfc_start_block (&block
);
5939 gfc_conv_descriptor_data_set (&block
, dest
,
5941 null_expr
= gfc_finish_block (&block
);
5942 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5943 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5944 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5945 return build3_v (COND_EXPR
, tmp
,
5946 null_expr
, non_null_expr
);
5950 return gfc_finish_block (&block
);
5954 /* Assign a single component of a derived type constructor. */
5957 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5964 gfc_start_block (&block
);
5966 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5968 gfc_init_se (&se
, NULL
);
5969 /* Pointer component. */
5970 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5972 /* Array pointer. */
5973 if (expr
->expr_type
== EXPR_NULL
)
5974 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5977 se
.direct_byref
= 1;
5979 gfc_conv_expr_descriptor (&se
, expr
);
5980 gfc_add_block_to_block (&block
, &se
.pre
);
5981 gfc_add_block_to_block (&block
, &se
.post
);
5986 /* Scalar pointers. */
5987 se
.want_pointer
= 1;
5988 gfc_conv_expr (&se
, expr
);
5989 gfc_add_block_to_block (&block
, &se
.pre
);
5991 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
5992 && expr
->symtree
->n
.sym
->attr
.dummy
)
5993 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5995 gfc_add_modify (&block
, dest
,
5996 fold_convert (TREE_TYPE (dest
), se
.expr
));
5997 gfc_add_block_to_block (&block
, &se
.post
);
6000 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6002 /* NULL initialization for CLASS components. */
6003 tmp
= gfc_trans_structure_assign (dest
,
6004 gfc_class_initializer (&cm
->ts
, expr
));
6005 gfc_add_expr_to_block (&block
, tmp
);
6007 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
6009 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6010 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6011 else if (cm
->attr
.allocatable
)
6013 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6014 gfc_add_expr_to_block (&block
, tmp
);
6018 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6019 gfc_add_expr_to_block (&block
, tmp
);
6022 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6024 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6026 gfc_init_se (&se
, NULL
);
6027 gfc_conv_expr (&se
, expr
);
6028 gfc_add_block_to_block (&block
, &se
.pre
);
6029 gfc_add_modify (&block
, dest
,
6030 fold_convert (TREE_TYPE (dest
), se
.expr
));
6031 gfc_add_block_to_block (&block
, &se
.post
);
6035 /* Nested constructors. */
6036 tmp
= gfc_trans_structure_assign (dest
, expr
);
6037 gfc_add_expr_to_block (&block
, tmp
);
6042 /* Scalar component. */
6043 gfc_init_se (&se
, NULL
);
6044 gfc_init_se (&lse
, NULL
);
6046 gfc_conv_expr (&se
, expr
);
6047 if (cm
->ts
.type
== BT_CHARACTER
)
6048 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6050 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6051 gfc_add_expr_to_block (&block
, tmp
);
6053 return gfc_finish_block (&block
);
6056 /* Assign a derived type constructor to a variable. */
6059 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6067 gfc_start_block (&block
);
6068 cm
= expr
->ts
.u
.derived
->components
;
6070 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6071 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6072 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6076 gcc_assert (cm
->backend_decl
== NULL
);
6077 gfc_init_se (&se
, NULL
);
6078 gfc_init_se (&lse
, NULL
);
6079 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6081 gfc_add_modify (&block
, lse
.expr
,
6082 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6084 return gfc_finish_block (&block
);
6087 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6088 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6090 /* Skip absent members in default initializers. */
6094 field
= cm
->backend_decl
;
6095 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6096 dest
, field
, NULL_TREE
);
6097 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6098 gfc_add_expr_to_block (&block
, tmp
);
6100 return gfc_finish_block (&block
);
6103 /* Build an expression for a constructor. If init is nonzero then
6104 this is part of a static variable initializer. */
6107 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6114 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6116 gcc_assert (se
->ss
== NULL
);
6117 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6118 type
= gfc_typenode_for_spec (&expr
->ts
);
6122 /* Create a temporary variable and fill it in. */
6123 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6124 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6125 gfc_add_expr_to_block (&se
->pre
, tmp
);
6129 cm
= expr
->ts
.u
.derived
->components
;
6131 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6132 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6134 /* Skip absent members in default initializers and allocatable
6135 components. Although the latter have a default initializer
6136 of EXPR_NULL,... by default, the static nullify is not needed
6137 since this is done every time we come into scope. */
6138 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6141 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6142 && strcmp (cm
->name
, "_extends") == 0
6143 && cm
->initializer
->symtree
)
6147 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6148 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6149 vtab
= unshare_expr_without_location (vtab
);
6150 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6152 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6154 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6155 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6159 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6160 TREE_TYPE (cm
->backend_decl
),
6161 cm
->attr
.dimension
, cm
->attr
.pointer
,
6162 cm
->attr
.proc_pointer
);
6163 val
= unshare_expr_without_location (val
);
6165 /* Append it to the constructor list. */
6166 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6169 se
->expr
= build_constructor (type
, v
);
6171 TREE_CONSTANT (se
->expr
) = 1;
6175 /* Translate a substring expression. */
6178 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6184 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6186 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6187 expr
->value
.character
.length
,
6188 expr
->value
.character
.string
);
6190 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6191 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6194 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6198 /* Entry point for expression translation. Evaluates a scalar quantity.
6199 EXPR is the expression to be translated, and SE is the state structure if
6200 called from within the scalarized. */
6203 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6208 if (ss
&& ss
->info
->expr
== expr
6209 && (ss
->info
->type
== GFC_SS_SCALAR
6210 || ss
->info
->type
== GFC_SS_REFERENCE
))
6212 gfc_ss_info
*ss_info
;
6215 /* Substitute a scalar expression evaluated outside the scalarization
6217 se
->expr
= ss_info
->data
.scalar
.value
;
6218 /* If the reference can be NULL, the value field contains the reference,
6219 not the value the reference points to (see gfc_add_loop_ss_code). */
6220 if (ss_info
->can_be_null_ref
)
6221 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6223 se
->string_length
= ss_info
->string_length
;
6224 gfc_advance_se_ss_chain (se
);
6228 /* We need to convert the expressions for the iso_c_binding derived types.
6229 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6230 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6231 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6232 updated to be an integer with a kind equal to the size of a (void *). */
6233 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6235 if (expr
->expr_type
== EXPR_VARIABLE
6236 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6237 || expr
->symtree
->n
.sym
->intmod_sym_id
6238 == ISOCBINDING_NULL_FUNPTR
))
6240 /* Set expr_type to EXPR_NULL, which will result in
6241 null_pointer_node being used below. */
6242 expr
->expr_type
= EXPR_NULL
;
6246 /* Update the type/kind of the expression to be what the new
6247 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6248 expr
->ts
.type
= BT_INTEGER
;
6249 expr
->ts
.f90_type
= BT_VOID
;
6250 expr
->ts
.kind
= gfc_index_integer_kind
;
6254 gfc_fix_class_refs (expr
);
6256 switch (expr
->expr_type
)
6259 gfc_conv_expr_op (se
, expr
);
6263 gfc_conv_function_expr (se
, expr
);
6267 gfc_conv_constant (se
, expr
);
6271 gfc_conv_variable (se
, expr
);
6275 se
->expr
= null_pointer_node
;
6278 case EXPR_SUBSTRING
:
6279 gfc_conv_substring_expr (se
, expr
);
6282 case EXPR_STRUCTURE
:
6283 gfc_conv_structure (se
, expr
, 0);
6287 gfc_conv_array_constructor_expr (se
, expr
);
6296 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6297 of an assignment. */
6299 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6301 gfc_conv_expr (se
, expr
);
6302 /* All numeric lvalues should have empty post chains. If not we need to
6303 figure out a way of rewriting an lvalue so that it has no post chain. */
6304 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6307 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6308 numeric expressions. Used for scalar values where inserting cleanup code
6311 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6315 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6316 gfc_conv_expr (se
, expr
);
6319 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6320 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6322 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6326 /* Helper to translate an expression and convert it to a particular type. */
6328 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6330 gfc_conv_expr_val (se
, expr
);
6331 se
->expr
= convert (type
, se
->expr
);
6335 /* Converts an expression so that it can be passed by reference. Scalar
6339 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6345 if (ss
&& ss
->info
->expr
== expr
6346 && ss
->info
->type
== GFC_SS_REFERENCE
)
6348 /* Returns a reference to the scalar evaluated outside the loop
6350 gfc_conv_expr (se
, expr
);
6351 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6355 if (expr
->ts
.type
== BT_CHARACTER
)
6357 gfc_conv_expr (se
, expr
);
6358 gfc_conv_string_parameter (se
);
6362 if (expr
->expr_type
== EXPR_VARIABLE
)
6364 se
->want_pointer
= 1;
6365 gfc_conv_expr (se
, expr
);
6368 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6369 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6370 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6376 if (expr
->expr_type
== EXPR_FUNCTION
6377 && ((expr
->value
.function
.esym
6378 && expr
->value
.function
.esym
->result
->attr
.pointer
6379 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6380 || (!expr
->value
.function
.esym
&& !expr
->ref
6381 && expr
->symtree
->n
.sym
->attr
.pointer
6382 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6384 se
->want_pointer
= 1;
6385 gfc_conv_expr (se
, expr
);
6386 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6387 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6392 gfc_conv_expr (se
, expr
);
6394 /* Create a temporary var to hold the value. */
6395 if (TREE_CONSTANT (se
->expr
))
6397 tree tmp
= se
->expr
;
6398 STRIP_TYPE_NOPS (tmp
);
6399 var
= build_decl (input_location
,
6400 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6401 DECL_INITIAL (var
) = tmp
;
6402 TREE_STATIC (var
) = 1;
6407 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6408 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6410 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6412 /* Take the address of that value. */
6413 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6418 gfc_trans_pointer_assign (gfc_code
* code
)
6420 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6424 /* Generate code for a pointer assignment. */
6427 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6429 gfc_expr
*expr1_vptr
= NULL
;
6439 gfc_start_block (&block
);
6441 gfc_init_se (&lse
, NULL
);
6443 /* Check whether the expression is a scalar or not; we cannot use
6444 expr1->rank as it can be nonzero for proc pointers. */
6445 ss
= gfc_walk_expr (expr1
);
6446 scalar
= ss
== gfc_ss_terminator
;
6448 gfc_free_ss_chain (ss
);
6450 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6451 && expr2
->expr_type
!= EXPR_FUNCTION
)
6453 gfc_add_data_component (expr2
);
6454 /* The following is required as gfc_add_data_component doesn't
6455 update ts.type if there is a tailing REF_ARRAY. */
6456 expr2
->ts
.type
= BT_DERIVED
;
6461 /* Scalar pointers. */
6462 lse
.want_pointer
= 1;
6463 gfc_conv_expr (&lse
, expr1
);
6464 gfc_init_se (&rse
, NULL
);
6465 rse
.want_pointer
= 1;
6466 gfc_conv_expr (&rse
, expr2
);
6468 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6469 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6470 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6473 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6474 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6475 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6478 gfc_add_block_to_block (&block
, &lse
.pre
);
6479 gfc_add_block_to_block (&block
, &rse
.pre
);
6481 /* Check character lengths if character expression. The test is only
6482 really added if -fbounds-check is enabled. Exclude deferred
6483 character length lefthand sides. */
6484 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6485 && !expr1
->ts
.deferred
6486 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6487 && !gfc_is_proc_ptr_comp (expr1
))
6489 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6490 gcc_assert (lse
.string_length
&& rse
.string_length
);
6491 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6492 lse
.string_length
, rse
.string_length
,
6496 /* The assignment to an deferred character length sets the string
6497 length to that of the rhs. */
6498 if (expr1
->ts
.deferred
)
6500 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6501 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6502 else if (lse
.string_length
!= NULL
)
6503 gfc_add_modify (&block
, lse
.string_length
,
6504 build_int_cst (gfc_charlen_type_node
, 0));
6507 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6508 rse
.expr
= gfc_class_data_get (rse
.expr
);
6510 gfc_add_modify (&block
, lse
.expr
,
6511 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6513 gfc_add_block_to_block (&block
, &rse
.post
);
6514 gfc_add_block_to_block (&block
, &lse
.post
);
6521 tree strlen_rhs
= NULL_TREE
;
6523 /* Array pointer. Find the last reference on the LHS and if it is an
6524 array section ref, we're dealing with bounds remapping. In this case,
6525 set it to AR_FULL so that gfc_conv_expr_descriptor does
6526 not see it and process the bounds remapping afterwards explicitly. */
6527 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6528 if (!remap
->next
&& remap
->type
== REF_ARRAY
6529 && remap
->u
.ar
.type
== AR_SECTION
)
6531 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6533 gfc_init_se (&lse
, NULL
);
6535 lse
.descriptor_only
= 1;
6536 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6537 && expr1
->ts
.type
== BT_CLASS
)
6538 expr1_vptr
= gfc_copy_expr (expr1
);
6539 gfc_conv_expr_descriptor (&lse
, expr1
);
6540 strlen_lhs
= lse
.string_length
;
6543 if (expr2
->expr_type
== EXPR_NULL
)
6545 /* Just set the data pointer to null. */
6546 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6548 else if (rank_remap
)
6550 /* If we are rank-remapping, just get the RHS's descriptor and
6551 process this later on. */
6552 gfc_init_se (&rse
, NULL
);
6553 rse
.direct_byref
= 1;
6554 rse
.byref_noassign
= 1;
6556 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6558 gfc_conv_function_expr (&rse
, expr2
);
6560 if (expr1
->ts
.type
!= BT_CLASS
)
6561 rse
.expr
= gfc_class_data_get (rse
.expr
);
6564 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6565 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6567 gfc_add_vptr_component (expr1_vptr
);
6568 gfc_init_se (&rse
, NULL
);
6569 rse
.want_pointer
= 1;
6570 gfc_conv_expr (&rse
, expr1_vptr
);
6571 gfc_add_modify (&lse
.pre
, rse
.expr
,
6572 fold_convert (TREE_TYPE (rse
.expr
),
6573 gfc_class_vptr_get (tmp
)));
6574 rse
.expr
= gfc_class_data_get (tmp
);
6577 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6579 tree bound
[GFC_MAX_DIMENSIONS
];
6582 for (i
= 0; i
< expr2
->rank
; i
++)
6583 bound
[i
] = NULL_TREE
;
6584 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6585 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6587 GFC_ARRAY_POINTER_CONT
, false);
6588 tmp
= gfc_create_var (tmp
, "ptrtemp");
6590 lse
.direct_byref
= 1;
6591 gfc_conv_expr_descriptor (&lse
, expr2
);
6592 strlen_rhs
= lse
.string_length
;
6597 gfc_conv_expr_descriptor (&rse
, expr2
);
6598 strlen_rhs
= rse
.string_length
;
6601 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6603 /* Assign directly to the LHS's descriptor. */
6604 lse
.direct_byref
= 1;
6605 gfc_conv_expr_descriptor (&lse
, expr2
);
6606 strlen_rhs
= lse
.string_length
;
6608 /* If this is a subreference array pointer assignment, use the rhs
6609 descriptor element size for the lhs span. */
6610 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6612 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6613 gfc_init_se (&rse
, NULL
);
6614 rse
.descriptor_only
= 1;
6615 gfc_conv_expr (&rse
, expr2
);
6616 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6617 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6618 if (!INTEGER_CST_P (tmp
))
6619 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6620 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6623 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6625 gfc_init_se (&rse
, NULL
);
6626 rse
.want_pointer
= 1;
6627 gfc_conv_function_expr (&rse
, expr2
);
6628 if (expr1
->ts
.type
!= BT_CLASS
)
6630 rse
.expr
= gfc_class_data_get (rse
.expr
);
6631 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6635 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6636 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6638 gfc_add_vptr_component (expr1_vptr
);
6639 gfc_init_se (&rse
, NULL
);
6640 rse
.want_pointer
= 1;
6641 gfc_conv_expr (&rse
, expr1_vptr
);
6642 gfc_add_modify (&lse
.pre
, rse
.expr
,
6643 fold_convert (TREE_TYPE (rse
.expr
),
6644 gfc_class_vptr_get (tmp
)));
6645 rse
.expr
= gfc_class_data_get (tmp
);
6646 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6651 /* Assign to a temporary descriptor and then copy that
6652 temporary to the pointer. */
6653 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6655 lse
.direct_byref
= 1;
6656 gfc_conv_expr_descriptor (&lse
, expr2
);
6657 strlen_rhs
= lse
.string_length
;
6658 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6662 gfc_free_expr (expr1_vptr
);
6664 gfc_add_block_to_block (&block
, &lse
.pre
);
6666 gfc_add_block_to_block (&block
, &rse
.pre
);
6668 /* If we do bounds remapping, update LHS descriptor accordingly. */
6672 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6676 /* Do rank remapping. We already have the RHS's descriptor
6677 converted in rse and now have to build the correct LHS
6678 descriptor for it. */
6682 tree lbound
, ubound
;
6685 dtype
= gfc_conv_descriptor_dtype (desc
);
6686 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6687 gfc_add_modify (&block
, dtype
, tmp
);
6689 /* Copy data pointer. */
6690 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6691 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6693 /* Copy offset but adjust it such that it would correspond
6694 to a lbound of zero. */
6695 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6696 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6698 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6700 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6702 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6703 gfc_array_index_type
, stride
, lbound
);
6704 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6705 gfc_array_index_type
, offs
, tmp
);
6707 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6709 /* Set the bounds as declared for the LHS and calculate strides as
6710 well as another offset update accordingly. */
6711 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6713 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6718 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6720 /* Convert declared bounds. */
6721 gfc_init_se (&lower_se
, NULL
);
6722 gfc_init_se (&upper_se
, NULL
);
6723 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6724 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6726 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6727 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6729 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6730 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6732 lbound
= gfc_evaluate_now (lbound
, &block
);
6733 ubound
= gfc_evaluate_now (ubound
, &block
);
6735 gfc_add_block_to_block (&block
, &lower_se
.post
);
6736 gfc_add_block_to_block (&block
, &upper_se
.post
);
6738 /* Set bounds in descriptor. */
6739 gfc_conv_descriptor_lbound_set (&block
, desc
,
6740 gfc_rank_cst
[dim
], lbound
);
6741 gfc_conv_descriptor_ubound_set (&block
, desc
,
6742 gfc_rank_cst
[dim
], ubound
);
6745 stride
= gfc_evaluate_now (stride
, &block
);
6746 gfc_conv_descriptor_stride_set (&block
, desc
,
6747 gfc_rank_cst
[dim
], stride
);
6749 /* Update offset. */
6750 offs
= gfc_conv_descriptor_offset_get (desc
);
6751 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6752 gfc_array_index_type
, lbound
, stride
);
6753 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6754 gfc_array_index_type
, offs
, tmp
);
6755 offs
= gfc_evaluate_now (offs
, &block
);
6756 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6758 /* Update stride. */
6759 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6760 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6761 gfc_array_index_type
, stride
, tmp
);
6766 /* Bounds remapping. Just shift the lower bounds. */
6768 gcc_assert (expr1
->rank
== expr2
->rank
);
6770 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6774 gcc_assert (remap
->u
.ar
.start
[dim
]);
6775 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6776 gfc_init_se (&lbound_se
, NULL
);
6777 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6779 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6780 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6781 dim
, lbound_se
.expr
);
6782 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6787 /* Check string lengths if applicable. The check is only really added
6788 to the output code if -fbounds-check is enabled. */
6789 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6791 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6792 gcc_assert (strlen_lhs
&& strlen_rhs
);
6793 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6794 strlen_lhs
, strlen_rhs
, &block
);
6797 /* If rank remapping was done, check with -fcheck=bounds that
6798 the target is at least as large as the pointer. */
6799 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6805 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6806 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6808 lsize
= gfc_evaluate_now (lsize
, &block
);
6809 rsize
= gfc_evaluate_now (rsize
, &block
);
6810 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6813 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6814 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6818 gfc_add_block_to_block (&block
, &lse
.post
);
6820 gfc_add_block_to_block (&block
, &rse
.post
);
6823 return gfc_finish_block (&block
);
6827 /* Makes sure se is suitable for passing as a function string parameter. */
6828 /* TODO: Need to check all callers of this function. It may be abused. */
6831 gfc_conv_string_parameter (gfc_se
* se
)
6835 if (TREE_CODE (se
->expr
) == STRING_CST
)
6837 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6838 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6842 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6844 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6846 type
= TREE_TYPE (se
->expr
);
6847 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6851 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6853 type
= build_pointer_type (type
);
6854 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6858 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6862 /* Generate code for assignment of scalar variables. Includes character
6863 strings and derived types with allocatable components.
6864 If you know that the LHS has no allocations, set dealloc to false.
6866 DEEP_COPY has no effect if the typespec TS is not a derived type with
6867 allocatable components. Otherwise, if it is set, an explicit copy of each
6868 allocatable component is made. This is necessary as a simple copy of the
6869 whole object would copy array descriptors as is, so that the lhs's
6870 allocatable components would point to the rhs's after the assignment.
6871 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6872 necessary if the rhs is a non-pointer function, as the allocatable components
6873 are not accessible by other means than the function's result after the
6874 function has returned. It is even more subtle when temporaries are involved,
6875 as the two following examples show:
6876 1. When we evaluate an array constructor, a temporary is created. Thus
6877 there is theoretically no alias possible. However, no deep copy is
6878 made for this temporary, so that if the constructor is made of one or
6879 more variable with allocatable components, those components still point
6880 to the variable's: DEEP_COPY should be set for the assignment from the
6881 temporary to the lhs in that case.
6882 2. When assigning a scalar to an array, we evaluate the scalar value out
6883 of the loop, store it into a temporary variable, and assign from that.
6884 In that case, deep copying when assigning to the temporary would be a
6885 waste of resources; however deep copies should happen when assigning from
6886 the temporary to each array element: again DEEP_COPY should be set for
6887 the assignment from the temporary to the lhs. */
6890 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6891 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6897 gfc_init_block (&block
);
6899 if (ts
.type
== BT_CHARACTER
)
6904 if (lse
->string_length
!= NULL_TREE
)
6906 gfc_conv_string_parameter (lse
);
6907 gfc_add_block_to_block (&block
, &lse
->pre
);
6908 llen
= lse
->string_length
;
6911 if (rse
->string_length
!= NULL_TREE
)
6913 gcc_assert (rse
->string_length
!= NULL_TREE
);
6914 gfc_conv_string_parameter (rse
);
6915 gfc_add_block_to_block (&block
, &rse
->pre
);
6916 rlen
= rse
->string_length
;
6919 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6920 rse
->expr
, ts
.kind
);
6922 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6924 tree tmp_var
= NULL_TREE
;
6927 /* Are the rhs and the lhs the same? */
6930 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6931 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6932 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6933 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6936 /* Deallocate the lhs allocated components as long as it is not
6937 the same as the rhs. This must be done following the assignment
6938 to prevent deallocating data that could be used in the rhs
6940 if (!l_is_temp
&& dealloc
)
6942 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
6943 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
6945 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6947 gfc_add_expr_to_block (&lse
->post
, tmp
);
6950 gfc_add_block_to_block (&block
, &rse
->pre
);
6951 gfc_add_block_to_block (&block
, &lse
->pre
);
6953 gfc_add_modify (&block
, lse
->expr
,
6954 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6956 /* Restore pointer address of coarray components. */
6957 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
6959 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
6960 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6962 gfc_add_expr_to_block (&block
, tmp
);
6965 /* Do a deep copy if the rhs is a variable, if it is not the
6969 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
6970 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6972 gfc_add_expr_to_block (&block
, tmp
);
6975 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
6977 gfc_add_block_to_block (&block
, &lse
->pre
);
6978 gfc_add_block_to_block (&block
, &rse
->pre
);
6979 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
6980 TREE_TYPE (lse
->expr
), rse
->expr
);
6981 gfc_add_modify (&block
, lse
->expr
, tmp
);
6985 gfc_add_block_to_block (&block
, &lse
->pre
);
6986 gfc_add_block_to_block (&block
, &rse
->pre
);
6988 gfc_add_modify (&block
, lse
->expr
,
6989 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6992 gfc_add_block_to_block (&block
, &lse
->post
);
6993 gfc_add_block_to_block (&block
, &rse
->post
);
6995 return gfc_finish_block (&block
);
6999 /* There are quite a lot of restrictions on the optimisation in using an
7000 array function assign without a temporary. */
7003 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7006 bool seen_array_ref
;
7008 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7010 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7011 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7014 /* Elemental functions are scalarized so that they don't need a
7015 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7016 they would need special treatment in gfc_trans_arrayfunc_assign. */
7017 if (expr2
->value
.function
.esym
!= NULL
7018 && expr2
->value
.function
.esym
->attr
.elemental
)
7021 /* Need a temporary if rhs is not FULL or a contiguous section. */
7022 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7025 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7026 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7029 /* Functions returning pointers or allocatables need temporaries. */
7030 c
= expr2
->value
.function
.esym
7031 ? (expr2
->value
.function
.esym
->attr
.pointer
7032 || expr2
->value
.function
.esym
->attr
.allocatable
)
7033 : (expr2
->symtree
->n
.sym
->attr
.pointer
7034 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7038 /* Character array functions need temporaries unless the
7039 character lengths are the same. */
7040 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7042 if (expr1
->ts
.u
.cl
->length
== NULL
7043 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7046 if (expr2
->ts
.u
.cl
->length
== NULL
7047 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7050 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7051 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7055 /* Check that no LHS component references appear during an array
7056 reference. This is needed because we do not have the means to
7057 span any arbitrary stride with an array descriptor. This check
7058 is not needed for the rhs because the function result has to be
7060 seen_array_ref
= false;
7061 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7063 if (ref
->type
== REF_ARRAY
)
7064 seen_array_ref
= true;
7065 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7069 /* Check for a dependency. */
7070 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7071 expr2
->value
.function
.esym
,
7072 expr2
->value
.function
.actual
,
7076 /* If we have reached here with an intrinsic function, we do not
7077 need a temporary except in the particular case that reallocation
7078 on assignment is active and the lhs is allocatable and a target. */
7079 if (expr2
->value
.function
.isym
)
7080 return (gfc_option
.flag_realloc_lhs
7081 && sym
->attr
.allocatable
7082 && sym
->attr
.target
);
7084 /* If the LHS is a dummy, we need a temporary if it is not
7086 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7089 /* If the lhs has been host_associated, is in common, a pointer or is
7090 a target and the function is not using a RESULT variable, aliasing
7091 can occur and a temporary is needed. */
7092 if ((sym
->attr
.host_assoc
7093 || sym
->attr
.in_common
7094 || sym
->attr
.pointer
7095 || sym
->attr
.cray_pointee
7096 || sym
->attr
.target
)
7097 && expr2
->symtree
!= NULL
7098 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7101 /* A PURE function can unconditionally be called without a temporary. */
7102 if (expr2
->value
.function
.esym
!= NULL
7103 && expr2
->value
.function
.esym
->attr
.pure
)
7106 /* Implicit_pure functions are those which could legally be declared
7108 if (expr2
->value
.function
.esym
!= NULL
7109 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7112 if (!sym
->attr
.use_assoc
7113 && !sym
->attr
.in_common
7114 && !sym
->attr
.pointer
7115 && !sym
->attr
.target
7116 && !sym
->attr
.cray_pointee
7117 && expr2
->value
.function
.esym
)
7119 /* A temporary is not needed if the function is not contained and
7120 the variable is local or host associated and not a pointer or
7122 if (!expr2
->value
.function
.esym
->attr
.contained
)
7125 /* A temporary is not needed if the lhs has never been host
7126 associated and the procedure is contained. */
7127 else if (!sym
->attr
.host_assoc
)
7130 /* A temporary is not needed if the variable is local and not
7131 a pointer, a target or a result. */
7133 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7137 /* Default to temporary use. */
7142 /* Provide the loop info so that the lhs descriptor can be built for
7143 reallocatable assignments from extrinsic function calls. */
7146 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7149 /* Signal that the function call should not be made by
7150 gfc_conv_loop_setup. */
7151 se
->ss
->is_alloc_lhs
= 1;
7152 gfc_init_loopinfo (loop
);
7153 gfc_add_ss_to_loop (loop
, *ss
);
7154 gfc_add_ss_to_loop (loop
, se
->ss
);
7155 gfc_conv_ss_startstride (loop
);
7156 gfc_conv_loop_setup (loop
, where
);
7157 gfc_copy_loopinfo_to_se (se
, loop
);
7158 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7159 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7160 se
->ss
->is_alloc_lhs
= 0;
7164 /* For assignment to a reallocatable lhs from intrinsic functions,
7165 replace the se.expr (ie. the result) with a temporary descriptor.
7166 Null the data field so that the library allocates space for the
7167 result. Free the data of the original descriptor after the function,
7168 in case it appears in an argument expression and transfer the
7169 result to the original descriptor. */
7172 fcncall_realloc_result (gfc_se
*se
, int rank
)
7181 /* Use the allocation done by the library. Substitute the lhs
7182 descriptor with a copy, whose data field is nulled.*/
7183 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7184 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7185 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7187 /* Unallocated, the descriptor does not have a dtype. */
7188 tmp
= gfc_conv_descriptor_dtype (desc
);
7189 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7191 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7192 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7193 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
7195 /* Free the lhs after the function call and copy the result data to
7196 the lhs descriptor. */
7197 tmp
= gfc_conv_descriptor_data_get (desc
);
7198 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7199 boolean_type_node
, tmp
,
7200 build_int_cst (TREE_TYPE (tmp
), 0));
7201 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7202 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7203 gfc_add_expr_to_block (&se
->post
, tmp
);
7205 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7206 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7208 /* Check that the shapes are the same between lhs and expression. */
7209 for (n
= 0 ; n
< rank
; n
++)
7212 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7213 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7214 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7215 gfc_array_index_type
, tmp
, tmp1
);
7216 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7217 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7218 gfc_array_index_type
, tmp
, tmp1
);
7219 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7220 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7221 gfc_array_index_type
, tmp
, tmp1
);
7222 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7223 boolean_type_node
, tmp
,
7224 gfc_index_zero_node
);
7225 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7226 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7227 boolean_type_node
, tmp
,
7231 /* 'zero_cond' being true is equal to lhs not being allocated or the
7232 shapes being different. */
7233 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7235 /* Now reset the bounds returned from the function call to bounds based
7236 on the lhs lbounds, except where the lhs is not allocated or the shapes
7237 of 'variable and 'expr' are different. Set the offset accordingly. */
7238 offset
= gfc_index_zero_node
;
7239 for (n
= 0 ; n
< rank
; n
++)
7243 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7244 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7245 gfc_array_index_type
, zero_cond
,
7246 gfc_index_one_node
, lbound
);
7247 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7249 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7250 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7251 gfc_array_index_type
, tmp
, lbound
);
7252 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7253 gfc_rank_cst
[n
], lbound
);
7254 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7255 gfc_rank_cst
[n
], tmp
);
7257 /* Set stride and accumulate the offset. */
7258 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7259 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7260 gfc_rank_cst
[n
], tmp
);
7261 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7262 gfc_array_index_type
, lbound
, tmp
);
7263 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7264 gfc_array_index_type
, offset
, tmp
);
7265 offset
= gfc_evaluate_now (offset
, &se
->post
);
7268 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7273 /* Try to translate array(:) = func (...), where func is a transformational
7274 array function, without using a temporary. Returns NULL if this isn't the
7278 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7282 gfc_component
*comp
= NULL
;
7285 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7288 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7290 comp
= gfc_get_proc_ptr_comp (expr2
);
7291 gcc_assert (expr2
->value
.function
.isym
7292 || (comp
&& comp
->attr
.dimension
)
7293 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7294 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7296 gfc_init_se (&se
, NULL
);
7297 gfc_start_block (&se
.pre
);
7298 se
.want_pointer
= 1;
7300 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7302 if (expr1
->ts
.type
== BT_DERIVED
7303 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7306 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7308 gfc_add_expr_to_block (&se
.pre
, tmp
);
7311 se
.direct_byref
= 1;
7312 se
.ss
= gfc_walk_expr (expr2
);
7313 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7315 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7316 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7317 Clearly, this cannot be done for an allocatable function result, since
7318 the shape of the result is unknown and, in any case, the function must
7319 correctly take care of the reallocation internally. For intrinsic
7320 calls, the array data is freed and the library takes care of allocation.
7321 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7323 if (gfc_option
.flag_realloc_lhs
7324 && gfc_is_reallocatable_lhs (expr1
)
7325 && !gfc_expr_attr (expr1
).codimension
7326 && !gfc_is_coindexed (expr1
)
7327 && !(expr2
->value
.function
.esym
7328 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7330 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7332 if (!expr2
->value
.function
.isym
)
7334 ss
= gfc_walk_expr (expr1
);
7335 gcc_assert (ss
!= gfc_ss_terminator
);
7337 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7338 ss
->is_alloc_lhs
= 1;
7341 fcncall_realloc_result (&se
, expr1
->rank
);
7344 gfc_conv_function_expr (&se
, expr2
);
7345 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7348 gfc_cleanup_loop (&loop
);
7350 gfc_free_ss_chain (se
.ss
);
7352 return gfc_finish_block (&se
.pre
);
7356 /* Try to efficiently translate array(:) = 0. Return NULL if this
7360 gfc_trans_zero_assign (gfc_expr
* expr
)
7362 tree dest
, len
, type
;
7366 sym
= expr
->symtree
->n
.sym
;
7367 dest
= gfc_get_symbol_decl (sym
);
7369 type
= TREE_TYPE (dest
);
7370 if (POINTER_TYPE_P (type
))
7371 type
= TREE_TYPE (type
);
7372 if (!GFC_ARRAY_TYPE_P (type
))
7375 /* Determine the length of the array. */
7376 len
= GFC_TYPE_ARRAY_SIZE (type
);
7377 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7380 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7381 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7382 fold_convert (gfc_array_index_type
, tmp
));
7384 /* If we are zeroing a local array avoid taking its address by emitting
7386 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7387 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7388 dest
, build_constructor (TREE_TYPE (dest
),
7391 /* Convert arguments to the correct types. */
7392 dest
= fold_convert (pvoid_type_node
, dest
);
7393 len
= fold_convert (size_type_node
, len
);
7395 /* Construct call to __builtin_memset. */
7396 tmp
= build_call_expr_loc (input_location
,
7397 builtin_decl_explicit (BUILT_IN_MEMSET
),
7398 3, dest
, integer_zero_node
, len
);
7399 return fold_convert (void_type_node
, tmp
);
7403 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7404 that constructs the call to __builtin_memcpy. */
7407 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7411 /* Convert arguments to the correct types. */
7412 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7413 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7415 dst
= fold_convert (pvoid_type_node
, dst
);
7417 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7418 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7420 src
= fold_convert (pvoid_type_node
, src
);
7422 len
= fold_convert (size_type_node
, len
);
7424 /* Construct call to __builtin_memcpy. */
7425 tmp
= build_call_expr_loc (input_location
,
7426 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7428 return fold_convert (void_type_node
, tmp
);
7432 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7433 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7434 source/rhs, both are gfc_full_array_ref_p which have been checked for
7438 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7440 tree dst
, dlen
, dtype
;
7441 tree src
, slen
, stype
;
7444 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7445 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7447 dtype
= TREE_TYPE (dst
);
7448 if (POINTER_TYPE_P (dtype
))
7449 dtype
= TREE_TYPE (dtype
);
7450 stype
= TREE_TYPE (src
);
7451 if (POINTER_TYPE_P (stype
))
7452 stype
= TREE_TYPE (stype
);
7454 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7457 /* Determine the lengths of the arrays. */
7458 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7459 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7461 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7462 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7463 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7465 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7466 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7468 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7469 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7470 slen
, fold_convert (gfc_array_index_type
, tmp
));
7472 /* Sanity check that they are the same. This should always be
7473 the case, as we should already have checked for conformance. */
7474 if (!tree_int_cst_equal (slen
, dlen
))
7477 return gfc_build_memcpy_call (dst
, src
, dlen
);
7481 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7482 this can't be done. EXPR1 is the destination/lhs for which
7483 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7486 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7488 unsigned HOST_WIDE_INT nelem
;
7494 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7498 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7499 dtype
= TREE_TYPE (dst
);
7500 if (POINTER_TYPE_P (dtype
))
7501 dtype
= TREE_TYPE (dtype
);
7502 if (!GFC_ARRAY_TYPE_P (dtype
))
7505 /* Determine the lengths of the array. */
7506 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7507 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7510 /* Confirm that the constructor is the same size. */
7511 if (compare_tree_int (len
, nelem
) != 0)
7514 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7515 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7516 fold_convert (gfc_array_index_type
, tmp
));
7518 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7519 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7521 stype
= TREE_TYPE (src
);
7522 if (POINTER_TYPE_P (stype
))
7523 stype
= TREE_TYPE (stype
);
7525 return gfc_build_memcpy_call (dst
, src
, len
);
7529 /* Tells whether the expression is to be treated as a variable reference. */
7532 expr_is_variable (gfc_expr
*expr
)
7535 gfc_component
*comp
;
7536 gfc_symbol
*func_ifc
;
7538 if (expr
->expr_type
== EXPR_VARIABLE
)
7541 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7544 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7545 return expr_is_variable (arg
);
7548 /* A data-pointer-returning function should be considered as a variable
7550 if (expr
->expr_type
== EXPR_FUNCTION
7551 && expr
->ref
== NULL
)
7553 if (expr
->value
.function
.isym
!= NULL
)
7556 if (expr
->value
.function
.esym
!= NULL
)
7558 func_ifc
= expr
->value
.function
.esym
;
7563 gcc_assert (expr
->symtree
);
7564 func_ifc
= expr
->symtree
->n
.sym
;
7571 comp
= gfc_get_proc_ptr_comp (expr
);
7572 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7575 func_ifc
= comp
->ts
.interface
;
7579 if (expr
->expr_type
== EXPR_COMPCALL
)
7581 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7582 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7589 gcc_assert (func_ifc
->attr
.function
7590 && func_ifc
->result
!= NULL
);
7591 return func_ifc
->result
->attr
.pointer
;
7595 /* Is the lhs OK for automatic reallocation? */
7598 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7602 /* An allocatable variable with no reference. */
7603 if (expr
->symtree
->n
.sym
->attr
.allocatable
7607 /* All that can be left are allocatable components. */
7608 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7609 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7610 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7613 /* Find an allocatable component ref last. */
7614 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7615 if (ref
->type
== REF_COMPONENT
7617 && ref
->u
.c
.component
->attr
.allocatable
)
7624 /* Allocate or reallocate scalar lhs, as necessary. */
7627 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7641 if (!expr1
|| expr1
->rank
)
7644 if (!expr2
|| expr2
->rank
)
7647 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7649 /* Since this is a scalar lhs, we can afford to do this. That is,
7650 there is no risk of side effects being repeated. */
7651 gfc_init_se (&lse
, NULL
);
7652 lse
.want_pointer
= 1;
7653 gfc_conv_expr (&lse
, expr1
);
7655 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7656 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7658 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7659 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7660 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7662 tmp
= build3_v (COND_EXPR
, cond
,
7663 build1_v (GOTO_EXPR
, jump_label1
),
7664 build_empty_stmt (input_location
));
7665 gfc_add_expr_to_block (block
, tmp
);
7667 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7669 /* Use the rhs string length and the lhs element size. */
7670 size
= string_length
;
7671 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7672 tmp
= TYPE_SIZE_UNIT (tmp
);
7673 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7674 TREE_TYPE (tmp
), tmp
,
7675 fold_convert (TREE_TYPE (tmp
), size
));
7679 /* Otherwise use the length in bytes of the rhs. */
7680 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7681 size_in_bytes
= size
;
7684 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7685 size_in_bytes
, size_one_node
);
7687 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7689 tmp
= build_call_expr_loc (input_location
,
7690 builtin_decl_explicit (BUILT_IN_CALLOC
),
7691 2, build_one_cst (size_type_node
),
7693 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7694 gfc_add_modify (block
, lse
.expr
, tmp
);
7698 tmp
= build_call_expr_loc (input_location
,
7699 builtin_decl_explicit (BUILT_IN_MALLOC
),
7701 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7702 gfc_add_modify (block
, lse
.expr
, tmp
);
7705 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7707 /* Deferred characters need checking for lhs and rhs string
7708 length. Other deferred parameter variables will have to
7710 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7711 gfc_add_expr_to_block (block
, tmp
);
7713 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7714 gfc_add_expr_to_block (block
, tmp
);
7716 /* For a deferred length character, reallocate if lengths of lhs and
7717 rhs are different. */
7718 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7720 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7721 expr1
->ts
.u
.cl
->backend_decl
, size
);
7722 /* Jump past the realloc if the lengths are the same. */
7723 tmp
= build3_v (COND_EXPR
, cond
,
7724 build1_v (GOTO_EXPR
, jump_label2
),
7725 build_empty_stmt (input_location
));
7726 gfc_add_expr_to_block (block
, tmp
);
7727 tmp
= build_call_expr_loc (input_location
,
7728 builtin_decl_explicit (BUILT_IN_REALLOC
),
7729 2, fold_convert (pvoid_type_node
, lse
.expr
),
7731 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7732 gfc_add_modify (block
, lse
.expr
, tmp
);
7733 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7734 gfc_add_expr_to_block (block
, tmp
);
7736 /* Update the lhs character length. */
7737 size
= string_length
;
7738 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7743 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7744 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7745 init_flag indicates initialization expressions and dealloc that no
7746 deallocate prior assignment is needed (if in doubt, set true). */
7749 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7755 gfc_ss
*lss_section
;
7762 bool scalar_to_array
;
7766 /* Assignment of the form lhs = rhs. */
7767 gfc_start_block (&block
);
7769 gfc_init_se (&lse
, NULL
);
7770 gfc_init_se (&rse
, NULL
);
7773 lss
= gfc_walk_expr (expr1
);
7774 if (gfc_is_reallocatable_lhs (expr1
)
7775 && !(expr2
->expr_type
== EXPR_FUNCTION
7776 && expr2
->value
.function
.isym
!= NULL
))
7777 lss
->is_alloc_lhs
= 1;
7779 if (lss
!= gfc_ss_terminator
)
7781 /* The assignment needs scalarization. */
7784 /* Find a non-scalar SS from the lhs. */
7785 while (lss_section
!= gfc_ss_terminator
7786 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7787 lss_section
= lss_section
->next
;
7789 gcc_assert (lss_section
!= gfc_ss_terminator
);
7791 /* Initialize the scalarizer. */
7792 gfc_init_loopinfo (&loop
);
7795 rss
= gfc_walk_expr (expr2
);
7796 if (rss
== gfc_ss_terminator
)
7797 /* The rhs is scalar. Add a ss for the expression. */
7798 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7800 /* Associate the SS with the loop. */
7801 gfc_add_ss_to_loop (&loop
, lss
);
7802 gfc_add_ss_to_loop (&loop
, rss
);
7804 /* Calculate the bounds of the scalarization. */
7805 gfc_conv_ss_startstride (&loop
);
7806 /* Enable loop reversal. */
7807 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7808 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7809 /* Resolve any data dependencies in the statement. */
7810 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7811 /* Setup the scalarizing loops. */
7812 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7814 /* Setup the gfc_se structures. */
7815 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7816 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7819 gfc_mark_ss_chain_used (rss
, 1);
7820 if (loop
.temp_ss
== NULL
)
7823 gfc_mark_ss_chain_used (lss
, 1);
7827 lse
.ss
= loop
.temp_ss
;
7828 gfc_mark_ss_chain_used (lss
, 3);
7829 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
7832 /* Allow the scalarizer to workshare array assignments. */
7833 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
7834 ompws_flags
|= OMPWS_SCALARIZER_WS
;
7836 /* Start the scalarized loop body. */
7837 gfc_start_scalarized_body (&loop
, &body
);
7840 gfc_init_block (&body
);
7842 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
7844 /* Translate the expression. */
7845 gfc_conv_expr (&rse
, expr2
);
7847 /* Stabilize a string length for temporaries. */
7848 if (expr2
->ts
.type
== BT_CHARACTER
)
7849 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
7851 string_length
= NULL_TREE
;
7855 gfc_conv_tmp_array_ref (&lse
);
7856 if (expr2
->ts
.type
== BT_CHARACTER
)
7857 lse
.string_length
= string_length
;
7860 gfc_conv_expr (&lse
, expr1
);
7862 /* Assignments of scalar derived types with allocatable components
7863 to arrays must be done with a deep copy and the rhs temporary
7864 must have its components deallocated afterwards. */
7865 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
7866 && expr2
->ts
.u
.derived
->attr
.alloc_comp
7867 && !expr_is_variable (expr2
)
7868 && !gfc_is_constant_expr (expr2
)
7869 && expr1
->rank
&& !expr2
->rank
);
7870 if (scalar_to_array
&& dealloc
)
7872 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
7873 gfc_add_expr_to_block (&loop
.post
, tmp
);
7876 /* When assigning a character function result to a deferred-length variable,
7877 the function call must happen before the (re)allocation of the lhs -
7878 otherwise the character length of the result is not known.
7879 NOTE: This relies on having the exact dependence of the length type
7880 parameter available to the caller; gfortran saves it in the .mod files. */
7881 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
7882 && expr1
->ts
.deferred
)
7883 gfc_add_block_to_block (&block
, &rse
.pre
);
7885 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7886 l_is_temp
|| init_flag
,
7887 expr_is_variable (expr2
) || scalar_to_array
7888 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
7889 gfc_add_expr_to_block (&body
, tmp
);
7891 if (lss
== gfc_ss_terminator
)
7893 /* F2003: Add the code for reallocation on assignment. */
7894 if (gfc_option
.flag_realloc_lhs
7895 && is_scalar_reallocatable_lhs (expr1
))
7896 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
7899 /* Use the scalar assignment as is. */
7900 gfc_add_block_to_block (&block
, &body
);
7904 gcc_assert (lse
.ss
== gfc_ss_terminator
7905 && rse
.ss
== gfc_ss_terminator
);
7909 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
7911 /* We need to copy the temporary to the actual lhs. */
7912 gfc_init_se (&lse
, NULL
);
7913 gfc_init_se (&rse
, NULL
);
7914 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7915 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7917 rse
.ss
= loop
.temp_ss
;
7920 gfc_conv_tmp_array_ref (&rse
);
7921 gfc_conv_expr (&lse
, expr1
);
7923 gcc_assert (lse
.ss
== gfc_ss_terminator
7924 && rse
.ss
== gfc_ss_terminator
);
7926 if (expr2
->ts
.type
== BT_CHARACTER
)
7927 rse
.string_length
= string_length
;
7929 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7930 false, false, dealloc
);
7931 gfc_add_expr_to_block (&body
, tmp
);
7934 /* F2003: Allocate or reallocate lhs of allocatable array. */
7935 if (gfc_option
.flag_realloc_lhs
7936 && gfc_is_reallocatable_lhs (expr1
)
7937 && !gfc_expr_attr (expr1
).codimension
7938 && !gfc_is_coindexed (expr1
)
7941 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7942 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
7943 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
7944 if (tmp
!= NULL_TREE
)
7945 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
7948 /* Generate the copying loops. */
7949 gfc_trans_scalarizing_loops (&loop
, &body
);
7951 /* Wrap the whole thing up. */
7952 gfc_add_block_to_block (&block
, &loop
.pre
);
7953 gfc_add_block_to_block (&block
, &loop
.post
);
7955 gfc_cleanup_loop (&loop
);
7958 return gfc_finish_block (&block
);
7962 /* Check whether EXPR is a copyable array. */
7965 copyable_array_p (gfc_expr
* expr
)
7967 if (expr
->expr_type
!= EXPR_VARIABLE
)
7970 /* First check it's an array. */
7971 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
7974 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
7977 /* Next check that it's of a simple enough type. */
7978 switch (expr
->ts
.type
)
7990 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
7999 /* Translate an assignment. */
8002 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8007 /* Special case a single function returning an array. */
8008 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8010 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8015 /* Special case assigning an array to zero. */
8016 if (copyable_array_p (expr1
)
8017 && is_zero_initializer_p (expr2
))
8019 tmp
= gfc_trans_zero_assign (expr1
);
8024 /* Special case copying one array to another. */
8025 if (copyable_array_p (expr1
)
8026 && copyable_array_p (expr2
)
8027 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8028 && !gfc_check_dependency (expr1
, expr2
, 0))
8030 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8035 /* Special case initializing an array from a constant array constructor. */
8036 if (copyable_array_p (expr1
)
8037 && expr2
->expr_type
== EXPR_ARRAY
8038 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8040 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8045 /* Fallback to the scalarizer to generate explicit loops. */
8046 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8050 gfc_trans_init_assign (gfc_code
* code
)
8052 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8056 gfc_trans_assign (gfc_code
* code
)
8058 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);