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
));
744 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
745 tmp
= gfc_finish_block (&block
);
747 if (optional_alloc_ptr
)
748 tmp2
= build_empty_stmt (input_location
);
751 gfc_init_block (&block
);
753 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
754 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
756 tmp2
= gfc_finish_block (&block
);
759 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
761 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
764 gfc_add_block_to_block (&parmse
->pre
, &block
);
766 /* Pass the address of the class object. */
767 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
769 if (optional
&& optional_alloc_ptr
)
770 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
771 TREE_TYPE (parmse
->expr
),
773 fold_convert (TREE_TYPE (parmse
->expr
),
778 /* Given a class array declaration and an index, returns the address
779 of the referenced element. */
782 gfc_get_class_array_ref (tree index
, tree class_decl
)
784 tree data
= gfc_class_data_get (class_decl
);
785 tree size
= gfc_vtable_size_get (class_decl
);
786 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
787 gfc_array_index_type
,
790 data
= gfc_conv_descriptor_data_get (data
);
791 ptr
= fold_convert (pvoid_type_node
, data
);
792 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
793 return fold_convert (TREE_TYPE (data
), ptr
);
797 /* Copies one class expression to another, assuming that if either
798 'to' or 'from' are arrays they are packed. Should 'from' be
799 NULL_TREE, the initialization expression for 'to' is used, assuming
800 that the _vptr is set. */
803 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
811 vec
<tree
, va_gc
> *args
;
814 stmtblock_t loopbody
;
820 if (from
!= NULL_TREE
)
821 fcn
= gfc_vtable_copy_get (from
);
823 fcn
= gfc_vtable_copy_get (to
);
825 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
827 if (from
!= NULL_TREE
)
828 from_data
= gfc_class_data_get (from
);
830 from_data
= gfc_vtable_def_init_get (to
);
832 to_data
= gfc_class_data_get (to
);
834 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
836 gfc_init_block (&body
);
837 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
838 gfc_array_index_type
, nelems
,
840 nelems
= gfc_evaluate_now (tmp
, &body
);
841 index
= gfc_create_var (gfc_array_index_type
, "S");
843 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
845 from_ref
= gfc_get_class_array_ref (index
, from
);
846 vec_safe_push (args
, from_ref
);
849 vec_safe_push (args
, from_data
);
851 to_ref
= gfc_get_class_array_ref (index
, to
);
852 vec_safe_push (args
, to_ref
);
854 tmp
= build_call_vec (fcn_type
, fcn
, args
);
856 /* Build the body of the loop. */
857 gfc_init_block (&loopbody
);
858 gfc_add_expr_to_block (&loopbody
, tmp
);
860 /* Build the loop and return. */
861 gfc_init_loopinfo (&loop
);
863 loop
.from
[0] = gfc_index_zero_node
;
864 loop
.loopvar
[0] = index
;
866 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
867 gfc_add_block_to_block (&body
, &loop
.pre
);
868 tmp
= gfc_finish_block (&body
);
869 gfc_cleanup_loop (&loop
);
873 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
874 vec_safe_push (args
, from_data
);
875 vec_safe_push (args
, to_data
);
876 tmp
= build_call_vec (fcn_type
, fcn
, args
);
883 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
885 gfc_actual_arglist
*actual
;
890 actual
= gfc_get_actual_arglist ();
891 actual
->expr
= gfc_copy_expr (rhs
);
892 actual
->next
= gfc_get_actual_arglist ();
893 actual
->next
->expr
= gfc_copy_expr (lhs
);
894 ppc
= gfc_copy_expr (obj
);
895 gfc_add_vptr_component (ppc
);
896 gfc_add_component_ref (ppc
, "_copy");
897 ppc_code
= gfc_get_code (EXEC_CALL
);
898 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
899 /* Although '_copy' is set to be elemental in class.c, it is
900 not staying that way. Find out why, sometime.... */
901 ppc_code
->resolved_sym
->attr
.elemental
= 1;
902 ppc_code
->ext
.actual
= actual
;
903 ppc_code
->expr1
= ppc
;
904 /* Since '_copy' is elemental, the scalarizer will take care
905 of arrays in gfc_trans_call. */
906 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
907 gfc_free_statements (ppc_code
);
911 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
912 A MEMCPY is needed to copy the full data from the default initializer
913 of the dynamic type. */
916 gfc_trans_class_init_assign (gfc_code
*code
)
920 gfc_se dst
,src
,memsz
;
921 gfc_expr
*lhs
, *rhs
, *sz
;
923 gfc_start_block (&block
);
925 lhs
= gfc_copy_expr (code
->expr1
);
926 gfc_add_data_component (lhs
);
928 rhs
= gfc_copy_expr (code
->expr1
);
929 gfc_add_vptr_component (rhs
);
931 /* Make sure that the component backend_decls have been built, which
932 will not have happened if the derived types concerned have not
934 gfc_get_derived_type (rhs
->ts
.u
.derived
);
935 gfc_add_def_init_component (rhs
);
937 if (code
->expr1
->ts
.type
== BT_CLASS
938 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
939 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
942 sz
= gfc_copy_expr (code
->expr1
);
943 gfc_add_vptr_component (sz
);
944 gfc_add_size_component (sz
);
946 gfc_init_se (&dst
, NULL
);
947 gfc_init_se (&src
, NULL
);
948 gfc_init_se (&memsz
, NULL
);
949 gfc_conv_expr (&dst
, lhs
);
950 gfc_conv_expr (&src
, rhs
);
951 gfc_conv_expr (&memsz
, sz
);
952 gfc_add_block_to_block (&block
, &src
.pre
);
953 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
955 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
958 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
959 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
961 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
962 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
964 build_empty_stmt (input_location
));
967 gfc_add_expr_to_block (&block
, tmp
);
969 return gfc_finish_block (&block
);
973 /* Translate an assignment to a CLASS object
974 (pointer or ordinary assignment). */
977 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
985 gfc_start_block (&block
);
988 while (ref
&& ref
->next
)
991 /* Class valued proc_pointer assignments do not need any further
993 if (ref
&& ref
->type
== REF_COMPONENT
994 && ref
->u
.c
.component
->attr
.proc_pointer
995 && expr2
->expr_type
== EXPR_VARIABLE
996 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
997 && op
== EXEC_POINTER_ASSIGN
)
1000 if (expr2
->ts
.type
!= BT_CLASS
)
1002 /* Insert an additional assignment which sets the '_vptr' field. */
1003 gfc_symbol
*vtab
= NULL
;
1006 lhs
= gfc_copy_expr (expr1
);
1007 gfc_add_vptr_component (lhs
);
1009 if (UNLIMITED_POLY (expr1
)
1010 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1012 rhs
= gfc_get_null_expr (&expr2
->where
);
1016 if (expr2
->ts
.type
== BT_DERIVED
)
1017 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
1018 else if (expr2
->expr_type
== EXPR_NULL
)
1019 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
1021 vtab
= gfc_find_intrinsic_vtab (&expr2
->ts
);
1024 rhs
= gfc_get_expr ();
1025 rhs
->expr_type
= EXPR_VARIABLE
;
1026 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1030 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1031 gfc_add_expr_to_block (&block
, tmp
);
1033 gfc_free_expr (lhs
);
1034 gfc_free_expr (rhs
);
1036 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1038 /* F2003:C717 only sequence and bind-C types can come here. */
1039 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1040 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1041 gfc_add_data_component (expr2
);
1044 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1046 /* Insert an additional assignment which sets the '_vptr' field. */
1047 lhs
= gfc_copy_expr (expr1
);
1048 gfc_add_vptr_component (lhs
);
1050 rhs
= gfc_copy_expr (expr2
);
1051 gfc_add_vptr_component (rhs
);
1053 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1054 gfc_add_expr_to_block (&block
, tmp
);
1056 gfc_free_expr (lhs
);
1057 gfc_free_expr (rhs
);
1060 /* Do the actual CLASS assignment. */
1061 if (expr2
->ts
.type
== BT_CLASS
1062 && !CLASS_DATA (expr2
)->attr
.dimension
)
1064 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1065 || !CLASS_DATA (expr2
)->attr
.dimension
)
1066 gfc_add_data_component (expr1
);
1070 if (op
== EXEC_ASSIGN
)
1071 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1072 else if (op
== EXEC_POINTER_ASSIGN
)
1073 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1077 gfc_add_expr_to_block (&block
, tmp
);
1079 return gfc_finish_block (&block
);
1083 /* End of prototype trans-class.c */
1087 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1089 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1090 && gfc_option
.warn_realloc_lhs
)
1091 gfc_warning ("Code for reallocating the allocatable array at %L will "
1093 else if (gfc_option
.warn_realloc_lhs_all
)
1094 gfc_warning ("Code for reallocating the allocatable variable at %L "
1095 "will be added", where
);
1099 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1100 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1103 /* Copy the scalarization loop variables. */
1106 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1109 dest
->loop
= src
->loop
;
1113 /* Initialize a simple expression holder.
1115 Care must be taken when multiple se are created with the same parent.
1116 The child se must be kept in sync. The easiest way is to delay creation
1117 of a child se until after after the previous se has been translated. */
1120 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1122 memset (se
, 0, sizeof (gfc_se
));
1123 gfc_init_block (&se
->pre
);
1124 gfc_init_block (&se
->post
);
1126 se
->parent
= parent
;
1129 gfc_copy_se_loopvars (se
, parent
);
1133 /* Advances to the next SS in the chain. Use this rather than setting
1134 se->ss = se->ss->next because all the parents needs to be kept in sync.
1138 gfc_advance_se_ss_chain (gfc_se
* se
)
1143 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1146 /* Walk down the parent chain. */
1149 /* Simple consistency check. */
1150 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1151 || p
->parent
->ss
->nested_ss
== p
->ss
);
1153 /* If we were in a nested loop, the next scalarized expression can be
1154 on the parent ss' next pointer. Thus we should not take the next
1155 pointer blindly, but rather go up one nest level as long as next
1156 is the end of chain. */
1158 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1168 /* Ensures the result of the expression as either a temporary variable
1169 or a constant so that it can be used repeatedly. */
1172 gfc_make_safe_expr (gfc_se
* se
)
1176 if (CONSTANT_CLASS_P (se
->expr
))
1179 /* We need a temporary for this result. */
1180 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1181 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1186 /* Return an expression which determines if a dummy parameter is present.
1187 Also used for arguments to procedures with multiple entry points. */
1190 gfc_conv_expr_present (gfc_symbol
* sym
)
1194 gcc_assert (sym
->attr
.dummy
);
1195 decl
= gfc_get_symbol_decl (sym
);
1197 /* Intrinsic scalars with VALUE attribute which are passed by value
1198 use a hidden argument to denote the present status. */
1199 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1200 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1201 && !sym
->attr
.dimension
)
1203 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1206 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1208 strcpy (&name
[1], sym
->name
);
1209 tree_name
= get_identifier (name
);
1211 /* Walk function argument list to find hidden arg. */
1212 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1213 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1214 if (DECL_NAME (cond
) == tree_name
)
1221 if (TREE_CODE (decl
) != PARM_DECL
)
1223 /* Array parameters use a temporary descriptor, we want the real
1225 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1226 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1227 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1230 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1231 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1233 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1234 as actual argument to denote absent dummies. For array descriptors,
1235 we thus also need to check the array descriptor. For BT_CLASS, it
1236 can also occur for scalars and F2003 due to type->class wrapping and
1237 class->class wrapping. Note further that BT_CLASS always uses an
1238 array descriptor for arrays, also for explicit-shape/assumed-size. */
1240 if (!sym
->attr
.allocatable
1241 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1242 || (sym
->ts
.type
== BT_CLASS
1243 && !CLASS_DATA (sym
)->attr
.allocatable
1244 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1245 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1246 || sym
->ts
.type
== BT_CLASS
))
1250 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1251 || sym
->as
->type
== AS_ASSUMED_RANK
1252 || sym
->attr
.codimension
))
1253 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1255 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1256 if (sym
->ts
.type
== BT_CLASS
)
1257 tmp
= gfc_class_data_get (tmp
);
1258 tmp
= gfc_conv_array_data (tmp
);
1260 else if (sym
->ts
.type
== BT_CLASS
)
1261 tmp
= gfc_class_data_get (decl
);
1265 if (tmp
!= NULL_TREE
)
1267 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1268 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1269 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1270 boolean_type_node
, cond
, tmp
);
1278 /* Converts a missing, dummy argument into a null or zero. */
1281 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1286 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1290 /* Create a temporary and convert it to the correct type. */
1291 tmp
= gfc_get_int_type (kind
);
1292 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1295 /* Test for a NULL value. */
1296 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1297 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1298 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1299 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1303 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1305 build_zero_cst (TREE_TYPE (se
->expr
)));
1306 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1310 if (ts
.type
== BT_CHARACTER
)
1312 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1313 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1314 present
, se
->string_length
, tmp
);
1315 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1316 se
->string_length
= tmp
;
1322 /* Get the character length of an expression, looking through gfc_refs
1326 gfc_get_expr_charlen (gfc_expr
*e
)
1331 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1332 && e
->ts
.type
== BT_CHARACTER
);
1334 length
= NULL
; /* To silence compiler warning. */
1336 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1339 gfc_init_se (&tmpse
, NULL
);
1340 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1341 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1345 /* First candidate: if the variable is of type CHARACTER, the
1346 expression's length could be the length of the character
1348 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1349 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1351 /* Look through the reference chain for component references. */
1352 for (r
= e
->ref
; r
; r
= r
->next
)
1357 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1358 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1366 /* We should never got substring references here. These will be
1367 broken down by the scalarizer. */
1373 gcc_assert (length
!= NULL
);
1378 /* Return for an expression the backend decl of the coarray. */
1381 get_tree_for_caf_expr (gfc_expr
*expr
)
1383 tree caf_decl
= NULL_TREE
;
1386 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1387 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1388 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1390 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1391 if (ref
->type
== REF_COMPONENT
)
1393 gfc_component
*comp
= ref
->u
.c
.component
;
1394 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
1395 caf_decl
= NULL_TREE
;
1396 if (comp
->attr
.codimension
)
1397 caf_decl
= comp
->backend_decl
;
1400 gcc_assert (caf_decl
!= NULL_TREE
);
1405 /* For each character array constructor subexpression without a ts.u.cl->length,
1406 replace it by its first element (if there aren't any elements, the length
1407 should already be set to zero). */
1410 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1412 gfc_actual_arglist
* arg
;
1418 switch (e
->expr_type
)
1422 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1423 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1427 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1431 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1432 flatten_array_ctors_without_strlen (arg
->expr
);
1437 /* We've found what we're looking for. */
1438 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1443 gcc_assert (e
->value
.constructor
);
1445 c
= gfc_constructor_first (e
->value
.constructor
);
1449 flatten_array_ctors_without_strlen (new_expr
);
1450 gfc_replace_expr (e
, new_expr
);
1454 /* Otherwise, fall through to handle constructor elements. */
1455 case EXPR_STRUCTURE
:
1456 for (c
= gfc_constructor_first (e
->value
.constructor
);
1457 c
; c
= gfc_constructor_next (c
))
1458 flatten_array_ctors_without_strlen (c
->expr
);
1468 /* Generate code to initialize a string length variable. Returns the
1469 value. For array constructors, cl->length might be NULL and in this case,
1470 the first element of the constructor is needed. expr is the original
1471 expression so we can access it but can be NULL if this is not needed. */
1474 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1478 gfc_init_se (&se
, NULL
);
1482 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1485 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1486 "flatten" array constructors by taking their first element; all elements
1487 should be the same length or a cl->length should be present. */
1490 gfc_expr
* expr_flat
;
1492 expr_flat
= gfc_copy_expr (expr
);
1493 flatten_array_ctors_without_strlen (expr_flat
);
1494 gfc_resolve_expr (expr_flat
);
1496 gfc_conv_expr (&se
, expr_flat
);
1497 gfc_add_block_to_block (pblock
, &se
.pre
);
1498 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1500 gfc_free_expr (expr_flat
);
1504 /* Convert cl->length. */
1506 gcc_assert (cl
->length
);
1508 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1509 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1510 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1511 gfc_add_block_to_block (pblock
, &se
.pre
);
1513 if (cl
->backend_decl
)
1514 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1516 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1521 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1522 const char *name
, locus
*where
)
1532 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1533 type
= build_pointer_type (type
);
1535 gfc_init_se (&start
, se
);
1536 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1537 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1539 if (integer_onep (start
.expr
))
1540 gfc_conv_string_parameter (se
);
1545 /* Avoid multiple evaluation of substring start. */
1546 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1547 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1549 /* Change the start of the string. */
1550 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1553 tmp
= build_fold_indirect_ref_loc (input_location
,
1555 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1556 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1559 /* Length = end + 1 - start. */
1560 gfc_init_se (&end
, se
);
1561 if (ref
->u
.ss
.end
== NULL
)
1562 end
.expr
= se
->string_length
;
1565 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1566 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1570 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1571 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1573 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1575 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1576 boolean_type_node
, start
.expr
,
1579 /* Check lower bound. */
1580 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1582 build_int_cst (gfc_charlen_type_node
, 1));
1583 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1584 boolean_type_node
, nonempty
, fault
);
1586 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1587 "is less than one", name
);
1589 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1590 "is less than one");
1591 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1592 fold_convert (long_integer_type_node
,
1596 /* Check upper bound. */
1597 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1598 end
.expr
, se
->string_length
);
1599 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1600 boolean_type_node
, nonempty
, fault
);
1602 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1603 "exceeds string length (%%ld)", name
);
1605 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1606 "exceeds string length (%%ld)");
1607 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1608 fold_convert (long_integer_type_node
, end
.expr
),
1609 fold_convert (long_integer_type_node
,
1610 se
->string_length
));
1614 /* Try to calculate the length from the start and end expressions. */
1616 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1620 i_len
= mpz_get_si (length
) + 1;
1624 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1625 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1629 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1630 end
.expr
, start
.expr
);
1631 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1632 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1633 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1634 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1637 se
->string_length
= tmp
;
1641 /* Convert a derived type component reference. */
1644 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1651 c
= ref
->u
.c
.component
;
1653 gcc_assert (c
->backend_decl
);
1655 field
= c
->backend_decl
;
1656 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1659 /* Components can correspond to fields of different containing
1660 types, as components are created without context, whereas
1661 a concrete use of a component has the type of decl as context.
1662 So, if the type doesn't match, we search the corresponding
1663 FIELD_DECL in the parent type. To not waste too much time
1664 we cache this result in norestrict_decl. */
1666 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1668 tree f2
= c
->norestrict_decl
;
1669 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1670 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1671 if (TREE_CODE (f2
) == FIELD_DECL
1672 && DECL_NAME (f2
) == DECL_NAME (field
))
1675 c
->norestrict_decl
= f2
;
1679 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1680 decl
, field
, NULL_TREE
);
1684 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1686 tmp
= c
->ts
.u
.cl
->backend_decl
;
1687 /* Components must always be constant length. */
1688 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1689 se
->string_length
= tmp
;
1692 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1693 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1694 && c
->ts
.type
!= BT_CHARACTER
)
1695 || c
->attr
.proc_pointer
)
1696 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1701 /* This function deals with component references to components of the
1702 parent type for derived type extensions. */
1704 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1712 c
= ref
->u
.c
.component
;
1714 /* Return if the component is in the parent type. */
1715 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1716 if (strcmp (c
->name
, cmp
->name
) == 0)
1719 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1720 parent
.type
= REF_COMPONENT
;
1722 parent
.u
.c
.sym
= dt
;
1723 parent
.u
.c
.component
= dt
->components
;
1725 if (dt
->backend_decl
== NULL
)
1726 gfc_get_derived_type (dt
);
1728 /* Build the reference and call self. */
1729 gfc_conv_component_ref (se
, &parent
);
1730 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1731 parent
.u
.c
.component
= c
;
1732 conv_parent_component_references (se
, &parent
);
1735 /* Return the contents of a variable. Also handles reference/pointer
1736 variables (all Fortran pointer references are implicit). */
1739 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1744 tree parent_decl
= NULL_TREE
;
1747 bool alternate_entry
;
1750 sym
= expr
->symtree
->n
.sym
;
1754 gfc_ss_info
*ss_info
= ss
->info
;
1756 /* Check that something hasn't gone horribly wrong. */
1757 gcc_assert (ss
!= gfc_ss_terminator
);
1758 gcc_assert (ss_info
->expr
== expr
);
1760 /* A scalarized term. We already know the descriptor. */
1761 se
->expr
= ss_info
->data
.array
.descriptor
;
1762 se
->string_length
= ss_info
->string_length
;
1763 ref
= ss_info
->data
.array
.ref
;
1765 gcc_assert (ref
->type
== REF_ARRAY
1766 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1768 gfc_conv_tmp_array_ref (se
);
1772 tree se_expr
= NULL_TREE
;
1774 se
->expr
= gfc_get_symbol_decl (sym
);
1776 /* Deal with references to a parent results or entries by storing
1777 the current_function_decl and moving to the parent_decl. */
1778 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1779 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1780 && sym
->result
== sym
;
1781 entry_master
= sym
->attr
.result
1782 && sym
->ns
->proc_name
->attr
.entry_master
1783 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1784 if (current_function_decl
)
1785 parent_decl
= DECL_CONTEXT (current_function_decl
);
1787 if ((se
->expr
== parent_decl
&& return_value
)
1788 || (sym
->ns
&& sym
->ns
->proc_name
1790 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1791 && (alternate_entry
|| entry_master
)))
1796 /* Special case for assigning the return value of a function.
1797 Self recursive functions must have an explicit return value. */
1798 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1799 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1801 /* Similarly for alternate entry points. */
1802 else if (alternate_entry
1803 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1806 gfc_entry_list
*el
= NULL
;
1808 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1811 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1816 else if (entry_master
1817 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1819 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1824 /* Procedure actual arguments. */
1825 else if (sym
->attr
.flavor
== FL_PROCEDURE
1826 && se
->expr
!= current_function_decl
)
1828 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1830 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1831 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1837 /* Dereference the expression, where needed. Since characters
1838 are entirely different from other types, they are treated
1840 if (sym
->ts
.type
== BT_CHARACTER
)
1842 /* Dereference character pointer dummy arguments
1844 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1846 || sym
->attr
.function
1847 || sym
->attr
.result
))
1848 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1852 else if (!sym
->attr
.value
)
1854 /* Dereference non-character scalar dummy arguments. */
1855 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1856 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1857 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1860 /* Dereference scalar hidden result. */
1861 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1862 && (sym
->attr
.function
|| sym
->attr
.result
)
1863 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1864 && !sym
->attr
.always_explicit
)
1865 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1868 /* Dereference non-character pointer variables.
1869 These must be dummies, results, or scalars. */
1870 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1871 || gfc_is_associate_pointer (sym
)
1872 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1874 || sym
->attr
.function
1876 || (!sym
->attr
.dimension
1877 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1878 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1885 /* For character variables, also get the length. */
1886 if (sym
->ts
.type
== BT_CHARACTER
)
1888 /* If the character length of an entry isn't set, get the length from
1889 the master function instead. */
1890 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1891 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1893 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1894 gcc_assert (se
->string_length
);
1902 /* Return the descriptor if that's what we want and this is an array
1903 section reference. */
1904 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1906 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1907 /* Return the descriptor for array pointers and allocations. */
1908 if (se
->want_pointer
1909 && ref
->next
== NULL
&& (se
->descriptor_only
))
1912 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1913 /* Return a pointer to an element. */
1917 if (ref
->u
.c
.sym
->attr
.extension
)
1918 conv_parent_component_references (se
, ref
);
1920 gfc_conv_component_ref (se
, ref
);
1921 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1922 && se
->want_pointer
&& se
->descriptor_only
)
1928 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1929 expr
->symtree
->name
, &expr
->where
);
1938 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1940 if (se
->want_pointer
)
1942 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1943 gfc_conv_string_parameter (se
);
1945 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1950 /* Unary ops are easy... Or they would be if ! was a valid op. */
1953 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1958 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1959 /* Initialize the operand. */
1960 gfc_init_se (&operand
, se
);
1961 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1962 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1964 type
= gfc_typenode_for_spec (&expr
->ts
);
1966 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1967 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1968 All other unary operators have an equivalent GIMPLE unary operator. */
1969 if (code
== TRUTH_NOT_EXPR
)
1970 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1971 build_int_cst (type
, 0));
1973 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1977 /* Expand power operator to optimal multiplications when a value is raised
1978 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1979 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1980 Programming", 3rd Edition, 1998. */
1982 /* This code is mostly duplicated from expand_powi in the backend.
1983 We establish the "optimal power tree" lookup table with the defined size.
1984 The items in the table are the exponents used to calculate the index
1985 exponents. Any integer n less than the value can get an "addition chain",
1986 with the first node being one. */
1987 #define POWI_TABLE_SIZE 256
1989 /* The table is from builtins.c. */
1990 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1992 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1993 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1994 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1995 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1996 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1997 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1998 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1999 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2000 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2001 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2002 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2003 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2004 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2005 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2006 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2007 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2008 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2009 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2010 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2011 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2012 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2013 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2014 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2015 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2016 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2017 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2018 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2019 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2020 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2021 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2022 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2023 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2026 /* If n is larger than lookup table's max index, we use the "window
2028 #define POWI_WINDOW_SIZE 3
2030 /* Recursive function to expand the power operator. The temporary
2031 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2033 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2040 if (n
< POWI_TABLE_SIZE
)
2045 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2046 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2050 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2051 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2052 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2056 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2060 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2061 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2063 if (n
< POWI_TABLE_SIZE
)
2070 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2071 return 1. Else return 0 and a call to runtime library functions
2072 will have to be built. */
2074 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2079 tree vartmp
[POWI_TABLE_SIZE
];
2081 unsigned HOST_WIDE_INT n
;
2083 wide_int wrhs
= rhs
;
2085 /* If exponent is too large, we won't expand it anyway, so don't bother
2086 with large integer values. */
2087 if (!wi::fits_shwi_p (wrhs
))
2090 m
= wrhs
.to_shwi ();
2091 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2092 of the asymmetric range of the integer type. */
2093 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2095 type
= TREE_TYPE (lhs
);
2096 sgn
= tree_int_cst_sgn (rhs
);
2098 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2099 || optimize_size
) && (m
> 2 || m
< -1))
2105 se
->expr
= gfc_build_const (type
, integer_one_node
);
2109 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2110 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2112 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2113 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2114 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2115 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2118 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2121 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2122 boolean_type_node
, tmp
, cond
);
2123 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2124 tmp
, build_int_cst (type
, 1),
2125 build_int_cst (type
, 0));
2129 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2130 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2131 build_int_cst (type
, -1),
2132 build_int_cst (type
, 0));
2133 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2134 cond
, build_int_cst (type
, 1), tmp
);
2138 memset (vartmp
, 0, sizeof (vartmp
));
2142 tmp
= gfc_build_const (type
, integer_one_node
);
2143 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2147 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2153 /* Power op (**). Constant integer exponent has special handling. */
2156 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2158 tree gfc_int4_type_node
;
2161 int res_ikind_1
, res_ikind_2
;
2166 gfc_init_se (&lse
, se
);
2167 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2168 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2169 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2171 gfc_init_se (&rse
, se
);
2172 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2173 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2175 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2176 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2177 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2180 gfc_int4_type_node
= gfc_get_int_type (4);
2182 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2183 library routine. But in the end, we have to convert the result back
2184 if this case applies -- with res_ikind_K, we keep track whether operand K
2185 falls into this case. */
2189 kind
= expr
->value
.op
.op1
->ts
.kind
;
2190 switch (expr
->value
.op
.op2
->ts
.type
)
2193 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2198 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2199 res_ikind_2
= ikind
;
2221 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2223 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2250 switch (expr
->value
.op
.op1
->ts
.type
)
2253 if (kind
== 3) /* Case 16 was not handled properly above. */
2255 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2259 /* Use builtins for real ** int4. */
2265 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2269 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2273 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2277 /* Use the __builtin_powil() only if real(kind=16) is
2278 actually the C long double type. */
2279 if (!gfc_real16_is_float128
)
2280 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2288 /* If we don't have a good builtin for this, go for the
2289 library function. */
2291 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2295 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2304 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2308 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2316 se
->expr
= build_call_expr_loc (input_location
,
2317 fndecl
, 2, lse
.expr
, rse
.expr
);
2319 /* Convert the result back if it is of wrong integer kind. */
2320 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2322 /* We want the maximum of both operand kinds as result. */
2323 if (res_ikind_1
< res_ikind_2
)
2324 res_ikind_1
= res_ikind_2
;
2325 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2330 /* Generate code to allocate a string temporary. */
2333 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2338 if (gfc_can_put_var_on_stack (len
))
2340 /* Create a temporary variable to hold the result. */
2341 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2342 gfc_charlen_type_node
, len
,
2343 build_int_cst (gfc_charlen_type_node
, 1));
2344 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2346 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2347 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2349 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2351 var
= gfc_create_var (tmp
, "str");
2352 var
= gfc_build_addr_expr (type
, var
);
2356 /* Allocate a temporary to hold the result. */
2357 var
= gfc_create_var (type
, "pstr");
2358 gcc_assert (POINTER_TYPE_P (type
));
2359 tmp
= TREE_TYPE (type
);
2360 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2361 tmp
= TREE_TYPE (tmp
);
2362 tmp
= TYPE_SIZE_UNIT (tmp
);
2363 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2364 fold_convert (size_type_node
, len
),
2365 fold_convert (size_type_node
, tmp
));
2366 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2367 gfc_add_modify (&se
->pre
, var
, tmp
);
2369 /* Free the temporary afterwards. */
2370 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2371 gfc_add_expr_to_block (&se
->post
, tmp
);
2378 /* Handle a string concatenation operation. A temporary will be allocated to
2382 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2385 tree len
, type
, var
, tmp
, fndecl
;
2387 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2388 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2389 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2391 gfc_init_se (&lse
, se
);
2392 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2393 gfc_conv_string_parameter (&lse
);
2394 gfc_init_se (&rse
, se
);
2395 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2396 gfc_conv_string_parameter (&rse
);
2398 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2399 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2401 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2402 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2403 if (len
== NULL_TREE
)
2405 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2406 TREE_TYPE (lse
.string_length
),
2407 lse
.string_length
, rse
.string_length
);
2410 type
= build_pointer_type (type
);
2412 var
= gfc_conv_string_tmp (se
, type
, len
);
2414 /* Do the actual concatenation. */
2415 if (expr
->ts
.kind
== 1)
2416 fndecl
= gfor_fndecl_concat_string
;
2417 else if (expr
->ts
.kind
== 4)
2418 fndecl
= gfor_fndecl_concat_string_char4
;
2422 tmp
= build_call_expr_loc (input_location
,
2423 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2424 rse
.string_length
, rse
.expr
);
2425 gfc_add_expr_to_block (&se
->pre
, tmp
);
2427 /* Add the cleanup for the operands. */
2428 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2429 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2432 se
->string_length
= len
;
2435 /* Translates an op expression. Common (binary) cases are handled by this
2436 function, others are passed on. Recursion is used in either case.
2437 We use the fact that (op1.ts == op2.ts) (except for the power
2439 Operators need no special handling for scalarized expressions as long as
2440 they call gfc_conv_simple_val to get their operands.
2441 Character strings get special handling. */
2444 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2446 enum tree_code code
;
2455 switch (expr
->value
.op
.op
)
2457 case INTRINSIC_PARENTHESES
:
2458 if ((expr
->ts
.type
== BT_REAL
2459 || expr
->ts
.type
== BT_COMPLEX
)
2460 && gfc_option
.flag_protect_parens
)
2462 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2463 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2468 case INTRINSIC_UPLUS
:
2469 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2472 case INTRINSIC_UMINUS
:
2473 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2477 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2480 case INTRINSIC_PLUS
:
2484 case INTRINSIC_MINUS
:
2488 case INTRINSIC_TIMES
:
2492 case INTRINSIC_DIVIDE
:
2493 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2494 an integer, we must round towards zero, so we use a
2496 if (expr
->ts
.type
== BT_INTEGER
)
2497 code
= TRUNC_DIV_EXPR
;
2502 case INTRINSIC_POWER
:
2503 gfc_conv_power_op (se
, expr
);
2506 case INTRINSIC_CONCAT
:
2507 gfc_conv_concat_op (se
, expr
);
2511 code
= TRUTH_ANDIF_EXPR
;
2516 code
= TRUTH_ORIF_EXPR
;
2520 /* EQV and NEQV only work on logicals, but since we represent them
2521 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2523 case INTRINSIC_EQ_OS
:
2531 case INTRINSIC_NE_OS
:
2532 case INTRINSIC_NEQV
:
2539 case INTRINSIC_GT_OS
:
2546 case INTRINSIC_GE_OS
:
2553 case INTRINSIC_LT_OS
:
2560 case INTRINSIC_LE_OS
:
2566 case INTRINSIC_USER
:
2567 case INTRINSIC_ASSIGN
:
2568 /* These should be converted into function calls by the frontend. */
2572 fatal_error ("Unknown intrinsic op");
2576 /* The only exception to this is **, which is handled separately anyway. */
2577 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2579 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2583 gfc_init_se (&lse
, se
);
2584 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2585 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2588 gfc_init_se (&rse
, se
);
2589 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2590 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2594 gfc_conv_string_parameter (&lse
);
2595 gfc_conv_string_parameter (&rse
);
2597 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2598 rse
.string_length
, rse
.expr
,
2599 expr
->value
.op
.op1
->ts
.kind
,
2601 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2602 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2605 type
= gfc_typenode_for_spec (&expr
->ts
);
2609 /* The result of logical ops is always boolean_type_node. */
2610 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2611 lse
.expr
, rse
.expr
);
2612 se
->expr
= convert (type
, tmp
);
2615 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2617 /* Add the post blocks. */
2618 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2619 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2622 /* If a string's length is one, we convert it to a single character. */
2625 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2629 || !cst_fits_uhwi_p (len
)
2630 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2633 if (tree_to_hwi (len
) == 1)
2635 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2636 return build_fold_indirect_ref_loc (input_location
, str
);
2640 && TREE_CODE (str
) == ADDR_EXPR
2641 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2642 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2643 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2644 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2645 && tree_to_uhwi (len
) > 1
2646 && tree_to_uhwi (len
)
2647 == (unsigned HOST_WIDE_INT
)
2648 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2650 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2651 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2652 if (TREE_CODE (ret
) == INTEGER_CST
)
2654 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2655 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2656 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2658 for (i
= 1; i
< length
; i
++)
2671 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2674 if (sym
->backend_decl
)
2676 /* This becomes the nominal_type in
2677 function.c:assign_parm_find_data_types. */
2678 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2679 /* This becomes the passed_type in
2680 function.c:assign_parm_find_data_types. C promotes char to
2681 integer for argument passing. */
2682 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2684 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2689 /* If we have a constant character expression, make it into an
2691 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2696 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2697 (int)(*expr
)->value
.character
.string
[0]);
2698 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2700 /* The expr needs to be compatible with a C int. If the
2701 conversion fails, then the 2 causes an ICE. */
2702 ts
.type
= BT_INTEGER
;
2703 ts
.kind
= gfc_c_int_kind
;
2704 gfc_convert_type (*expr
, &ts
, 2);
2707 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2709 if ((*expr
)->ref
== NULL
)
2711 se
->expr
= gfc_string_to_single_character
2712 (build_int_cst (integer_type_node
, 1),
2713 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2715 ((*expr
)->symtree
->n
.sym
)),
2720 gfc_conv_variable (se
, *expr
);
2721 se
->expr
= gfc_string_to_single_character
2722 (build_int_cst (integer_type_node
, 1),
2723 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2731 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2732 if STR is a string literal, otherwise return -1. */
2735 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2738 && TREE_CODE (str
) == ADDR_EXPR
2739 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2740 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2741 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2742 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2743 && tree_fits_uhwi_p (len
)
2744 && tree_to_uhwi (len
) >= 1
2745 && tree_to_uhwi (len
)
2746 == (unsigned HOST_WIDE_INT
)
2747 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2749 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2750 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2751 if (TREE_CODE (folded
) == INTEGER_CST
)
2753 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2754 int length
= TREE_STRING_LENGTH (string_cst
);
2755 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2757 for (; length
> 0; length
--)
2758 if (ptr
[length
- 1] != ' ')
2767 /* Helper to build a call to memcmp. */
2770 build_memcmp_call (tree s1
, tree s2
, tree n
)
2774 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2775 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2777 s1
= fold_convert (pvoid_type_node
, s1
);
2779 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2780 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2782 s2
= fold_convert (pvoid_type_node
, s2
);
2784 n
= fold_convert (size_type_node
, n
);
2786 tmp
= build_call_expr_loc (input_location
,
2787 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2790 return fold_convert (integer_type_node
, tmp
);
2793 /* Compare two strings. If they are all single characters, the result is the
2794 subtraction of them. Otherwise, we build a library call. */
2797 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2798 enum tree_code code
)
2804 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2805 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2807 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2808 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2810 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2812 /* Deal with single character specially. */
2813 sc1
= fold_convert (integer_type_node
, sc1
);
2814 sc2
= fold_convert (integer_type_node
, sc2
);
2815 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2819 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2821 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2823 /* If one string is a string literal with LEN_TRIM longer
2824 than the length of the second string, the strings
2826 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2827 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2828 return integer_one_node
;
2829 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2830 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2831 return integer_one_node
;
2834 /* We can compare via memcpy if the strings are known to be equal
2835 in length and they are
2837 - kind=4 and the comparison is for (in)equality. */
2839 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2840 && tree_int_cst_equal (len1
, len2
)
2841 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2846 chartype
= gfc_get_char_type (kind
);
2847 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2848 fold_convert (TREE_TYPE(len1
),
2849 TYPE_SIZE_UNIT(chartype
)),
2851 return build_memcmp_call (str1
, str2
, tmp
);
2854 /* Build a call for the comparison. */
2856 fndecl
= gfor_fndecl_compare_string
;
2858 fndecl
= gfor_fndecl_compare_string_char4
;
2862 return build_call_expr_loc (input_location
, fndecl
, 4,
2863 len1
, str1
, len2
, str2
);
2867 /* Return the backend_decl for a procedure pointer component. */
2870 get_proc_ptr_comp (gfc_expr
*e
)
2876 gfc_init_se (&comp_se
, NULL
);
2877 e2
= gfc_copy_expr (e
);
2878 /* We have to restore the expr type later so that gfc_free_expr frees
2879 the exact same thing that was allocated.
2880 TODO: This is ugly. */
2881 old_type
= e2
->expr_type
;
2882 e2
->expr_type
= EXPR_VARIABLE
;
2883 gfc_conv_expr (&comp_se
, e2
);
2884 e2
->expr_type
= old_type
;
2886 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2890 /* Convert a typebound function reference from a class object. */
2892 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2897 if (TREE_CODE (base_object
) != VAR_DECL
)
2899 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2900 gfc_add_modify (&se
->pre
, var
, base_object
);
2902 se
->expr
= gfc_class_vptr_get (base_object
);
2903 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2905 while (ref
&& ref
->next
)
2907 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2908 if (ref
->u
.c
.sym
->attr
.extension
)
2909 conv_parent_component_references (se
, ref
);
2910 gfc_conv_component_ref (se
, ref
);
2911 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2916 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2920 if (gfc_is_proc_ptr_comp (expr
))
2921 tmp
= get_proc_ptr_comp (expr
);
2922 else if (sym
->attr
.dummy
)
2924 tmp
= gfc_get_symbol_decl (sym
);
2925 if (sym
->attr
.proc_pointer
)
2926 tmp
= build_fold_indirect_ref_loc (input_location
,
2928 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2929 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2933 if (!sym
->backend_decl
)
2934 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2936 TREE_USED (sym
->backend_decl
) = 1;
2938 tmp
= sym
->backend_decl
;
2940 if (sym
->attr
.cray_pointee
)
2942 /* TODO - make the cray pointee a pointer to a procedure,
2943 assign the pointer to it and use it for the call. This
2945 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2946 gfc_get_symbol_decl (sym
->cp_pointer
));
2947 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2950 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2952 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2953 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2960 /* Initialize MAPPING. */
2963 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2965 mapping
->syms
= NULL
;
2966 mapping
->charlens
= NULL
;
2970 /* Free all memory held by MAPPING (but not MAPPING itself). */
2973 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2975 gfc_interface_sym_mapping
*sym
;
2976 gfc_interface_sym_mapping
*nextsym
;
2978 gfc_charlen
*nextcl
;
2980 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2982 nextsym
= sym
->next
;
2983 sym
->new_sym
->n
.sym
->formal
= NULL
;
2984 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2985 gfc_free_expr (sym
->expr
);
2986 free (sym
->new_sym
);
2989 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2992 gfc_free_expr (cl
->length
);
2998 /* Return a copy of gfc_charlen CL. Add the returned structure to
2999 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3001 static gfc_charlen
*
3002 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3005 gfc_charlen
*new_charlen
;
3007 new_charlen
= gfc_get_charlen ();
3008 new_charlen
->next
= mapping
->charlens
;
3009 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3011 mapping
->charlens
= new_charlen
;
3016 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3017 array variable that can be used as the actual argument for dummy
3018 argument SYM. Add any initialization code to BLOCK. PACKED is as
3019 for gfc_get_nodesc_array_type and DATA points to the first element
3020 in the passed array. */
3023 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3024 gfc_packed packed
, tree data
)
3029 type
= gfc_typenode_for_spec (&sym
->ts
);
3030 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3031 !sym
->attr
.target
&& !sym
->attr
.pointer
3032 && !sym
->attr
.proc_pointer
);
3034 var
= gfc_create_var (type
, "ifm");
3035 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3041 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3042 and offset of descriptorless array type TYPE given that it has the same
3043 size as DESC. Add any set-up code to BLOCK. */
3046 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3053 offset
= gfc_index_zero_node
;
3054 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3056 dim
= gfc_rank_cst
[n
];
3057 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3058 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3060 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3061 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3062 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3063 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3065 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3067 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3068 gfc_array_index_type
,
3069 gfc_conv_descriptor_ubound_get (desc
, dim
),
3070 gfc_conv_descriptor_lbound_get (desc
, dim
));
3071 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3072 gfc_array_index_type
,
3073 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3074 tmp
= gfc_evaluate_now (tmp
, block
);
3075 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3077 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3078 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3079 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3080 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3081 gfc_array_index_type
, offset
, tmp
);
3083 offset
= gfc_evaluate_now (offset
, block
);
3084 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3088 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3089 in SE. The caller may still use se->expr and se->string_length after
3090 calling this function. */
3093 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3094 gfc_symbol
* sym
, gfc_se
* se
,
3097 gfc_interface_sym_mapping
*sm
;
3101 gfc_symbol
*new_sym
;
3103 gfc_symtree
*new_symtree
;
3105 /* Create a new symbol to represent the actual argument. */
3106 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3107 new_sym
->ts
= sym
->ts
;
3108 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3109 new_sym
->attr
.referenced
= 1;
3110 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3111 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3112 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3113 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3114 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3115 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3116 new_sym
->attr
.function
= sym
->attr
.function
;
3118 /* Ensure that the interface is available and that
3119 descriptors are passed for array actual arguments. */
3120 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3122 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3123 new_sym
->attr
.always_explicit
3124 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3127 /* Create a fake symtree for it. */
3129 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3130 new_symtree
->n
.sym
= new_sym
;
3131 gcc_assert (new_symtree
== root
);
3133 /* Create a dummy->actual mapping. */
3134 sm
= XCNEW (gfc_interface_sym_mapping
);
3135 sm
->next
= mapping
->syms
;
3137 sm
->new_sym
= new_symtree
;
3138 sm
->expr
= gfc_copy_expr (expr
);
3141 /* Stabilize the argument's value. */
3142 if (!sym
->attr
.function
&& se
)
3143 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3145 if (sym
->ts
.type
== BT_CHARACTER
)
3147 /* Create a copy of the dummy argument's length. */
3148 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3149 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3151 /* If the length is specified as "*", record the length that
3152 the caller is passing. We should use the callee's length
3153 in all other cases. */
3154 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3156 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3157 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3164 /* Use the passed value as-is if the argument is a function. */
3165 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3168 /* If the argument is either a string or a pointer to a string,
3169 convert it to a boundless character type. */
3170 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3172 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3173 tmp
= build_pointer_type (tmp
);
3174 if (sym
->attr
.pointer
)
3175 value
= build_fold_indirect_ref_loc (input_location
,
3179 value
= fold_convert (tmp
, value
);
3182 /* If the argument is a scalar, a pointer to an array or an allocatable,
3184 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3185 value
= build_fold_indirect_ref_loc (input_location
,
3188 /* For character(*), use the actual argument's descriptor. */
3189 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3190 value
= build_fold_indirect_ref_loc (input_location
,
3193 /* If the argument is an array descriptor, use it to determine
3194 information about the actual argument's shape. */
3195 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3196 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3198 /* Get the actual argument's descriptor. */
3199 desc
= build_fold_indirect_ref_loc (input_location
,
3202 /* Create the replacement variable. */
3203 tmp
= gfc_conv_descriptor_data_get (desc
);
3204 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3207 /* Use DESC to work out the upper bounds, strides and offset. */
3208 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3211 /* Otherwise we have a packed array. */
3212 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3213 PACKED_FULL
, se
->expr
);
3215 new_sym
->backend_decl
= value
;
3219 /* Called once all dummy argument mappings have been added to MAPPING,
3220 but before the mapping is used to evaluate expressions. Pre-evaluate
3221 the length of each argument, adding any initialization code to PRE and
3222 any finalization code to POST. */
3225 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3226 stmtblock_t
* pre
, stmtblock_t
* post
)
3228 gfc_interface_sym_mapping
*sym
;
3232 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3233 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3234 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3236 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3237 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3238 gfc_init_se (&se
, NULL
);
3239 gfc_conv_expr (&se
, expr
);
3240 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3241 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3242 gfc_add_block_to_block (pre
, &se
.pre
);
3243 gfc_add_block_to_block (post
, &se
.post
);
3245 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3250 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3254 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3255 gfc_constructor_base base
)
3258 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3260 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3263 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3264 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3265 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3271 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3275 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3280 for (; ref
; ref
= ref
->next
)
3284 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3286 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3287 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3288 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3296 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3297 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3303 /* Convert intrinsic function calls into result expressions. */
3306 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3314 arg1
= expr
->value
.function
.actual
->expr
;
3315 if (expr
->value
.function
.actual
->next
)
3316 arg2
= expr
->value
.function
.actual
->next
->expr
;
3320 sym
= arg1
->symtree
->n
.sym
;
3322 if (sym
->attr
.dummy
)
3327 switch (expr
->value
.function
.isym
->id
)
3330 /* TODO figure out why this condition is necessary. */
3331 if (sym
->attr
.function
3332 && (arg1
->ts
.u
.cl
->length
== NULL
3333 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3334 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3337 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3341 if (!sym
->as
|| sym
->as
->rank
== 0)
3344 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3346 dup
= mpz_get_si (arg2
->value
.integer
);
3351 dup
= sym
->as
->rank
;
3355 for (; d
< dup
; d
++)
3359 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3361 gfc_free_expr (new_expr
);
3365 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3366 gfc_get_int_expr (gfc_default_integer_kind
,
3368 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3370 new_expr
= gfc_multiply (new_expr
, tmp
);
3376 case GFC_ISYM_LBOUND
:
3377 case GFC_ISYM_UBOUND
:
3378 /* TODO These implementations of lbound and ubound do not limit if
3379 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3381 if (!sym
->as
|| sym
->as
->rank
== 0)
3384 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3385 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3387 /* TODO: If the need arises, this could produce an array of
3391 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3393 if (sym
->as
->lower
[d
])
3394 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3398 if (sym
->as
->upper
[d
])
3399 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3407 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3411 gfc_replace_expr (expr
, new_expr
);
3417 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3418 gfc_interface_mapping
* mapping
)
3420 gfc_formal_arglist
*f
;
3421 gfc_actual_arglist
*actual
;
3423 actual
= expr
->value
.function
.actual
;
3424 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3426 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3431 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3434 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3439 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3441 for (d
= 0; d
< as
->rank
; d
++)
3443 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3444 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3447 expr
->value
.function
.esym
->as
= as
;
3450 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3452 expr
->value
.function
.esym
->ts
.u
.cl
->length
3453 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3455 gfc_apply_interface_mapping_to_expr (mapping
,
3456 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3461 /* EXPR is a copy of an expression that appeared in the interface
3462 associated with MAPPING. Walk it recursively looking for references to
3463 dummy arguments that MAPPING maps to actual arguments. Replace each such
3464 reference with a reference to the associated actual argument. */
3467 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3470 gfc_interface_sym_mapping
*sym
;
3471 gfc_actual_arglist
*actual
;
3476 /* Copying an expression does not copy its length, so do that here. */
3477 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3479 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3480 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3483 /* Apply the mapping to any references. */
3484 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3486 /* ...and to the expression's symbol, if it has one. */
3487 /* TODO Find out why the condition on expr->symtree had to be moved into
3488 the loop rather than being outside it, as originally. */
3489 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3490 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3492 if (sym
->new_sym
->n
.sym
->backend_decl
)
3493 expr
->symtree
= sym
->new_sym
;
3495 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3496 /* Replace base type for polymorphic arguments. */
3497 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3498 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3499 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3502 /* ...and to subexpressions in expr->value. */
3503 switch (expr
->expr_type
)
3508 case EXPR_SUBSTRING
:
3512 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3513 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3517 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3518 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3520 if (expr
->value
.function
.esym
== NULL
3521 && expr
->value
.function
.isym
!= NULL
3522 && expr
->value
.function
.actual
->expr
->symtree
3523 && gfc_map_intrinsic_function (expr
, mapping
))
3526 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3527 if (sym
->old
== expr
->value
.function
.esym
)
3529 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3530 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3531 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3536 case EXPR_STRUCTURE
:
3537 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3550 /* Evaluate interface expression EXPR using MAPPING. Store the result
3554 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3555 gfc_se
* se
, gfc_expr
* expr
)
3557 expr
= gfc_copy_expr (expr
);
3558 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3559 gfc_conv_expr (se
, expr
);
3560 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3561 gfc_free_expr (expr
);
3565 /* Returns a reference to a temporary array into which a component of
3566 an actual argument derived type array is copied and then returned
3567 after the function call. */
3569 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3570 sym_intent intent
, bool formal_ptr
)
3578 gfc_array_info
*info
;
3588 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3590 gfc_init_se (&lse
, NULL
);
3591 gfc_init_se (&rse
, NULL
);
3593 /* Walk the argument expression. */
3594 rss
= gfc_walk_expr (expr
);
3596 gcc_assert (rss
!= gfc_ss_terminator
);
3598 /* Initialize the scalarizer. */
3599 gfc_init_loopinfo (&loop
);
3600 gfc_add_ss_to_loop (&loop
, rss
);
3602 /* Calculate the bounds of the scalarization. */
3603 gfc_conv_ss_startstride (&loop
);
3605 /* Build an ss for the temporary. */
3606 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3607 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3609 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3610 if (GFC_ARRAY_TYPE_P (base_type
)
3611 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3612 base_type
= gfc_get_element_type (base_type
);
3614 if (expr
->ts
.type
== BT_CLASS
)
3615 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3617 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3618 ? expr
->ts
.u
.cl
->backend_decl
3622 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3624 /* Associate the SS with the loop. */
3625 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3627 /* Setup the scalarizing loops. */
3628 gfc_conv_loop_setup (&loop
, &expr
->where
);
3630 /* Pass the temporary descriptor back to the caller. */
3631 info
= &loop
.temp_ss
->info
->data
.array
;
3632 parmse
->expr
= info
->descriptor
;
3634 /* Setup the gfc_se structures. */
3635 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3636 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3639 lse
.ss
= loop
.temp_ss
;
3640 gfc_mark_ss_chain_used (rss
, 1);
3641 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3643 /* Start the scalarized loop body. */
3644 gfc_start_scalarized_body (&loop
, &body
);
3646 /* Translate the expression. */
3647 gfc_conv_expr (&rse
, expr
);
3649 gfc_conv_tmp_array_ref (&lse
);
3651 if (intent
!= INTENT_OUT
)
3653 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3654 gfc_add_expr_to_block (&body
, tmp
);
3655 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3656 gfc_trans_scalarizing_loops (&loop
, &body
);
3660 /* Make sure that the temporary declaration survives by merging
3661 all the loop declarations into the current context. */
3662 for (n
= 0; n
< loop
.dimen
; n
++)
3664 gfc_merge_block_scope (&body
);
3665 body
= loop
.code
[loop
.order
[n
]];
3667 gfc_merge_block_scope (&body
);
3670 /* Add the post block after the second loop, so that any
3671 freeing of allocated memory is done at the right time. */
3672 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3674 /**********Copy the temporary back again.*********/
3676 gfc_init_se (&lse
, NULL
);
3677 gfc_init_se (&rse
, NULL
);
3679 /* Walk the argument expression. */
3680 lss
= gfc_walk_expr (expr
);
3681 rse
.ss
= loop
.temp_ss
;
3684 /* Initialize the scalarizer. */
3685 gfc_init_loopinfo (&loop2
);
3686 gfc_add_ss_to_loop (&loop2
, lss
);
3688 /* Calculate the bounds of the scalarization. */
3689 gfc_conv_ss_startstride (&loop2
);
3691 /* Setup the scalarizing loops. */
3692 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3694 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3695 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3697 gfc_mark_ss_chain_used (lss
, 1);
3698 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3700 /* Declare the variable to hold the temporary offset and start the
3701 scalarized loop body. */
3702 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3703 gfc_start_scalarized_body (&loop2
, &body
);
3705 /* Build the offsets for the temporary from the loop variables. The
3706 temporary array has lbounds of zero and strides of one in all
3707 dimensions, so this is very simple. The offset is only computed
3708 outside the innermost loop, so the overall transfer could be
3709 optimized further. */
3710 info
= &rse
.ss
->info
->data
.array
;
3711 dimen
= rse
.ss
->dimen
;
3713 tmp_index
= gfc_index_zero_node
;
3714 for (n
= dimen
- 1; n
> 0; n
--)
3717 tmp
= rse
.loop
->loopvar
[n
];
3718 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3719 tmp
, rse
.loop
->from
[n
]);
3720 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3723 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3724 gfc_array_index_type
,
3725 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3726 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3727 gfc_array_index_type
,
3728 tmp_str
, gfc_index_one_node
);
3730 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3731 gfc_array_index_type
, tmp
, tmp_str
);
3734 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3735 gfc_array_index_type
,
3736 tmp_index
, rse
.loop
->from
[0]);
3737 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3739 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3740 gfc_array_index_type
,
3741 rse
.loop
->loopvar
[0], offset
);
3743 /* Now use the offset for the reference. */
3744 tmp
= build_fold_indirect_ref_loc (input_location
,
3746 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3748 if (expr
->ts
.type
== BT_CHARACTER
)
3749 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3751 gfc_conv_expr (&lse
, expr
);
3753 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3755 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3756 gfc_add_expr_to_block (&body
, tmp
);
3758 /* Generate the copying loops. */
3759 gfc_trans_scalarizing_loops (&loop2
, &body
);
3761 /* Wrap the whole thing up by adding the second loop to the post-block
3762 and following it by the post-block of the first loop. In this way,
3763 if the temporary needs freeing, it is done after use! */
3764 if (intent
!= INTENT_IN
)
3766 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3767 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3770 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3772 gfc_cleanup_loop (&loop
);
3773 gfc_cleanup_loop (&loop2
);
3775 /* Pass the string length to the argument expression. */
3776 if (expr
->ts
.type
== BT_CHARACTER
)
3777 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3779 /* Determine the offset for pointer formal arguments and set the
3783 size
= gfc_index_one_node
;
3784 offset
= gfc_index_zero_node
;
3785 for (n
= 0; n
< dimen
; n
++)
3787 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3789 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3790 gfc_array_index_type
, tmp
,
3791 gfc_index_one_node
);
3792 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3796 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3799 gfc_index_one_node
);
3800 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3801 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3802 gfc_array_index_type
,
3804 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3805 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3806 gfc_array_index_type
,
3807 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3808 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3809 gfc_array_index_type
,
3810 tmp
, gfc_index_one_node
);
3811 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3812 gfc_array_index_type
, size
, tmp
);
3815 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3819 /* We want either the address for the data or the address of the descriptor,
3820 depending on the mode of passing array arguments. */
3822 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3824 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3830 /* Generate the code for argument list functions. */
3833 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3835 /* Pass by value for g77 %VAL(arg), pass the address
3836 indirectly for %LOC, else by reference. Thus %REF
3837 is a "do-nothing" and %LOC is the same as an F95
3839 if (strncmp (name
, "%VAL", 4) == 0)
3840 gfc_conv_expr (se
, expr
);
3841 else if (strncmp (name
, "%LOC", 4) == 0)
3843 gfc_conv_expr_reference (se
, expr
);
3844 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3846 else if (strncmp (name
, "%REF", 4) == 0)
3847 gfc_conv_expr_reference (se
, expr
);
3849 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3853 /* Generate code for a procedure call. Note can return se->post != NULL.
3854 If se->direct_byref is set then se->expr contains the return parameter.
3855 Return nonzero, if the call has alternate specifiers.
3856 'expr' is only needed for procedure pointer components. */
3859 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3860 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3861 vec
<tree
, va_gc
> *append_args
)
3863 gfc_interface_mapping mapping
;
3864 vec
<tree
, va_gc
> *arglist
;
3865 vec
<tree
, va_gc
> *retargs
;
3869 gfc_array_info
*info
;
3876 vec
<tree
, va_gc
> *stringargs
;
3877 vec
<tree
, va_gc
> *optionalargs
;
3879 gfc_formal_arglist
*formal
;
3880 gfc_actual_arglist
*arg
;
3881 int has_alternate_specifier
= 0;
3882 bool need_interface_mapping
;
3889 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3890 gfc_component
*comp
= NULL
;
3896 optionalargs
= NULL
;
3901 comp
= gfc_get_proc_ptr_comp (expr
);
3905 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3907 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3908 if (se
->ss
->info
->useflags
)
3910 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3911 && sym
->result
->attr
.dimension
)
3912 || (comp
&& comp
->attr
.dimension
));
3913 gcc_assert (se
->loop
!= NULL
);
3915 /* Access the previously obtained result. */
3916 gfc_conv_tmp_array_ref (se
);
3920 info
= &se
->ss
->info
->data
.array
;
3925 gfc_init_block (&post
);
3926 gfc_init_interface_mapping (&mapping
);
3929 formal
= gfc_sym_get_dummy_args (sym
);
3930 need_interface_mapping
= sym
->attr
.dimension
||
3931 (sym
->ts
.type
== BT_CHARACTER
3932 && sym
->ts
.u
.cl
->length
3933 && sym
->ts
.u
.cl
->length
->expr_type
3938 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3939 need_interface_mapping
= comp
->attr
.dimension
||
3940 (comp
->ts
.type
== BT_CHARACTER
3941 && comp
->ts
.u
.cl
->length
3942 && comp
->ts
.u
.cl
->length
->expr_type
3946 base_object
= NULL_TREE
;
3948 /* Evaluate the arguments. */
3949 for (arg
= args
; arg
!= NULL
;
3950 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3953 fsym
= formal
? formal
->sym
: NULL
;
3954 parm_kind
= MISSING
;
3956 /* Class array expressions are sometimes coming completely unadorned
3957 with either arrayspec or _data component. Correct that here.
3958 OOP-TODO: Move this to the frontend. */
3959 if (e
&& e
->expr_type
== EXPR_VARIABLE
3961 && e
->ts
.type
== BT_CLASS
3962 && (CLASS_DATA (e
)->attr
.codimension
3963 || CLASS_DATA (e
)->attr
.dimension
))
3965 gfc_typespec temp_ts
= e
->ts
;
3966 gfc_add_class_array_ref (e
);
3972 if (se
->ignore_optional
)
3974 /* Some intrinsics have already been resolved to the correct
3978 else if (arg
->label
)
3980 has_alternate_specifier
= 1;
3985 gfc_init_se (&parmse
, NULL
);
3987 /* For scalar arguments with VALUE attribute which are passed by
3988 value, pass "0" and a hidden argument gives the optional
3990 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
3991 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
3992 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
3994 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
3996 vec_safe_push (optionalargs
, boolean_false_node
);
4000 /* Pass a NULL pointer for an absent arg. */
4001 parmse
.expr
= null_pointer_node
;
4002 if (arg
->missing_arg_type
== BT_CHARACTER
)
4003 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4008 else if (arg
->expr
->expr_type
== EXPR_NULL
4009 && fsym
&& !fsym
->attr
.pointer
4010 && (fsym
->ts
.type
!= BT_CLASS
4011 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4013 /* Pass a NULL pointer to denote an absent arg. */
4014 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4015 && (fsym
->ts
.type
!= BT_CLASS
4016 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4017 gfc_init_se (&parmse
, NULL
);
4018 parmse
.expr
= null_pointer_node
;
4019 if (arg
->missing_arg_type
== BT_CHARACTER
)
4020 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4022 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4023 && e
->ts
.type
== BT_DERIVED
)
4025 /* The derived type needs to be converted to a temporary
4027 gfc_init_se (&parmse
, se
);
4028 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4030 && e
->expr_type
== EXPR_VARIABLE
4031 && e
->symtree
->n
.sym
->attr
.optional
,
4032 CLASS_DATA (fsym
)->attr
.class_pointer
4033 || CLASS_DATA (fsym
)->attr
.allocatable
);
4035 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4037 /* The intrinsic type needs to be converted to a temporary
4038 CLASS object for the unlimited polymorphic formal. */
4039 gfc_init_se (&parmse
, se
);
4040 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4042 else if (se
->ss
&& se
->ss
->info
->useflags
)
4048 /* An elemental function inside a scalarized loop. */
4049 gfc_init_se (&parmse
, se
);
4050 parm_kind
= ELEMENTAL
;
4052 gfc_conv_expr_reference (&parmse
, e
);
4053 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4054 && e
->expr_type
== EXPR_FUNCTION
)
4055 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4058 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4059 && gfc_is_class_container_ref (e
))
4061 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4063 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4064 && e
->symtree
->n
.sym
->attr
.optional
)
4066 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4067 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4068 TREE_TYPE (parmse
.expr
),
4070 fold_convert (TREE_TYPE (parmse
.expr
),
4071 null_pointer_node
));
4075 /* If we are passing an absent array as optional dummy to an
4076 elemental procedure, make sure that we pass NULL when the data
4077 pointer is NULL. We need this extra conditional because of
4078 scalarization which passes arrays elements to the procedure,
4079 ignoring the fact that the array can be absent/unallocated/... */
4080 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4082 tree descriptor_data
;
4084 descriptor_data
= ss
->info
->data
.array
.data
;
4085 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4087 fold_convert (TREE_TYPE (descriptor_data
),
4088 null_pointer_node
));
4090 = fold_build3_loc (input_location
, COND_EXPR
,
4091 TREE_TYPE (parmse
.expr
),
4093 fold_convert (TREE_TYPE (parmse
.expr
),
4098 /* The scalarizer does not repackage the reference to a class
4099 array - instead it returns a pointer to the data element. */
4100 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4101 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4102 fsym
->attr
.intent
!= INTENT_IN
4103 && (CLASS_DATA (fsym
)->attr
.class_pointer
4104 || CLASS_DATA (fsym
)->attr
.allocatable
),
4106 && e
->expr_type
== EXPR_VARIABLE
4107 && e
->symtree
->n
.sym
->attr
.optional
,
4108 CLASS_DATA (fsym
)->attr
.class_pointer
4109 || CLASS_DATA (fsym
)->attr
.allocatable
);
4116 gfc_init_se (&parmse
, NULL
);
4118 /* Check whether the expression is a scalar or not; we cannot use
4119 e->rank as it can be nonzero for functions arguments. */
4120 argss
= gfc_walk_expr (e
);
4121 scalar
= argss
== gfc_ss_terminator
;
4123 gfc_free_ss_chain (argss
);
4125 /* Special handling for passing scalar polymorphic coarrays;
4126 otherwise one passes "class->_data.data" instead of "&class". */
4127 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4128 && fsym
&& fsym
->ts
.type
== BT_CLASS
4129 && CLASS_DATA (fsym
)->attr
.codimension
4130 && !CLASS_DATA (fsym
)->attr
.dimension
)
4132 gfc_add_class_array_ref (e
);
4133 parmse
.want_coarray
= 1;
4137 /* A scalar or transformational function. */
4140 if (e
->expr_type
== EXPR_VARIABLE
4141 && e
->symtree
->n
.sym
->attr
.cray_pointee
4142 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4144 /* The Cray pointer needs to be converted to a pointer to
4145 a type given by the expression. */
4146 gfc_conv_expr (&parmse
, e
);
4147 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4148 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4149 parmse
.expr
= convert (type
, tmp
);
4151 else if (fsym
&& fsym
->attr
.value
)
4153 if (fsym
->ts
.type
== BT_CHARACTER
4154 && fsym
->ts
.is_c_interop
4155 && fsym
->ns
->proc_name
!= NULL
4156 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4159 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4160 if (parmse
.expr
== NULL
)
4161 gfc_conv_expr (&parmse
, e
);
4165 gfc_conv_expr (&parmse
, e
);
4166 if (fsym
->attr
.optional
4167 && fsym
->ts
.type
!= BT_CLASS
4168 && fsym
->ts
.type
!= BT_DERIVED
)
4170 if (e
->expr_type
!= EXPR_VARIABLE
4171 || !e
->symtree
->n
.sym
->attr
.optional
4173 vec_safe_push (optionalargs
, boolean_true_node
);
4176 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4177 if (!e
->symtree
->n
.sym
->attr
.value
)
4179 = fold_build3_loc (input_location
, COND_EXPR
,
4180 TREE_TYPE (parmse
.expr
),
4182 fold_convert (TREE_TYPE (parmse
.expr
),
4183 integer_zero_node
));
4185 vec_safe_push (optionalargs
, tmp
);
4190 else if (arg
->name
&& arg
->name
[0] == '%')
4191 /* Argument list functions %VAL, %LOC and %REF are signalled
4192 through arg->name. */
4193 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4194 else if ((e
->expr_type
== EXPR_FUNCTION
)
4195 && ((e
->value
.function
.esym
4196 && e
->value
.function
.esym
->result
->attr
.pointer
)
4197 || (!e
->value
.function
.esym
4198 && e
->symtree
->n
.sym
->attr
.pointer
))
4199 && fsym
&& fsym
->attr
.target
)
4201 gfc_conv_expr (&parmse
, e
);
4202 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4204 else if (e
->expr_type
== EXPR_FUNCTION
4205 && e
->symtree
->n
.sym
->result
4206 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4207 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4209 /* Functions returning procedure pointers. */
4210 gfc_conv_expr (&parmse
, e
);
4211 if (fsym
&& fsym
->attr
.proc_pointer
)
4212 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4216 if (e
->ts
.type
== BT_CLASS
&& fsym
4217 && fsym
->ts
.type
== BT_CLASS
4218 && (!CLASS_DATA (fsym
)->as
4219 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4220 && CLASS_DATA (e
)->attr
.codimension
)
4222 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4223 gcc_assert (!CLASS_DATA (fsym
)->as
);
4224 gfc_add_class_array_ref (e
);
4225 parmse
.want_coarray
= 1;
4226 gfc_conv_expr_reference (&parmse
, e
);
4227 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4229 && e
->expr_type
== EXPR_VARIABLE
);
4232 gfc_conv_expr_reference (&parmse
, e
);
4234 /* Catch base objects that are not variables. */
4235 if (e
->ts
.type
== BT_CLASS
4236 && e
->expr_type
!= EXPR_VARIABLE
4237 && expr
&& e
== expr
->base_expr
)
4238 base_object
= build_fold_indirect_ref_loc (input_location
,
4241 /* A class array element needs converting back to be a
4242 class object, if the formal argument is a class object. */
4243 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4244 && e
->ts
.type
== BT_CLASS
4245 && ((CLASS_DATA (fsym
)->as
4246 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4247 || CLASS_DATA (e
)->attr
.dimension
))
4248 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4249 fsym
->attr
.intent
!= INTENT_IN
4250 && (CLASS_DATA (fsym
)->attr
.class_pointer
4251 || CLASS_DATA (fsym
)->attr
.allocatable
),
4253 && e
->expr_type
== EXPR_VARIABLE
4254 && e
->symtree
->n
.sym
->attr
.optional
,
4255 CLASS_DATA (fsym
)->attr
.class_pointer
4256 || CLASS_DATA (fsym
)->attr
.allocatable
);
4258 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4259 allocated on entry, it must be deallocated. */
4260 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4261 && (fsym
->attr
.allocatable
4262 || (fsym
->ts
.type
== BT_CLASS
4263 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4268 gfc_init_block (&block
);
4270 if (e
->ts
.type
== BT_CLASS
)
4271 ptr
= gfc_class_data_get (ptr
);
4273 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4275 gfc_add_expr_to_block (&block
, tmp
);
4276 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4277 void_type_node
, ptr
,
4279 gfc_add_expr_to_block (&block
, tmp
);
4281 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4283 gfc_add_modify (&block
, ptr
,
4284 fold_convert (TREE_TYPE (ptr
),
4285 null_pointer_node
));
4286 gfc_add_expr_to_block (&block
, tmp
);
4288 else if (fsym
->ts
.type
== BT_CLASS
)
4291 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4292 tmp
= gfc_get_symbol_decl (vtab
);
4293 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4294 ptr
= gfc_class_vptr_get (parmse
.expr
);
4295 gfc_add_modify (&block
, ptr
,
4296 fold_convert (TREE_TYPE (ptr
), tmp
));
4297 gfc_add_expr_to_block (&block
, tmp
);
4300 if (fsym
->attr
.optional
4301 && e
->expr_type
== EXPR_VARIABLE
4302 && e
->symtree
->n
.sym
->attr
.optional
)
4304 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4306 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4307 gfc_finish_block (&block
),
4308 build_empty_stmt (input_location
));
4311 tmp
= gfc_finish_block (&block
);
4313 gfc_add_expr_to_block (&se
->pre
, tmp
);
4316 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4317 || fsym
->ts
.type
== BT_ASSUMED
)
4318 && e
->ts
.type
== BT_CLASS
4319 && !CLASS_DATA (e
)->attr
.dimension
4320 && !CLASS_DATA (e
)->attr
.codimension
)
4321 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4323 /* Wrap scalar variable in a descriptor. We need to convert
4324 the address of a pointer back to the pointer itself before,
4325 we can assign it to the data field. */
4327 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4328 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4331 if (TREE_CODE (tmp
) == ADDR_EXPR
4332 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4333 tmp
= TREE_OPERAND (tmp
, 0);
4334 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4336 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4339 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4340 && ((fsym
->attr
.pointer
4341 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4342 || (fsym
->attr
.proc_pointer
4343 && !(e
->expr_type
== EXPR_VARIABLE
4344 && e
->symtree
->n
.sym
->attr
.dummy
))
4345 || (fsym
->attr
.proc_pointer
4346 && e
->expr_type
== EXPR_VARIABLE
4347 && gfc_is_proc_ptr_comp (e
))
4348 || (fsym
->attr
.allocatable
4349 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4351 /* Scalar pointer dummy args require an extra level of
4352 indirection. The null pointer already contains
4353 this level of indirection. */
4354 parm_kind
= SCALAR_POINTER
;
4355 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4359 else if (e
->ts
.type
== BT_CLASS
4360 && fsym
&& fsym
->ts
.type
== BT_CLASS
4361 && (CLASS_DATA (fsym
)->attr
.dimension
4362 || CLASS_DATA (fsym
)->attr
.codimension
))
4364 /* Pass a class array. */
4365 gfc_conv_expr_descriptor (&parmse
, e
);
4367 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4368 allocated on entry, it must be deallocated. */
4369 if (fsym
->attr
.intent
== INTENT_OUT
4370 && CLASS_DATA (fsym
)->attr
.allocatable
)
4375 gfc_init_block (&block
);
4377 ptr
= gfc_class_data_get (ptr
);
4379 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4380 NULL_TREE
, NULL_TREE
,
4383 gfc_add_expr_to_block (&block
, tmp
);
4384 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4385 void_type_node
, ptr
,
4387 gfc_add_expr_to_block (&block
, tmp
);
4388 gfc_reset_vptr (&block
, e
);
4390 if (fsym
->attr
.optional
4391 && e
->expr_type
== EXPR_VARIABLE
4393 || (e
->ref
->type
== REF_ARRAY
4394 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4395 && e
->symtree
->n
.sym
->attr
.optional
)
4397 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4399 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4400 gfc_finish_block (&block
),
4401 build_empty_stmt (input_location
));
4404 tmp
= gfc_finish_block (&block
);
4406 gfc_add_expr_to_block (&se
->pre
, tmp
);
4409 /* The conversion does not repackage the reference to a class
4410 array - _data descriptor. */
4411 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4412 fsym
->attr
.intent
!= INTENT_IN
4413 && (CLASS_DATA (fsym
)->attr
.class_pointer
4414 || CLASS_DATA (fsym
)->attr
.allocatable
),
4416 && e
->expr_type
== EXPR_VARIABLE
4417 && e
->symtree
->n
.sym
->attr
.optional
,
4418 CLASS_DATA (fsym
)->attr
.class_pointer
4419 || CLASS_DATA (fsym
)->attr
.allocatable
);
4423 /* If the procedure requires an explicit interface, the actual
4424 argument is passed according to the corresponding formal
4425 argument. If the corresponding formal argument is a POINTER,
4426 ALLOCATABLE or assumed shape, we do not use g77's calling
4427 convention, and pass the address of the array descriptor
4428 instead. Otherwise we use g77's calling convention. */
4431 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4432 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4433 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4435 f
= f
|| !comp
->attr
.always_explicit
;
4437 f
= f
|| !sym
->attr
.always_explicit
;
4439 /* If the argument is a function call that may not create
4440 a temporary for the result, we have to check that we
4441 can do it, i.e. that there is no alias between this
4442 argument and another one. */
4443 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4449 intent
= fsym
->attr
.intent
;
4451 intent
= INTENT_UNKNOWN
;
4453 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4455 parmse
.force_tmp
= 1;
4457 iarg
= e
->value
.function
.actual
->expr
;
4459 /* Temporary needed if aliasing due to host association. */
4460 if (sym
->attr
.contained
4462 && !sym
->attr
.implicit_pure
4463 && !sym
->attr
.use_assoc
4464 && iarg
->expr_type
== EXPR_VARIABLE
4465 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4466 parmse
.force_tmp
= 1;
4468 /* Ditto within module. */
4469 if (sym
->attr
.use_assoc
4471 && !sym
->attr
.implicit_pure
4472 && iarg
->expr_type
== EXPR_VARIABLE
4473 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4474 parmse
.force_tmp
= 1;
4477 if (e
->expr_type
== EXPR_VARIABLE
4478 && is_subref_array (e
))
4479 /* The actual argument is a component reference to an
4480 array of derived types. In this case, the argument
4481 is converted to a temporary, which is passed and then
4482 written back after the procedure call. */
4483 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4484 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4485 fsym
&& fsym
->attr
.pointer
);
4486 else if (gfc_is_class_array_ref (e
, NULL
)
4487 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4488 /* The actual argument is a component reference to an
4489 array of derived types. In this case, the argument
4490 is converted to a temporary, which is passed and then
4491 written back after the procedure call.
4492 OOP-TODO: Insert code so that if the dynamic type is
4493 the same as the declared type, copy-in/copy-out does
4495 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4496 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4497 fsym
&& fsym
->attr
.pointer
);
4499 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4501 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4502 allocated on entry, it must be deallocated. */
4503 if (fsym
&& fsym
->attr
.allocatable
4504 && fsym
->attr
.intent
== INTENT_OUT
)
4506 tmp
= build_fold_indirect_ref_loc (input_location
,
4508 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4509 if (fsym
->attr
.optional
4510 && e
->expr_type
== EXPR_VARIABLE
4511 && e
->symtree
->n
.sym
->attr
.optional
)
4512 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4514 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4515 tmp
, build_empty_stmt (input_location
));
4516 gfc_add_expr_to_block (&se
->pre
, tmp
);
4521 /* The case with fsym->attr.optional is that of a user subroutine
4522 with an interface indicating an optional argument. When we call
4523 an intrinsic subroutine, however, fsym is NULL, but we might still
4524 have an optional argument, so we proceed to the substitution
4526 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4528 /* If an optional argument is itself an optional dummy argument,
4529 check its presence and substitute a null if absent. This is
4530 only needed when passing an array to an elemental procedure
4531 as then array elements are accessed - or no NULL pointer is
4532 allowed and a "1" or "0" should be passed if not present.
4533 When passing a non-array-descriptor full array to a
4534 non-array-descriptor dummy, no check is needed. For
4535 array-descriptor actual to array-descriptor dummy, see
4536 PR 41911 for why a check has to be inserted.
4537 fsym == NULL is checked as intrinsics required the descriptor
4538 but do not always set fsym. */
4539 if (e
->expr_type
== EXPR_VARIABLE
4540 && e
->symtree
->n
.sym
->attr
.optional
4541 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4542 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4546 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4547 || fsym
->as
->type
== AS_ASSUMED_RANK
4548 || fsym
->as
->type
== AS_DEFERRED
))))))
4549 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4550 e
->representation
.length
);
4555 /* Obtain the character length of an assumed character length
4556 length procedure from the typespec. */
4557 if (fsym
->ts
.type
== BT_CHARACTER
4558 && parmse
.string_length
== NULL_TREE
4559 && e
->ts
.type
== BT_PROCEDURE
4560 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4561 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4562 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4564 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4565 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4569 if (fsym
&& need_interface_mapping
&& e
)
4570 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4572 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4573 gfc_add_block_to_block (&post
, &parmse
.post
);
4575 /* Allocated allocatable components of derived types must be
4576 deallocated for non-variable scalars. Non-variable arrays are
4577 dealt with in trans-array.c(gfc_conv_array_parameter). */
4578 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4579 && e
->ts
.u
.derived
->attr
.alloc_comp
4580 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4581 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4584 tmp
= build_fold_indirect_ref_loc (input_location
,
4586 parm_rank
= e
->rank
;
4594 case (SCALAR_POINTER
):
4595 tmp
= build_fold_indirect_ref_loc (input_location
,
4600 if (e
->expr_type
== EXPR_OP
4601 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4602 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4605 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4606 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4607 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4610 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4612 /* The derived type is passed to gfc_deallocate_alloc_comp.
4613 Therefore, class actuals can handled correctly but derived
4614 types passed to class formals need the _data component. */
4615 tmp
= gfc_class_data_get (tmp
);
4616 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4617 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4620 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4622 gfc_add_expr_to_block (&se
->post
, tmp
);
4625 /* Add argument checking of passing an unallocated/NULL actual to
4626 a nonallocatable/nonpointer dummy. */
4628 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4630 symbol_attribute attr
;
4634 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4635 attr
= gfc_expr_attr (e
);
4637 goto end_pointer_check
;
4639 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4640 allocatable to an optional dummy, cf. 12.5.2.12. */
4641 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4642 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4643 goto end_pointer_check
;
4647 /* If the actual argument is an optional pointer/allocatable and
4648 the formal argument takes an nonpointer optional value,
4649 it is invalid to pass a non-present argument on, even
4650 though there is no technical reason for this in gfortran.
4651 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4652 tree present
, null_ptr
, type
;
4654 if (attr
.allocatable
4655 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4656 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4657 "allocated or not present", e
->symtree
->n
.sym
->name
);
4658 else if (attr
.pointer
4659 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4660 asprintf (&msg
, "Pointer actual argument '%s' is not "
4661 "associated or not present",
4662 e
->symtree
->n
.sym
->name
);
4663 else if (attr
.proc_pointer
4664 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4665 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4666 "associated or not present",
4667 e
->symtree
->n
.sym
->name
);
4669 goto end_pointer_check
;
4671 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4672 type
= TREE_TYPE (present
);
4673 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4674 boolean_type_node
, present
,
4676 null_pointer_node
));
4677 type
= TREE_TYPE (parmse
.expr
);
4678 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4679 boolean_type_node
, parmse
.expr
,
4681 null_pointer_node
));
4682 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4683 boolean_type_node
, present
, null_ptr
);
4687 if (attr
.allocatable
4688 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4689 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4690 "allocated", e
->symtree
->n
.sym
->name
);
4691 else if (attr
.pointer
4692 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4693 asprintf (&msg
, "Pointer actual argument '%s' is not "
4694 "associated", e
->symtree
->n
.sym
->name
);
4695 else if (attr
.proc_pointer
4696 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4697 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4698 "associated", e
->symtree
->n
.sym
->name
);
4700 goto end_pointer_check
;
4704 /* If the argument is passed by value, we need to strip the
4706 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4707 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4709 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4710 boolean_type_node
, tmp
,
4711 fold_convert (TREE_TYPE (tmp
),
4712 null_pointer_node
));
4715 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4721 /* Deferred length dummies pass the character length by reference
4722 so that the value can be returned. */
4723 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4725 tmp
= parmse
.string_length
;
4726 if (TREE_CODE (tmp
) != VAR_DECL
)
4727 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4728 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4731 /* Character strings are passed as two parameters, a length and a
4732 pointer - except for Bind(c) which only passes the pointer.
4733 An unlimited polymorphic formal argument likewise does not
4735 if (parmse
.string_length
!= NULL_TREE
4736 && !sym
->attr
.is_bind_c
4737 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4738 vec_safe_push (stringargs
, parmse
.string_length
);
4740 /* When calling __copy for character expressions to unlimited
4741 polymorphic entities, the dst argument needs a string length. */
4742 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4743 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4744 && arg
->next
&& arg
->next
->expr
4745 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4746 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4747 vec_safe_push (stringargs
, parmse
.string_length
);
4749 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4750 pass the token and the offset as additional arguments. */
4751 if (fsym
&& fsym
->attr
.codimension
4752 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4753 && !fsym
->attr
.allocatable
4756 /* Token and offset. */
4757 vec_safe_push (stringargs
, null_pointer_node
);
4758 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4759 gcc_assert (fsym
->attr
.optional
);
4761 else if (fsym
&& fsym
->attr
.codimension
4762 && !fsym
->attr
.allocatable
4763 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4765 tree caf_decl
, caf_type
;
4768 caf_decl
= get_tree_for_caf_expr (e
);
4769 caf_type
= TREE_TYPE (caf_decl
);
4771 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4772 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4773 tmp
= gfc_conv_descriptor_token (caf_decl
);
4774 else if (DECL_LANG_SPECIFIC (caf_decl
)
4775 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4776 tmp
= GFC_DECL_TOKEN (caf_decl
);
4779 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4780 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4781 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4784 vec_safe_push (stringargs
, tmp
);
4786 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4787 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4788 offset
= build_int_cst (gfc_array_index_type
, 0);
4789 else if (DECL_LANG_SPECIFIC (caf_decl
)
4790 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4791 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4792 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4793 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4795 offset
= build_int_cst (gfc_array_index_type
, 0);
4797 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4798 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4801 gcc_assert (POINTER_TYPE_P (caf_type
));
4805 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4806 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4807 && !fsym
->attr
.allocatable
))
4809 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4810 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4811 (TREE_TYPE (parmse
.expr
))));
4812 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4813 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4815 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4816 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4819 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4823 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4824 gfc_array_index_type
,
4825 fold_convert (gfc_array_index_type
, tmp2
),
4826 fold_convert (gfc_array_index_type
, tmp
));
4827 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4828 gfc_array_index_type
, offset
, tmp
);
4830 vec_safe_push (stringargs
, offset
);
4833 vec_safe_push (arglist
, parmse
.expr
);
4835 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4842 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4843 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4844 else if (ts
.type
== BT_CHARACTER
)
4846 if (ts
.u
.cl
->length
== NULL
)
4848 /* Assumed character length results are not allowed by 5.1.1.5 of the
4849 standard and are trapped in resolve.c; except in the case of SPREAD
4850 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4851 we take the character length of the first argument for the result.
4852 For dummies, we have to look through the formal argument list for
4853 this function and use the character length found there.*/
4855 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4856 else if (!sym
->attr
.dummy
)
4857 cl
.backend_decl
= (*stringargs
)[0];
4860 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4861 for (; formal
; formal
= formal
->next
)
4862 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4863 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4865 len
= cl
.backend_decl
;
4871 /* Calculate the length of the returned string. */
4872 gfc_init_se (&parmse
, NULL
);
4873 if (need_interface_mapping
)
4874 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4876 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4877 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4878 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4880 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4881 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4882 gfc_charlen_type_node
, tmp
,
4883 build_int_cst (gfc_charlen_type_node
, 0));
4884 cl
.backend_decl
= tmp
;
4887 /* Set up a charlen structure for it. */
4892 len
= cl
.backend_decl
;
4895 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4896 || (!comp
&& gfc_return_by_reference (sym
));
4899 if (se
->direct_byref
)
4901 /* Sometimes, too much indirection can be applied; e.g. for
4902 function_result = array_valued_recursive_function. */
4903 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4904 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4905 && GFC_DESCRIPTOR_TYPE_P
4906 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4907 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4910 /* If the lhs of an assignment x = f(..) is allocatable and
4911 f2003 is allowed, we must do the automatic reallocation.
4912 TODO - deal with intrinsics, without using a temporary. */
4913 if (gfc_option
.flag_realloc_lhs
4914 && se
->ss
&& se
->ss
->loop_chain
4915 && se
->ss
->loop_chain
->is_alloc_lhs
4916 && !expr
->value
.function
.isym
4917 && sym
->result
->as
!= NULL
)
4919 /* Evaluate the bounds of the result, if known. */
4920 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4923 /* Perform the automatic reallocation. */
4924 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4926 gfc_add_expr_to_block (&se
->pre
, tmp
);
4928 /* Pass the temporary as the first argument. */
4929 result
= info
->descriptor
;
4932 result
= build_fold_indirect_ref_loc (input_location
,
4934 vec_safe_push (retargs
, se
->expr
);
4936 else if (comp
&& comp
->attr
.dimension
)
4938 gcc_assert (se
->loop
&& info
);
4940 /* Set the type of the array. */
4941 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4942 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4944 /* Evaluate the bounds of the result, if known. */
4945 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4947 /* If the lhs of an assignment x = f(..) is allocatable and
4948 f2003 is allowed, we must not generate the function call
4949 here but should just send back the results of the mapping.
4950 This is signalled by the function ss being flagged. */
4951 if (gfc_option
.flag_realloc_lhs
4952 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4954 gfc_free_interface_mapping (&mapping
);
4955 return has_alternate_specifier
;
4958 /* Create a temporary to store the result. In case the function
4959 returns a pointer, the temporary will be a shallow copy and
4960 mustn't be deallocated. */
4961 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4962 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4963 tmp
, NULL_TREE
, false,
4964 !comp
->attr
.pointer
, callee_alloc
,
4965 &se
->ss
->info
->expr
->where
);
4967 /* Pass the temporary as the first argument. */
4968 result
= info
->descriptor
;
4969 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4970 vec_safe_push (retargs
, tmp
);
4972 else if (!comp
&& sym
->result
->attr
.dimension
)
4974 gcc_assert (se
->loop
&& info
);
4976 /* Set the type of the array. */
4977 tmp
= gfc_typenode_for_spec (&ts
);
4978 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4980 /* Evaluate the bounds of the result, if known. */
4981 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
4983 /* If the lhs of an assignment x = f(..) is allocatable and
4984 f2003 is allowed, we must not generate the function call
4985 here but should just send back the results of the mapping.
4986 This is signalled by the function ss being flagged. */
4987 if (gfc_option
.flag_realloc_lhs
4988 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4990 gfc_free_interface_mapping (&mapping
);
4991 return has_alternate_specifier
;
4994 /* Create a temporary to store the result. In case the function
4995 returns a pointer, the temporary will be a shallow copy and
4996 mustn't be deallocated. */
4997 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
4998 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4999 tmp
, NULL_TREE
, false,
5000 !sym
->attr
.pointer
, callee_alloc
,
5001 &se
->ss
->info
->expr
->where
);
5003 /* Pass the temporary as the first argument. */
5004 result
= info
->descriptor
;
5005 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5006 vec_safe_push (retargs
, tmp
);
5008 else if (ts
.type
== BT_CHARACTER
)
5010 /* Pass the string length. */
5011 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5012 type
= build_pointer_type (type
);
5014 /* Return an address to a char[0:len-1]* temporary for
5015 character pointers. */
5016 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5017 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5019 var
= gfc_create_var (type
, "pstr");
5021 if ((!comp
&& sym
->attr
.allocatable
)
5022 || (comp
&& comp
->attr
.allocatable
))
5024 gfc_add_modify (&se
->pre
, var
,
5025 fold_convert (TREE_TYPE (var
),
5026 null_pointer_node
));
5027 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5028 gfc_add_expr_to_block (&se
->post
, tmp
);
5031 /* Provide an address expression for the function arguments. */
5032 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5035 var
= gfc_conv_string_tmp (se
, type
, len
);
5037 vec_safe_push (retargs
, var
);
5041 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5043 type
= gfc_get_complex_type (ts
.kind
);
5044 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5045 vec_safe_push (retargs
, var
);
5048 /* Add the string length to the argument list. */
5049 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5052 if (TREE_CODE (tmp
) != VAR_DECL
)
5053 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5054 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5055 vec_safe_push (retargs
, tmp
);
5057 else if (ts
.type
== BT_CHARACTER
)
5058 vec_safe_push (retargs
, len
);
5060 gfc_free_interface_mapping (&mapping
);
5062 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5063 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5064 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5065 vec_safe_reserve (retargs
, arglen
);
5067 /* Add the return arguments. */
5068 retargs
->splice (arglist
);
5070 /* Add the hidden present status for optional+value to the arguments. */
5071 retargs
->splice (optionalargs
);
5073 /* Add the hidden string length parameters to the arguments. */
5074 retargs
->splice (stringargs
);
5076 /* We may want to append extra arguments here. This is used e.g. for
5077 calls to libgfortran_matmul_??, which need extra information. */
5078 if (!vec_safe_is_empty (append_args
))
5079 retargs
->splice (append_args
);
5082 /* Generate the actual call. */
5083 if (base_object
== NULL_TREE
)
5084 conv_function_val (se
, sym
, expr
);
5086 conv_base_obj_fcn_val (se
, base_object
, expr
);
5088 /* If there are alternate return labels, function type should be
5089 integer. Can't modify the type in place though, since it can be shared
5090 with other functions. For dummy arguments, the typing is done to
5091 this result, even if it has to be repeated for each call. */
5092 if (has_alternate_specifier
5093 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5095 if (!sym
->attr
.dummy
)
5097 TREE_TYPE (sym
->backend_decl
)
5098 = build_function_type (integer_type_node
,
5099 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5100 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5103 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5106 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5107 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5109 /* If we have a pointer function, but we don't want a pointer, e.g.
5112 where f is pointer valued, we have to dereference the result. */
5113 if (!se
->want_pointer
&& !byref
5114 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5115 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5116 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5118 /* f2c calling conventions require a scalar default real function to
5119 return a double precision result. Convert this back to default
5120 real. We only care about the cases that can happen in Fortran 77.
5122 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5123 && sym
->ts
.kind
== gfc_default_real_kind
5124 && !sym
->attr
.always_explicit
)
5125 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5127 /* A pure function may still have side-effects - it may modify its
5129 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5131 if (!sym
->attr
.pure
)
5132 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5137 /* Add the function call to the pre chain. There is no expression. */
5138 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5139 se
->expr
= NULL_TREE
;
5141 if (!se
->direct_byref
)
5143 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5145 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5147 /* Check the data pointer hasn't been modified. This would
5148 happen in a function returning a pointer. */
5149 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5150 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5153 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5156 se
->expr
= info
->descriptor
;
5157 /* Bundle in the string length. */
5158 se
->string_length
= len
;
5160 else if (ts
.type
== BT_CHARACTER
)
5162 /* Dereference for character pointer results. */
5163 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5164 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5165 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5169 se
->string_length
= len
;
5173 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5174 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5179 /* Follow the function call with the argument post block. */
5182 gfc_add_block_to_block (&se
->pre
, &post
);
5184 /* Transformational functions of derived types with allocatable
5185 components must have the result allocatable components copied. */
5186 arg
= expr
->value
.function
.actual
;
5187 if (result
&& arg
&& expr
->rank
5188 && expr
->value
.function
.isym
5189 && expr
->value
.function
.isym
->transformational
5190 && arg
->expr
->ts
.type
== BT_DERIVED
5191 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5194 /* Copy the allocatable components. We have to use a
5195 temporary here to prevent source allocatable components
5196 from being corrupted. */
5197 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5198 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5199 result
, tmp2
, expr
->rank
);
5200 gfc_add_expr_to_block (&se
->pre
, tmp
);
5201 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5203 gfc_add_expr_to_block (&se
->pre
, tmp
);
5205 /* Finally free the temporary's data field. */
5206 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5207 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5208 NULL_TREE
, NULL_TREE
, true,
5210 gfc_add_expr_to_block (&se
->pre
, tmp
);
5214 gfc_add_block_to_block (&se
->post
, &post
);
5216 return has_alternate_specifier
;
5220 /* Fill a character string with spaces. */
5223 fill_with_spaces (tree start
, tree type
, tree size
)
5225 stmtblock_t block
, loop
;
5226 tree i
, el
, exit_label
, cond
, tmp
;
5228 /* For a simple char type, we can call memset(). */
5229 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5230 return build_call_expr_loc (input_location
,
5231 builtin_decl_explicit (BUILT_IN_MEMSET
),
5233 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5234 lang_hooks
.to_target_charset (' ')),
5237 /* Otherwise, we use a loop:
5238 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5242 /* Initialize variables. */
5243 gfc_init_block (&block
);
5244 i
= gfc_create_var (sizetype
, "i");
5245 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5246 el
= gfc_create_var (build_pointer_type (type
), "el");
5247 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5248 exit_label
= gfc_build_label_decl (NULL_TREE
);
5249 TREE_USED (exit_label
) = 1;
5253 gfc_init_block (&loop
);
5255 /* Exit condition. */
5256 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5257 build_zero_cst (sizetype
));
5258 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5259 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5260 build_empty_stmt (input_location
));
5261 gfc_add_expr_to_block (&loop
, tmp
);
5264 gfc_add_modify (&loop
,
5265 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5266 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5268 /* Increment loop variables. */
5269 gfc_add_modify (&loop
, i
,
5270 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5271 TYPE_SIZE_UNIT (type
)));
5272 gfc_add_modify (&loop
, el
,
5273 fold_build_pointer_plus_loc (input_location
,
5274 el
, TYPE_SIZE_UNIT (type
)));
5276 /* Making the loop... actually loop! */
5277 tmp
= gfc_finish_block (&loop
);
5278 tmp
= build1_v (LOOP_EXPR
, tmp
);
5279 gfc_add_expr_to_block (&block
, tmp
);
5281 /* The exit label. */
5282 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5283 gfc_add_expr_to_block (&block
, tmp
);
5286 return gfc_finish_block (&block
);
5290 /* Generate code to copy a string. */
5293 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5294 int dkind
, tree slength
, tree src
, int skind
)
5296 tree tmp
, dlen
, slen
;
5305 stmtblock_t tempblock
;
5307 gcc_assert (dkind
== skind
);
5309 if (slength
!= NULL_TREE
)
5311 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5312 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5316 slen
= build_int_cst (size_type_node
, 1);
5320 if (dlength
!= NULL_TREE
)
5322 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5323 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5327 dlen
= build_int_cst (size_type_node
, 1);
5331 /* Assign directly if the types are compatible. */
5332 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5333 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5335 gfc_add_modify (block
, dsc
, ssc
);
5339 /* Do nothing if the destination length is zero. */
5340 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5341 build_int_cst (size_type_node
, 0));
5343 /* The following code was previously in _gfortran_copy_string:
5345 // The two strings may overlap so we use memmove.
5347 copy_string (GFC_INTEGER_4 destlen, char * dest,
5348 GFC_INTEGER_4 srclen, const char * src)
5350 if (srclen >= destlen)
5352 // This will truncate if too long.
5353 memmove (dest, src, destlen);
5357 memmove (dest, src, srclen);
5359 memset (&dest[srclen], ' ', destlen - srclen);
5363 We're now doing it here for better optimization, but the logic
5366 /* For non-default character kinds, we have to multiply the string
5367 length by the base type size. */
5368 chartype
= gfc_get_char_type (dkind
);
5369 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5370 fold_convert (size_type_node
, slen
),
5371 fold_convert (size_type_node
,
5372 TYPE_SIZE_UNIT (chartype
)));
5373 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5374 fold_convert (size_type_node
, dlen
),
5375 fold_convert (size_type_node
,
5376 TYPE_SIZE_UNIT (chartype
)));
5378 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5379 dest
= fold_convert (pvoid_type_node
, dest
);
5381 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5383 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5384 src
= fold_convert (pvoid_type_node
, src
);
5386 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5388 /* Truncate string if source is too long. */
5389 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5391 tmp2
= build_call_expr_loc (input_location
,
5392 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5393 3, dest
, src
, dlen
);
5395 /* Else copy and pad with spaces. */
5396 tmp3
= build_call_expr_loc (input_location
,
5397 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5398 3, dest
, src
, slen
);
5400 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5401 tmp4
= fill_with_spaces (tmp4
, chartype
,
5402 fold_build2_loc (input_location
, MINUS_EXPR
,
5403 TREE_TYPE(dlen
), dlen
, slen
));
5405 gfc_init_block (&tempblock
);
5406 gfc_add_expr_to_block (&tempblock
, tmp3
);
5407 gfc_add_expr_to_block (&tempblock
, tmp4
);
5408 tmp3
= gfc_finish_block (&tempblock
);
5410 /* The whole copy_string function is there. */
5411 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5413 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5414 build_empty_stmt (input_location
));
5415 gfc_add_expr_to_block (block
, tmp
);
5419 /* Translate a statement function.
5420 The value of a statement function reference is obtained by evaluating the
5421 expression using the values of the actual arguments for the values of the
5422 corresponding dummy arguments. */
5425 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5429 gfc_formal_arglist
*fargs
;
5430 gfc_actual_arglist
*args
;
5433 gfc_saved_var
*saved_vars
;
5439 sym
= expr
->symtree
->n
.sym
;
5440 args
= expr
->value
.function
.actual
;
5441 gfc_init_se (&lse
, NULL
);
5442 gfc_init_se (&rse
, NULL
);
5445 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5447 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5448 temp_vars
= XCNEWVEC (tree
, n
);
5450 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5451 fargs
= fargs
->next
, n
++)
5453 /* Each dummy shall be specified, explicitly or implicitly, to be
5455 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5458 if (fsym
->ts
.type
== BT_CHARACTER
)
5460 /* Copy string arguments. */
5463 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5464 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5466 /* Create a temporary to hold the value. */
5467 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5468 fsym
->ts
.u
.cl
->backend_decl
5469 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5471 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5472 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5474 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5476 gfc_conv_expr (&rse
, args
->expr
);
5477 gfc_conv_string_parameter (&rse
);
5478 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5479 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5481 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5482 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5483 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5484 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5488 /* For everything else, just evaluate the expression. */
5490 /* Create a temporary to hold the value. */
5491 type
= gfc_typenode_for_spec (&fsym
->ts
);
5492 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5494 gfc_conv_expr (&lse
, args
->expr
);
5496 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5497 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5498 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5504 /* Use the temporary variables in place of the real ones. */
5505 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5506 fargs
= fargs
->next
, n
++)
5507 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5509 gfc_conv_expr (se
, sym
->value
);
5511 if (sym
->ts
.type
== BT_CHARACTER
)
5513 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5515 /* Force the expression to the correct length. */
5516 if (!INTEGER_CST_P (se
->string_length
)
5517 || tree_int_cst_lt (se
->string_length
,
5518 sym
->ts
.u
.cl
->backend_decl
))
5520 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5521 tmp
= gfc_create_var (type
, sym
->name
);
5522 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5523 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5524 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5528 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5531 /* Restore the original variables. */
5532 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5533 fargs
= fargs
->next
, n
++)
5534 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5540 /* Translate a function expression. */
5543 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5547 if (expr
->value
.function
.isym
)
5549 gfc_conv_intrinsic_function (se
, expr
);
5553 /* expr.value.function.esym is the resolved (specific) function symbol for
5554 most functions. However this isn't set for dummy procedures. */
5555 sym
= expr
->value
.function
.esym
;
5557 sym
= expr
->symtree
->n
.sym
;
5559 /* We distinguish statement functions from general functions to improve
5560 runtime performance. */
5561 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5563 gfc_conv_statement_function (se
, expr
);
5567 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5572 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5575 is_zero_initializer_p (gfc_expr
* expr
)
5577 if (expr
->expr_type
!= EXPR_CONSTANT
)
5580 /* We ignore constants with prescribed memory representations for now. */
5581 if (expr
->representation
.string
)
5584 switch (expr
->ts
.type
)
5587 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5590 return mpfr_zero_p (expr
->value
.real
)
5591 && MPFR_SIGN (expr
->value
.real
) >= 0;
5594 return expr
->value
.logical
== 0;
5597 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5598 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5599 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5600 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5610 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5615 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5616 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5618 gfc_conv_tmp_array_ref (se
);
5622 /* Build a static initializer. EXPR is the expression for the initial value.
5623 The other parameters describe the variable of the component being
5624 initialized. EXPR may be null. */
5627 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5628 bool array
, bool pointer
, bool procptr
)
5632 if (!(expr
|| pointer
|| procptr
))
5635 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5636 (these are the only two iso_c_binding derived types that can be
5637 used as initialization expressions). If so, we need to modify
5638 the 'expr' to be that for a (void *). */
5639 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5640 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5642 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5644 /* The derived symbol has already been converted to a (void *). Use
5646 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5647 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5649 gfc_init_se (&se
, NULL
);
5650 gfc_conv_constant (&se
, expr
);
5651 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5655 if (array
&& !procptr
)
5658 /* Arrays need special handling. */
5660 ctor
= gfc_build_null_descriptor (type
);
5661 /* Special case assigning an array to zero. */
5662 else if (is_zero_initializer_p (expr
))
5663 ctor
= build_constructor (type
, NULL
);
5665 ctor
= gfc_conv_array_initializer (type
, expr
);
5666 TREE_STATIC (ctor
) = 1;
5669 else if (pointer
|| procptr
)
5671 if (ts
->type
== BT_CLASS
&& !procptr
)
5673 gfc_init_se (&se
, NULL
);
5674 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5675 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5676 TREE_STATIC (se
.expr
) = 1;
5679 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5680 return fold_convert (type
, null_pointer_node
);
5683 gfc_init_se (&se
, NULL
);
5684 se
.want_pointer
= 1;
5685 gfc_conv_expr (&se
, expr
);
5686 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5696 gfc_init_se (&se
, NULL
);
5697 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5698 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5700 gfc_conv_structure (&se
, expr
, 1);
5701 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5702 TREE_STATIC (se
.expr
) = 1;
5707 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5708 TREE_STATIC (ctor
) = 1;
5713 gfc_init_se (&se
, NULL
);
5714 gfc_conv_constant (&se
, expr
);
5715 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5722 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5728 gfc_array_info
*lss_array
;
5735 gfc_start_block (&block
);
5737 /* Initialize the scalarizer. */
5738 gfc_init_loopinfo (&loop
);
5740 gfc_init_se (&lse
, NULL
);
5741 gfc_init_se (&rse
, NULL
);
5744 rss
= gfc_walk_expr (expr
);
5745 if (rss
== gfc_ss_terminator
)
5746 /* The rhs is scalar. Add a ss for the expression. */
5747 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5749 /* Create a SS for the destination. */
5750 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5752 lss_array
= &lss
->info
->data
.array
;
5753 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5754 lss_array
->descriptor
= dest
;
5755 lss_array
->data
= gfc_conv_array_data (dest
);
5756 lss_array
->offset
= gfc_conv_array_offset (dest
);
5757 for (n
= 0; n
< cm
->as
->rank
; n
++)
5759 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5760 lss_array
->stride
[n
] = gfc_index_one_node
;
5762 mpz_init (lss_array
->shape
[n
]);
5763 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5764 cm
->as
->lower
[n
]->value
.integer
);
5765 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5768 /* Associate the SS with the loop. */
5769 gfc_add_ss_to_loop (&loop
, lss
);
5770 gfc_add_ss_to_loop (&loop
, rss
);
5772 /* Calculate the bounds of the scalarization. */
5773 gfc_conv_ss_startstride (&loop
);
5775 /* Setup the scalarizing loops. */
5776 gfc_conv_loop_setup (&loop
, &expr
->where
);
5778 /* Setup the gfc_se structures. */
5779 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5780 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5783 gfc_mark_ss_chain_used (rss
, 1);
5785 gfc_mark_ss_chain_used (lss
, 1);
5787 /* Start the scalarized loop body. */
5788 gfc_start_scalarized_body (&loop
, &body
);
5790 gfc_conv_tmp_array_ref (&lse
);
5791 if (cm
->ts
.type
== BT_CHARACTER
)
5792 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5794 gfc_conv_expr (&rse
, expr
);
5796 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5797 gfc_add_expr_to_block (&body
, tmp
);
5799 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5801 /* Generate the copying loops. */
5802 gfc_trans_scalarizing_loops (&loop
, &body
);
5804 /* Wrap the whole thing up. */
5805 gfc_add_block_to_block (&block
, &loop
.pre
);
5806 gfc_add_block_to_block (&block
, &loop
.post
);
5808 gcc_assert (lss_array
->shape
!= NULL
);
5809 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5810 gfc_cleanup_loop (&loop
);
5812 return gfc_finish_block (&block
);
5817 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5827 gfc_expr
*arg
= NULL
;
5829 gfc_start_block (&block
);
5830 gfc_init_se (&se
, NULL
);
5832 /* Get the descriptor for the expressions. */
5833 se
.want_pointer
= 0;
5834 gfc_conv_expr_descriptor (&se
, expr
);
5835 gfc_add_block_to_block (&block
, &se
.pre
);
5836 gfc_add_modify (&block
, dest
, se
.expr
);
5838 /* Deal with arrays of derived types with allocatable components. */
5839 if (cm
->ts
.type
== BT_DERIVED
5840 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5841 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5845 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5846 TREE_TYPE(cm
->backend_decl
),
5849 gfc_add_expr_to_block (&block
, tmp
);
5850 gfc_add_block_to_block (&block
, &se
.post
);
5852 if (expr
->expr_type
!= EXPR_VARIABLE
)
5853 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5856 /* We need to know if the argument of a conversion function is a
5857 variable, so that the correct lower bound can be used. */
5858 if (expr
->expr_type
== EXPR_FUNCTION
5859 && expr
->value
.function
.isym
5860 && expr
->value
.function
.isym
->conversion
5861 && expr
->value
.function
.actual
->expr
5862 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5863 arg
= expr
->value
.function
.actual
->expr
;
5865 /* Obtain the array spec of full array references. */
5867 as
= gfc_get_full_arrayspec_from_expr (arg
);
5869 as
= gfc_get_full_arrayspec_from_expr (expr
);
5871 /* Shift the lbound and ubound of temporaries to being unity,
5872 rather than zero, based. Always calculate the offset. */
5873 offset
= gfc_conv_descriptor_offset_get (dest
);
5874 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5875 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5877 for (n
= 0; n
< expr
->rank
; n
++)
5882 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5883 TODO It looks as if gfc_conv_expr_descriptor should return
5884 the correct bounds and that the following should not be
5885 necessary. This would simplify gfc_conv_intrinsic_bound
5887 if (as
&& as
->lower
[n
])
5890 gfc_init_se (&lbse
, NULL
);
5891 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5892 gfc_add_block_to_block (&block
, &lbse
.pre
);
5893 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5897 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5898 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5902 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5905 lbound
= gfc_index_one_node
;
5907 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5909 /* Shift the bounds and set the offset accordingly. */
5910 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5911 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5912 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5913 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5915 gfc_conv_descriptor_ubound_set (&block
, dest
,
5916 gfc_rank_cst
[n
], tmp
);
5917 gfc_conv_descriptor_lbound_set (&block
, dest
,
5918 gfc_rank_cst
[n
], lbound
);
5920 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5921 gfc_conv_descriptor_lbound_get (dest
,
5923 gfc_conv_descriptor_stride_get (dest
,
5925 gfc_add_modify (&block
, tmp2
, tmp
);
5926 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5928 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5933 /* If a conversion expression has a null data pointer
5934 argument, nullify the allocatable component. */
5938 if (arg
->symtree
->n
.sym
->attr
.allocatable
5939 || arg
->symtree
->n
.sym
->attr
.pointer
)
5941 non_null_expr
= gfc_finish_block (&block
);
5942 gfc_start_block (&block
);
5943 gfc_conv_descriptor_data_set (&block
, dest
,
5945 null_expr
= gfc_finish_block (&block
);
5946 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5947 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5948 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5949 return build3_v (COND_EXPR
, tmp
,
5950 null_expr
, non_null_expr
);
5954 return gfc_finish_block (&block
);
5958 /* Assign a single component of a derived type constructor. */
5961 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5968 gfc_start_block (&block
);
5970 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5972 gfc_init_se (&se
, NULL
);
5973 /* Pointer component. */
5974 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5976 /* Array pointer. */
5977 if (expr
->expr_type
== EXPR_NULL
)
5978 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5981 se
.direct_byref
= 1;
5983 gfc_conv_expr_descriptor (&se
, expr
);
5984 gfc_add_block_to_block (&block
, &se
.pre
);
5985 gfc_add_block_to_block (&block
, &se
.post
);
5990 /* Scalar pointers. */
5991 se
.want_pointer
= 1;
5992 gfc_conv_expr (&se
, expr
);
5993 gfc_add_block_to_block (&block
, &se
.pre
);
5995 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
5996 && expr
->symtree
->n
.sym
->attr
.dummy
)
5997 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5999 gfc_add_modify (&block
, dest
,
6000 fold_convert (TREE_TYPE (dest
), se
.expr
));
6001 gfc_add_block_to_block (&block
, &se
.post
);
6004 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6006 /* NULL initialization for CLASS components. */
6007 tmp
= gfc_trans_structure_assign (dest
,
6008 gfc_class_initializer (&cm
->ts
, expr
));
6009 gfc_add_expr_to_block (&block
, tmp
);
6011 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
6013 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6014 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6015 else if (cm
->attr
.allocatable
)
6017 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6018 gfc_add_expr_to_block (&block
, tmp
);
6022 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6023 gfc_add_expr_to_block (&block
, tmp
);
6026 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6028 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6030 gfc_init_se (&se
, NULL
);
6031 gfc_conv_expr (&se
, expr
);
6032 gfc_add_block_to_block (&block
, &se
.pre
);
6033 gfc_add_modify (&block
, dest
,
6034 fold_convert (TREE_TYPE (dest
), se
.expr
));
6035 gfc_add_block_to_block (&block
, &se
.post
);
6039 /* Nested constructors. */
6040 tmp
= gfc_trans_structure_assign (dest
, expr
);
6041 gfc_add_expr_to_block (&block
, tmp
);
6046 /* Scalar component. */
6047 gfc_init_se (&se
, NULL
);
6048 gfc_init_se (&lse
, NULL
);
6050 gfc_conv_expr (&se
, expr
);
6051 if (cm
->ts
.type
== BT_CHARACTER
)
6052 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6054 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6055 gfc_add_expr_to_block (&block
, tmp
);
6057 return gfc_finish_block (&block
);
6060 /* Assign a derived type constructor to a variable. */
6063 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6071 gfc_start_block (&block
);
6072 cm
= expr
->ts
.u
.derived
->components
;
6074 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6075 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6076 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6080 gcc_assert (cm
->backend_decl
== NULL
);
6081 gfc_init_se (&se
, NULL
);
6082 gfc_init_se (&lse
, NULL
);
6083 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6085 gfc_add_modify (&block
, lse
.expr
,
6086 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6088 return gfc_finish_block (&block
);
6091 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6092 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6094 /* Skip absent members in default initializers. */
6098 field
= cm
->backend_decl
;
6099 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6100 dest
, field
, NULL_TREE
);
6101 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6102 gfc_add_expr_to_block (&block
, tmp
);
6104 return gfc_finish_block (&block
);
6107 /* Build an expression for a constructor. If init is nonzero then
6108 this is part of a static variable initializer. */
6111 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6118 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6120 gcc_assert (se
->ss
== NULL
);
6121 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6122 type
= gfc_typenode_for_spec (&expr
->ts
);
6126 /* Create a temporary variable and fill it in. */
6127 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6128 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6129 gfc_add_expr_to_block (&se
->pre
, tmp
);
6133 cm
= expr
->ts
.u
.derived
->components
;
6135 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6136 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6138 /* Skip absent members in default initializers and allocatable
6139 components. Although the latter have a default initializer
6140 of EXPR_NULL,... by default, the static nullify is not needed
6141 since this is done every time we come into scope. */
6142 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6145 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6146 && strcmp (cm
->name
, "_extends") == 0
6147 && cm
->initializer
->symtree
)
6151 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6152 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6153 vtab
= unshare_expr_without_location (vtab
);
6154 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6156 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6158 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6159 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6163 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6164 TREE_TYPE (cm
->backend_decl
),
6165 cm
->attr
.dimension
, cm
->attr
.pointer
,
6166 cm
->attr
.proc_pointer
);
6167 val
= unshare_expr_without_location (val
);
6169 /* Append it to the constructor list. */
6170 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6173 se
->expr
= build_constructor (type
, v
);
6175 TREE_CONSTANT (se
->expr
) = 1;
6179 /* Translate a substring expression. */
6182 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6188 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6190 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6191 expr
->value
.character
.length
,
6192 expr
->value
.character
.string
);
6194 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6195 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6198 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6202 /* Entry point for expression translation. Evaluates a scalar quantity.
6203 EXPR is the expression to be translated, and SE is the state structure if
6204 called from within the scalarized. */
6207 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6212 if (ss
&& ss
->info
->expr
== expr
6213 && (ss
->info
->type
== GFC_SS_SCALAR
6214 || ss
->info
->type
== GFC_SS_REFERENCE
))
6216 gfc_ss_info
*ss_info
;
6219 /* Substitute a scalar expression evaluated outside the scalarization
6221 se
->expr
= ss_info
->data
.scalar
.value
;
6222 /* If the reference can be NULL, the value field contains the reference,
6223 not the value the reference points to (see gfc_add_loop_ss_code). */
6224 if (ss_info
->can_be_null_ref
)
6225 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6227 se
->string_length
= ss_info
->string_length
;
6228 gfc_advance_se_ss_chain (se
);
6232 /* We need to convert the expressions for the iso_c_binding derived types.
6233 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6234 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6235 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6236 updated to be an integer with a kind equal to the size of a (void *). */
6237 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6239 if (expr
->expr_type
== EXPR_VARIABLE
6240 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6241 || expr
->symtree
->n
.sym
->intmod_sym_id
6242 == ISOCBINDING_NULL_FUNPTR
))
6244 /* Set expr_type to EXPR_NULL, which will result in
6245 null_pointer_node being used below. */
6246 expr
->expr_type
= EXPR_NULL
;
6250 /* Update the type/kind of the expression to be what the new
6251 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6252 expr
->ts
.type
= BT_INTEGER
;
6253 expr
->ts
.f90_type
= BT_VOID
;
6254 expr
->ts
.kind
= gfc_index_integer_kind
;
6258 gfc_fix_class_refs (expr
);
6260 switch (expr
->expr_type
)
6263 gfc_conv_expr_op (se
, expr
);
6267 gfc_conv_function_expr (se
, expr
);
6271 gfc_conv_constant (se
, expr
);
6275 gfc_conv_variable (se
, expr
);
6279 se
->expr
= null_pointer_node
;
6282 case EXPR_SUBSTRING
:
6283 gfc_conv_substring_expr (se
, expr
);
6286 case EXPR_STRUCTURE
:
6287 gfc_conv_structure (se
, expr
, 0);
6291 gfc_conv_array_constructor_expr (se
, expr
);
6300 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6301 of an assignment. */
6303 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6305 gfc_conv_expr (se
, expr
);
6306 /* All numeric lvalues should have empty post chains. If not we need to
6307 figure out a way of rewriting an lvalue so that it has no post chain. */
6308 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6311 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6312 numeric expressions. Used for scalar values where inserting cleanup code
6315 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6319 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6320 gfc_conv_expr (se
, expr
);
6323 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6324 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6326 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6330 /* Helper to translate an expression and convert it to a particular type. */
6332 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6334 gfc_conv_expr_val (se
, expr
);
6335 se
->expr
= convert (type
, se
->expr
);
6339 /* Converts an expression so that it can be passed by reference. Scalar
6343 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6349 if (ss
&& ss
->info
->expr
== expr
6350 && ss
->info
->type
== GFC_SS_REFERENCE
)
6352 /* Returns a reference to the scalar evaluated outside the loop
6354 gfc_conv_expr (se
, expr
);
6355 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6359 if (expr
->ts
.type
== BT_CHARACTER
)
6361 gfc_conv_expr (se
, expr
);
6362 gfc_conv_string_parameter (se
);
6366 if (expr
->expr_type
== EXPR_VARIABLE
)
6368 se
->want_pointer
= 1;
6369 gfc_conv_expr (se
, expr
);
6372 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6373 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6374 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6380 if (expr
->expr_type
== EXPR_FUNCTION
6381 && ((expr
->value
.function
.esym
6382 && expr
->value
.function
.esym
->result
->attr
.pointer
6383 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6384 || (!expr
->value
.function
.esym
&& !expr
->ref
6385 && expr
->symtree
->n
.sym
->attr
.pointer
6386 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6388 se
->want_pointer
= 1;
6389 gfc_conv_expr (se
, expr
);
6390 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6391 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6396 gfc_conv_expr (se
, expr
);
6398 /* Create a temporary var to hold the value. */
6399 if (TREE_CONSTANT (se
->expr
))
6401 tree tmp
= se
->expr
;
6402 STRIP_TYPE_NOPS (tmp
);
6403 var
= build_decl (input_location
,
6404 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6405 DECL_INITIAL (var
) = tmp
;
6406 TREE_STATIC (var
) = 1;
6411 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6412 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6414 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6416 /* Take the address of that value. */
6417 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6422 gfc_trans_pointer_assign (gfc_code
* code
)
6424 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6428 /* Generate code for a pointer assignment. */
6431 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6433 gfc_expr
*expr1_vptr
= NULL
;
6443 gfc_start_block (&block
);
6445 gfc_init_se (&lse
, NULL
);
6447 /* Check whether the expression is a scalar or not; we cannot use
6448 expr1->rank as it can be nonzero for proc pointers. */
6449 ss
= gfc_walk_expr (expr1
);
6450 scalar
= ss
== gfc_ss_terminator
;
6452 gfc_free_ss_chain (ss
);
6454 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6455 && expr2
->expr_type
!= EXPR_FUNCTION
)
6457 gfc_add_data_component (expr2
);
6458 /* The following is required as gfc_add_data_component doesn't
6459 update ts.type if there is a tailing REF_ARRAY. */
6460 expr2
->ts
.type
= BT_DERIVED
;
6465 /* Scalar pointers. */
6466 lse
.want_pointer
= 1;
6467 gfc_conv_expr (&lse
, expr1
);
6468 gfc_init_se (&rse
, NULL
);
6469 rse
.want_pointer
= 1;
6470 gfc_conv_expr (&rse
, expr2
);
6472 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6473 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6474 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6477 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6478 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6479 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6482 gfc_add_block_to_block (&block
, &lse
.pre
);
6483 gfc_add_block_to_block (&block
, &rse
.pre
);
6485 /* Check character lengths if character expression. The test is only
6486 really added if -fbounds-check is enabled. Exclude deferred
6487 character length lefthand sides. */
6488 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6489 && !expr1
->ts
.deferred
6490 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6491 && !gfc_is_proc_ptr_comp (expr1
))
6493 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6494 gcc_assert (lse
.string_length
&& rse
.string_length
);
6495 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6496 lse
.string_length
, rse
.string_length
,
6500 /* The assignment to an deferred character length sets the string
6501 length to that of the rhs. */
6502 if (expr1
->ts
.deferred
)
6504 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6505 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6506 else if (lse
.string_length
!= NULL
)
6507 gfc_add_modify (&block
, lse
.string_length
,
6508 build_int_cst (gfc_charlen_type_node
, 0));
6511 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6512 rse
.expr
= gfc_class_data_get (rse
.expr
);
6514 gfc_add_modify (&block
, lse
.expr
,
6515 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6517 gfc_add_block_to_block (&block
, &rse
.post
);
6518 gfc_add_block_to_block (&block
, &lse
.post
);
6525 tree strlen_rhs
= NULL_TREE
;
6527 /* Array pointer. Find the last reference on the LHS and if it is an
6528 array section ref, we're dealing with bounds remapping. In this case,
6529 set it to AR_FULL so that gfc_conv_expr_descriptor does
6530 not see it and process the bounds remapping afterwards explicitly. */
6531 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6532 if (!remap
->next
&& remap
->type
== REF_ARRAY
6533 && remap
->u
.ar
.type
== AR_SECTION
)
6535 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6537 gfc_init_se (&lse
, NULL
);
6539 lse
.descriptor_only
= 1;
6540 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6541 && expr1
->ts
.type
== BT_CLASS
)
6542 expr1_vptr
= gfc_copy_expr (expr1
);
6543 gfc_conv_expr_descriptor (&lse
, expr1
);
6544 strlen_lhs
= lse
.string_length
;
6547 if (expr2
->expr_type
== EXPR_NULL
)
6549 /* Just set the data pointer to null. */
6550 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6552 else if (rank_remap
)
6554 /* If we are rank-remapping, just get the RHS's descriptor and
6555 process this later on. */
6556 gfc_init_se (&rse
, NULL
);
6557 rse
.direct_byref
= 1;
6558 rse
.byref_noassign
= 1;
6560 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6562 gfc_conv_function_expr (&rse
, expr2
);
6564 if (expr1
->ts
.type
!= BT_CLASS
)
6565 rse
.expr
= gfc_class_data_get (rse
.expr
);
6568 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6569 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6571 gfc_add_vptr_component (expr1_vptr
);
6572 gfc_init_se (&rse
, NULL
);
6573 rse
.want_pointer
= 1;
6574 gfc_conv_expr (&rse
, expr1_vptr
);
6575 gfc_add_modify (&lse
.pre
, rse
.expr
,
6576 fold_convert (TREE_TYPE (rse
.expr
),
6577 gfc_class_vptr_get (tmp
)));
6578 rse
.expr
= gfc_class_data_get (tmp
);
6581 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6583 tree bound
[GFC_MAX_DIMENSIONS
];
6586 for (i
= 0; i
< expr2
->rank
; i
++)
6587 bound
[i
] = NULL_TREE
;
6588 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6589 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6591 GFC_ARRAY_POINTER_CONT
, false);
6592 tmp
= gfc_create_var (tmp
, "ptrtemp");
6594 lse
.direct_byref
= 1;
6595 gfc_conv_expr_descriptor (&lse
, expr2
);
6596 strlen_rhs
= lse
.string_length
;
6601 gfc_conv_expr_descriptor (&rse
, expr2
);
6602 strlen_rhs
= rse
.string_length
;
6605 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6607 /* Assign directly to the LHS's descriptor. */
6608 lse
.direct_byref
= 1;
6609 gfc_conv_expr_descriptor (&lse
, expr2
);
6610 strlen_rhs
= lse
.string_length
;
6612 /* If this is a subreference array pointer assignment, use the rhs
6613 descriptor element size for the lhs span. */
6614 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6616 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6617 gfc_init_se (&rse
, NULL
);
6618 rse
.descriptor_only
= 1;
6619 gfc_conv_expr (&rse
, expr2
);
6620 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6621 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6622 if (!INTEGER_CST_P (tmp
))
6623 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6624 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6627 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6629 gfc_init_se (&rse
, NULL
);
6630 rse
.want_pointer
= 1;
6631 gfc_conv_function_expr (&rse
, expr2
);
6632 if (expr1
->ts
.type
!= BT_CLASS
)
6634 rse
.expr
= gfc_class_data_get (rse
.expr
);
6635 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6639 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6640 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6642 gfc_add_vptr_component (expr1_vptr
);
6643 gfc_init_se (&rse
, NULL
);
6644 rse
.want_pointer
= 1;
6645 gfc_conv_expr (&rse
, expr1_vptr
);
6646 gfc_add_modify (&lse
.pre
, rse
.expr
,
6647 fold_convert (TREE_TYPE (rse
.expr
),
6648 gfc_class_vptr_get (tmp
)));
6649 rse
.expr
= gfc_class_data_get (tmp
);
6650 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6655 /* Assign to a temporary descriptor and then copy that
6656 temporary to the pointer. */
6657 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6659 lse
.direct_byref
= 1;
6660 gfc_conv_expr_descriptor (&lse
, expr2
);
6661 strlen_rhs
= lse
.string_length
;
6662 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6666 gfc_free_expr (expr1_vptr
);
6668 gfc_add_block_to_block (&block
, &lse
.pre
);
6670 gfc_add_block_to_block (&block
, &rse
.pre
);
6672 /* If we do bounds remapping, update LHS descriptor accordingly. */
6676 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6680 /* Do rank remapping. We already have the RHS's descriptor
6681 converted in rse and now have to build the correct LHS
6682 descriptor for it. */
6686 tree lbound
, ubound
;
6689 dtype
= gfc_conv_descriptor_dtype (desc
);
6690 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6691 gfc_add_modify (&block
, dtype
, tmp
);
6693 /* Copy data pointer. */
6694 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6695 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6697 /* Copy offset but adjust it such that it would correspond
6698 to a lbound of zero. */
6699 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6700 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6702 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6704 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6706 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6707 gfc_array_index_type
, stride
, lbound
);
6708 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6709 gfc_array_index_type
, offs
, tmp
);
6711 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6713 /* Set the bounds as declared for the LHS and calculate strides as
6714 well as another offset update accordingly. */
6715 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6717 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6722 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6724 /* Convert declared bounds. */
6725 gfc_init_se (&lower_se
, NULL
);
6726 gfc_init_se (&upper_se
, NULL
);
6727 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6728 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6730 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6731 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6733 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6734 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6736 lbound
= gfc_evaluate_now (lbound
, &block
);
6737 ubound
= gfc_evaluate_now (ubound
, &block
);
6739 gfc_add_block_to_block (&block
, &lower_se
.post
);
6740 gfc_add_block_to_block (&block
, &upper_se
.post
);
6742 /* Set bounds in descriptor. */
6743 gfc_conv_descriptor_lbound_set (&block
, desc
,
6744 gfc_rank_cst
[dim
], lbound
);
6745 gfc_conv_descriptor_ubound_set (&block
, desc
,
6746 gfc_rank_cst
[dim
], ubound
);
6749 stride
= gfc_evaluate_now (stride
, &block
);
6750 gfc_conv_descriptor_stride_set (&block
, desc
,
6751 gfc_rank_cst
[dim
], stride
);
6753 /* Update offset. */
6754 offs
= gfc_conv_descriptor_offset_get (desc
);
6755 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6756 gfc_array_index_type
, lbound
, stride
);
6757 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6758 gfc_array_index_type
, offs
, tmp
);
6759 offs
= gfc_evaluate_now (offs
, &block
);
6760 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6762 /* Update stride. */
6763 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6764 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6765 gfc_array_index_type
, stride
, tmp
);
6770 /* Bounds remapping. Just shift the lower bounds. */
6772 gcc_assert (expr1
->rank
== expr2
->rank
);
6774 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6778 gcc_assert (remap
->u
.ar
.start
[dim
]);
6779 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6780 gfc_init_se (&lbound_se
, NULL
);
6781 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6783 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6784 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6785 dim
, lbound_se
.expr
);
6786 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6791 /* Check string lengths if applicable. The check is only really added
6792 to the output code if -fbounds-check is enabled. */
6793 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6795 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6796 gcc_assert (strlen_lhs
&& strlen_rhs
);
6797 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6798 strlen_lhs
, strlen_rhs
, &block
);
6801 /* If rank remapping was done, check with -fcheck=bounds that
6802 the target is at least as large as the pointer. */
6803 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6809 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6810 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6812 lsize
= gfc_evaluate_now (lsize
, &block
);
6813 rsize
= gfc_evaluate_now (rsize
, &block
);
6814 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6817 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6818 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6822 gfc_add_block_to_block (&block
, &lse
.post
);
6824 gfc_add_block_to_block (&block
, &rse
.post
);
6827 return gfc_finish_block (&block
);
6831 /* Makes sure se is suitable for passing as a function string parameter. */
6832 /* TODO: Need to check all callers of this function. It may be abused. */
6835 gfc_conv_string_parameter (gfc_se
* se
)
6839 if (TREE_CODE (se
->expr
) == STRING_CST
)
6841 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6842 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6846 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6848 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6850 type
= TREE_TYPE (se
->expr
);
6851 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6855 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6857 type
= build_pointer_type (type
);
6858 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6862 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6866 /* Generate code for assignment of scalar variables. Includes character
6867 strings and derived types with allocatable components.
6868 If you know that the LHS has no allocations, set dealloc to false.
6870 DEEP_COPY has no effect if the typespec TS is not a derived type with
6871 allocatable components. Otherwise, if it is set, an explicit copy of each
6872 allocatable component is made. This is necessary as a simple copy of the
6873 whole object would copy array descriptors as is, so that the lhs's
6874 allocatable components would point to the rhs's after the assignment.
6875 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6876 necessary if the rhs is a non-pointer function, as the allocatable components
6877 are not accessible by other means than the function's result after the
6878 function has returned. It is even more subtle when temporaries are involved,
6879 as the two following examples show:
6880 1. When we evaluate an array constructor, a temporary is created. Thus
6881 there is theoretically no alias possible. However, no deep copy is
6882 made for this temporary, so that if the constructor is made of one or
6883 more variable with allocatable components, those components still point
6884 to the variable's: DEEP_COPY should be set for the assignment from the
6885 temporary to the lhs in that case.
6886 2. When assigning a scalar to an array, we evaluate the scalar value out
6887 of the loop, store it into a temporary variable, and assign from that.
6888 In that case, deep copying when assigning to the temporary would be a
6889 waste of resources; however deep copies should happen when assigning from
6890 the temporary to each array element: again DEEP_COPY should be set for
6891 the assignment from the temporary to the lhs. */
6894 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6895 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6901 gfc_init_block (&block
);
6903 if (ts
.type
== BT_CHARACTER
)
6908 if (lse
->string_length
!= NULL_TREE
)
6910 gfc_conv_string_parameter (lse
);
6911 gfc_add_block_to_block (&block
, &lse
->pre
);
6912 llen
= lse
->string_length
;
6915 if (rse
->string_length
!= NULL_TREE
)
6917 gcc_assert (rse
->string_length
!= NULL_TREE
);
6918 gfc_conv_string_parameter (rse
);
6919 gfc_add_block_to_block (&block
, &rse
->pre
);
6920 rlen
= rse
->string_length
;
6923 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6924 rse
->expr
, ts
.kind
);
6926 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6928 tree tmp_var
= NULL_TREE
;
6931 /* Are the rhs and the lhs the same? */
6934 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6935 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6936 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6937 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6940 /* Deallocate the lhs allocated components as long as it is not
6941 the same as the rhs. This must be done following the assignment
6942 to prevent deallocating data that could be used in the rhs
6944 if (!l_is_temp
&& dealloc
)
6946 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
6947 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
6949 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6951 gfc_add_expr_to_block (&lse
->post
, tmp
);
6954 gfc_add_block_to_block (&block
, &rse
->pre
);
6955 gfc_add_block_to_block (&block
, &lse
->pre
);
6957 gfc_add_modify (&block
, lse
->expr
,
6958 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6960 /* Restore pointer address of coarray components. */
6961 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
6963 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
6964 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6966 gfc_add_expr_to_block (&block
, tmp
);
6969 /* Do a deep copy if the rhs is a variable, if it is not the
6973 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
6974 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6976 gfc_add_expr_to_block (&block
, tmp
);
6979 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
6981 gfc_add_block_to_block (&block
, &lse
->pre
);
6982 gfc_add_block_to_block (&block
, &rse
->pre
);
6983 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
6984 TREE_TYPE (lse
->expr
), rse
->expr
);
6985 gfc_add_modify (&block
, lse
->expr
, tmp
);
6989 gfc_add_block_to_block (&block
, &lse
->pre
);
6990 gfc_add_block_to_block (&block
, &rse
->pre
);
6992 gfc_add_modify (&block
, lse
->expr
,
6993 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6996 gfc_add_block_to_block (&block
, &lse
->post
);
6997 gfc_add_block_to_block (&block
, &rse
->post
);
6999 return gfc_finish_block (&block
);
7003 /* There are quite a lot of restrictions on the optimisation in using an
7004 array function assign without a temporary. */
7007 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7010 bool seen_array_ref
;
7012 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7014 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7015 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7018 /* Elemental functions are scalarized so that they don't need a
7019 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7020 they would need special treatment in gfc_trans_arrayfunc_assign. */
7021 if (expr2
->value
.function
.esym
!= NULL
7022 && expr2
->value
.function
.esym
->attr
.elemental
)
7025 /* Need a temporary if rhs is not FULL or a contiguous section. */
7026 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7029 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7030 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7033 /* Functions returning pointers or allocatables need temporaries. */
7034 c
= expr2
->value
.function
.esym
7035 ? (expr2
->value
.function
.esym
->attr
.pointer
7036 || expr2
->value
.function
.esym
->attr
.allocatable
)
7037 : (expr2
->symtree
->n
.sym
->attr
.pointer
7038 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7042 /* Character array functions need temporaries unless the
7043 character lengths are the same. */
7044 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7046 if (expr1
->ts
.u
.cl
->length
== NULL
7047 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7050 if (expr2
->ts
.u
.cl
->length
== NULL
7051 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7054 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7055 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7059 /* Check that no LHS component references appear during an array
7060 reference. This is needed because we do not have the means to
7061 span any arbitrary stride with an array descriptor. This check
7062 is not needed for the rhs because the function result has to be
7064 seen_array_ref
= false;
7065 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7067 if (ref
->type
== REF_ARRAY
)
7068 seen_array_ref
= true;
7069 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7073 /* Check for a dependency. */
7074 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7075 expr2
->value
.function
.esym
,
7076 expr2
->value
.function
.actual
,
7080 /* If we have reached here with an intrinsic function, we do not
7081 need a temporary except in the particular case that reallocation
7082 on assignment is active and the lhs is allocatable and a target. */
7083 if (expr2
->value
.function
.isym
)
7084 return (gfc_option
.flag_realloc_lhs
7085 && sym
->attr
.allocatable
7086 && sym
->attr
.target
);
7088 /* If the LHS is a dummy, we need a temporary if it is not
7090 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7093 /* If the lhs has been host_associated, is in common, a pointer or is
7094 a target and the function is not using a RESULT variable, aliasing
7095 can occur and a temporary is needed. */
7096 if ((sym
->attr
.host_assoc
7097 || sym
->attr
.in_common
7098 || sym
->attr
.pointer
7099 || sym
->attr
.cray_pointee
7100 || sym
->attr
.target
)
7101 && expr2
->symtree
!= NULL
7102 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7105 /* A PURE function can unconditionally be called without a temporary. */
7106 if (expr2
->value
.function
.esym
!= NULL
7107 && expr2
->value
.function
.esym
->attr
.pure
)
7110 /* Implicit_pure functions are those which could legally be declared
7112 if (expr2
->value
.function
.esym
!= NULL
7113 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7116 if (!sym
->attr
.use_assoc
7117 && !sym
->attr
.in_common
7118 && !sym
->attr
.pointer
7119 && !sym
->attr
.target
7120 && !sym
->attr
.cray_pointee
7121 && expr2
->value
.function
.esym
)
7123 /* A temporary is not needed if the function is not contained and
7124 the variable is local or host associated and not a pointer or
7126 if (!expr2
->value
.function
.esym
->attr
.contained
)
7129 /* A temporary is not needed if the lhs has never been host
7130 associated and the procedure is contained. */
7131 else if (!sym
->attr
.host_assoc
)
7134 /* A temporary is not needed if the variable is local and not
7135 a pointer, a target or a result. */
7137 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7141 /* Default to temporary use. */
7146 /* Provide the loop info so that the lhs descriptor can be built for
7147 reallocatable assignments from extrinsic function calls. */
7150 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7153 /* Signal that the function call should not be made by
7154 gfc_conv_loop_setup. */
7155 se
->ss
->is_alloc_lhs
= 1;
7156 gfc_init_loopinfo (loop
);
7157 gfc_add_ss_to_loop (loop
, *ss
);
7158 gfc_add_ss_to_loop (loop
, se
->ss
);
7159 gfc_conv_ss_startstride (loop
);
7160 gfc_conv_loop_setup (loop
, where
);
7161 gfc_copy_loopinfo_to_se (se
, loop
);
7162 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7163 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7164 se
->ss
->is_alloc_lhs
= 0;
7168 /* For assignment to a reallocatable lhs from intrinsic functions,
7169 replace the se.expr (ie. the result) with a temporary descriptor.
7170 Null the data field so that the library allocates space for the
7171 result. Free the data of the original descriptor after the function,
7172 in case it appears in an argument expression and transfer the
7173 result to the original descriptor. */
7176 fcncall_realloc_result (gfc_se
*se
, int rank
)
7185 /* Use the allocation done by the library. Substitute the lhs
7186 descriptor with a copy, whose data field is nulled.*/
7187 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7188 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7189 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7191 /* Unallocated, the descriptor does not have a dtype. */
7192 tmp
= gfc_conv_descriptor_dtype (desc
);
7193 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7195 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7196 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7197 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
7199 /* Free the lhs after the function call and copy the result data to
7200 the lhs descriptor. */
7201 tmp
= gfc_conv_descriptor_data_get (desc
);
7202 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7203 boolean_type_node
, tmp
,
7204 build_int_cst (TREE_TYPE (tmp
), 0));
7205 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7206 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7207 gfc_add_expr_to_block (&se
->post
, tmp
);
7209 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7210 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7212 /* Check that the shapes are the same between lhs and expression. */
7213 for (n
= 0 ; n
< rank
; n
++)
7216 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7217 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7218 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7219 gfc_array_index_type
, tmp
, tmp1
);
7220 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7221 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7222 gfc_array_index_type
, tmp
, tmp1
);
7223 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7224 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7225 gfc_array_index_type
, tmp
, tmp1
);
7226 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7227 boolean_type_node
, tmp
,
7228 gfc_index_zero_node
);
7229 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7230 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7231 boolean_type_node
, tmp
,
7235 /* 'zero_cond' being true is equal to lhs not being allocated or the
7236 shapes being different. */
7237 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7239 /* Now reset the bounds returned from the function call to bounds based
7240 on the lhs lbounds, except where the lhs is not allocated or the shapes
7241 of 'variable and 'expr' are different. Set the offset accordingly. */
7242 offset
= gfc_index_zero_node
;
7243 for (n
= 0 ; n
< rank
; n
++)
7247 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7248 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7249 gfc_array_index_type
, zero_cond
,
7250 gfc_index_one_node
, lbound
);
7251 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7253 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7254 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7255 gfc_array_index_type
, tmp
, lbound
);
7256 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7257 gfc_rank_cst
[n
], lbound
);
7258 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7259 gfc_rank_cst
[n
], tmp
);
7261 /* Set stride and accumulate the offset. */
7262 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7263 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7264 gfc_rank_cst
[n
], tmp
);
7265 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7266 gfc_array_index_type
, lbound
, tmp
);
7267 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7268 gfc_array_index_type
, offset
, tmp
);
7269 offset
= gfc_evaluate_now (offset
, &se
->post
);
7272 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7277 /* Try to translate array(:) = func (...), where func is a transformational
7278 array function, without using a temporary. Returns NULL if this isn't the
7282 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7286 gfc_component
*comp
= NULL
;
7289 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7292 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7294 comp
= gfc_get_proc_ptr_comp (expr2
);
7295 gcc_assert (expr2
->value
.function
.isym
7296 || (comp
&& comp
->attr
.dimension
)
7297 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7298 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7300 gfc_init_se (&se
, NULL
);
7301 gfc_start_block (&se
.pre
);
7302 se
.want_pointer
= 1;
7304 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7306 if (expr1
->ts
.type
== BT_DERIVED
7307 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7310 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7312 gfc_add_expr_to_block (&se
.pre
, tmp
);
7315 se
.direct_byref
= 1;
7316 se
.ss
= gfc_walk_expr (expr2
);
7317 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7319 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7320 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7321 Clearly, this cannot be done for an allocatable function result, since
7322 the shape of the result is unknown and, in any case, the function must
7323 correctly take care of the reallocation internally. For intrinsic
7324 calls, the array data is freed and the library takes care of allocation.
7325 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7327 if (gfc_option
.flag_realloc_lhs
7328 && gfc_is_reallocatable_lhs (expr1
)
7329 && !gfc_expr_attr (expr1
).codimension
7330 && !gfc_is_coindexed (expr1
)
7331 && !(expr2
->value
.function
.esym
7332 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7334 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7336 if (!expr2
->value
.function
.isym
)
7338 ss
= gfc_walk_expr (expr1
);
7339 gcc_assert (ss
!= gfc_ss_terminator
);
7341 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7342 ss
->is_alloc_lhs
= 1;
7345 fcncall_realloc_result (&se
, expr1
->rank
);
7348 gfc_conv_function_expr (&se
, expr2
);
7349 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7352 gfc_cleanup_loop (&loop
);
7354 gfc_free_ss_chain (se
.ss
);
7356 return gfc_finish_block (&se
.pre
);
7360 /* Try to efficiently translate array(:) = 0. Return NULL if this
7364 gfc_trans_zero_assign (gfc_expr
* expr
)
7366 tree dest
, len
, type
;
7370 sym
= expr
->symtree
->n
.sym
;
7371 dest
= gfc_get_symbol_decl (sym
);
7373 type
= TREE_TYPE (dest
);
7374 if (POINTER_TYPE_P (type
))
7375 type
= TREE_TYPE (type
);
7376 if (!GFC_ARRAY_TYPE_P (type
))
7379 /* Determine the length of the array. */
7380 len
= GFC_TYPE_ARRAY_SIZE (type
);
7381 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7384 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7385 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7386 fold_convert (gfc_array_index_type
, tmp
));
7388 /* If we are zeroing a local array avoid taking its address by emitting
7390 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7391 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7392 dest
, build_constructor (TREE_TYPE (dest
),
7395 /* Convert arguments to the correct types. */
7396 dest
= fold_convert (pvoid_type_node
, dest
);
7397 len
= fold_convert (size_type_node
, len
);
7399 /* Construct call to __builtin_memset. */
7400 tmp
= build_call_expr_loc (input_location
,
7401 builtin_decl_explicit (BUILT_IN_MEMSET
),
7402 3, dest
, integer_zero_node
, len
);
7403 return fold_convert (void_type_node
, tmp
);
7407 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7408 that constructs the call to __builtin_memcpy. */
7411 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7415 /* Convert arguments to the correct types. */
7416 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7417 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7419 dst
= fold_convert (pvoid_type_node
, dst
);
7421 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7422 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7424 src
= fold_convert (pvoid_type_node
, src
);
7426 len
= fold_convert (size_type_node
, len
);
7428 /* Construct call to __builtin_memcpy. */
7429 tmp
= build_call_expr_loc (input_location
,
7430 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7432 return fold_convert (void_type_node
, tmp
);
7436 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7437 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7438 source/rhs, both are gfc_full_array_ref_p which have been checked for
7442 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7444 tree dst
, dlen
, dtype
;
7445 tree src
, slen
, stype
;
7448 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7449 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7451 dtype
= TREE_TYPE (dst
);
7452 if (POINTER_TYPE_P (dtype
))
7453 dtype
= TREE_TYPE (dtype
);
7454 stype
= TREE_TYPE (src
);
7455 if (POINTER_TYPE_P (stype
))
7456 stype
= TREE_TYPE (stype
);
7458 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7461 /* Determine the lengths of the arrays. */
7462 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7463 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7465 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7466 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7467 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7469 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7470 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7472 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7473 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7474 slen
, fold_convert (gfc_array_index_type
, tmp
));
7476 /* Sanity check that they are the same. This should always be
7477 the case, as we should already have checked for conformance. */
7478 if (!tree_int_cst_equal (slen
, dlen
))
7481 return gfc_build_memcpy_call (dst
, src
, dlen
);
7485 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7486 this can't be done. EXPR1 is the destination/lhs for which
7487 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7490 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7492 unsigned HOST_WIDE_INT nelem
;
7498 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7502 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7503 dtype
= TREE_TYPE (dst
);
7504 if (POINTER_TYPE_P (dtype
))
7505 dtype
= TREE_TYPE (dtype
);
7506 if (!GFC_ARRAY_TYPE_P (dtype
))
7509 /* Determine the lengths of the array. */
7510 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7511 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7514 /* Confirm that the constructor is the same size. */
7515 if (compare_tree_int (len
, nelem
) != 0)
7518 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7519 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7520 fold_convert (gfc_array_index_type
, tmp
));
7522 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7523 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7525 stype
= TREE_TYPE (src
);
7526 if (POINTER_TYPE_P (stype
))
7527 stype
= TREE_TYPE (stype
);
7529 return gfc_build_memcpy_call (dst
, src
, len
);
7533 /* Tells whether the expression is to be treated as a variable reference. */
7536 expr_is_variable (gfc_expr
*expr
)
7539 gfc_component
*comp
;
7540 gfc_symbol
*func_ifc
;
7542 if (expr
->expr_type
== EXPR_VARIABLE
)
7545 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7548 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7549 return expr_is_variable (arg
);
7552 /* A data-pointer-returning function should be considered as a variable
7554 if (expr
->expr_type
== EXPR_FUNCTION
7555 && expr
->ref
== NULL
)
7557 if (expr
->value
.function
.isym
!= NULL
)
7560 if (expr
->value
.function
.esym
!= NULL
)
7562 func_ifc
= expr
->value
.function
.esym
;
7567 gcc_assert (expr
->symtree
);
7568 func_ifc
= expr
->symtree
->n
.sym
;
7575 comp
= gfc_get_proc_ptr_comp (expr
);
7576 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7579 func_ifc
= comp
->ts
.interface
;
7583 if (expr
->expr_type
== EXPR_COMPCALL
)
7585 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7586 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7593 gcc_assert (func_ifc
->attr
.function
7594 && func_ifc
->result
!= NULL
);
7595 return func_ifc
->result
->attr
.pointer
;
7599 /* Is the lhs OK for automatic reallocation? */
7602 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7606 /* An allocatable variable with no reference. */
7607 if (expr
->symtree
->n
.sym
->attr
.allocatable
7611 /* All that can be left are allocatable components. */
7612 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7613 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7614 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7617 /* Find an allocatable component ref last. */
7618 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7619 if (ref
->type
== REF_COMPONENT
7621 && ref
->u
.c
.component
->attr
.allocatable
)
7628 /* Allocate or reallocate scalar lhs, as necessary. */
7631 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7645 if (!expr1
|| expr1
->rank
)
7648 if (!expr2
|| expr2
->rank
)
7651 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7653 /* Since this is a scalar lhs, we can afford to do this. That is,
7654 there is no risk of side effects being repeated. */
7655 gfc_init_se (&lse
, NULL
);
7656 lse
.want_pointer
= 1;
7657 gfc_conv_expr (&lse
, expr1
);
7659 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7660 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7662 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7663 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7664 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7666 tmp
= build3_v (COND_EXPR
, cond
,
7667 build1_v (GOTO_EXPR
, jump_label1
),
7668 build_empty_stmt (input_location
));
7669 gfc_add_expr_to_block (block
, tmp
);
7671 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7673 /* Use the rhs string length and the lhs element size. */
7674 size
= string_length
;
7675 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7676 tmp
= TYPE_SIZE_UNIT (tmp
);
7677 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7678 TREE_TYPE (tmp
), tmp
,
7679 fold_convert (TREE_TYPE (tmp
), size
));
7683 /* Otherwise use the length in bytes of the rhs. */
7684 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7685 size_in_bytes
= size
;
7688 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7689 size_in_bytes
, size_one_node
);
7691 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7693 tmp
= build_call_expr_loc (input_location
,
7694 builtin_decl_explicit (BUILT_IN_CALLOC
),
7695 2, build_one_cst (size_type_node
),
7697 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7698 gfc_add_modify (block
, lse
.expr
, tmp
);
7702 tmp
= build_call_expr_loc (input_location
,
7703 builtin_decl_explicit (BUILT_IN_MALLOC
),
7705 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7706 gfc_add_modify (block
, lse
.expr
, tmp
);
7709 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7711 /* Deferred characters need checking for lhs and rhs string
7712 length. Other deferred parameter variables will have to
7714 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7715 gfc_add_expr_to_block (block
, tmp
);
7717 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7718 gfc_add_expr_to_block (block
, tmp
);
7720 /* For a deferred length character, reallocate if lengths of lhs and
7721 rhs are different. */
7722 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7724 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7725 expr1
->ts
.u
.cl
->backend_decl
, size
);
7726 /* Jump past the realloc if the lengths are the same. */
7727 tmp
= build3_v (COND_EXPR
, cond
,
7728 build1_v (GOTO_EXPR
, jump_label2
),
7729 build_empty_stmt (input_location
));
7730 gfc_add_expr_to_block (block
, tmp
);
7731 tmp
= build_call_expr_loc (input_location
,
7732 builtin_decl_explicit (BUILT_IN_REALLOC
),
7733 2, fold_convert (pvoid_type_node
, lse
.expr
),
7735 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7736 gfc_add_modify (block
, lse
.expr
, tmp
);
7737 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7738 gfc_add_expr_to_block (block
, tmp
);
7740 /* Update the lhs character length. */
7741 size
= string_length
;
7742 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7746 /* Check for assignments of the type
7750 to make sure we do not check for reallocation unneccessarily. */
7754 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7756 gfc_actual_arglist
*a
;
7759 switch (expr2
->expr_type
)
7762 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7765 if (expr2
->value
.function
.esym
7766 && expr2
->value
.function
.esym
->attr
.elemental
)
7768 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7771 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7776 else if (expr2
->value
.function
.isym
7777 && expr2
->value
.function
.isym
->elemental
)
7779 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7782 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7791 switch (expr2
->value
.op
.op
)
7794 case INTRINSIC_UPLUS
:
7795 case INTRINSIC_UMINUS
:
7796 case INTRINSIC_PARENTHESES
:
7797 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7799 case INTRINSIC_PLUS
:
7800 case INTRINSIC_MINUS
:
7801 case INTRINSIC_TIMES
:
7802 case INTRINSIC_DIVIDE
:
7803 case INTRINSIC_POWER
:
7807 case INTRINSIC_NEQV
:
7814 case INTRINSIC_EQ_OS
:
7815 case INTRINSIC_NE_OS
:
7816 case INTRINSIC_GT_OS
:
7817 case INTRINSIC_GE_OS
:
7818 case INTRINSIC_LT_OS
:
7819 case INTRINSIC_LE_OS
:
7821 e1
= expr2
->value
.op
.op1
;
7822 e2
= expr2
->value
.op
.op2
;
7824 if (e1
->rank
== 0 && e2
->rank
> 0)
7825 return is_runtime_conformable (expr1
, e2
);
7826 else if (e1
->rank
> 0 && e2
->rank
== 0)
7827 return is_runtime_conformable (expr1
, e1
);
7828 else if (e1
->rank
> 0 && e2
->rank
> 0)
7829 return is_runtime_conformable (expr1
, e1
)
7830 && is_runtime_conformable (expr1
, e2
);
7846 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7847 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7848 init_flag indicates initialization expressions and dealloc that no
7849 deallocate prior assignment is needed (if in doubt, set true). */
7852 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7858 gfc_ss
*lss_section
;
7865 bool scalar_to_array
;
7869 /* Assignment of the form lhs = rhs. */
7870 gfc_start_block (&block
);
7872 gfc_init_se (&lse
, NULL
);
7873 gfc_init_se (&rse
, NULL
);
7876 lss
= gfc_walk_expr (expr1
);
7877 if (gfc_is_reallocatable_lhs (expr1
)
7878 && !(expr2
->expr_type
== EXPR_FUNCTION
7879 && expr2
->value
.function
.isym
!= NULL
))
7880 lss
->is_alloc_lhs
= 1;
7882 if (lss
!= gfc_ss_terminator
)
7884 /* The assignment needs scalarization. */
7887 /* Find a non-scalar SS from the lhs. */
7888 while (lss_section
!= gfc_ss_terminator
7889 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7890 lss_section
= lss_section
->next
;
7892 gcc_assert (lss_section
!= gfc_ss_terminator
);
7894 /* Initialize the scalarizer. */
7895 gfc_init_loopinfo (&loop
);
7898 rss
= gfc_walk_expr (expr2
);
7899 if (rss
== gfc_ss_terminator
)
7900 /* The rhs is scalar. Add a ss for the expression. */
7901 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7903 /* Associate the SS with the loop. */
7904 gfc_add_ss_to_loop (&loop
, lss
);
7905 gfc_add_ss_to_loop (&loop
, rss
);
7907 /* Calculate the bounds of the scalarization. */
7908 gfc_conv_ss_startstride (&loop
);
7909 /* Enable loop reversal. */
7910 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7911 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7912 /* Resolve any data dependencies in the statement. */
7913 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7914 /* Setup the scalarizing loops. */
7915 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7917 /* Setup the gfc_se structures. */
7918 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7919 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7922 gfc_mark_ss_chain_used (rss
, 1);
7923 if (loop
.temp_ss
== NULL
)
7926 gfc_mark_ss_chain_used (lss
, 1);
7930 lse
.ss
= loop
.temp_ss
;
7931 gfc_mark_ss_chain_used (lss
, 3);
7932 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
7935 /* Allow the scalarizer to workshare array assignments. */
7936 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
7937 ompws_flags
|= OMPWS_SCALARIZER_WS
;
7939 /* Start the scalarized loop body. */
7940 gfc_start_scalarized_body (&loop
, &body
);
7943 gfc_init_block (&body
);
7945 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
7947 /* Translate the expression. */
7948 gfc_conv_expr (&rse
, expr2
);
7950 /* Stabilize a string length for temporaries. */
7951 if (expr2
->ts
.type
== BT_CHARACTER
)
7952 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
7954 string_length
= NULL_TREE
;
7958 gfc_conv_tmp_array_ref (&lse
);
7959 if (expr2
->ts
.type
== BT_CHARACTER
)
7960 lse
.string_length
= string_length
;
7963 gfc_conv_expr (&lse
, expr1
);
7965 /* Assignments of scalar derived types with allocatable components
7966 to arrays must be done with a deep copy and the rhs temporary
7967 must have its components deallocated afterwards. */
7968 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
7969 && expr2
->ts
.u
.derived
->attr
.alloc_comp
7970 && !expr_is_variable (expr2
)
7971 && !gfc_is_constant_expr (expr2
)
7972 && expr1
->rank
&& !expr2
->rank
);
7973 if (scalar_to_array
&& dealloc
)
7975 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
7976 gfc_add_expr_to_block (&loop
.post
, tmp
);
7979 /* When assigning a character function result to a deferred-length variable,
7980 the function call must happen before the (re)allocation of the lhs -
7981 otherwise the character length of the result is not known.
7982 NOTE: This relies on having the exact dependence of the length type
7983 parameter available to the caller; gfortran saves it in the .mod files. */
7984 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
7985 && expr1
->ts
.deferred
)
7986 gfc_add_block_to_block (&block
, &rse
.pre
);
7988 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7989 l_is_temp
|| init_flag
,
7990 expr_is_variable (expr2
) || scalar_to_array
7991 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
7992 gfc_add_expr_to_block (&body
, tmp
);
7994 if (lss
== gfc_ss_terminator
)
7996 /* F2003: Add the code for reallocation on assignment. */
7997 if (gfc_option
.flag_realloc_lhs
7998 && is_scalar_reallocatable_lhs (expr1
))
7999 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8002 /* Use the scalar assignment as is. */
8003 gfc_add_block_to_block (&block
, &body
);
8007 gcc_assert (lse
.ss
== gfc_ss_terminator
8008 && rse
.ss
== gfc_ss_terminator
);
8012 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8014 /* We need to copy the temporary to the actual lhs. */
8015 gfc_init_se (&lse
, NULL
);
8016 gfc_init_se (&rse
, NULL
);
8017 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8018 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8020 rse
.ss
= loop
.temp_ss
;
8023 gfc_conv_tmp_array_ref (&rse
);
8024 gfc_conv_expr (&lse
, expr1
);
8026 gcc_assert (lse
.ss
== gfc_ss_terminator
8027 && rse
.ss
== gfc_ss_terminator
);
8029 if (expr2
->ts
.type
== BT_CHARACTER
)
8030 rse
.string_length
= string_length
;
8032 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8033 false, false, dealloc
);
8034 gfc_add_expr_to_block (&body
, tmp
);
8037 /* F2003: Allocate or reallocate lhs of allocatable array. */
8038 if (gfc_option
.flag_realloc_lhs
8039 && gfc_is_reallocatable_lhs (expr1
)
8040 && !gfc_expr_attr (expr1
).codimension
8041 && !gfc_is_coindexed (expr1
)
8043 && !is_runtime_conformable (expr1
, expr2
))
8045 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8046 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8047 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8048 if (tmp
!= NULL_TREE
)
8049 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8052 /* Generate the copying loops. */
8053 gfc_trans_scalarizing_loops (&loop
, &body
);
8055 /* Wrap the whole thing up. */
8056 gfc_add_block_to_block (&block
, &loop
.pre
);
8057 gfc_add_block_to_block (&block
, &loop
.post
);
8059 gfc_cleanup_loop (&loop
);
8062 return gfc_finish_block (&block
);
8066 /* Check whether EXPR is a copyable array. */
8069 copyable_array_p (gfc_expr
* expr
)
8071 if (expr
->expr_type
!= EXPR_VARIABLE
)
8074 /* First check it's an array. */
8075 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8078 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8081 /* Next check that it's of a simple enough type. */
8082 switch (expr
->ts
.type
)
8094 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8103 /* Translate an assignment. */
8106 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8111 /* Special case a single function returning an array. */
8112 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8114 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8119 /* Special case assigning an array to zero. */
8120 if (copyable_array_p (expr1
)
8121 && is_zero_initializer_p (expr2
))
8123 tmp
= gfc_trans_zero_assign (expr1
);
8128 /* Special case copying one array to another. */
8129 if (copyable_array_p (expr1
)
8130 && copyable_array_p (expr2
)
8131 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8132 && !gfc_check_dependency (expr1
, expr2
, 0))
8134 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8139 /* Special case initializing an array from a constant array constructor. */
8140 if (copyable_array_p (expr1
)
8141 && expr2
->expr_type
== EXPR_ARRAY
8142 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8144 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8149 /* Fallback to the scalarizer to generate explicit loops. */
8150 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8154 gfc_trans_init_assign (gfc_code
* code
)
8156 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8160 gfc_trans_assign (gfc_code
* code
)
8162 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);