1 /* Expression translation
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "double-int.h"
39 #include "fold-const.h"
40 #include "stringpool.h"
41 #include "diagnostic-core.h" /* For fatal_error. */
42 #include "langhooks.h"
45 #include "constructor.h"
47 #include "trans-const.h"
48 #include "trans-types.h"
49 #include "trans-array.h"
50 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
51 #include "trans-stmt.h"
52 #include "dependency.h"
55 /* Convert a scalar to an array descriptor. To be used for assumed-rank
59 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
61 enum gfc_array_kind akind
;
64 akind
= GFC_ARRAY_POINTER_CONT
;
65 else if (attr
.allocatable
)
66 akind
= GFC_ARRAY_ALLOCATABLE
;
68 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
70 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
71 scalar
= TREE_TYPE (scalar
);
72 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
73 akind
, !(attr
.pointer
|| attr
.target
));
77 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
81 type
= get_scalar_to_descriptor_type (scalar
, attr
);
82 desc
= gfc_create_var (type
, "desc");
83 DECL_ARTIFICIAL (desc
) = 1;
85 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
86 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype (type
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* This is the seed for an eventual trans-class.c
103 The following parameters should not be used directly since they might
104 in future implementations. Use the corresponding APIs. */
105 #define CLASS_DATA_FIELD 0
106 #define CLASS_VPTR_FIELD 1
107 #define CLASS_LEN_FIELD 2
108 #define VTABLE_HASH_FIELD 0
109 #define VTABLE_SIZE_FIELD 1
110 #define VTABLE_EXTENDS_FIELD 2
111 #define VTABLE_DEF_INIT_FIELD 3
112 #define VTABLE_COPY_FIELD 4
113 #define VTABLE_FINAL_FIELD 5
117 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
121 vec
<constructor_elt
, va_gc
> *init
= NULL
;
123 field
= TYPE_FIELDS (TREE_TYPE (decl
));
124 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
125 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
127 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
128 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
130 return build_constructor (TREE_TYPE (decl
), init
);
135 gfc_class_data_get (tree decl
)
138 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
139 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
140 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
142 return fold_build3_loc (input_location
, COMPONENT_REF
,
143 TREE_TYPE (data
), decl
, data
,
149 gfc_class_vptr_get (tree decl
)
152 /* For class arrays decl may be a temporary descriptor handle, the vptr is
153 then available through the saved descriptor. */
154 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
155 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
156 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
157 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
158 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
159 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
161 return fold_build3_loc (input_location
, COMPONENT_REF
,
162 TREE_TYPE (vptr
), decl
, vptr
,
168 gfc_class_len_get (tree decl
)
171 /* For class arrays decl may be a temporary descriptor handle, the len is
172 then available through the saved descriptor. */
173 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
174 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
175 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
176 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
177 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
178 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
180 return fold_build3_loc (input_location
, COMPONENT_REF
,
181 TREE_TYPE (len
), decl
, len
,
186 /* Get the specified FIELD from the VPTR. */
189 vptr_field_get (tree vptr
, int fieldno
)
192 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
193 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
195 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
196 TREE_TYPE (field
), vptr
, field
,
203 /* Get the field from the class' vptr. */
206 class_vtab_field_get (tree decl
, int fieldno
)
209 vptr
= gfc_class_vptr_get (decl
);
210 return vptr_field_get (vptr
, fieldno
);
214 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
216 #define VTAB_GET_FIELD_GEN(name, field) tree \
217 gfc_class_vtab_## name ##_get (tree cl) \
219 return class_vtab_field_get (cl, field); \
223 gfc_vptr_## name ##_get (tree vptr) \
225 return vptr_field_get (vptr, field); \
228 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
229 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
230 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
231 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
232 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
235 /* The size field is returned as an array index type. Therefore treat
236 it and only it specially. */
239 gfc_class_vtab_size_get (tree cl
)
242 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
243 /* Always return size as an array index type. */
244 size
= fold_convert (gfc_array_index_type
, size
);
250 gfc_vptr_size_get (tree vptr
)
253 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
254 /* Always return size as an array index type. */
255 size
= fold_convert (gfc_array_index_type
, size
);
261 #undef CLASS_DATA_FIELD
262 #undef CLASS_VPTR_FIELD
263 #undef VTABLE_HASH_FIELD
264 #undef VTABLE_SIZE_FIELD
265 #undef VTABLE_EXTENDS_FIELD
266 #undef VTABLE_DEF_INIT_FIELD
267 #undef VTABLE_COPY_FIELD
268 #undef VTABLE_FINAL_FIELD
271 /* Search for the last _class ref in the chain of references of this
272 expression and cut the chain there. Albeit this routine is similiar
273 to class.c::gfc_add_component_ref (), is there a significant
274 difference: gfc_add_component_ref () concentrates on an array ref to
275 be the last ref in the chain. This routine is oblivious to the kind
276 of refs following. */
279 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
282 gfc_ref
*ref
, *class_ref
, *tail
;
284 /* Find the last class reference. */
286 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
288 if (ref
->type
== REF_COMPONENT
289 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
292 if (ref
->next
== NULL
)
296 /* Remove and store all subsequent references after the
300 tail
= class_ref
->next
;
301 class_ref
->next
= NULL
;
309 base_expr
= gfc_expr_to_initialize (e
);
311 /* Restore the original tail expression. */
314 gfc_free_ref_list (class_ref
->next
);
315 class_ref
->next
= tail
;
319 gfc_free_ref_list (e
->ref
);
326 /* Reset the vptr to the declared type, e.g. after deallocation. */
329 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
331 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
336 /* If we have a class array, we need go back to the class
338 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
339 && lhs
->ref
->next
->type
== REF_ARRAY
340 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
341 && lhs
->ref
->type
== REF_COMPONENT
342 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
344 gfc_free_ref_list (lhs
->ref
);
348 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
349 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
350 && ref
->next
->next
->type
== REF_ARRAY
351 && ref
->next
->next
->u
.ar
.type
== AR_FULL
352 && ref
->next
->type
== REF_COMPONENT
353 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
355 gfc_free_ref_list (ref
->next
);
359 gfc_add_vptr_component (lhs
);
361 if (UNLIMITED_POLY (e
))
362 rhs
= gfc_get_null_expr (NULL
);
365 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
366 rhs
= gfc_lval_expr_from_sym (vtab
);
368 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
369 gfc_add_expr_to_block (block
, tmp
);
375 /* Reset the len for unlimited polymorphic objects. */
378 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
382 e
= gfc_find_and_cut_at_last_class_ref (expr
);
383 gfc_add_len_component (e
);
384 gfc_init_se (&se_len
, NULL
);
385 gfc_conv_expr (&se_len
, e
);
386 gfc_add_modify (block
, se_len
.expr
,
387 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
392 /* Obtain the vptr of the last class reference in an expression.
393 Return NULL_TREE if no class reference is found. */
396 gfc_get_vptr_from_expr (tree expr
)
401 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
403 type
= TREE_TYPE (tmp
);
406 if (GFC_CLASS_TYPE_P (type
))
407 return gfc_class_vptr_get (tmp
);
408 if (type
!= TYPE_CANONICAL (type
))
409 type
= TYPE_CANONICAL (type
);
413 if (TREE_CODE (tmp
) == VAR_DECL
)
421 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
424 tree tmp
, tmp2
, type
;
426 gfc_conv_descriptor_data_set (block
, lhs_desc
,
427 gfc_conv_descriptor_data_get (rhs_desc
));
428 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
429 gfc_conv_descriptor_offset_get (rhs_desc
));
431 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
432 gfc_conv_descriptor_dtype (rhs_desc
));
434 /* Assign the dimension as range-ref. */
435 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
436 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
438 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
439 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
440 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
441 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
442 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
443 gfc_add_modify (block
, tmp
, tmp2
);
447 /* Takes a derived type expression and returns the address of a temporary
448 class object of the 'declared' type. If vptr is not NULL, this is
449 used for the temporary class object.
450 optional_alloc_ptr is false when the dummy is neither allocatable
451 nor a pointer; that's only relevant for the optional handling. */
453 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
454 gfc_typespec class_ts
, tree vptr
, bool optional
,
455 bool optional_alloc_ptr
)
458 tree cond_optional
= NULL_TREE
;
464 /* The derived type needs to be converted to a temporary
466 tmp
= gfc_typenode_for_spec (&class_ts
);
467 var
= gfc_create_var (tmp
, "class");
470 ctree
= gfc_class_vptr_get (var
);
472 if (vptr
!= NULL_TREE
)
474 /* Use the dynamic vptr. */
479 /* In this case the vtab corresponds to the derived type and the
480 vptr must point to it. */
481 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
483 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
485 gfc_add_modify (&parmse
->pre
, ctree
,
486 fold_convert (TREE_TYPE (ctree
), tmp
));
488 /* Now set the data field. */
489 ctree
= gfc_class_data_get (var
);
492 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
494 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
496 /* For an array reference in an elemental procedure call we need
497 to retain the ss to provide the scalarized array reference. */
498 gfc_conv_expr_reference (parmse
, e
);
499 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
501 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
503 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
504 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
509 ss
= gfc_walk_expr (e
);
510 if (ss
== gfc_ss_terminator
)
513 gfc_conv_expr_reference (parmse
, e
);
515 /* Scalar to an assumed-rank array. */
516 if (class_ts
.u
.derived
->components
->as
)
519 type
= get_scalar_to_descriptor_type (parmse
->expr
,
521 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
522 gfc_get_dtype (type
));
524 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
525 TREE_TYPE (parmse
->expr
),
526 cond_optional
, parmse
->expr
,
527 fold_convert (TREE_TYPE (parmse
->expr
),
529 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
533 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
535 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
537 fold_convert (TREE_TYPE (tmp
),
539 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
545 gfc_init_block (&block
);
548 gfc_conv_expr_descriptor (parmse
, e
);
550 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
552 gcc_assert (class_ts
.u
.derived
->components
->as
->type
554 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
558 if (gfc_expr_attr (e
).codimension
)
559 parmse
->expr
= fold_build1_loc (input_location
,
563 gfc_add_modify (&block
, ctree
, parmse
->expr
);
568 tmp
= gfc_finish_block (&block
);
570 gfc_init_block (&block
);
571 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
573 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
574 gfc_finish_block (&block
));
575 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
578 gfc_add_block_to_block (&parmse
->pre
, &block
);
582 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
583 && class_ts
.u
.derived
->components
->ts
.u
.derived
584 ->attr
.unlimited_polymorphic
)
586 /* Take care about initializing the _len component correctly. */
587 ctree
= gfc_class_len_get (var
);
588 if (UNLIMITED_POLY (e
))
593 len
= gfc_copy_expr (e
);
594 gfc_add_len_component (len
);
595 gfc_init_se (&se
, NULL
);
596 gfc_conv_expr (&se
, len
);
598 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
599 cond_optional
, se
.expr
,
600 fold_convert (TREE_TYPE (se
.expr
),
606 tmp
= integer_zero_node
;
607 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
610 /* Pass the address of the class object. */
611 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
613 if (optional
&& optional_alloc_ptr
)
614 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
615 TREE_TYPE (parmse
->expr
),
616 cond_optional
, parmse
->expr
,
617 fold_convert (TREE_TYPE (parmse
->expr
),
622 /* Create a new class container, which is required as scalar coarrays
623 have an array descriptor while normal scalars haven't. Optionally,
624 NULL pointer checks are added if the argument is OPTIONAL. */
627 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
628 gfc_typespec class_ts
, bool optional
)
630 tree var
, ctree
, tmp
;
635 gfc_init_block (&block
);
638 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
640 if (ref
->type
== REF_COMPONENT
641 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
645 if (class_ref
== NULL
646 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
647 tmp
= e
->symtree
->n
.sym
->backend_decl
;
650 /* Remove everything after the last class reference, convert the
651 expression and then recover its tailend once more. */
653 ref
= class_ref
->next
;
654 class_ref
->next
= NULL
;
655 gfc_init_se (&tmpse
, NULL
);
656 gfc_conv_expr (&tmpse
, e
);
657 class_ref
->next
= ref
;
661 var
= gfc_typenode_for_spec (&class_ts
);
662 var
= gfc_create_var (var
, "class");
664 ctree
= gfc_class_vptr_get (var
);
665 gfc_add_modify (&block
, ctree
,
666 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
668 ctree
= gfc_class_data_get (var
);
669 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
670 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
672 /* Pass the address of the class object. */
673 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
677 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
680 tmp
= gfc_finish_block (&block
);
682 gfc_init_block (&block
);
683 tmp2
= gfc_class_data_get (var
);
684 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
686 tmp2
= gfc_finish_block (&block
);
688 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
690 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
693 gfc_add_block_to_block (&parmse
->pre
, &block
);
697 /* Takes an intrinsic type expression and returns the address of a temporary
698 class object of the 'declared' type. */
700 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
701 gfc_typespec class_ts
)
709 /* The intrinsic type needs to be converted to a temporary
711 tmp
= gfc_typenode_for_spec (&class_ts
);
712 var
= gfc_create_var (tmp
, "class");
715 ctree
= gfc_class_vptr_get (var
);
717 vtab
= gfc_find_vtab (&e
->ts
);
719 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
720 gfc_add_modify (&parmse
->pre
, ctree
,
721 fold_convert (TREE_TYPE (ctree
), tmp
));
723 /* Now set the data field. */
724 ctree
= gfc_class_data_get (var
);
725 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
727 /* For an array reference in an elemental procedure call we need
728 to retain the ss to provide the scalarized array reference. */
729 gfc_conv_expr_reference (parmse
, e
);
730 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
731 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
735 ss
= gfc_walk_expr (e
);
736 if (ss
== gfc_ss_terminator
)
739 gfc_conv_expr_reference (parmse
, e
);
740 if (class_ts
.u
.derived
->components
->as
741 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
743 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
745 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
746 TREE_TYPE (ctree
), tmp
);
749 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
750 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
755 parmse
->use_offset
= 1;
756 gfc_conv_expr_descriptor (parmse
, e
);
757 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
759 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
760 TREE_TYPE (ctree
), parmse
->expr
);
761 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
764 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
768 gcc_assert (class_ts
.type
== BT_CLASS
);
769 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
770 && class_ts
.u
.derived
->components
->ts
.u
.derived
771 ->attr
.unlimited_polymorphic
)
773 ctree
= gfc_class_len_get (var
);
774 /* When the actual arg is a char array, then set the _len component of the
775 unlimited polymorphic entity, too. */
776 if (e
->ts
.type
== BT_CHARACTER
)
778 /* Start with parmse->string_length because this seems to be set to a
779 correct value more often. */
780 if (parmse
->string_length
)
781 tmp
= parmse
->string_length
;
782 /* When the string_length is not yet set, then try the backend_decl of
784 else if (e
->ts
.u
.cl
->backend_decl
)
785 tmp
= e
->ts
.u
.cl
->backend_decl
;
786 /* If both of the above approaches fail, then try to generate an
787 expression from the input, which is only feasible currently, when the
788 expression can be evaluated to a constant one. */
791 /* Try to simplify the expression. */
792 gfc_simplify_expr (e
, 0);
793 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
795 /* Amazingly all data is present to compute the length of a
796 constant string, but the expression is not yet there. */
797 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
799 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
800 e
->value
.character
.length
);
801 gfc_conv_const_charlen (e
->ts
.u
.cl
);
802 e
->ts
.u
.cl
->resolved
= 1;
803 tmp
= e
->ts
.u
.cl
->backend_decl
;
807 gfc_error ("Can't compute the length of the char array at %L.",
813 tmp
= integer_zero_node
;
815 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
817 else if (class_ts
.type
== BT_CLASS
818 && class_ts
.u
.derived
->components
819 && class_ts
.u
.derived
->components
->ts
.u
820 .derived
->attr
.unlimited_polymorphic
)
822 ctree
= gfc_class_len_get (var
);
823 gfc_add_modify (&parmse
->pre
, ctree
,
824 fold_convert (TREE_TYPE (ctree
),
827 /* Pass the address of the class object. */
828 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
832 /* Takes a scalarized class array expression and returns the
833 address of a temporary scalar class object of the 'declared'
835 OOP-TODO: This could be improved by adding code that branched on
836 the dynamic type being the same as the declared type. In this case
837 the original class expression can be passed directly.
838 optional_alloc_ptr is false when the dummy is neither allocatable
839 nor a pointer; that's relevant for the optional handling.
840 Set copyback to true if class container's _data and _vtab pointers
841 might get modified. */
844 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
845 bool elemental
, bool copyback
, bool optional
,
846 bool optional_alloc_ptr
)
852 tree cond
= NULL_TREE
;
853 tree slen
= NULL_TREE
;
857 bool full_array
= false;
859 gfc_init_block (&block
);
862 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
864 if (ref
->type
== REF_COMPONENT
865 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
868 if (ref
->next
== NULL
)
872 if ((ref
== NULL
|| class_ref
== ref
)
873 && (!class_ts
.u
.derived
->components
->as
874 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
877 /* Test for FULL_ARRAY. */
878 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
879 && gfc_expr_attr (e
).dimension
)
882 gfc_is_class_array_ref (e
, &full_array
);
884 /* The derived type needs to be converted to a temporary
886 tmp
= gfc_typenode_for_spec (&class_ts
);
887 var
= gfc_create_var (tmp
, "class");
890 ctree
= gfc_class_data_get (var
);
891 if (class_ts
.u
.derived
->components
->as
892 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
896 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
898 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
899 gfc_get_dtype (type
));
901 tmp
= gfc_class_data_get (parmse
->expr
);
902 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
903 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
905 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
908 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
912 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
913 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
914 TREE_TYPE (ctree
), parmse
->expr
);
915 gfc_add_modify (&block
, ctree
, parmse
->expr
);
918 /* Return the data component, except in the case of scalarized array
919 references, where nullification of the cannot occur and so there
921 if (!elemental
&& full_array
&& copyback
)
923 if (class_ts
.u
.derived
->components
->as
924 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
927 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
928 gfc_conv_descriptor_data_get (ctree
));
930 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
933 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
937 ctree
= gfc_class_vptr_get (var
);
939 /* The vptr is the second field of the actual argument.
940 First we have to find the corresponding class reference. */
943 if (class_ref
== NULL
944 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
946 tmp
= e
->symtree
->n
.sym
->backend_decl
;
947 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
948 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
949 slen
= integer_zero_node
;
953 /* Remove everything after the last class reference, convert the
954 expression and then recover its tailend once more. */
956 ref
= class_ref
->next
;
957 class_ref
->next
= NULL
;
958 gfc_init_se (&tmpse
, NULL
);
959 gfc_conv_expr (&tmpse
, e
);
960 class_ref
->next
= ref
;
962 slen
= tmpse
.string_length
;
965 gcc_assert (tmp
!= NULL_TREE
);
967 /* Dereference if needs be. */
968 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
969 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
971 vptr
= gfc_class_vptr_get (tmp
);
972 gfc_add_modify (&block
, ctree
,
973 fold_convert (TREE_TYPE (ctree
), vptr
));
975 /* Return the vptr component, except in the case of scalarized array
976 references, where the dynamic type cannot change. */
977 if (!elemental
&& full_array
&& copyback
)
978 gfc_add_modify (&parmse
->post
, vptr
,
979 fold_convert (TREE_TYPE (vptr
), ctree
));
981 /* For unlimited polymorphic objects also set the _len component. */
982 if (class_ts
.type
== BT_CLASS
983 && class_ts
.u
.derived
->components
984 && class_ts
.u
.derived
->components
->ts
.u
985 .derived
->attr
.unlimited_polymorphic
)
987 ctree
= gfc_class_len_get (var
);
988 if (UNLIMITED_POLY (e
))
989 tmp
= gfc_class_len_get (tmp
);
990 else if (e
->ts
.type
== BT_CHARACTER
)
992 gcc_assert (slen
!= NULL_TREE
);
996 tmp
= integer_zero_node
;
997 gfc_add_modify (&parmse
->pre
, ctree
,
998 fold_convert (TREE_TYPE (ctree
), tmp
));
1005 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1006 /* parmse->pre may contain some preparatory instructions for the
1007 temporary array descriptor. Those may only be executed when the
1008 optional argument is set, therefore add parmse->pre's instructions
1009 to block, which is later guarded by an if (optional_arg_given). */
1010 gfc_add_block_to_block (&parmse
->pre
, &block
);
1011 block
.head
= parmse
->pre
.head
;
1012 parmse
->pre
.head
= NULL_TREE
;
1013 tmp
= gfc_finish_block (&block
);
1015 if (optional_alloc_ptr
)
1016 tmp2
= build_empty_stmt (input_location
);
1019 gfc_init_block (&block
);
1021 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1022 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1023 null_pointer_node
));
1024 tmp2
= gfc_finish_block (&block
);
1027 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1029 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1032 gfc_add_block_to_block (&parmse
->pre
, &block
);
1034 /* Pass the address of the class object. */
1035 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1037 if (optional
&& optional_alloc_ptr
)
1038 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1039 TREE_TYPE (parmse
->expr
),
1041 fold_convert (TREE_TYPE (parmse
->expr
),
1042 null_pointer_node
));
1046 /* Given a class array declaration and an index, returns the address
1047 of the referenced element. */
1050 gfc_get_class_array_ref (tree index
, tree class_decl
)
1052 tree data
= gfc_class_data_get (class_decl
);
1053 tree size
= gfc_class_vtab_size_get (class_decl
);
1054 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1055 gfc_array_index_type
,
1058 data
= gfc_conv_descriptor_data_get (data
);
1059 ptr
= fold_convert (pvoid_type_node
, data
);
1060 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1061 return fold_convert (TREE_TYPE (data
), ptr
);
1065 /* Copies one class expression to another, assuming that if either
1066 'to' or 'from' are arrays they are packed. Should 'from' be
1067 NULL_TREE, the initialization expression for 'to' is used, assuming
1068 that the _vptr is set. */
1071 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1081 vec
<tree
, va_gc
> *args
;
1088 /* To prevent warnings on uninitialized variables. */
1089 from_len
= to_len
= NULL_TREE
;
1091 if (from
!= NULL_TREE
)
1092 fcn
= gfc_class_vtab_copy_get (from
);
1094 fcn
= gfc_class_vtab_copy_get (to
);
1096 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1098 if (from
!= NULL_TREE
)
1099 from_data
= gfc_class_data_get (from
);
1101 from_data
= gfc_class_vtab_def_init_get (to
);
1105 if (from
!= NULL_TREE
&& unlimited
)
1106 from_len
= gfc_class_len_get (from
);
1108 from_len
= integer_zero_node
;
1111 to_data
= gfc_class_data_get (to
);
1113 to_len
= gfc_class_len_get (to
);
1115 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1117 stmtblock_t loopbody
;
1122 gfc_init_block (&body
);
1123 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1124 gfc_array_index_type
, nelems
,
1125 gfc_index_one_node
);
1126 nelems
= gfc_evaluate_now (tmp
, &body
);
1127 index
= gfc_create_var (gfc_array_index_type
, "S");
1129 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
1131 from_ref
= gfc_get_class_array_ref (index
, from
);
1132 vec_safe_push (args
, from_ref
);
1135 vec_safe_push (args
, from_data
);
1137 to_ref
= gfc_get_class_array_ref (index
, to
);
1138 vec_safe_push (args
, to_ref
);
1140 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1142 /* Build the body of the loop. */
1143 gfc_init_block (&loopbody
);
1144 gfc_add_expr_to_block (&loopbody
, tmp
);
1146 /* Build the loop and return. */
1147 gfc_init_loopinfo (&loop
);
1149 loop
.from
[0] = gfc_index_zero_node
;
1150 loop
.loopvar
[0] = index
;
1151 loop
.to
[0] = nelems
;
1152 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1153 gfc_init_block (&ifbody
);
1154 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1155 stdcopy
= gfc_finish_block (&ifbody
);
1156 /* In initialization mode from_len is a constant zero. */
1157 if (unlimited
&& !integer_zerop (from_len
))
1159 vec_safe_push (args
, from_len
);
1160 vec_safe_push (args
, to_len
);
1161 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1162 /* Build the body of the loop. */
1163 gfc_init_block (&loopbody
);
1164 gfc_add_expr_to_block (&loopbody
, tmp
);
1166 /* Build the loop and return. */
1167 gfc_init_loopinfo (&loop
);
1169 loop
.from
[0] = gfc_index_zero_node
;
1170 loop
.loopvar
[0] = index
;
1171 loop
.to
[0] = nelems
;
1172 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1173 gfc_init_block (&ifbody
);
1174 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1175 extcopy
= gfc_finish_block (&ifbody
);
1177 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1178 boolean_type_node
, from_len
,
1180 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1181 void_type_node
, tmp
, extcopy
, stdcopy
);
1182 gfc_add_expr_to_block (&body
, tmp
);
1183 tmp
= gfc_finish_block (&body
);
1187 gfc_add_expr_to_block (&body
, stdcopy
);
1188 tmp
= gfc_finish_block (&body
);
1190 gfc_cleanup_loop (&loop
);
1194 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
1195 vec_safe_push (args
, from_data
);
1196 vec_safe_push (args
, to_data
);
1197 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1199 /* In initialization mode from_len is a constant zero. */
1200 if (unlimited
&& !integer_zerop (from_len
))
1202 vec_safe_push (args
, from_len
);
1203 vec_safe_push (args
, to_len
);
1204 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1205 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1206 boolean_type_node
, from_len
,
1208 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1209 void_type_node
, tmp
, extcopy
, stdcopy
);
1215 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1216 if (from
== NULL_TREE
)
1219 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1221 from_data
, null_pointer_node
);
1222 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1223 void_type_node
, cond
,
1224 tmp
, build_empty_stmt (input_location
));
1232 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1234 gfc_actual_arglist
*actual
;
1239 actual
= gfc_get_actual_arglist ();
1240 actual
->expr
= gfc_copy_expr (rhs
);
1241 actual
->next
= gfc_get_actual_arglist ();
1242 actual
->next
->expr
= gfc_copy_expr (lhs
);
1243 ppc
= gfc_copy_expr (obj
);
1244 gfc_add_vptr_component (ppc
);
1245 gfc_add_component_ref (ppc
, "_copy");
1246 ppc_code
= gfc_get_code (EXEC_CALL
);
1247 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1248 /* Although '_copy' is set to be elemental in class.c, it is
1249 not staying that way. Find out why, sometime.... */
1250 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1251 ppc_code
->ext
.actual
= actual
;
1252 ppc_code
->expr1
= ppc
;
1253 /* Since '_copy' is elemental, the scalarizer will take care
1254 of arrays in gfc_trans_call. */
1255 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1256 gfc_free_statements (ppc_code
);
1258 if (UNLIMITED_POLY(obj
))
1260 /* Check if rhs is non-NULL. */
1262 gfc_init_se (&src
, NULL
);
1263 gfc_conv_expr (&src
, rhs
);
1264 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1265 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1266 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1267 null_pointer_node
));
1268 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1269 build_empty_stmt (input_location
));
1275 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1276 A MEMCPY is needed to copy the full data from the default initializer
1277 of the dynamic type. */
1280 gfc_trans_class_init_assign (gfc_code
*code
)
1284 gfc_se dst
,src
,memsz
;
1285 gfc_expr
*lhs
, *rhs
, *sz
;
1287 gfc_start_block (&block
);
1289 lhs
= gfc_copy_expr (code
->expr1
);
1290 gfc_add_data_component (lhs
);
1292 rhs
= gfc_copy_expr (code
->expr1
);
1293 gfc_add_vptr_component (rhs
);
1295 /* Make sure that the component backend_decls have been built, which
1296 will not have happened if the derived types concerned have not
1298 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1299 gfc_add_def_init_component (rhs
);
1300 /* The _def_init is always scalar. */
1303 if (code
->expr1
->ts
.type
== BT_CLASS
1304 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1305 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1308 sz
= gfc_copy_expr (code
->expr1
);
1309 gfc_add_vptr_component (sz
);
1310 gfc_add_size_component (sz
);
1312 gfc_init_se (&dst
, NULL
);
1313 gfc_init_se (&src
, NULL
);
1314 gfc_init_se (&memsz
, NULL
);
1315 gfc_conv_expr (&dst
, lhs
);
1316 gfc_conv_expr (&src
, rhs
);
1317 gfc_conv_expr (&memsz
, sz
);
1318 gfc_add_block_to_block (&block
, &src
.pre
);
1319 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1321 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1323 if (UNLIMITED_POLY(code
->expr1
))
1325 /* Check if _def_init is non-NULL. */
1326 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1327 boolean_type_node
, src
.expr
,
1328 fold_convert (TREE_TYPE (src
.expr
),
1329 null_pointer_node
));
1330 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1331 tmp
, build_empty_stmt (input_location
));
1335 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1336 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1338 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1339 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1341 build_empty_stmt (input_location
));
1344 gfc_add_expr_to_block (&block
, tmp
);
1346 return gfc_finish_block (&block
);
1350 /* Translate an assignment to a CLASS object
1351 (pointer or ordinary assignment). */
1354 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1362 gfc_start_block (&block
);
1365 while (ref
&& ref
->next
)
1368 /* Class valued proc_pointer assignments do not need any further
1370 if (ref
&& ref
->type
== REF_COMPONENT
1371 && ref
->u
.c
.component
->attr
.proc_pointer
1372 && expr2
->expr_type
== EXPR_VARIABLE
1373 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1374 && op
== EXEC_POINTER_ASSIGN
)
1377 if (expr2
->ts
.type
!= BT_CLASS
)
1379 /* Insert an additional assignment which sets the '_vptr' field. */
1380 gfc_symbol
*vtab
= NULL
;
1383 lhs
= gfc_copy_expr (expr1
);
1384 gfc_add_vptr_component (lhs
);
1386 if (UNLIMITED_POLY (expr1
)
1387 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1389 rhs
= gfc_get_null_expr (&expr2
->where
);
1393 if (expr2
->expr_type
== EXPR_NULL
)
1394 vtab
= gfc_find_vtab (&expr1
->ts
);
1396 vtab
= gfc_find_vtab (&expr2
->ts
);
1399 rhs
= gfc_get_expr ();
1400 rhs
->expr_type
= EXPR_VARIABLE
;
1401 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1405 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1406 gfc_add_expr_to_block (&block
, tmp
);
1408 gfc_free_expr (lhs
);
1409 gfc_free_expr (rhs
);
1411 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1413 /* F2003:C717 only sequence and bind-C types can come here. */
1414 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1415 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1416 gfc_add_data_component (expr2
);
1419 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1421 /* Insert an additional assignment which sets the '_vptr' field. */
1422 lhs
= gfc_copy_expr (expr1
);
1423 gfc_add_vptr_component (lhs
);
1425 rhs
= gfc_copy_expr (expr2
);
1426 gfc_add_vptr_component (rhs
);
1428 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1429 gfc_add_expr_to_block (&block
, tmp
);
1431 gfc_free_expr (lhs
);
1432 gfc_free_expr (rhs
);
1435 /* Do the actual CLASS assignment. */
1436 if (expr2
->ts
.type
== BT_CLASS
1437 && !CLASS_DATA (expr2
)->attr
.dimension
)
1439 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1440 || !CLASS_DATA (expr2
)->attr
.dimension
)
1441 gfc_add_data_component (expr1
);
1445 if (op
== EXEC_ASSIGN
)
1446 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1447 else if (op
== EXEC_POINTER_ASSIGN
)
1448 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1452 gfc_add_expr_to_block (&block
, tmp
);
1454 return gfc_finish_block (&block
);
1458 /* End of prototype trans-class.c */
1462 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1464 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1465 gfc_warning (OPT_Wrealloc_lhs
,
1466 "Code for reallocating the allocatable array at %L will "
1468 else if (warn_realloc_lhs_all
)
1469 gfc_warning (OPT_Wrealloc_lhs_all
,
1470 "Code for reallocating the allocatable variable at %L "
1471 "will be added", where
);
1475 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
);
1476 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1479 /* Copy the scalarization loop variables. */
1482 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1485 dest
->loop
= src
->loop
;
1489 /* Initialize a simple expression holder.
1491 Care must be taken when multiple se are created with the same parent.
1492 The child se must be kept in sync. The easiest way is to delay creation
1493 of a child se until after after the previous se has been translated. */
1496 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1498 memset (se
, 0, sizeof (gfc_se
));
1499 gfc_init_block (&se
->pre
);
1500 gfc_init_block (&se
->post
);
1502 se
->parent
= parent
;
1505 gfc_copy_se_loopvars (se
, parent
);
1509 /* Advances to the next SS in the chain. Use this rather than setting
1510 se->ss = se->ss->next because all the parents needs to be kept in sync.
1514 gfc_advance_se_ss_chain (gfc_se
* se
)
1519 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1522 /* Walk down the parent chain. */
1525 /* Simple consistency check. */
1526 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1527 || p
->parent
->ss
->nested_ss
== p
->ss
);
1529 /* If we were in a nested loop, the next scalarized expression can be
1530 on the parent ss' next pointer. Thus we should not take the next
1531 pointer blindly, but rather go up one nest level as long as next
1532 is the end of chain. */
1534 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1544 /* Ensures the result of the expression as either a temporary variable
1545 or a constant so that it can be used repeatedly. */
1548 gfc_make_safe_expr (gfc_se
* se
)
1552 if (CONSTANT_CLASS_P (se
->expr
))
1555 /* We need a temporary for this result. */
1556 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1557 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1562 /* Return an expression which determines if a dummy parameter is present.
1563 Also used for arguments to procedures with multiple entry points. */
1566 gfc_conv_expr_present (gfc_symbol
* sym
)
1570 gcc_assert (sym
->attr
.dummy
);
1571 decl
= gfc_get_symbol_decl (sym
);
1573 /* Intrinsic scalars with VALUE attribute which are passed by value
1574 use a hidden argument to denote the present status. */
1575 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1576 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1577 && !sym
->attr
.dimension
)
1579 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1582 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1584 strcpy (&name
[1], sym
->name
);
1585 tree_name
= get_identifier (name
);
1587 /* Walk function argument list to find hidden arg. */
1588 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1589 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1590 if (DECL_NAME (cond
) == tree_name
)
1597 if (TREE_CODE (decl
) != PARM_DECL
)
1599 /* Array parameters use a temporary descriptor, we want the real
1601 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1602 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1603 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1606 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1607 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1609 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1610 as actual argument to denote absent dummies. For array descriptors,
1611 we thus also need to check the array descriptor. For BT_CLASS, it
1612 can also occur for scalars and F2003 due to type->class wrapping and
1613 class->class wrapping. Note further that BT_CLASS always uses an
1614 array descriptor for arrays, also for explicit-shape/assumed-size. */
1616 if (!sym
->attr
.allocatable
1617 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1618 || (sym
->ts
.type
== BT_CLASS
1619 && !CLASS_DATA (sym
)->attr
.allocatable
1620 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1621 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1622 || sym
->ts
.type
== BT_CLASS
))
1626 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1627 || sym
->as
->type
== AS_ASSUMED_RANK
1628 || sym
->attr
.codimension
))
1629 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1631 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1632 if (sym
->ts
.type
== BT_CLASS
)
1633 tmp
= gfc_class_data_get (tmp
);
1634 tmp
= gfc_conv_array_data (tmp
);
1636 else if (sym
->ts
.type
== BT_CLASS
)
1637 tmp
= gfc_class_data_get (decl
);
1641 if (tmp
!= NULL_TREE
)
1643 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1644 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1645 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1646 boolean_type_node
, cond
, tmp
);
1654 /* Converts a missing, dummy argument into a null or zero. */
1657 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1662 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1666 /* Create a temporary and convert it to the correct type. */
1667 tmp
= gfc_get_int_type (kind
);
1668 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1671 /* Test for a NULL value. */
1672 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1673 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1674 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1675 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1679 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1681 build_zero_cst (TREE_TYPE (se
->expr
)));
1682 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1686 if (ts
.type
== BT_CHARACTER
)
1688 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1689 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1690 present
, se
->string_length
, tmp
);
1691 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1692 se
->string_length
= tmp
;
1698 /* Get the character length of an expression, looking through gfc_refs
1702 gfc_get_expr_charlen (gfc_expr
*e
)
1707 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1708 && e
->ts
.type
== BT_CHARACTER
);
1710 length
= NULL
; /* To silence compiler warning. */
1712 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1715 gfc_init_se (&tmpse
, NULL
);
1716 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1717 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1721 /* First candidate: if the variable is of type CHARACTER, the
1722 expression's length could be the length of the character
1724 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1725 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1727 /* Look through the reference chain for component references. */
1728 for (r
= e
->ref
; r
; r
= r
->next
)
1733 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1734 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1742 /* We should never got substring references here. These will be
1743 broken down by the scalarizer. */
1749 gcc_assert (length
!= NULL
);
1754 /* Return for an expression the backend decl of the coarray. */
1757 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1761 gfc_ref
*ref
, *comp_ref
= NULL
;
1763 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1765 /* Not-implemented diagnostic. */
1766 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1767 if (ref
->type
== REF_COMPONENT
)
1770 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1771 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1772 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1773 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1774 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1775 && !ref
->u
.c
.component
->attr
.codimension
1776 && (ref
->u
.c
.component
->attr
.pointer
1777 || ref
->u
.c
.component
->attr
.allocatable
)))
1778 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1779 "component of the coindexed coarray at %L is not yet "
1780 "supported", &expr
->where
);
1783 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1784 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1785 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1786 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1788 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1789 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1790 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1791 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1792 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1793 "not yet supported", &expr
->where
);
1797 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1798 general not possible as the required stride multiplier might be not
1799 a multiple of c_sizeof(b). In case of noncoindexed access, the
1800 scalarizer often takes care of it - for coarrays, it always fails. */
1801 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1802 if (ref
->type
== REF_COMPONENT
1803 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1804 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1805 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1806 && ref
->u
.c
.component
->attr
.codimension
)))
1810 for ( ; ref
; ref
= ref
->next
)
1811 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1813 for ( ; ref
; ref
= ref
->next
)
1814 if (ref
->type
== REF_COMPONENT
)
1815 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1816 "with an array partref is not yet supported",
1820 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1821 gcc_assert (caf_decl
);
1822 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1823 caf_decl
= gfc_class_data_get (caf_decl
);
1824 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1827 /* The following code assumes that the coarray is a component reachable via
1828 only scalar components/variables; the Fortran standard guarantees this. */
1830 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1831 if (ref
->type
== REF_COMPONENT
)
1833 gfc_component
*comp
= ref
->u
.c
.component
;
1835 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1836 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1837 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1838 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1839 comp
->backend_decl
, NULL_TREE
);
1840 if (comp
->ts
.type
== BT_CLASS
)
1841 caf_decl
= gfc_class_data_get (caf_decl
);
1842 if (comp
->attr
.codimension
)
1848 gcc_assert (found
&& caf_decl
);
1853 /* Obtain the Coarray token - and optionally also the offset. */
1856 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1861 /* Coarray token. */
1862 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1864 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1865 == GFC_ARRAY_ALLOCATABLE
1866 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1867 *token
= gfc_conv_descriptor_token (caf_decl
);
1869 else if (DECL_LANG_SPECIFIC (caf_decl
)
1870 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1871 *token
= GFC_DECL_TOKEN (caf_decl
);
1874 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1875 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1876 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1882 /* Offset between the coarray base address and the address wanted. */
1883 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1884 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1885 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1886 *offset
= build_int_cst (gfc_array_index_type
, 0);
1887 else if (DECL_LANG_SPECIFIC (caf_decl
)
1888 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1889 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1890 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1891 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1893 *offset
= build_int_cst (gfc_array_index_type
, 0);
1895 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1896 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1898 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1899 tmp
= gfc_conv_descriptor_data_get (tmp
);
1901 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1902 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1905 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1909 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1910 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1912 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1913 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1916 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1920 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1921 fold_convert (gfc_array_index_type
, *offset
),
1922 fold_convert (gfc_array_index_type
, tmp
));
1926 /* Convert the coindex of a coarray into an image index; the result is
1927 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1928 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1931 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1934 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1938 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1939 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1941 gcc_assert (ref
!= NULL
);
1943 img_idx
= integer_zero_node
;
1944 extent
= integer_one_node
;
1945 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1946 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1948 gfc_init_se (&se
, NULL
);
1949 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1950 gfc_add_block_to_block (block
, &se
.pre
);
1951 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1952 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1953 integer_type_node
, se
.expr
,
1954 fold_convert(integer_type_node
, lbound
));
1955 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1957 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1959 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1961 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1962 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1963 tmp
= fold_convert (integer_type_node
, tmp
);
1964 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1965 integer_type_node
, extent
, tmp
);
1969 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1971 gfc_init_se (&se
, NULL
);
1972 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1973 gfc_add_block_to_block (block
, &se
.pre
);
1974 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1975 lbound
= fold_convert (integer_type_node
, lbound
);
1976 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1977 integer_type_node
, se
.expr
, lbound
);
1978 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1980 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1982 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1984 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1985 ubound
= fold_convert (integer_type_node
, ubound
);
1986 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1987 integer_type_node
, ubound
, lbound
);
1988 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1989 tmp
, integer_one_node
);
1990 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1991 integer_type_node
, extent
, tmp
);
1994 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1995 img_idx
, integer_one_node
);
2000 /* For each character array constructor subexpression without a ts.u.cl->length,
2001 replace it by its first element (if there aren't any elements, the length
2002 should already be set to zero). */
2005 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2007 gfc_actual_arglist
* arg
;
2013 switch (e
->expr_type
)
2017 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2018 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2022 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2026 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2027 flatten_array_ctors_without_strlen (arg
->expr
);
2032 /* We've found what we're looking for. */
2033 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2038 gcc_assert (e
->value
.constructor
);
2040 c
= gfc_constructor_first (e
->value
.constructor
);
2044 flatten_array_ctors_without_strlen (new_expr
);
2045 gfc_replace_expr (e
, new_expr
);
2049 /* Otherwise, fall through to handle constructor elements. */
2050 case EXPR_STRUCTURE
:
2051 for (c
= gfc_constructor_first (e
->value
.constructor
);
2052 c
; c
= gfc_constructor_next (c
))
2053 flatten_array_ctors_without_strlen (c
->expr
);
2063 /* Generate code to initialize a string length variable. Returns the
2064 value. For array constructors, cl->length might be NULL and in this case,
2065 the first element of the constructor is needed. expr is the original
2066 expression so we can access it but can be NULL if this is not needed. */
2069 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2073 gfc_init_se (&se
, NULL
);
2077 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2080 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2081 "flatten" array constructors by taking their first element; all elements
2082 should be the same length or a cl->length should be present. */
2085 gfc_expr
* expr_flat
;
2087 expr_flat
= gfc_copy_expr (expr
);
2088 flatten_array_ctors_without_strlen (expr_flat
);
2089 gfc_resolve_expr (expr_flat
);
2091 gfc_conv_expr (&se
, expr_flat
);
2092 gfc_add_block_to_block (pblock
, &se
.pre
);
2093 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2095 gfc_free_expr (expr_flat
);
2099 /* Convert cl->length. */
2101 gcc_assert (cl
->length
);
2103 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2104 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2105 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2106 gfc_add_block_to_block (pblock
, &se
.pre
);
2108 if (cl
->backend_decl
)
2109 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2111 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2116 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2117 const char *name
, locus
*where
)
2127 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2128 type
= build_pointer_type (type
);
2130 gfc_init_se (&start
, se
);
2131 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2132 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2134 if (integer_onep (start
.expr
))
2135 gfc_conv_string_parameter (se
);
2140 /* Avoid multiple evaluation of substring start. */
2141 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2142 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2144 /* Change the start of the string. */
2145 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2148 tmp
= build_fold_indirect_ref_loc (input_location
,
2150 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2151 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2154 /* Length = end + 1 - start. */
2155 gfc_init_se (&end
, se
);
2156 if (ref
->u
.ss
.end
== NULL
)
2157 end
.expr
= se
->string_length
;
2160 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2161 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2165 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2166 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2168 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2170 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2171 boolean_type_node
, start
.expr
,
2174 /* Check lower bound. */
2175 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2177 build_int_cst (gfc_charlen_type_node
, 1));
2178 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2179 boolean_type_node
, nonempty
, fault
);
2181 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2182 "is less than one", name
);
2184 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2185 "is less than one");
2186 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2187 fold_convert (long_integer_type_node
,
2191 /* Check upper bound. */
2192 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2193 end
.expr
, se
->string_length
);
2194 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2195 boolean_type_node
, nonempty
, fault
);
2197 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2198 "exceeds string length (%%ld)", name
);
2200 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2201 "exceeds string length (%%ld)");
2202 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2203 fold_convert (long_integer_type_node
, end
.expr
),
2204 fold_convert (long_integer_type_node
,
2205 se
->string_length
));
2209 /* Try to calculate the length from the start and end expressions. */
2211 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2215 i_len
= mpz_get_si (length
) + 1;
2219 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2220 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2224 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2225 end
.expr
, start
.expr
);
2226 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2227 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2228 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2229 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2232 se
->string_length
= tmp
;
2236 /* Convert a derived type component reference. */
2239 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2246 c
= ref
->u
.c
.component
;
2248 if (c
->backend_decl
== NULL_TREE
2249 && ref
->u
.c
.sym
!= NULL
)
2250 gfc_get_derived_type (ref
->u
.c
.sym
);
2252 field
= c
->backend_decl
;
2253 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2256 /* Components can correspond to fields of different containing
2257 types, as components are created without context, whereas
2258 a concrete use of a component has the type of decl as context.
2259 So, if the type doesn't match, we search the corresponding
2260 FIELD_DECL in the parent type. To not waste too much time
2261 we cache this result in norestrict_decl. */
2263 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
2265 tree f2
= c
->norestrict_decl
;
2266 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2267 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2268 if (TREE_CODE (f2
) == FIELD_DECL
2269 && DECL_NAME (f2
) == DECL_NAME (field
))
2272 c
->norestrict_decl
= f2
;
2276 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2277 && strcmp ("_data", c
->name
) == 0)
2279 /* Found a ref to the _data component. Store the associated ref to
2280 the vptr in se->class_vptr. */
2281 se
->class_vptr
= gfc_class_vptr_get (decl
);
2284 se
->class_vptr
= NULL_TREE
;
2286 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2287 decl
, field
, NULL_TREE
);
2291 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2292 strlen () conditional below. */
2293 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2294 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2296 tmp
= c
->ts
.u
.cl
->backend_decl
;
2297 /* Components must always be constant length. */
2298 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2299 se
->string_length
= tmp
;
2302 if (gfc_deferred_strlen (c
, &field
))
2304 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2306 decl
, field
, NULL_TREE
);
2307 se
->string_length
= tmp
;
2310 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2311 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2312 && c
->ts
.type
!= BT_CHARACTER
)
2313 || c
->attr
.proc_pointer
)
2314 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2319 /* This function deals with component references to components of the
2320 parent type for derived type extensions. */
2322 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2330 c
= ref
->u
.c
.component
;
2332 /* Return if the component is in the parent type. */
2333 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2334 if (strcmp (c
->name
, cmp
->name
) == 0)
2337 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2338 parent
.type
= REF_COMPONENT
;
2340 parent
.u
.c
.sym
= dt
;
2341 parent
.u
.c
.component
= dt
->components
;
2343 if (dt
->backend_decl
== NULL
)
2344 gfc_get_derived_type (dt
);
2346 /* Build the reference and call self. */
2347 gfc_conv_component_ref (se
, &parent
);
2348 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2349 parent
.u
.c
.component
= c
;
2350 conv_parent_component_references (se
, &parent
);
2353 /* Return the contents of a variable. Also handles reference/pointer
2354 variables (all Fortran pointer references are implicit). */
2357 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2362 tree parent_decl
= NULL_TREE
;
2365 bool alternate_entry
;
2368 bool first_time
= true;
2370 sym
= expr
->symtree
->n
.sym
;
2371 is_classarray
= IS_CLASS_ARRAY (sym
);
2375 gfc_ss_info
*ss_info
= ss
->info
;
2377 /* Check that something hasn't gone horribly wrong. */
2378 gcc_assert (ss
!= gfc_ss_terminator
);
2379 gcc_assert (ss_info
->expr
== expr
);
2381 /* A scalarized term. We already know the descriptor. */
2382 se
->expr
= ss_info
->data
.array
.descriptor
;
2383 se
->string_length
= ss_info
->string_length
;
2384 ref
= ss_info
->data
.array
.ref
;
2386 gcc_assert (ref
->type
== REF_ARRAY
2387 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2389 gfc_conv_tmp_array_ref (se
);
2393 tree se_expr
= NULL_TREE
;
2395 se
->expr
= gfc_get_symbol_decl (sym
);
2397 /* Deal with references to a parent results or entries by storing
2398 the current_function_decl and moving to the parent_decl. */
2399 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2400 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2401 && sym
->result
== sym
;
2402 entry_master
= sym
->attr
.result
2403 && sym
->ns
->proc_name
->attr
.entry_master
2404 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2405 if (current_function_decl
)
2406 parent_decl
= DECL_CONTEXT (current_function_decl
);
2408 if ((se
->expr
== parent_decl
&& return_value
)
2409 || (sym
->ns
&& sym
->ns
->proc_name
2411 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2412 && (alternate_entry
|| entry_master
)))
2417 /* Special case for assigning the return value of a function.
2418 Self recursive functions must have an explicit return value. */
2419 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2420 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2422 /* Similarly for alternate entry points. */
2423 else if (alternate_entry
2424 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2427 gfc_entry_list
*el
= NULL
;
2429 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2432 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2437 else if (entry_master
2438 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2440 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2445 /* Procedure actual arguments. */
2446 else if (sym
->attr
.flavor
== FL_PROCEDURE
2447 && se
->expr
!= current_function_decl
)
2449 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2451 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2452 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2458 /* Dereference the expression, where needed. Since characters
2459 are entirely different from other types, they are treated
2461 if (sym
->ts
.type
== BT_CHARACTER
)
2463 /* Dereference character pointer dummy arguments
2465 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2467 || sym
->attr
.function
2468 || sym
->attr
.result
))
2469 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2473 else if (!sym
->attr
.value
)
2475 /* Dereference temporaries for class array dummy arguments. */
2476 if (sym
->attr
.dummy
&& is_classarray
2477 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2479 if (!se
->descriptor_only
)
2480 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2482 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2486 /* Dereference non-character scalar dummy arguments. */
2487 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2488 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2489 && (sym
->ts
.type
!= BT_CLASS
2490 || (!CLASS_DATA (sym
)->attr
.dimension
2491 && !(CLASS_DATA (sym
)->attr
.codimension
2492 && CLASS_DATA (sym
)->attr
.allocatable
))))
2493 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2496 /* Dereference scalar hidden result. */
2497 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2498 && (sym
->attr
.function
|| sym
->attr
.result
)
2499 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2500 && !sym
->attr
.always_explicit
)
2501 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2504 /* Dereference non-character, non-class pointer variables.
2505 These must be dummies, results, or scalars. */
2507 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2508 || gfc_is_associate_pointer (sym
)
2509 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2511 || sym
->attr
.function
2513 || (!sym
->attr
.dimension
2514 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2515 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2517 /* Now treat the class array pointer variables accordingly. */
2518 else if (sym
->ts
.type
== BT_CLASS
2520 && (CLASS_DATA (sym
)->attr
.dimension
2521 || CLASS_DATA (sym
)->attr
.codimension
)
2522 && ((CLASS_DATA (sym
)->as
2523 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2524 || CLASS_DATA (sym
)->attr
.allocatable
2525 || CLASS_DATA (sym
)->attr
.class_pointer
))
2526 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2528 /* And the case where a non-dummy, non-result, non-function,
2529 non-allotable and non-pointer classarray is present. This case was
2530 previously covered by the first if, but with introducing the
2531 condition !is_classarray there, that case has to be covered
2533 else if (sym
->ts
.type
== BT_CLASS
2535 && !sym
->attr
.function
2536 && !sym
->attr
.result
2537 && (CLASS_DATA (sym
)->attr
.dimension
2538 || CLASS_DATA (sym
)->attr
.codimension
)
2539 && !CLASS_DATA (sym
)->attr
.allocatable
2540 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2541 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2548 /* For character variables, also get the length. */
2549 if (sym
->ts
.type
== BT_CHARACTER
)
2551 /* If the character length of an entry isn't set, get the length from
2552 the master function instead. */
2553 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2554 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2556 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2557 gcc_assert (se
->string_length
);
2565 /* Return the descriptor if that's what we want and this is an array
2566 section reference. */
2567 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2569 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2570 /* Return the descriptor for array pointers and allocations. */
2571 if (se
->want_pointer
2572 && ref
->next
== NULL
&& (se
->descriptor_only
))
2575 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2576 /* Return a pointer to an element. */
2580 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2581 && se
->descriptor_only
2582 && !CLASS_DATA (sym
)->attr
.allocatable
2583 && !CLASS_DATA (sym
)->attr
.class_pointer
2584 && CLASS_DATA (sym
)->as
2585 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2586 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2587 /* Skip the first ref of a _data component, because for class
2588 arrays that one is already done by introducing a temporary
2589 array descriptor. */
2592 if (ref
->u
.c
.sym
->attr
.extension
)
2593 conv_parent_component_references (se
, ref
);
2595 gfc_conv_component_ref (se
, ref
);
2596 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2597 && se
->want_pointer
&& se
->descriptor_only
)
2603 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2604 expr
->symtree
->name
, &expr
->where
);
2614 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2616 if (se
->want_pointer
)
2618 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2619 gfc_conv_string_parameter (se
);
2621 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2626 /* Unary ops are easy... Or they would be if ! was a valid op. */
2629 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2634 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2635 /* Initialize the operand. */
2636 gfc_init_se (&operand
, se
);
2637 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2638 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2640 type
= gfc_typenode_for_spec (&expr
->ts
);
2642 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2643 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2644 All other unary operators have an equivalent GIMPLE unary operator. */
2645 if (code
== TRUTH_NOT_EXPR
)
2646 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2647 build_int_cst (type
, 0));
2649 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2653 /* Expand power operator to optimal multiplications when a value is raised
2654 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2655 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2656 Programming", 3rd Edition, 1998. */
2658 /* This code is mostly duplicated from expand_powi in the backend.
2659 We establish the "optimal power tree" lookup table with the defined size.
2660 The items in the table are the exponents used to calculate the index
2661 exponents. Any integer n less than the value can get an "addition chain",
2662 with the first node being one. */
2663 #define POWI_TABLE_SIZE 256
2665 /* The table is from builtins.c. */
2666 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2668 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2669 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2670 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2671 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2672 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2673 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2674 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2675 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2676 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2677 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2678 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2679 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2680 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2681 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2682 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2683 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2684 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2685 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2686 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2687 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2688 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2689 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2690 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2691 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2692 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2693 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2694 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2695 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2696 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2697 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2698 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2699 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2702 /* If n is larger than lookup table's max index, we use the "window
2704 #define POWI_WINDOW_SIZE 3
2706 /* Recursive function to expand the power operator. The temporary
2707 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2709 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2716 if (n
< POWI_TABLE_SIZE
)
2721 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2722 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2726 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2727 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2728 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2732 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2736 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2737 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2739 if (n
< POWI_TABLE_SIZE
)
2746 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2747 return 1. Else return 0 and a call to runtime library functions
2748 will have to be built. */
2750 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2755 tree vartmp
[POWI_TABLE_SIZE
];
2757 unsigned HOST_WIDE_INT n
;
2759 wide_int wrhs
= rhs
;
2761 /* If exponent is too large, we won't expand it anyway, so don't bother
2762 with large integer values. */
2763 if (!wi::fits_shwi_p (wrhs
))
2766 m
= wrhs
.to_shwi ();
2767 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2768 of the asymmetric range of the integer type. */
2769 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2771 type
= TREE_TYPE (lhs
);
2772 sgn
= tree_int_cst_sgn (rhs
);
2774 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2775 || optimize_size
) && (m
> 2 || m
< -1))
2781 se
->expr
= gfc_build_const (type
, integer_one_node
);
2785 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2786 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2788 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2789 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2790 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2791 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2794 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2797 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2798 boolean_type_node
, tmp
, cond
);
2799 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2800 tmp
, build_int_cst (type
, 1),
2801 build_int_cst (type
, 0));
2805 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2806 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2807 build_int_cst (type
, -1),
2808 build_int_cst (type
, 0));
2809 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2810 cond
, build_int_cst (type
, 1), tmp
);
2814 memset (vartmp
, 0, sizeof (vartmp
));
2818 tmp
= gfc_build_const (type
, integer_one_node
);
2819 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2823 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2829 /* Power op (**). Constant integer exponent has special handling. */
2832 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2834 tree gfc_int4_type_node
;
2837 int res_ikind_1
, res_ikind_2
;
2842 gfc_init_se (&lse
, se
);
2843 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2844 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2845 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2847 gfc_init_se (&rse
, se
);
2848 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2849 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2851 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2852 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2853 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2856 gfc_int4_type_node
= gfc_get_int_type (4);
2858 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2859 library routine. But in the end, we have to convert the result back
2860 if this case applies -- with res_ikind_K, we keep track whether operand K
2861 falls into this case. */
2865 kind
= expr
->value
.op
.op1
->ts
.kind
;
2866 switch (expr
->value
.op
.op2
->ts
.type
)
2869 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2874 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2875 res_ikind_2
= ikind
;
2897 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2899 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2926 switch (expr
->value
.op
.op1
->ts
.type
)
2929 if (kind
== 3) /* Case 16 was not handled properly above. */
2931 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2935 /* Use builtins for real ** int4. */
2941 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2945 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2949 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2953 /* Use the __builtin_powil() only if real(kind=16) is
2954 actually the C long double type. */
2955 if (!gfc_real16_is_float128
)
2956 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2964 /* If we don't have a good builtin for this, go for the
2965 library function. */
2967 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2971 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2980 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2984 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2992 se
->expr
= build_call_expr_loc (input_location
,
2993 fndecl
, 2, lse
.expr
, rse
.expr
);
2995 /* Convert the result back if it is of wrong integer kind. */
2996 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2998 /* We want the maximum of both operand kinds as result. */
2999 if (res_ikind_1
< res_ikind_2
)
3000 res_ikind_1
= res_ikind_2
;
3001 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3006 /* Generate code to allocate a string temporary. */
3009 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3014 if (gfc_can_put_var_on_stack (len
))
3016 /* Create a temporary variable to hold the result. */
3017 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3018 gfc_charlen_type_node
, len
,
3019 build_int_cst (gfc_charlen_type_node
, 1));
3020 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3022 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3023 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3025 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3027 var
= gfc_create_var (tmp
, "str");
3028 var
= gfc_build_addr_expr (type
, var
);
3032 /* Allocate a temporary to hold the result. */
3033 var
= gfc_create_var (type
, "pstr");
3034 gcc_assert (POINTER_TYPE_P (type
));
3035 tmp
= TREE_TYPE (type
);
3036 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3037 tmp
= TREE_TYPE (tmp
);
3038 tmp
= TYPE_SIZE_UNIT (tmp
);
3039 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3040 fold_convert (size_type_node
, len
),
3041 fold_convert (size_type_node
, tmp
));
3042 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3043 gfc_add_modify (&se
->pre
, var
, tmp
);
3045 /* Free the temporary afterwards. */
3046 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
3047 gfc_add_expr_to_block (&se
->post
, tmp
);
3054 /* Handle a string concatenation operation. A temporary will be allocated to
3058 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3061 tree len
, type
, var
, tmp
, fndecl
;
3063 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3064 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3065 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3067 gfc_init_se (&lse
, se
);
3068 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3069 gfc_conv_string_parameter (&lse
);
3070 gfc_init_se (&rse
, se
);
3071 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3072 gfc_conv_string_parameter (&rse
);
3074 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3075 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3077 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3078 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3079 if (len
== NULL_TREE
)
3081 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3082 TREE_TYPE (lse
.string_length
),
3083 lse
.string_length
, rse
.string_length
);
3086 type
= build_pointer_type (type
);
3088 var
= gfc_conv_string_tmp (se
, type
, len
);
3090 /* Do the actual concatenation. */
3091 if (expr
->ts
.kind
== 1)
3092 fndecl
= gfor_fndecl_concat_string
;
3093 else if (expr
->ts
.kind
== 4)
3094 fndecl
= gfor_fndecl_concat_string_char4
;
3098 tmp
= build_call_expr_loc (input_location
,
3099 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3100 rse
.string_length
, rse
.expr
);
3101 gfc_add_expr_to_block (&se
->pre
, tmp
);
3103 /* Add the cleanup for the operands. */
3104 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3105 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3108 se
->string_length
= len
;
3111 /* Translates an op expression. Common (binary) cases are handled by this
3112 function, others are passed on. Recursion is used in either case.
3113 We use the fact that (op1.ts == op2.ts) (except for the power
3115 Operators need no special handling for scalarized expressions as long as
3116 they call gfc_conv_simple_val to get their operands.
3117 Character strings get special handling. */
3120 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3122 enum tree_code code
;
3131 switch (expr
->value
.op
.op
)
3133 case INTRINSIC_PARENTHESES
:
3134 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3135 && flag_protect_parens
)
3137 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3138 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3143 case INTRINSIC_UPLUS
:
3144 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3147 case INTRINSIC_UMINUS
:
3148 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3152 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3155 case INTRINSIC_PLUS
:
3159 case INTRINSIC_MINUS
:
3163 case INTRINSIC_TIMES
:
3167 case INTRINSIC_DIVIDE
:
3168 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3169 an integer, we must round towards zero, so we use a
3171 if (expr
->ts
.type
== BT_INTEGER
)
3172 code
= TRUNC_DIV_EXPR
;
3177 case INTRINSIC_POWER
:
3178 gfc_conv_power_op (se
, expr
);
3181 case INTRINSIC_CONCAT
:
3182 gfc_conv_concat_op (se
, expr
);
3186 code
= TRUTH_ANDIF_EXPR
;
3191 code
= TRUTH_ORIF_EXPR
;
3195 /* EQV and NEQV only work on logicals, but since we represent them
3196 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3198 case INTRINSIC_EQ_OS
:
3206 case INTRINSIC_NE_OS
:
3207 case INTRINSIC_NEQV
:
3214 case INTRINSIC_GT_OS
:
3221 case INTRINSIC_GE_OS
:
3228 case INTRINSIC_LT_OS
:
3235 case INTRINSIC_LE_OS
:
3241 case INTRINSIC_USER
:
3242 case INTRINSIC_ASSIGN
:
3243 /* These should be converted into function calls by the frontend. */
3247 fatal_error (input_location
, "Unknown intrinsic op");
3251 /* The only exception to this is **, which is handled separately anyway. */
3252 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3254 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3258 gfc_init_se (&lse
, se
);
3259 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3260 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3263 gfc_init_se (&rse
, se
);
3264 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3265 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3269 gfc_conv_string_parameter (&lse
);
3270 gfc_conv_string_parameter (&rse
);
3272 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3273 rse
.string_length
, rse
.expr
,
3274 expr
->value
.op
.op1
->ts
.kind
,
3276 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3277 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3280 type
= gfc_typenode_for_spec (&expr
->ts
);
3284 /* The result of logical ops is always boolean_type_node. */
3285 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3286 lse
.expr
, rse
.expr
);
3287 se
->expr
= convert (type
, tmp
);
3290 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3292 /* Add the post blocks. */
3293 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3294 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3297 /* If a string's length is one, we convert it to a single character. */
3300 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3304 || !tree_fits_uhwi_p (len
)
3305 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3308 if (TREE_INT_CST_LOW (len
) == 1)
3310 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3311 return build_fold_indirect_ref_loc (input_location
, str
);
3315 && TREE_CODE (str
) == ADDR_EXPR
3316 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3317 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3318 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3319 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3320 && TREE_INT_CST_LOW (len
) > 1
3321 && TREE_INT_CST_LOW (len
)
3322 == (unsigned HOST_WIDE_INT
)
3323 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3325 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3326 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3327 if (TREE_CODE (ret
) == INTEGER_CST
)
3329 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3330 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3331 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3333 for (i
= 1; i
< length
; i
++)
3346 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3349 if (sym
->backend_decl
)
3351 /* This becomes the nominal_type in
3352 function.c:assign_parm_find_data_types. */
3353 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3354 /* This becomes the passed_type in
3355 function.c:assign_parm_find_data_types. C promotes char to
3356 integer for argument passing. */
3357 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3359 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3364 /* If we have a constant character expression, make it into an
3366 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3371 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3372 (int)(*expr
)->value
.character
.string
[0]);
3373 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3375 /* The expr needs to be compatible with a C int. If the
3376 conversion fails, then the 2 causes an ICE. */
3377 ts
.type
= BT_INTEGER
;
3378 ts
.kind
= gfc_c_int_kind
;
3379 gfc_convert_type (*expr
, &ts
, 2);
3382 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3384 if ((*expr
)->ref
== NULL
)
3386 se
->expr
= gfc_string_to_single_character
3387 (build_int_cst (integer_type_node
, 1),
3388 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3390 ((*expr
)->symtree
->n
.sym
)),
3395 gfc_conv_variable (se
, *expr
);
3396 se
->expr
= gfc_string_to_single_character
3397 (build_int_cst (integer_type_node
, 1),
3398 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3406 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3407 if STR is a string literal, otherwise return -1. */
3410 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3413 && TREE_CODE (str
) == ADDR_EXPR
3414 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3415 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3416 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3417 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3418 && tree_fits_uhwi_p (len
)
3419 && tree_to_uhwi (len
) >= 1
3420 && tree_to_uhwi (len
)
3421 == (unsigned HOST_WIDE_INT
)
3422 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3424 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3425 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3426 if (TREE_CODE (folded
) == INTEGER_CST
)
3428 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3429 int length
= TREE_STRING_LENGTH (string_cst
);
3430 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3432 for (; length
> 0; length
--)
3433 if (ptr
[length
- 1] != ' ')
3442 /* Helper to build a call to memcmp. */
3445 build_memcmp_call (tree s1
, tree s2
, tree n
)
3449 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3450 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3452 s1
= fold_convert (pvoid_type_node
, s1
);
3454 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3455 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3457 s2
= fold_convert (pvoid_type_node
, s2
);
3459 n
= fold_convert (size_type_node
, n
);
3461 tmp
= build_call_expr_loc (input_location
,
3462 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3465 return fold_convert (integer_type_node
, tmp
);
3468 /* Compare two strings. If they are all single characters, the result is the
3469 subtraction of them. Otherwise, we build a library call. */
3472 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3473 enum tree_code code
)
3479 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3480 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3482 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3483 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3485 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3487 /* Deal with single character specially. */
3488 sc1
= fold_convert (integer_type_node
, sc1
);
3489 sc2
= fold_convert (integer_type_node
, sc2
);
3490 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3494 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3496 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3498 /* If one string is a string literal with LEN_TRIM longer
3499 than the length of the second string, the strings
3501 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3502 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3503 return integer_one_node
;
3504 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3505 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3506 return integer_one_node
;
3509 /* We can compare via memcpy if the strings are known to be equal
3510 in length and they are
3512 - kind=4 and the comparison is for (in)equality. */
3514 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3515 && tree_int_cst_equal (len1
, len2
)
3516 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3521 chartype
= gfc_get_char_type (kind
);
3522 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3523 fold_convert (TREE_TYPE(len1
),
3524 TYPE_SIZE_UNIT(chartype
)),
3526 return build_memcmp_call (str1
, str2
, tmp
);
3529 /* Build a call for the comparison. */
3531 fndecl
= gfor_fndecl_compare_string
;
3533 fndecl
= gfor_fndecl_compare_string_char4
;
3537 return build_call_expr_loc (input_location
, fndecl
, 4,
3538 len1
, str1
, len2
, str2
);
3542 /* Return the backend_decl for a procedure pointer component. */
3545 get_proc_ptr_comp (gfc_expr
*e
)
3551 gfc_init_se (&comp_se
, NULL
);
3552 e2
= gfc_copy_expr (e
);
3553 /* We have to restore the expr type later so that gfc_free_expr frees
3554 the exact same thing that was allocated.
3555 TODO: This is ugly. */
3556 old_type
= e2
->expr_type
;
3557 e2
->expr_type
= EXPR_VARIABLE
;
3558 gfc_conv_expr (&comp_se
, e2
);
3559 e2
->expr_type
= old_type
;
3561 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3565 /* Convert a typebound function reference from a class object. */
3567 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3572 if (TREE_CODE (base_object
) != VAR_DECL
)
3574 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3575 gfc_add_modify (&se
->pre
, var
, base_object
);
3577 se
->expr
= gfc_class_vptr_get (base_object
);
3578 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3580 while (ref
&& ref
->next
)
3582 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3583 if (ref
->u
.c
.sym
->attr
.extension
)
3584 conv_parent_component_references (se
, ref
);
3585 gfc_conv_component_ref (se
, ref
);
3586 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3591 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3595 if (gfc_is_proc_ptr_comp (expr
))
3596 tmp
= get_proc_ptr_comp (expr
);
3597 else if (sym
->attr
.dummy
)
3599 tmp
= gfc_get_symbol_decl (sym
);
3600 if (sym
->attr
.proc_pointer
)
3601 tmp
= build_fold_indirect_ref_loc (input_location
,
3603 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3604 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3608 if (!sym
->backend_decl
)
3609 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3611 TREE_USED (sym
->backend_decl
) = 1;
3613 tmp
= sym
->backend_decl
;
3615 if (sym
->attr
.cray_pointee
)
3617 /* TODO - make the cray pointee a pointer to a procedure,
3618 assign the pointer to it and use it for the call. This
3620 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3621 gfc_get_symbol_decl (sym
->cp_pointer
));
3622 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3625 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3627 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3628 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3635 /* Initialize MAPPING. */
3638 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3640 mapping
->syms
= NULL
;
3641 mapping
->charlens
= NULL
;
3645 /* Free all memory held by MAPPING (but not MAPPING itself). */
3648 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3650 gfc_interface_sym_mapping
*sym
;
3651 gfc_interface_sym_mapping
*nextsym
;
3653 gfc_charlen
*nextcl
;
3655 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3657 nextsym
= sym
->next
;
3658 sym
->new_sym
->n
.sym
->formal
= NULL
;
3659 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3660 gfc_free_expr (sym
->expr
);
3661 free (sym
->new_sym
);
3664 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3667 gfc_free_expr (cl
->length
);
3673 /* Return a copy of gfc_charlen CL. Add the returned structure to
3674 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3676 static gfc_charlen
*
3677 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3680 gfc_charlen
*new_charlen
;
3682 new_charlen
= gfc_get_charlen ();
3683 new_charlen
->next
= mapping
->charlens
;
3684 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3686 mapping
->charlens
= new_charlen
;
3691 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3692 array variable that can be used as the actual argument for dummy
3693 argument SYM. Add any initialization code to BLOCK. PACKED is as
3694 for gfc_get_nodesc_array_type and DATA points to the first element
3695 in the passed array. */
3698 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3699 gfc_packed packed
, tree data
)
3704 type
= gfc_typenode_for_spec (&sym
->ts
);
3705 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3706 !sym
->attr
.target
&& !sym
->attr
.pointer
3707 && !sym
->attr
.proc_pointer
);
3709 var
= gfc_create_var (type
, "ifm");
3710 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3716 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3717 and offset of descriptorless array type TYPE given that it has the same
3718 size as DESC. Add any set-up code to BLOCK. */
3721 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3728 offset
= gfc_index_zero_node
;
3729 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3731 dim
= gfc_rank_cst
[n
];
3732 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3733 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3735 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3736 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3737 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3738 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3740 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3742 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3743 gfc_array_index_type
,
3744 gfc_conv_descriptor_ubound_get (desc
, dim
),
3745 gfc_conv_descriptor_lbound_get (desc
, dim
));
3746 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3747 gfc_array_index_type
,
3748 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3749 tmp
= gfc_evaluate_now (tmp
, block
);
3750 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3752 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3753 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3754 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3755 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3756 gfc_array_index_type
, offset
, tmp
);
3758 offset
= gfc_evaluate_now (offset
, block
);
3759 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3763 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3764 in SE. The caller may still use se->expr and se->string_length after
3765 calling this function. */
3768 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3769 gfc_symbol
* sym
, gfc_se
* se
,
3772 gfc_interface_sym_mapping
*sm
;
3776 gfc_symbol
*new_sym
;
3778 gfc_symtree
*new_symtree
;
3780 /* Create a new symbol to represent the actual argument. */
3781 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3782 new_sym
->ts
= sym
->ts
;
3783 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3784 new_sym
->attr
.referenced
= 1;
3785 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3786 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3787 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3788 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3789 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3790 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3791 new_sym
->attr
.function
= sym
->attr
.function
;
3793 /* Ensure that the interface is available and that
3794 descriptors are passed for array actual arguments. */
3795 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3797 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3798 new_sym
->attr
.always_explicit
3799 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3802 /* Create a fake symtree for it. */
3804 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3805 new_symtree
->n
.sym
= new_sym
;
3806 gcc_assert (new_symtree
== root
);
3808 /* Create a dummy->actual mapping. */
3809 sm
= XCNEW (gfc_interface_sym_mapping
);
3810 sm
->next
= mapping
->syms
;
3812 sm
->new_sym
= new_symtree
;
3813 sm
->expr
= gfc_copy_expr (expr
);
3816 /* Stabilize the argument's value. */
3817 if (!sym
->attr
.function
&& se
)
3818 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3820 if (sym
->ts
.type
== BT_CHARACTER
)
3822 /* Create a copy of the dummy argument's length. */
3823 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3824 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3826 /* If the length is specified as "*", record the length that
3827 the caller is passing. We should use the callee's length
3828 in all other cases. */
3829 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3831 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3832 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3839 /* Use the passed value as-is if the argument is a function. */
3840 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3843 /* If the argument is either a string or a pointer to a string,
3844 convert it to a boundless character type. */
3845 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3847 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3848 tmp
= build_pointer_type (tmp
);
3849 if (sym
->attr
.pointer
)
3850 value
= build_fold_indirect_ref_loc (input_location
,
3854 value
= fold_convert (tmp
, value
);
3857 /* If the argument is a scalar, a pointer to an array or an allocatable,
3859 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3860 value
= build_fold_indirect_ref_loc (input_location
,
3863 /* For character(*), use the actual argument's descriptor. */
3864 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3865 value
= build_fold_indirect_ref_loc (input_location
,
3868 /* If the argument is an array descriptor, use it to determine
3869 information about the actual argument's shape. */
3870 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3871 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3873 /* Get the actual argument's descriptor. */
3874 desc
= build_fold_indirect_ref_loc (input_location
,
3877 /* Create the replacement variable. */
3878 tmp
= gfc_conv_descriptor_data_get (desc
);
3879 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3882 /* Use DESC to work out the upper bounds, strides and offset. */
3883 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3886 /* Otherwise we have a packed array. */
3887 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3888 PACKED_FULL
, se
->expr
);
3890 new_sym
->backend_decl
= value
;
3894 /* Called once all dummy argument mappings have been added to MAPPING,
3895 but before the mapping is used to evaluate expressions. Pre-evaluate
3896 the length of each argument, adding any initialization code to PRE and
3897 any finalization code to POST. */
3900 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3901 stmtblock_t
* pre
, stmtblock_t
* post
)
3903 gfc_interface_sym_mapping
*sym
;
3907 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3908 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3909 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3911 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3912 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3913 gfc_init_se (&se
, NULL
);
3914 gfc_conv_expr (&se
, expr
);
3915 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3916 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3917 gfc_add_block_to_block (pre
, &se
.pre
);
3918 gfc_add_block_to_block (post
, &se
.post
);
3920 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3925 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3929 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3930 gfc_constructor_base base
)
3933 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3935 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3938 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3939 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3940 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3946 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3950 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3955 for (; ref
; ref
= ref
->next
)
3959 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3961 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3962 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3963 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3971 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3972 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3978 /* Convert intrinsic function calls into result expressions. */
3981 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3989 arg1
= expr
->value
.function
.actual
->expr
;
3990 if (expr
->value
.function
.actual
->next
)
3991 arg2
= expr
->value
.function
.actual
->next
->expr
;
3995 sym
= arg1
->symtree
->n
.sym
;
3997 if (sym
->attr
.dummy
)
4002 switch (expr
->value
.function
.isym
->id
)
4005 /* TODO figure out why this condition is necessary. */
4006 if (sym
->attr
.function
4007 && (arg1
->ts
.u
.cl
->length
== NULL
4008 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4009 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4012 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4016 if (!sym
->as
|| sym
->as
->rank
== 0)
4019 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4021 dup
= mpz_get_si (arg2
->value
.integer
);
4026 dup
= sym
->as
->rank
;
4030 for (; d
< dup
; d
++)
4034 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4036 gfc_free_expr (new_expr
);
4040 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4041 gfc_get_int_expr (gfc_default_integer_kind
,
4043 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4045 new_expr
= gfc_multiply (new_expr
, tmp
);
4051 case GFC_ISYM_LBOUND
:
4052 case GFC_ISYM_UBOUND
:
4053 /* TODO These implementations of lbound and ubound do not limit if
4054 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4056 if (!sym
->as
|| sym
->as
->rank
== 0)
4059 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4060 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4062 /* TODO: If the need arises, this could produce an array of
4066 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4068 if (sym
->as
->lower
[d
])
4069 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4073 if (sym
->as
->upper
[d
])
4074 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4082 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4086 gfc_replace_expr (expr
, new_expr
);
4092 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4093 gfc_interface_mapping
* mapping
)
4095 gfc_formal_arglist
*f
;
4096 gfc_actual_arglist
*actual
;
4098 actual
= expr
->value
.function
.actual
;
4099 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4101 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4106 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4109 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4114 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4116 for (d
= 0; d
< as
->rank
; d
++)
4118 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4119 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4122 expr
->value
.function
.esym
->as
= as
;
4125 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4127 expr
->value
.function
.esym
->ts
.u
.cl
->length
4128 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4130 gfc_apply_interface_mapping_to_expr (mapping
,
4131 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4136 /* EXPR is a copy of an expression that appeared in the interface
4137 associated with MAPPING. Walk it recursively looking for references to
4138 dummy arguments that MAPPING maps to actual arguments. Replace each such
4139 reference with a reference to the associated actual argument. */
4142 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4145 gfc_interface_sym_mapping
*sym
;
4146 gfc_actual_arglist
*actual
;
4151 /* Copying an expression does not copy its length, so do that here. */
4152 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4154 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4155 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4158 /* Apply the mapping to any references. */
4159 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4161 /* ...and to the expression's symbol, if it has one. */
4162 /* TODO Find out why the condition on expr->symtree had to be moved into
4163 the loop rather than being outside it, as originally. */
4164 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4165 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4167 if (sym
->new_sym
->n
.sym
->backend_decl
)
4168 expr
->symtree
= sym
->new_sym
;
4170 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4173 /* ...and to subexpressions in expr->value. */
4174 switch (expr
->expr_type
)
4179 case EXPR_SUBSTRING
:
4183 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4184 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4188 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4189 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4191 if (expr
->value
.function
.esym
== NULL
4192 && expr
->value
.function
.isym
!= NULL
4193 && expr
->value
.function
.actual
->expr
->symtree
4194 && gfc_map_intrinsic_function (expr
, mapping
))
4197 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4198 if (sym
->old
== expr
->value
.function
.esym
)
4200 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4201 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4202 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4207 case EXPR_STRUCTURE
:
4208 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4221 /* Evaluate interface expression EXPR using MAPPING. Store the result
4225 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4226 gfc_se
* se
, gfc_expr
* expr
)
4228 expr
= gfc_copy_expr (expr
);
4229 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4230 gfc_conv_expr (se
, expr
);
4231 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4232 gfc_free_expr (expr
);
4236 /* Returns a reference to a temporary array into which a component of
4237 an actual argument derived type array is copied and then returned
4238 after the function call. */
4240 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4241 sym_intent intent
, bool formal_ptr
)
4249 gfc_array_info
*info
;
4259 gfc_init_se (&lse
, NULL
);
4260 gfc_init_se (&rse
, NULL
);
4262 /* Walk the argument expression. */
4263 rss
= gfc_walk_expr (expr
);
4265 gcc_assert (rss
!= gfc_ss_terminator
);
4267 /* Initialize the scalarizer. */
4268 gfc_init_loopinfo (&loop
);
4269 gfc_add_ss_to_loop (&loop
, rss
);
4271 /* Calculate the bounds of the scalarization. */
4272 gfc_conv_ss_startstride (&loop
);
4274 /* Build an ss for the temporary. */
4275 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4276 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4278 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4279 if (GFC_ARRAY_TYPE_P (base_type
)
4280 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4281 base_type
= gfc_get_element_type (base_type
);
4283 if (expr
->ts
.type
== BT_CLASS
)
4284 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4286 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4287 ? expr
->ts
.u
.cl
->backend_decl
4291 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4293 /* Associate the SS with the loop. */
4294 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4296 /* Setup the scalarizing loops. */
4297 gfc_conv_loop_setup (&loop
, &expr
->where
);
4299 /* Pass the temporary descriptor back to the caller. */
4300 info
= &loop
.temp_ss
->info
->data
.array
;
4301 parmse
->expr
= info
->descriptor
;
4303 /* Setup the gfc_se structures. */
4304 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4305 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4308 lse
.ss
= loop
.temp_ss
;
4309 gfc_mark_ss_chain_used (rss
, 1);
4310 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4312 /* Start the scalarized loop body. */
4313 gfc_start_scalarized_body (&loop
, &body
);
4315 /* Translate the expression. */
4316 gfc_conv_expr (&rse
, expr
);
4318 /* Reset the offset for the function call since the loop
4319 is zero based on the data pointer. Note that the temp
4320 comes first in the loop chain since it is added second. */
4321 if (gfc_is_alloc_class_array_function (expr
))
4323 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4324 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4325 gfc_index_zero_node
);
4328 gfc_conv_tmp_array_ref (&lse
);
4330 if (intent
!= INTENT_OUT
)
4332 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
4333 gfc_add_expr_to_block (&body
, tmp
);
4334 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4335 gfc_trans_scalarizing_loops (&loop
, &body
);
4339 /* Make sure that the temporary declaration survives by merging
4340 all the loop declarations into the current context. */
4341 for (n
= 0; n
< loop
.dimen
; n
++)
4343 gfc_merge_block_scope (&body
);
4344 body
= loop
.code
[loop
.order
[n
]];
4346 gfc_merge_block_scope (&body
);
4349 /* Add the post block after the second loop, so that any
4350 freeing of allocated memory is done at the right time. */
4351 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4353 /**********Copy the temporary back again.*********/
4355 gfc_init_se (&lse
, NULL
);
4356 gfc_init_se (&rse
, NULL
);
4358 /* Walk the argument expression. */
4359 lss
= gfc_walk_expr (expr
);
4360 rse
.ss
= loop
.temp_ss
;
4363 /* Initialize the scalarizer. */
4364 gfc_init_loopinfo (&loop2
);
4365 gfc_add_ss_to_loop (&loop2
, lss
);
4367 dimen
= rse
.ss
->dimen
;
4369 /* Skip the write-out loop for this case. */
4370 if (gfc_is_alloc_class_array_function (expr
))
4371 goto class_array_fcn
;
4373 /* Calculate the bounds of the scalarization. */
4374 gfc_conv_ss_startstride (&loop2
);
4376 /* Setup the scalarizing loops. */
4377 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4379 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4380 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4382 gfc_mark_ss_chain_used (lss
, 1);
4383 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4385 /* Declare the variable to hold the temporary offset and start the
4386 scalarized loop body. */
4387 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4388 gfc_start_scalarized_body (&loop2
, &body
);
4390 /* Build the offsets for the temporary from the loop variables. The
4391 temporary array has lbounds of zero and strides of one in all
4392 dimensions, so this is very simple. The offset is only computed
4393 outside the innermost loop, so the overall transfer could be
4394 optimized further. */
4395 info
= &rse
.ss
->info
->data
.array
;
4397 tmp_index
= gfc_index_zero_node
;
4398 for (n
= dimen
- 1; n
> 0; n
--)
4401 tmp
= rse
.loop
->loopvar
[n
];
4402 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4403 tmp
, rse
.loop
->from
[n
]);
4404 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4407 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4408 gfc_array_index_type
,
4409 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4410 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4411 gfc_array_index_type
,
4412 tmp_str
, gfc_index_one_node
);
4414 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4415 gfc_array_index_type
, tmp
, tmp_str
);
4418 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4419 gfc_array_index_type
,
4420 tmp_index
, rse
.loop
->from
[0]);
4421 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4423 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4424 gfc_array_index_type
,
4425 rse
.loop
->loopvar
[0], offset
);
4427 /* Now use the offset for the reference. */
4428 tmp
= build_fold_indirect_ref_loc (input_location
,
4430 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4432 if (expr
->ts
.type
== BT_CHARACTER
)
4433 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4435 gfc_conv_expr (&lse
, expr
);
4437 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4439 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4440 gfc_add_expr_to_block (&body
, tmp
);
4442 /* Generate the copying loops. */
4443 gfc_trans_scalarizing_loops (&loop2
, &body
);
4445 /* Wrap the whole thing up by adding the second loop to the post-block
4446 and following it by the post-block of the first loop. In this way,
4447 if the temporary needs freeing, it is done after use! */
4448 if (intent
!= INTENT_IN
)
4450 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4451 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4456 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4458 gfc_cleanup_loop (&loop
);
4459 gfc_cleanup_loop (&loop2
);
4461 /* Pass the string length to the argument expression. */
4462 if (expr
->ts
.type
== BT_CHARACTER
)
4463 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4465 /* Determine the offset for pointer formal arguments and set the
4469 size
= gfc_index_one_node
;
4470 offset
= gfc_index_zero_node
;
4471 for (n
= 0; n
< dimen
; n
++)
4473 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4475 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4476 gfc_array_index_type
, tmp
,
4477 gfc_index_one_node
);
4478 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4482 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4485 gfc_index_one_node
);
4486 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4487 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4488 gfc_array_index_type
,
4490 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4491 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4492 gfc_array_index_type
,
4493 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4494 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4495 gfc_array_index_type
,
4496 tmp
, gfc_index_one_node
);
4497 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4498 gfc_array_index_type
, size
, tmp
);
4501 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4505 /* We want either the address for the data or the address of the descriptor,
4506 depending on the mode of passing array arguments. */
4508 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4510 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4516 /* Generate the code for argument list functions. */
4519 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4521 /* Pass by value for g77 %VAL(arg), pass the address
4522 indirectly for %LOC, else by reference. Thus %REF
4523 is a "do-nothing" and %LOC is the same as an F95
4525 if (strncmp (name
, "%VAL", 4) == 0)
4526 gfc_conv_expr (se
, expr
);
4527 else if (strncmp (name
, "%LOC", 4) == 0)
4529 gfc_conv_expr_reference (se
, expr
);
4530 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4532 else if (strncmp (name
, "%REF", 4) == 0)
4533 gfc_conv_expr_reference (se
, expr
);
4535 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4539 /* Generate code for a procedure call. Note can return se->post != NULL.
4540 If se->direct_byref is set then se->expr contains the return parameter.
4541 Return nonzero, if the call has alternate specifiers.
4542 'expr' is only needed for procedure pointer components. */
4545 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4546 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4547 vec
<tree
, va_gc
> *append_args
)
4549 gfc_interface_mapping mapping
;
4550 vec
<tree
, va_gc
> *arglist
;
4551 vec
<tree
, va_gc
> *retargs
;
4555 gfc_array_info
*info
;
4562 vec
<tree
, va_gc
> *stringargs
;
4563 vec
<tree
, va_gc
> *optionalargs
;
4565 gfc_formal_arglist
*formal
;
4566 gfc_actual_arglist
*arg
;
4567 int has_alternate_specifier
= 0;
4568 bool need_interface_mapping
;
4575 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4576 gfc_component
*comp
= NULL
;
4582 optionalargs
= NULL
;
4587 comp
= gfc_get_proc_ptr_comp (expr
);
4591 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4593 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4594 if (se
->ss
->info
->useflags
)
4596 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4597 && sym
->result
->attr
.dimension
)
4598 || (comp
&& comp
->attr
.dimension
)
4599 || gfc_is_alloc_class_array_function (expr
));
4600 gcc_assert (se
->loop
!= NULL
);
4601 /* Access the previously obtained result. */
4602 gfc_conv_tmp_array_ref (se
);
4606 info
= &se
->ss
->info
->data
.array
;
4611 gfc_init_block (&post
);
4612 gfc_init_interface_mapping (&mapping
);
4615 formal
= gfc_sym_get_dummy_args (sym
);
4616 need_interface_mapping
= sym
->attr
.dimension
||
4617 (sym
->ts
.type
== BT_CHARACTER
4618 && sym
->ts
.u
.cl
->length
4619 && sym
->ts
.u
.cl
->length
->expr_type
4624 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4625 need_interface_mapping
= comp
->attr
.dimension
||
4626 (comp
->ts
.type
== BT_CHARACTER
4627 && comp
->ts
.u
.cl
->length
4628 && comp
->ts
.u
.cl
->length
->expr_type
4632 base_object
= NULL_TREE
;
4634 /* Evaluate the arguments. */
4635 for (arg
= args
; arg
!= NULL
;
4636 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4639 fsym
= formal
? formal
->sym
: NULL
;
4640 parm_kind
= MISSING
;
4642 /* Class array expressions are sometimes coming completely unadorned
4643 with either arrayspec or _data component. Correct that here.
4644 OOP-TODO: Move this to the frontend. */
4645 if (e
&& e
->expr_type
== EXPR_VARIABLE
4647 && e
->ts
.type
== BT_CLASS
4648 && (CLASS_DATA (e
)->attr
.codimension
4649 || CLASS_DATA (e
)->attr
.dimension
))
4651 gfc_typespec temp_ts
= e
->ts
;
4652 gfc_add_class_array_ref (e
);
4658 if (se
->ignore_optional
)
4660 /* Some intrinsics have already been resolved to the correct
4664 else if (arg
->label
)
4666 has_alternate_specifier
= 1;
4671 gfc_init_se (&parmse
, NULL
);
4673 /* For scalar arguments with VALUE attribute which are passed by
4674 value, pass "0" and a hidden argument gives the optional
4676 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4677 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4678 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4680 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4682 vec_safe_push (optionalargs
, boolean_false_node
);
4686 /* Pass a NULL pointer for an absent arg. */
4687 parmse
.expr
= null_pointer_node
;
4688 if (arg
->missing_arg_type
== BT_CHARACTER
)
4689 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4694 else if (arg
->expr
->expr_type
== EXPR_NULL
4695 && fsym
&& !fsym
->attr
.pointer
4696 && (fsym
->ts
.type
!= BT_CLASS
4697 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4699 /* Pass a NULL pointer to denote an absent arg. */
4700 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4701 && (fsym
->ts
.type
!= BT_CLASS
4702 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4703 gfc_init_se (&parmse
, NULL
);
4704 parmse
.expr
= null_pointer_node
;
4705 if (arg
->missing_arg_type
== BT_CHARACTER
)
4706 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4708 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4709 && e
->ts
.type
== BT_DERIVED
)
4711 /* The derived type needs to be converted to a temporary
4713 gfc_init_se (&parmse
, se
);
4714 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4716 && e
->expr_type
== EXPR_VARIABLE
4717 && e
->symtree
->n
.sym
->attr
.optional
,
4718 CLASS_DATA (fsym
)->attr
.class_pointer
4719 || CLASS_DATA (fsym
)->attr
.allocatable
);
4721 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4723 /* The intrinsic type needs to be converted to a temporary
4724 CLASS object for the unlimited polymorphic formal. */
4725 gfc_init_se (&parmse
, se
);
4726 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4728 else if (se
->ss
&& se
->ss
->info
->useflags
)
4734 /* An elemental function inside a scalarized loop. */
4735 gfc_init_se (&parmse
, se
);
4736 parm_kind
= ELEMENTAL
;
4738 /* For all value functions or polymorphic scalar non-pointer
4739 non-allocatable variables use the expression in e directly. This
4740 ensures, that initializers of polymorphic entities are correctly
4742 if (fsym
&& (fsym
->attr
.value
4743 || (e
->expr_type
== EXPR_VARIABLE
4744 && fsym
->ts
.type
== BT_DERIVED
4745 && e
->ts
.type
== BT_DERIVED
4746 && !e
->ts
.u
.derived
->attr
.dimension
4749 || (!e
->symtree
->n
.sym
->attr
.allocatable
4750 && !e
->symtree
->n
.sym
->attr
.pointer
)))))
4751 gfc_conv_expr (&parmse
, e
);
4753 gfc_conv_expr_reference (&parmse
, e
);
4755 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4756 && e
->expr_type
== EXPR_FUNCTION
)
4757 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4760 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4761 && gfc_is_class_container_ref (e
))
4763 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4765 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4766 && e
->symtree
->n
.sym
->attr
.optional
)
4768 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4769 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4770 TREE_TYPE (parmse
.expr
),
4772 fold_convert (TREE_TYPE (parmse
.expr
),
4773 null_pointer_node
));
4777 /* If we are passing an absent array as optional dummy to an
4778 elemental procedure, make sure that we pass NULL when the data
4779 pointer is NULL. We need this extra conditional because of
4780 scalarization which passes arrays elements to the procedure,
4781 ignoring the fact that the array can be absent/unallocated/... */
4782 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4784 tree descriptor_data
;
4786 descriptor_data
= ss
->info
->data
.array
.data
;
4787 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4789 fold_convert (TREE_TYPE (descriptor_data
),
4790 null_pointer_node
));
4792 = fold_build3_loc (input_location
, COND_EXPR
,
4793 TREE_TYPE (parmse
.expr
),
4794 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4795 fold_convert (TREE_TYPE (parmse
.expr
),
4800 /* The scalarizer does not repackage the reference to a class
4801 array - instead it returns a pointer to the data element. */
4802 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4803 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4804 fsym
->attr
.intent
!= INTENT_IN
4805 && (CLASS_DATA (fsym
)->attr
.class_pointer
4806 || CLASS_DATA (fsym
)->attr
.allocatable
),
4808 && e
->expr_type
== EXPR_VARIABLE
4809 && e
->symtree
->n
.sym
->attr
.optional
,
4810 CLASS_DATA (fsym
)->attr
.class_pointer
4811 || CLASS_DATA (fsym
)->attr
.allocatable
);
4818 gfc_init_se (&parmse
, NULL
);
4820 /* Check whether the expression is a scalar or not; we cannot use
4821 e->rank as it can be nonzero for functions arguments. */
4822 argss
= gfc_walk_expr (e
);
4823 scalar
= argss
== gfc_ss_terminator
;
4825 gfc_free_ss_chain (argss
);
4827 /* Special handling for passing scalar polymorphic coarrays;
4828 otherwise one passes "class->_data.data" instead of "&class". */
4829 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4830 && fsym
&& fsym
->ts
.type
== BT_CLASS
4831 && CLASS_DATA (fsym
)->attr
.codimension
4832 && !CLASS_DATA (fsym
)->attr
.dimension
)
4834 gfc_add_class_array_ref (e
);
4835 parmse
.want_coarray
= 1;
4839 /* A scalar or transformational function. */
4842 if (e
->expr_type
== EXPR_VARIABLE
4843 && e
->symtree
->n
.sym
->attr
.cray_pointee
4844 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4846 /* The Cray pointer needs to be converted to a pointer to
4847 a type given by the expression. */
4848 gfc_conv_expr (&parmse
, e
);
4849 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4850 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4851 parmse
.expr
= convert (type
, tmp
);
4853 else if (fsym
&& fsym
->attr
.value
)
4855 if (fsym
->ts
.type
== BT_CHARACTER
4856 && fsym
->ts
.is_c_interop
4857 && fsym
->ns
->proc_name
!= NULL
4858 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4861 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4862 if (parmse
.expr
== NULL
)
4863 gfc_conv_expr (&parmse
, e
);
4867 gfc_conv_expr (&parmse
, e
);
4868 if (fsym
->attr
.optional
4869 && fsym
->ts
.type
!= BT_CLASS
4870 && fsym
->ts
.type
!= BT_DERIVED
)
4872 if (e
->expr_type
!= EXPR_VARIABLE
4873 || !e
->symtree
->n
.sym
->attr
.optional
4875 vec_safe_push (optionalargs
, boolean_true_node
);
4878 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4879 if (!e
->symtree
->n
.sym
->attr
.value
)
4881 = fold_build3_loc (input_location
, COND_EXPR
,
4882 TREE_TYPE (parmse
.expr
),
4884 fold_convert (TREE_TYPE (parmse
.expr
),
4885 integer_zero_node
));
4887 vec_safe_push (optionalargs
, tmp
);
4892 else if (arg
->name
&& arg
->name
[0] == '%')
4893 /* Argument list functions %VAL, %LOC and %REF are signalled
4894 through arg->name. */
4895 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4896 else if ((e
->expr_type
== EXPR_FUNCTION
)
4897 && ((e
->value
.function
.esym
4898 && e
->value
.function
.esym
->result
->attr
.pointer
)
4899 || (!e
->value
.function
.esym
4900 && e
->symtree
->n
.sym
->attr
.pointer
))
4901 && fsym
&& fsym
->attr
.target
)
4903 gfc_conv_expr (&parmse
, e
);
4904 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4906 else if (e
->expr_type
== EXPR_FUNCTION
4907 && e
->symtree
->n
.sym
->result
4908 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4909 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4911 /* Functions returning procedure pointers. */
4912 gfc_conv_expr (&parmse
, e
);
4913 if (fsym
&& fsym
->attr
.proc_pointer
)
4914 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4918 if (e
->ts
.type
== BT_CLASS
&& fsym
4919 && fsym
->ts
.type
== BT_CLASS
4920 && (!CLASS_DATA (fsym
)->as
4921 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4922 && CLASS_DATA (e
)->attr
.codimension
)
4924 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4925 gcc_assert (!CLASS_DATA (fsym
)->as
);
4926 gfc_add_class_array_ref (e
);
4927 parmse
.want_coarray
= 1;
4928 gfc_conv_expr_reference (&parmse
, e
);
4929 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4931 && e
->expr_type
== EXPR_VARIABLE
);
4933 else if (e
->ts
.type
== BT_CLASS
&& fsym
4934 && fsym
->ts
.type
== BT_CLASS
4935 && !CLASS_DATA (fsym
)->as
4936 && !CLASS_DATA (e
)->as
4937 && strcmp (fsym
->ts
.u
.derived
->name
,
4938 e
->ts
.u
.derived
->name
))
4940 type
= gfc_typenode_for_spec (&fsym
->ts
);
4941 var
= gfc_create_var (type
, fsym
->name
);
4942 gfc_conv_expr (&parmse
, e
);
4943 if (fsym
->attr
.optional
4944 && e
->expr_type
== EXPR_VARIABLE
4945 && e
->symtree
->n
.sym
->attr
.optional
)
4949 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4950 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4951 boolean_type_node
, tmp
,
4952 fold_convert (TREE_TYPE (tmp
),
4953 null_pointer_node
));
4954 gfc_start_block (&block
);
4955 gfc_add_modify (&block
, var
,
4956 fold_build1_loc (input_location
,
4958 type
, parmse
.expr
));
4959 gfc_add_expr_to_block (&parmse
.pre
,
4960 fold_build3_loc (input_location
,
4961 COND_EXPR
, void_type_node
,
4962 cond
, gfc_finish_block (&block
),
4963 build_empty_stmt (input_location
)));
4964 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4965 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4966 TREE_TYPE (parmse
.expr
),
4968 fold_convert (TREE_TYPE (parmse
.expr
),
4969 null_pointer_node
));
4973 gfc_add_modify (&parmse
.pre
, var
,
4974 fold_build1_loc (input_location
,
4976 type
, parmse
.expr
));
4977 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4981 gfc_conv_expr_reference (&parmse
, e
);
4983 /* Catch base objects that are not variables. */
4984 if (e
->ts
.type
== BT_CLASS
4985 && e
->expr_type
!= EXPR_VARIABLE
4986 && expr
&& e
== expr
->base_expr
)
4987 base_object
= build_fold_indirect_ref_loc (input_location
,
4990 /* A class array element needs converting back to be a
4991 class object, if the formal argument is a class object. */
4992 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4993 && e
->ts
.type
== BT_CLASS
4994 && ((CLASS_DATA (fsym
)->as
4995 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4996 || CLASS_DATA (e
)->attr
.dimension
))
4997 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4998 fsym
->attr
.intent
!= INTENT_IN
4999 && (CLASS_DATA (fsym
)->attr
.class_pointer
5000 || CLASS_DATA (fsym
)->attr
.allocatable
),
5002 && e
->expr_type
== EXPR_VARIABLE
5003 && e
->symtree
->n
.sym
->attr
.optional
,
5004 CLASS_DATA (fsym
)->attr
.class_pointer
5005 || CLASS_DATA (fsym
)->attr
.allocatable
);
5007 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5008 allocated on entry, it must be deallocated. */
5009 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5010 && (fsym
->attr
.allocatable
5011 || (fsym
->ts
.type
== BT_CLASS
5012 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5017 gfc_init_block (&block
);
5019 if (e
->ts
.type
== BT_CLASS
)
5020 ptr
= gfc_class_data_get (ptr
);
5022 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5024 gfc_add_expr_to_block (&block
, tmp
);
5025 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5026 void_type_node
, ptr
,
5028 gfc_add_expr_to_block (&block
, tmp
);
5030 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5032 gfc_add_modify (&block
, ptr
,
5033 fold_convert (TREE_TYPE (ptr
),
5034 null_pointer_node
));
5035 gfc_add_expr_to_block (&block
, tmp
);
5037 else if (fsym
->ts
.type
== BT_CLASS
)
5040 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5041 tmp
= gfc_get_symbol_decl (vtab
);
5042 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5043 ptr
= gfc_class_vptr_get (parmse
.expr
);
5044 gfc_add_modify (&block
, ptr
,
5045 fold_convert (TREE_TYPE (ptr
), tmp
));
5046 gfc_add_expr_to_block (&block
, tmp
);
5049 if (fsym
->attr
.optional
5050 && e
->expr_type
== EXPR_VARIABLE
5051 && e
->symtree
->n
.sym
->attr
.optional
)
5053 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5055 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5056 gfc_finish_block (&block
),
5057 build_empty_stmt (input_location
));
5060 tmp
= gfc_finish_block (&block
);
5062 gfc_add_expr_to_block (&se
->pre
, tmp
);
5065 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5066 || fsym
->ts
.type
== BT_ASSUMED
)
5067 && e
->ts
.type
== BT_CLASS
5068 && !CLASS_DATA (e
)->attr
.dimension
5069 && !CLASS_DATA (e
)->attr
.codimension
)
5070 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5072 /* Wrap scalar variable in a descriptor. We need to convert
5073 the address of a pointer back to the pointer itself before,
5074 we can assign it to the data field. */
5076 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5077 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5080 if (TREE_CODE (tmp
) == ADDR_EXPR
5081 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5082 tmp
= TREE_OPERAND (tmp
, 0);
5083 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5085 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5088 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5089 && ((fsym
->attr
.pointer
5090 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5091 || (fsym
->attr
.proc_pointer
5092 && !(e
->expr_type
== EXPR_VARIABLE
5093 && e
->symtree
->n
.sym
->attr
.dummy
))
5094 || (fsym
->attr
.proc_pointer
5095 && e
->expr_type
== EXPR_VARIABLE
5096 && gfc_is_proc_ptr_comp (e
))
5097 || (fsym
->attr
.allocatable
5098 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5100 /* Scalar pointer dummy args require an extra level of
5101 indirection. The null pointer already contains
5102 this level of indirection. */
5103 parm_kind
= SCALAR_POINTER
;
5104 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5108 else if (e
->ts
.type
== BT_CLASS
5109 && fsym
&& fsym
->ts
.type
== BT_CLASS
5110 && (CLASS_DATA (fsym
)->attr
.dimension
5111 || CLASS_DATA (fsym
)->attr
.codimension
))
5113 /* Pass a class array. */
5114 parmse
.use_offset
= 1;
5115 gfc_conv_expr_descriptor (&parmse
, e
);
5117 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5118 allocated on entry, it must be deallocated. */
5119 if (fsym
->attr
.intent
== INTENT_OUT
5120 && CLASS_DATA (fsym
)->attr
.allocatable
)
5125 gfc_init_block (&block
);
5127 ptr
= gfc_class_data_get (ptr
);
5129 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5130 NULL_TREE
, NULL_TREE
,
5133 gfc_add_expr_to_block (&block
, tmp
);
5134 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5135 void_type_node
, ptr
,
5137 gfc_add_expr_to_block (&block
, tmp
);
5138 gfc_reset_vptr (&block
, e
);
5140 if (fsym
->attr
.optional
5141 && e
->expr_type
== EXPR_VARIABLE
5143 || (e
->ref
->type
== REF_ARRAY
5144 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5145 && e
->symtree
->n
.sym
->attr
.optional
)
5147 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5149 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5150 gfc_finish_block (&block
),
5151 build_empty_stmt (input_location
));
5154 tmp
= gfc_finish_block (&block
);
5156 gfc_add_expr_to_block (&se
->pre
, tmp
);
5159 /* The conversion does not repackage the reference to a class
5160 array - _data descriptor. */
5161 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5162 fsym
->attr
.intent
!= INTENT_IN
5163 && (CLASS_DATA (fsym
)->attr
.class_pointer
5164 || CLASS_DATA (fsym
)->attr
.allocatable
),
5166 && e
->expr_type
== EXPR_VARIABLE
5167 && e
->symtree
->n
.sym
->attr
.optional
,
5168 CLASS_DATA (fsym
)->attr
.class_pointer
5169 || CLASS_DATA (fsym
)->attr
.allocatable
);
5173 /* If the procedure requires an explicit interface, the actual
5174 argument is passed according to the corresponding formal
5175 argument. If the corresponding formal argument is a POINTER,
5176 ALLOCATABLE or assumed shape, we do not use g77's calling
5177 convention, and pass the address of the array descriptor
5178 instead. Otherwise we use g77's calling convention. */
5181 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5182 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
5183 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5185 f
= f
|| !comp
->attr
.always_explicit
;
5187 f
= f
|| !sym
->attr
.always_explicit
;
5189 /* If the argument is a function call that may not create
5190 a temporary for the result, we have to check that we
5191 can do it, i.e. that there is no alias between this
5192 argument and another one. */
5193 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5199 intent
= fsym
->attr
.intent
;
5201 intent
= INTENT_UNKNOWN
;
5203 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5205 parmse
.force_tmp
= 1;
5207 iarg
= e
->value
.function
.actual
->expr
;
5209 /* Temporary needed if aliasing due to host association. */
5210 if (sym
->attr
.contained
5212 && !sym
->attr
.implicit_pure
5213 && !sym
->attr
.use_assoc
5214 && iarg
->expr_type
== EXPR_VARIABLE
5215 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5216 parmse
.force_tmp
= 1;
5218 /* Ditto within module. */
5219 if (sym
->attr
.use_assoc
5221 && !sym
->attr
.implicit_pure
5222 && iarg
->expr_type
== EXPR_VARIABLE
5223 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5224 parmse
.force_tmp
= 1;
5227 if (e
->expr_type
== EXPR_VARIABLE
5228 && is_subref_array (e
))
5229 /* The actual argument is a component reference to an
5230 array of derived types. In this case, the argument
5231 is converted to a temporary, which is passed and then
5232 written back after the procedure call. */
5233 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5234 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5235 fsym
&& fsym
->attr
.pointer
);
5236 else if (gfc_is_class_array_ref (e
, NULL
)
5237 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5238 /* The actual argument is a component reference to an
5239 array of derived types. In this case, the argument
5240 is converted to a temporary, which is passed and then
5241 written back after the procedure call.
5242 OOP-TODO: Insert code so that if the dynamic type is
5243 the same as the declared type, copy-in/copy-out does
5245 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5246 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5247 fsym
&& fsym
->attr
.pointer
);
5249 else if (gfc_is_alloc_class_array_function (e
)
5250 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5251 /* See previous comment. For function actual argument,
5252 the write out is not needed so the intent is set as
5255 e
->must_finalize
= 1;
5256 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5258 fsym
&& fsym
->attr
.pointer
);
5261 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
5263 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5264 allocated on entry, it must be deallocated. */
5265 if (fsym
&& fsym
->attr
.allocatable
5266 && fsym
->attr
.intent
== INTENT_OUT
)
5268 tmp
= build_fold_indirect_ref_loc (input_location
,
5270 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5271 if (fsym
->attr
.optional
5272 && e
->expr_type
== EXPR_VARIABLE
5273 && e
->symtree
->n
.sym
->attr
.optional
)
5274 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5276 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5277 tmp
, build_empty_stmt (input_location
));
5278 gfc_add_expr_to_block (&se
->pre
, tmp
);
5283 /* The case with fsym->attr.optional is that of a user subroutine
5284 with an interface indicating an optional argument. When we call
5285 an intrinsic subroutine, however, fsym is NULL, but we might still
5286 have an optional argument, so we proceed to the substitution
5288 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5290 /* If an optional argument is itself an optional dummy argument,
5291 check its presence and substitute a null if absent. This is
5292 only needed when passing an array to an elemental procedure
5293 as then array elements are accessed - or no NULL pointer is
5294 allowed and a "1" or "0" should be passed if not present.
5295 When passing a non-array-descriptor full array to a
5296 non-array-descriptor dummy, no check is needed. For
5297 array-descriptor actual to array-descriptor dummy, see
5298 PR 41911 for why a check has to be inserted.
5299 fsym == NULL is checked as intrinsics required the descriptor
5300 but do not always set fsym. */
5301 if (e
->expr_type
== EXPR_VARIABLE
5302 && e
->symtree
->n
.sym
->attr
.optional
5303 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
5304 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5308 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5309 || fsym
->as
->type
== AS_ASSUMED_RANK
5310 || fsym
->as
->type
== AS_DEFERRED
))))))
5311 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5312 e
->representation
.length
);
5317 /* Obtain the character length of an assumed character length
5318 length procedure from the typespec. */
5319 if (fsym
->ts
.type
== BT_CHARACTER
5320 && parmse
.string_length
== NULL_TREE
5321 && e
->ts
.type
== BT_PROCEDURE
5322 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5323 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5324 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5326 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5327 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5331 if (fsym
&& need_interface_mapping
&& e
)
5332 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5334 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5335 gfc_add_block_to_block (&post
, &parmse
.post
);
5337 /* Allocated allocatable components of derived types must be
5338 deallocated for non-variable scalars. Non-variable arrays are
5339 dealt with in trans-array.c(gfc_conv_array_parameter). */
5340 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5341 && e
->ts
.u
.derived
->attr
.alloc_comp
5342 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
5343 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
5346 tmp
= build_fold_indirect_ref_loc (input_location
,
5348 parm_rank
= e
->rank
;
5356 case (SCALAR_POINTER
):
5357 tmp
= build_fold_indirect_ref_loc (input_location
,
5362 if (e
->expr_type
== EXPR_OP
5363 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5364 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5367 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5368 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5369 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5372 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5374 /* The derived type is passed to gfc_deallocate_alloc_comp.
5375 Therefore, class actuals can handled correctly but derived
5376 types passed to class formals need the _data component. */
5377 tmp
= gfc_class_data_get (tmp
);
5378 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5379 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5382 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5384 gfc_add_expr_to_block (&se
->post
, tmp
);
5387 /* Add argument checking of passing an unallocated/NULL actual to
5388 a nonallocatable/nonpointer dummy. */
5390 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5392 symbol_attribute attr
;
5396 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5397 attr
= gfc_expr_attr (e
);
5399 goto end_pointer_check
;
5401 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5402 allocatable to an optional dummy, cf. 12.5.2.12. */
5403 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5404 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5405 goto end_pointer_check
;
5409 /* If the actual argument is an optional pointer/allocatable and
5410 the formal argument takes an nonpointer optional value,
5411 it is invalid to pass a non-present argument on, even
5412 though there is no technical reason for this in gfortran.
5413 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5414 tree present
, null_ptr
, type
;
5416 if (attr
.allocatable
5417 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5418 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5419 "allocated or not present",
5420 e
->symtree
->n
.sym
->name
);
5421 else if (attr
.pointer
5422 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5423 msg
= xasprintf ("Pointer actual argument '%s' is not "
5424 "associated or not present",
5425 e
->symtree
->n
.sym
->name
);
5426 else if (attr
.proc_pointer
5427 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5428 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5429 "associated or not present",
5430 e
->symtree
->n
.sym
->name
);
5432 goto end_pointer_check
;
5434 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5435 type
= TREE_TYPE (present
);
5436 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5437 boolean_type_node
, present
,
5439 null_pointer_node
));
5440 type
= TREE_TYPE (parmse
.expr
);
5441 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5442 boolean_type_node
, parmse
.expr
,
5444 null_pointer_node
));
5445 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5446 boolean_type_node
, present
, null_ptr
);
5450 if (attr
.allocatable
5451 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5452 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5453 "allocated", e
->symtree
->n
.sym
->name
);
5454 else if (attr
.pointer
5455 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5456 msg
= xasprintf ("Pointer actual argument '%s' is not "
5457 "associated", e
->symtree
->n
.sym
->name
);
5458 else if (attr
.proc_pointer
5459 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5460 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5461 "associated", e
->symtree
->n
.sym
->name
);
5463 goto end_pointer_check
;
5467 /* If the argument is passed by value, we need to strip the
5469 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5470 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5472 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5473 boolean_type_node
, tmp
,
5474 fold_convert (TREE_TYPE (tmp
),
5475 null_pointer_node
));
5478 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5484 /* Deferred length dummies pass the character length by reference
5485 so that the value can be returned. */
5486 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5488 if (INDIRECT_REF_P (parmse
.string_length
))
5489 /* In chains of functions/procedure calls the string_length already
5490 is a pointer to the variable holding the length. Therefore
5491 remove the deref on call. */
5492 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5495 tmp
= parmse
.string_length
;
5496 if (TREE_CODE (tmp
) != VAR_DECL
)
5497 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5498 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5502 /* Character strings are passed as two parameters, a length and a
5503 pointer - except for Bind(c) which only passes the pointer.
5504 An unlimited polymorphic formal argument likewise does not
5506 if (parmse
.string_length
!= NULL_TREE
5507 && !sym
->attr
.is_bind_c
5508 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5509 vec_safe_push (stringargs
, parmse
.string_length
);
5511 /* When calling __copy for character expressions to unlimited
5512 polymorphic entities, the dst argument needs a string length. */
5513 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5514 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5515 && arg
->next
&& arg
->next
->expr
5516 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5517 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5518 vec_safe_push (stringargs
, parmse
.string_length
);
5520 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5521 pass the token and the offset as additional arguments. */
5522 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5523 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5524 && !fsym
->attr
.allocatable
)
5525 || (fsym
->ts
.type
== BT_CLASS
5526 && CLASS_DATA (fsym
)->attr
.codimension
5527 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5529 /* Token and offset. */
5530 vec_safe_push (stringargs
, null_pointer_node
);
5531 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5532 gcc_assert (fsym
->attr
.optional
);
5534 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5535 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5536 && !fsym
->attr
.allocatable
)
5537 || (fsym
->ts
.type
== BT_CLASS
5538 && CLASS_DATA (fsym
)->attr
.codimension
5539 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5541 tree caf_decl
, caf_type
;
5544 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5545 caf_type
= TREE_TYPE (caf_decl
);
5547 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5548 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5549 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5550 tmp
= gfc_conv_descriptor_token (caf_decl
);
5551 else if (DECL_LANG_SPECIFIC (caf_decl
)
5552 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5553 tmp
= GFC_DECL_TOKEN (caf_decl
);
5556 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5557 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5558 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5561 vec_safe_push (stringargs
, tmp
);
5563 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5564 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5565 offset
= build_int_cst (gfc_array_index_type
, 0);
5566 else if (DECL_LANG_SPECIFIC (caf_decl
)
5567 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5568 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5569 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5570 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5572 offset
= build_int_cst (gfc_array_index_type
, 0);
5574 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5575 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5578 gcc_assert (POINTER_TYPE_P (caf_type
));
5582 tmp2
= fsym
->ts
.type
== BT_CLASS
5583 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5584 if ((fsym
->ts
.type
!= BT_CLASS
5585 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5586 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5587 || (fsym
->ts
.type
== BT_CLASS
5588 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5589 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5591 if (fsym
->ts
.type
== BT_CLASS
)
5592 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5595 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5596 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5598 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5599 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5601 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5602 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5605 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5608 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5609 gfc_array_index_type
,
5610 fold_convert (gfc_array_index_type
, tmp2
),
5611 fold_convert (gfc_array_index_type
, tmp
));
5612 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5613 gfc_array_index_type
, offset
, tmp
);
5615 vec_safe_push (stringargs
, offset
);
5618 vec_safe_push (arglist
, parmse
.expr
);
5620 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5627 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5628 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5629 else if (ts
.type
== BT_CHARACTER
)
5631 if (ts
.u
.cl
->length
== NULL
)
5633 /* Assumed character length results are not allowed by 5.1.1.5 of the
5634 standard and are trapped in resolve.c; except in the case of SPREAD
5635 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5636 we take the character length of the first argument for the result.
5637 For dummies, we have to look through the formal argument list for
5638 this function and use the character length found there.*/
5640 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5641 else if (!sym
->attr
.dummy
)
5642 cl
.backend_decl
= (*stringargs
)[0];
5645 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5646 for (; formal
; formal
= formal
->next
)
5647 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5648 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5650 len
= cl
.backend_decl
;
5656 /* Calculate the length of the returned string. */
5657 gfc_init_se (&parmse
, NULL
);
5658 if (need_interface_mapping
)
5659 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5661 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5662 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5663 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5665 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5666 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5667 gfc_charlen_type_node
, tmp
,
5668 build_int_cst (gfc_charlen_type_node
, 0));
5669 cl
.backend_decl
= tmp
;
5672 /* Set up a charlen structure for it. */
5677 len
= cl
.backend_decl
;
5680 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5681 || (!comp
&& gfc_return_by_reference (sym
));
5684 if (se
->direct_byref
)
5686 /* Sometimes, too much indirection can be applied; e.g. for
5687 function_result = array_valued_recursive_function. */
5688 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5689 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5690 && GFC_DESCRIPTOR_TYPE_P
5691 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5692 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5695 /* If the lhs of an assignment x = f(..) is allocatable and
5696 f2003 is allowed, we must do the automatic reallocation.
5697 TODO - deal with intrinsics, without using a temporary. */
5698 if (flag_realloc_lhs
5699 && se
->ss
&& se
->ss
->loop_chain
5700 && se
->ss
->loop_chain
->is_alloc_lhs
5701 && !expr
->value
.function
.isym
5702 && sym
->result
->as
!= NULL
)
5704 /* Evaluate the bounds of the result, if known. */
5705 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5708 /* Perform the automatic reallocation. */
5709 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5711 gfc_add_expr_to_block (&se
->pre
, tmp
);
5713 /* Pass the temporary as the first argument. */
5714 result
= info
->descriptor
;
5717 result
= build_fold_indirect_ref_loc (input_location
,
5719 vec_safe_push (retargs
, se
->expr
);
5721 else if (comp
&& comp
->attr
.dimension
)
5723 gcc_assert (se
->loop
&& info
);
5725 /* Set the type of the array. */
5726 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5727 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5729 /* Evaluate the bounds of the result, if known. */
5730 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5732 /* If the lhs of an assignment x = f(..) is allocatable and
5733 f2003 is allowed, we must not generate the function call
5734 here but should just send back the results of the mapping.
5735 This is signalled by the function ss being flagged. */
5736 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5738 gfc_free_interface_mapping (&mapping
);
5739 return has_alternate_specifier
;
5742 /* Create a temporary to store the result. In case the function
5743 returns a pointer, the temporary will be a shallow copy and
5744 mustn't be deallocated. */
5745 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5746 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5747 tmp
, NULL_TREE
, false,
5748 !comp
->attr
.pointer
, callee_alloc
,
5749 &se
->ss
->info
->expr
->where
);
5751 /* Pass the temporary as the first argument. */
5752 result
= info
->descriptor
;
5753 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5754 vec_safe_push (retargs
, tmp
);
5756 else if (!comp
&& sym
->result
->attr
.dimension
)
5758 gcc_assert (se
->loop
&& info
);
5760 /* Set the type of the array. */
5761 tmp
= gfc_typenode_for_spec (&ts
);
5762 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5764 /* Evaluate the bounds of the result, if known. */
5765 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5767 /* If the lhs of an assignment x = f(..) is allocatable and
5768 f2003 is allowed, we must not generate the function call
5769 here but should just send back the results of the mapping.
5770 This is signalled by the function ss being flagged. */
5771 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5773 gfc_free_interface_mapping (&mapping
);
5774 return has_alternate_specifier
;
5777 /* Create a temporary to store the result. In case the function
5778 returns a pointer, the temporary will be a shallow copy and
5779 mustn't be deallocated. */
5780 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5781 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5782 tmp
, NULL_TREE
, false,
5783 !sym
->attr
.pointer
, callee_alloc
,
5784 &se
->ss
->info
->expr
->where
);
5786 /* Pass the temporary as the first argument. */
5787 result
= info
->descriptor
;
5788 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5789 vec_safe_push (retargs
, tmp
);
5791 else if (ts
.type
== BT_CHARACTER
)
5793 /* Pass the string length. */
5794 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5795 type
= build_pointer_type (type
);
5797 /* Return an address to a char[0:len-1]* temporary for
5798 character pointers. */
5799 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5800 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5802 var
= gfc_create_var (type
, "pstr");
5804 if ((!comp
&& sym
->attr
.allocatable
)
5805 || (comp
&& comp
->attr
.allocatable
))
5807 gfc_add_modify (&se
->pre
, var
,
5808 fold_convert (TREE_TYPE (var
),
5809 null_pointer_node
));
5810 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5811 gfc_add_expr_to_block (&se
->post
, tmp
);
5814 /* Provide an address expression for the function arguments. */
5815 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5818 var
= gfc_conv_string_tmp (se
, type
, len
);
5820 vec_safe_push (retargs
, var
);
5824 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5826 type
= gfc_get_complex_type (ts
.kind
);
5827 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5828 vec_safe_push (retargs
, var
);
5831 /* Add the string length to the argument list. */
5832 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5835 if (TREE_CODE (tmp
) != VAR_DECL
)
5836 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5837 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5838 vec_safe_push (retargs
, tmp
);
5840 else if (ts
.type
== BT_CHARACTER
)
5841 vec_safe_push (retargs
, len
);
5843 gfc_free_interface_mapping (&mapping
);
5845 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5846 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5847 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5848 vec_safe_reserve (retargs
, arglen
);
5850 /* Add the return arguments. */
5851 retargs
->splice (arglist
);
5853 /* Add the hidden present status for optional+value to the arguments. */
5854 retargs
->splice (optionalargs
);
5856 /* Add the hidden string length parameters to the arguments. */
5857 retargs
->splice (stringargs
);
5859 /* We may want to append extra arguments here. This is used e.g. for
5860 calls to libgfortran_matmul_??, which need extra information. */
5861 if (!vec_safe_is_empty (append_args
))
5862 retargs
->splice (append_args
);
5865 /* Generate the actual call. */
5866 if (base_object
== NULL_TREE
)
5867 conv_function_val (se
, sym
, expr
);
5869 conv_base_obj_fcn_val (se
, base_object
, expr
);
5871 /* If there are alternate return labels, function type should be
5872 integer. Can't modify the type in place though, since it can be shared
5873 with other functions. For dummy arguments, the typing is done to
5874 this result, even if it has to be repeated for each call. */
5875 if (has_alternate_specifier
5876 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5878 if (!sym
->attr
.dummy
)
5880 TREE_TYPE (sym
->backend_decl
)
5881 = build_function_type (integer_type_node
,
5882 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5883 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5886 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5889 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5890 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5892 /* If we have a pointer function, but we don't want a pointer, e.g.
5895 where f is pointer valued, we have to dereference the result. */
5896 if (!se
->want_pointer
&& !byref
5897 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5898 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5899 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5901 /* f2c calling conventions require a scalar default real function to
5902 return a double precision result. Convert this back to default
5903 real. We only care about the cases that can happen in Fortran 77.
5905 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5906 && sym
->ts
.kind
== gfc_default_real_kind
5907 && !sym
->attr
.always_explicit
)
5908 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5910 /* A pure function may still have side-effects - it may modify its
5912 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5914 if (!sym
->attr
.pure
)
5915 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5920 /* Add the function call to the pre chain. There is no expression. */
5921 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5922 se
->expr
= NULL_TREE
;
5924 if (!se
->direct_byref
)
5926 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5928 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5930 /* Check the data pointer hasn't been modified. This would
5931 happen in a function returning a pointer. */
5932 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5933 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5936 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5939 se
->expr
= info
->descriptor
;
5940 /* Bundle in the string length. */
5941 se
->string_length
= len
;
5943 else if (ts
.type
== BT_CHARACTER
)
5945 /* Dereference for character pointer results. */
5946 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5947 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5948 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5952 se
->string_length
= len
;
5956 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5957 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5962 /* Follow the function call with the argument post block. */
5965 gfc_add_block_to_block (&se
->pre
, &post
);
5967 /* Transformational functions of derived types with allocatable
5968 components must have the result allocatable components copied. */
5969 arg
= expr
->value
.function
.actual
;
5970 if (result
&& arg
&& expr
->rank
5971 && expr
->value
.function
.isym
5972 && expr
->value
.function
.isym
->transformational
5973 && arg
->expr
->ts
.type
== BT_DERIVED
5974 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5977 /* Copy the allocatable components. We have to use a
5978 temporary here to prevent source allocatable components
5979 from being corrupted. */
5980 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5981 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5982 result
, tmp2
, expr
->rank
);
5983 gfc_add_expr_to_block (&se
->pre
, tmp
);
5984 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5986 gfc_add_expr_to_block (&se
->pre
, tmp
);
5988 /* Finally free the temporary's data field. */
5989 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5990 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5991 NULL_TREE
, NULL_TREE
, true,
5993 gfc_add_expr_to_block (&se
->pre
, tmp
);
5998 /* For a function with a class array result, save the result as
5999 a temporary, set the info fields needed by the scalarizer and
6000 call the finalization function of the temporary. Note that the
6001 nullification of allocatable components needed by the result
6002 is done in gfc_trans_assignment_1. */
6003 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6004 && se
->ss
&& se
->ss
->loop
)
6005 || gfc_is_alloc_class_scalar_function (expr
))
6006 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6007 && expr
->must_finalize
)
6012 if (se
->ss
&& se
->ss
->loop
)
6014 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6015 tmp
= gfc_class_data_get (se
->expr
);
6016 info
->descriptor
= tmp
;
6017 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6018 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6019 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6021 tree dim
= gfc_rank_cst
[n
];
6022 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6023 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6028 /* TODO Eliminate the doubling of temporaries. This
6029 one is necessary to ensure no memory leakage. */
6030 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6031 tmp
= gfc_class_data_get (se
->expr
);
6032 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6033 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6036 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6037 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6040 fold_convert (TREE_TYPE (final_fndecl
),
6041 null_pointer_node
));
6042 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6044 tmp
= build_call_expr_loc (input_location
,
6046 gfc_build_addr_expr (NULL
, tmp
),
6047 gfc_class_vtab_size_get (se
->expr
),
6048 boolean_false_node
);
6049 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6050 void_type_node
, is_final
, tmp
,
6051 build_empty_stmt (input_location
));
6053 if (se
->ss
&& se
->ss
->loop
)
6055 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6056 tmp
= gfc_call_free (convert (pvoid_type_node
, info
->data
));
6057 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6061 gfc_add_expr_to_block (&se
->post
, tmp
);
6062 tmp
= gfc_class_data_get (se
->expr
);
6063 tmp
= gfc_call_free (convert (pvoid_type_node
, tmp
));
6064 gfc_add_expr_to_block (&se
->post
, tmp
);
6066 expr
->must_finalize
= 0;
6069 gfc_add_block_to_block (&se
->post
, &post
);
6072 return has_alternate_specifier
;
6076 /* Fill a character string with spaces. */
6079 fill_with_spaces (tree start
, tree type
, tree size
)
6081 stmtblock_t block
, loop
;
6082 tree i
, el
, exit_label
, cond
, tmp
;
6084 /* For a simple char type, we can call memset(). */
6085 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6086 return build_call_expr_loc (input_location
,
6087 builtin_decl_explicit (BUILT_IN_MEMSET
),
6089 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6090 lang_hooks
.to_target_charset (' ')),
6093 /* Otherwise, we use a loop:
6094 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6098 /* Initialize variables. */
6099 gfc_init_block (&block
);
6100 i
= gfc_create_var (sizetype
, "i");
6101 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6102 el
= gfc_create_var (build_pointer_type (type
), "el");
6103 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6104 exit_label
= gfc_build_label_decl (NULL_TREE
);
6105 TREE_USED (exit_label
) = 1;
6109 gfc_init_block (&loop
);
6111 /* Exit condition. */
6112 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6113 build_zero_cst (sizetype
));
6114 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6115 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6116 build_empty_stmt (input_location
));
6117 gfc_add_expr_to_block (&loop
, tmp
);
6120 gfc_add_modify (&loop
,
6121 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6122 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6124 /* Increment loop variables. */
6125 gfc_add_modify (&loop
, i
,
6126 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6127 TYPE_SIZE_UNIT (type
)));
6128 gfc_add_modify (&loop
, el
,
6129 fold_build_pointer_plus_loc (input_location
,
6130 el
, TYPE_SIZE_UNIT (type
)));
6132 /* Making the loop... actually loop! */
6133 tmp
= gfc_finish_block (&loop
);
6134 tmp
= build1_v (LOOP_EXPR
, tmp
);
6135 gfc_add_expr_to_block (&block
, tmp
);
6137 /* The exit label. */
6138 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6139 gfc_add_expr_to_block (&block
, tmp
);
6142 return gfc_finish_block (&block
);
6146 /* Generate code to copy a string. */
6149 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6150 int dkind
, tree slength
, tree src
, int skind
)
6152 tree tmp
, dlen
, slen
;
6161 stmtblock_t tempblock
;
6163 gcc_assert (dkind
== skind
);
6165 if (slength
!= NULL_TREE
)
6167 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6168 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6172 slen
= build_int_cst (size_type_node
, 1);
6176 if (dlength
!= NULL_TREE
)
6178 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6179 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6183 dlen
= build_int_cst (size_type_node
, 1);
6187 /* Assign directly if the types are compatible. */
6188 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6189 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6191 gfc_add_modify (block
, dsc
, ssc
);
6195 /* Do nothing if the destination length is zero. */
6196 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6197 build_int_cst (size_type_node
, 0));
6199 /* The following code was previously in _gfortran_copy_string:
6201 // The two strings may overlap so we use memmove.
6203 copy_string (GFC_INTEGER_4 destlen, char * dest,
6204 GFC_INTEGER_4 srclen, const char * src)
6206 if (srclen >= destlen)
6208 // This will truncate if too long.
6209 memmove (dest, src, destlen);
6213 memmove (dest, src, srclen);
6215 memset (&dest[srclen], ' ', destlen - srclen);
6219 We're now doing it here for better optimization, but the logic
6222 /* For non-default character kinds, we have to multiply the string
6223 length by the base type size. */
6224 chartype
= gfc_get_char_type (dkind
);
6225 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6226 fold_convert (size_type_node
, slen
),
6227 fold_convert (size_type_node
,
6228 TYPE_SIZE_UNIT (chartype
)));
6229 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6230 fold_convert (size_type_node
, dlen
),
6231 fold_convert (size_type_node
,
6232 TYPE_SIZE_UNIT (chartype
)));
6234 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6235 dest
= fold_convert (pvoid_type_node
, dest
);
6237 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6239 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6240 src
= fold_convert (pvoid_type_node
, src
);
6242 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6244 /* Truncate string if source is too long. */
6245 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6247 tmp2
= build_call_expr_loc (input_location
,
6248 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6249 3, dest
, src
, dlen
);
6251 /* Else copy and pad with spaces. */
6252 tmp3
= build_call_expr_loc (input_location
,
6253 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6254 3, dest
, src
, slen
);
6256 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6257 tmp4
= fill_with_spaces (tmp4
, chartype
,
6258 fold_build2_loc (input_location
, MINUS_EXPR
,
6259 TREE_TYPE(dlen
), dlen
, slen
));
6261 gfc_init_block (&tempblock
);
6262 gfc_add_expr_to_block (&tempblock
, tmp3
);
6263 gfc_add_expr_to_block (&tempblock
, tmp4
);
6264 tmp3
= gfc_finish_block (&tempblock
);
6266 /* The whole copy_string function is there. */
6267 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6269 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6270 build_empty_stmt (input_location
));
6271 gfc_add_expr_to_block (block
, tmp
);
6275 /* Translate a statement function.
6276 The value of a statement function reference is obtained by evaluating the
6277 expression using the values of the actual arguments for the values of the
6278 corresponding dummy arguments. */
6281 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6285 gfc_formal_arglist
*fargs
;
6286 gfc_actual_arglist
*args
;
6289 gfc_saved_var
*saved_vars
;
6295 sym
= expr
->symtree
->n
.sym
;
6296 args
= expr
->value
.function
.actual
;
6297 gfc_init_se (&lse
, NULL
);
6298 gfc_init_se (&rse
, NULL
);
6301 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6303 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6304 temp_vars
= XCNEWVEC (tree
, n
);
6306 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6307 fargs
= fargs
->next
, n
++)
6309 /* Each dummy shall be specified, explicitly or implicitly, to be
6311 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6314 if (fsym
->ts
.type
== BT_CHARACTER
)
6316 /* Copy string arguments. */
6319 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6320 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6322 /* Create a temporary to hold the value. */
6323 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6324 fsym
->ts
.u
.cl
->backend_decl
6325 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6327 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6328 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6330 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6332 gfc_conv_expr (&rse
, args
->expr
);
6333 gfc_conv_string_parameter (&rse
);
6334 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6335 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6337 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6338 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6339 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6340 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6344 /* For everything else, just evaluate the expression. */
6346 /* Create a temporary to hold the value. */
6347 type
= gfc_typenode_for_spec (&fsym
->ts
);
6348 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6350 gfc_conv_expr (&lse
, args
->expr
);
6352 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6353 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6354 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6360 /* Use the temporary variables in place of the real ones. */
6361 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6362 fargs
= fargs
->next
, n
++)
6363 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6365 gfc_conv_expr (se
, sym
->value
);
6367 if (sym
->ts
.type
== BT_CHARACTER
)
6369 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6371 /* Force the expression to the correct length. */
6372 if (!INTEGER_CST_P (se
->string_length
)
6373 || tree_int_cst_lt (se
->string_length
,
6374 sym
->ts
.u
.cl
->backend_decl
))
6376 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6377 tmp
= gfc_create_var (type
, sym
->name
);
6378 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6379 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6380 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6384 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6387 /* Restore the original variables. */
6388 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6389 fargs
= fargs
->next
, n
++)
6390 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6396 /* Translate a function expression. */
6399 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6403 if (expr
->value
.function
.isym
)
6405 gfc_conv_intrinsic_function (se
, expr
);
6409 /* expr.value.function.esym is the resolved (specific) function symbol for
6410 most functions. However this isn't set for dummy procedures. */
6411 sym
= expr
->value
.function
.esym
;
6413 sym
= expr
->symtree
->n
.sym
;
6415 /* The IEEE_ARITHMETIC functions are caught here. */
6416 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6417 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6420 /* We distinguish statement functions from general functions to improve
6421 runtime performance. */
6422 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6424 gfc_conv_statement_function (se
, expr
);
6428 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6433 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6436 is_zero_initializer_p (gfc_expr
* expr
)
6438 if (expr
->expr_type
!= EXPR_CONSTANT
)
6441 /* We ignore constants with prescribed memory representations for now. */
6442 if (expr
->representation
.string
)
6445 switch (expr
->ts
.type
)
6448 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6451 return mpfr_zero_p (expr
->value
.real
)
6452 && MPFR_SIGN (expr
->value
.real
) >= 0;
6455 return expr
->value
.logical
== 0;
6458 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6459 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6460 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6461 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6471 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6476 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6477 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6479 gfc_conv_tmp_array_ref (se
);
6483 /* Build a static initializer. EXPR is the expression for the initial value.
6484 The other parameters describe the variable of the component being
6485 initialized. EXPR may be null. */
6488 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6489 bool array
, bool pointer
, bool procptr
)
6493 if (!(expr
|| pointer
|| procptr
))
6496 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6497 (these are the only two iso_c_binding derived types that can be
6498 used as initialization expressions). If so, we need to modify
6499 the 'expr' to be that for a (void *). */
6500 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6501 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6503 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6505 /* The derived symbol has already been converted to a (void *). Use
6507 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6508 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6510 gfc_init_se (&se
, NULL
);
6511 gfc_conv_constant (&se
, expr
);
6512 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6516 if (array
&& !procptr
)
6519 /* Arrays need special handling. */
6521 ctor
= gfc_build_null_descriptor (type
);
6522 /* Special case assigning an array to zero. */
6523 else if (is_zero_initializer_p (expr
))
6524 ctor
= build_constructor (type
, NULL
);
6526 ctor
= gfc_conv_array_initializer (type
, expr
);
6527 TREE_STATIC (ctor
) = 1;
6530 else if (pointer
|| procptr
)
6532 if (ts
->type
== BT_CLASS
&& !procptr
)
6534 gfc_init_se (&se
, NULL
);
6535 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6536 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6537 TREE_STATIC (se
.expr
) = 1;
6540 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6541 return fold_convert (type
, null_pointer_node
);
6544 gfc_init_se (&se
, NULL
);
6545 se
.want_pointer
= 1;
6546 gfc_conv_expr (&se
, expr
);
6547 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6557 gfc_init_se (&se
, NULL
);
6558 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6559 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6561 gfc_conv_structure (&se
, expr
, 1);
6562 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6563 TREE_STATIC (se
.expr
) = 1;
6568 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6569 TREE_STATIC (ctor
) = 1;
6574 gfc_init_se (&se
, NULL
);
6575 gfc_conv_constant (&se
, expr
);
6576 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6583 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6589 gfc_array_info
*lss_array
;
6596 gfc_start_block (&block
);
6598 /* Initialize the scalarizer. */
6599 gfc_init_loopinfo (&loop
);
6601 gfc_init_se (&lse
, NULL
);
6602 gfc_init_se (&rse
, NULL
);
6605 rss
= gfc_walk_expr (expr
);
6606 if (rss
== gfc_ss_terminator
)
6607 /* The rhs is scalar. Add a ss for the expression. */
6608 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6610 /* Create a SS for the destination. */
6611 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6613 lss_array
= &lss
->info
->data
.array
;
6614 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6615 lss_array
->descriptor
= dest
;
6616 lss_array
->data
= gfc_conv_array_data (dest
);
6617 lss_array
->offset
= gfc_conv_array_offset (dest
);
6618 for (n
= 0; n
< cm
->as
->rank
; n
++)
6620 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6621 lss_array
->stride
[n
] = gfc_index_one_node
;
6623 mpz_init (lss_array
->shape
[n
]);
6624 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6625 cm
->as
->lower
[n
]->value
.integer
);
6626 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6629 /* Associate the SS with the loop. */
6630 gfc_add_ss_to_loop (&loop
, lss
);
6631 gfc_add_ss_to_loop (&loop
, rss
);
6633 /* Calculate the bounds of the scalarization. */
6634 gfc_conv_ss_startstride (&loop
);
6636 /* Setup the scalarizing loops. */
6637 gfc_conv_loop_setup (&loop
, &expr
->where
);
6639 /* Setup the gfc_se structures. */
6640 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6641 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6644 gfc_mark_ss_chain_used (rss
, 1);
6646 gfc_mark_ss_chain_used (lss
, 1);
6648 /* Start the scalarized loop body. */
6649 gfc_start_scalarized_body (&loop
, &body
);
6651 gfc_conv_tmp_array_ref (&lse
);
6652 if (cm
->ts
.type
== BT_CHARACTER
)
6653 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6655 gfc_conv_expr (&rse
, expr
);
6657 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6658 gfc_add_expr_to_block (&body
, tmp
);
6660 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6662 /* Generate the copying loops. */
6663 gfc_trans_scalarizing_loops (&loop
, &body
);
6665 /* Wrap the whole thing up. */
6666 gfc_add_block_to_block (&block
, &loop
.pre
);
6667 gfc_add_block_to_block (&block
, &loop
.post
);
6669 gcc_assert (lss_array
->shape
!= NULL
);
6670 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6671 gfc_cleanup_loop (&loop
);
6673 return gfc_finish_block (&block
);
6678 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6688 gfc_expr
*arg
= NULL
;
6690 gfc_start_block (&block
);
6691 gfc_init_se (&se
, NULL
);
6693 /* Get the descriptor for the expressions. */
6694 se
.want_pointer
= 0;
6695 gfc_conv_expr_descriptor (&se
, expr
);
6696 gfc_add_block_to_block (&block
, &se
.pre
);
6697 gfc_add_modify (&block
, dest
, se
.expr
);
6699 /* Deal with arrays of derived types with allocatable components. */
6700 if (cm
->ts
.type
== BT_DERIVED
6701 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6702 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6705 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6706 && CLASS_DATA(cm
)->attr
.allocatable
)
6708 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6709 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6714 tmp
= TREE_TYPE (dest
);
6715 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6716 tmp
, expr
->rank
, NULL_TREE
);
6720 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6721 TREE_TYPE(cm
->backend_decl
),
6722 cm
->as
->rank
, NULL_TREE
);
6724 gfc_add_expr_to_block (&block
, tmp
);
6725 gfc_add_block_to_block (&block
, &se
.post
);
6727 if (expr
->expr_type
!= EXPR_VARIABLE
)
6728 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6731 /* We need to know if the argument of a conversion function is a
6732 variable, so that the correct lower bound can be used. */
6733 if (expr
->expr_type
== EXPR_FUNCTION
6734 && expr
->value
.function
.isym
6735 && expr
->value
.function
.isym
->conversion
6736 && expr
->value
.function
.actual
->expr
6737 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6738 arg
= expr
->value
.function
.actual
->expr
;
6740 /* Obtain the array spec of full array references. */
6742 as
= gfc_get_full_arrayspec_from_expr (arg
);
6744 as
= gfc_get_full_arrayspec_from_expr (expr
);
6746 /* Shift the lbound and ubound of temporaries to being unity,
6747 rather than zero, based. Always calculate the offset. */
6748 offset
= gfc_conv_descriptor_offset_get (dest
);
6749 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6750 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6752 for (n
= 0; n
< expr
->rank
; n
++)
6757 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6758 TODO It looks as if gfc_conv_expr_descriptor should return
6759 the correct bounds and that the following should not be
6760 necessary. This would simplify gfc_conv_intrinsic_bound
6762 if (as
&& as
->lower
[n
])
6765 gfc_init_se (&lbse
, NULL
);
6766 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6767 gfc_add_block_to_block (&block
, &lbse
.pre
);
6768 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6772 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6773 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6777 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6780 lbound
= gfc_index_one_node
;
6782 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6784 /* Shift the bounds and set the offset accordingly. */
6785 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6786 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6787 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6788 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6790 gfc_conv_descriptor_ubound_set (&block
, dest
,
6791 gfc_rank_cst
[n
], tmp
);
6792 gfc_conv_descriptor_lbound_set (&block
, dest
,
6793 gfc_rank_cst
[n
], lbound
);
6795 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6796 gfc_conv_descriptor_lbound_get (dest
,
6798 gfc_conv_descriptor_stride_get (dest
,
6800 gfc_add_modify (&block
, tmp2
, tmp
);
6801 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6803 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6808 /* If a conversion expression has a null data pointer
6809 argument, nullify the allocatable component. */
6813 if (arg
->symtree
->n
.sym
->attr
.allocatable
6814 || arg
->symtree
->n
.sym
->attr
.pointer
)
6816 non_null_expr
= gfc_finish_block (&block
);
6817 gfc_start_block (&block
);
6818 gfc_conv_descriptor_data_set (&block
, dest
,
6820 null_expr
= gfc_finish_block (&block
);
6821 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6822 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6823 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6824 return build3_v (COND_EXPR
, tmp
,
6825 null_expr
, non_null_expr
);
6829 return gfc_finish_block (&block
);
6833 /* Allocate or reallocate scalar component, as necessary. */
6836 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6846 tree lhs_cl_size
= NULL_TREE
;
6851 if (!expr2
|| expr2
->rank
)
6854 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6856 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6858 char name
[GFC_MAX_SYMBOL_LEN
+9];
6859 gfc_component
*strlen
;
6860 /* Use the rhs string length and the lhs element size. */
6861 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6862 if (!expr2
->ts
.u
.cl
->backend_decl
)
6864 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6865 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6868 size
= expr2
->ts
.u
.cl
->backend_decl
;
6870 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6872 sprintf (name
, "_%s_length", cm
->name
);
6873 strlen
= gfc_find_component (sym
, name
, true, true);
6874 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6875 gfc_charlen_type_node
,
6876 TREE_OPERAND (comp
, 0),
6877 strlen
->backend_decl
, NULL_TREE
);
6879 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6880 tmp
= TYPE_SIZE_UNIT (tmp
);
6881 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6882 TREE_TYPE (tmp
), tmp
,
6883 fold_convert (TREE_TYPE (tmp
), size
));
6887 /* Otherwise use the length in bytes of the rhs. */
6888 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6889 size_in_bytes
= size
;
6892 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6893 size_in_bytes
, size_one_node
);
6895 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6897 tmp
= build_call_expr_loc (input_location
,
6898 builtin_decl_explicit (BUILT_IN_CALLOC
),
6899 2, build_one_cst (size_type_node
),
6901 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6902 gfc_add_modify (block
, comp
, tmp
);
6906 tmp
= build_call_expr_loc (input_location
,
6907 builtin_decl_explicit (BUILT_IN_MALLOC
),
6909 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
6910 ptr
= gfc_class_data_get (comp
);
6913 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
6914 gfc_add_modify (block
, ptr
, tmp
);
6917 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6918 /* Update the lhs character length. */
6919 gfc_add_modify (block
, lhs_cl_size
, size
);
6923 /* Assign a single component of a derived type constructor. */
6926 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6927 gfc_symbol
*sym
, bool init
)
6935 gfc_start_block (&block
);
6937 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6939 /* Only care about pointers here, not about allocatables. */
6940 gfc_init_se (&se
, NULL
);
6941 /* Pointer component. */
6942 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6943 && !cm
->attr
.proc_pointer
)
6945 /* Array pointer. */
6946 if (expr
->expr_type
== EXPR_NULL
)
6947 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6950 se
.direct_byref
= 1;
6952 gfc_conv_expr_descriptor (&se
, expr
);
6953 gfc_add_block_to_block (&block
, &se
.pre
);
6954 gfc_add_block_to_block (&block
, &se
.post
);
6959 /* Scalar pointers. */
6960 se
.want_pointer
= 1;
6961 gfc_conv_expr (&se
, expr
);
6962 gfc_add_block_to_block (&block
, &se
.pre
);
6964 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6965 && expr
->symtree
->n
.sym
->attr
.dummy
)
6966 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6968 gfc_add_modify (&block
, dest
,
6969 fold_convert (TREE_TYPE (dest
), se
.expr
));
6970 gfc_add_block_to_block (&block
, &se
.post
);
6973 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6975 /* NULL initialization for CLASS components. */
6976 tmp
= gfc_trans_structure_assign (dest
,
6977 gfc_class_initializer (&cm
->ts
, expr
),
6979 gfc_add_expr_to_block (&block
, tmp
);
6981 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6982 && !cm
->attr
.proc_pointer
)
6984 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6985 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6986 else if (cm
->attr
.allocatable
)
6988 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6989 gfc_add_expr_to_block (&block
, tmp
);
6993 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6994 gfc_add_expr_to_block (&block
, tmp
);
6997 else if (cm
->ts
.type
== BT_CLASS
6998 && CLASS_DATA (cm
)->attr
.dimension
6999 && CLASS_DATA (cm
)->attr
.allocatable
7000 && expr
->ts
.type
== BT_DERIVED
)
7002 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7003 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7004 tmp
= gfc_class_vptr_get (dest
);
7005 gfc_add_modify (&block
, tmp
,
7006 fold_convert (TREE_TYPE (tmp
), vtab
));
7007 tmp
= gfc_class_data_get (dest
);
7008 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7009 gfc_add_expr_to_block (&block
, tmp
);
7011 else if (init
&& (cm
->attr
.allocatable
7012 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
7014 /* Take care about non-array allocatable components here. The alloc_*
7015 routine below is motivated by the alloc_scalar_allocatable_for_
7016 assignment() routine, but with the realloc portions removed and
7018 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7023 /* The remainder of these instructions follow the if (cm->attr.pointer)
7024 if (!cm->attr.dimension) part above. */
7025 gfc_init_se (&se
, NULL
);
7026 gfc_conv_expr (&se
, expr
);
7027 gfc_add_block_to_block (&block
, &se
.pre
);
7029 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7030 && expr
->symtree
->n
.sym
->attr
.dummy
)
7031 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7033 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7035 tmp
= gfc_class_data_get (dest
);
7036 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7037 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7038 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7039 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7040 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7043 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7045 /* For deferred strings insert a memcpy. */
7046 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7049 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7050 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7052 : expr
->ts
.u
.cl
->backend_decl
);
7053 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7054 gfc_add_expr_to_block (&block
, tmp
);
7057 gfc_add_modify (&block
, tmp
,
7058 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7059 gfc_add_block_to_block (&block
, &se
.post
);
7061 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7063 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7065 gfc_init_se (&se
, NULL
);
7066 gfc_conv_expr (&se
, expr
);
7067 gfc_add_block_to_block (&block
, &se
.pre
);
7068 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7069 && expr
->expr_type
== EXPR_VARIABLE
)
7071 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7073 gfc_add_expr_to_block (&block
, tmp
);
7076 gfc_add_modify (&block
, dest
,
7077 fold_convert (TREE_TYPE (dest
), se
.expr
));
7078 gfc_add_block_to_block (&block
, &se
.post
);
7082 /* Nested constructors. */
7083 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7084 gfc_add_expr_to_block (&block
, tmp
);
7087 else if (gfc_deferred_strlen (cm
, &tmp
))
7091 gcc_assert (strlen
);
7092 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7094 TREE_OPERAND (dest
, 0),
7097 if (expr
->expr_type
== EXPR_NULL
)
7099 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7100 gfc_add_modify (&block
, dest
, tmp
);
7101 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7102 gfc_add_modify (&block
, strlen
, tmp
);
7107 gfc_init_se (&se
, NULL
);
7108 gfc_conv_expr (&se
, expr
);
7109 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7110 tmp
= build_call_expr_loc (input_location
,
7111 builtin_decl_explicit (BUILT_IN_MALLOC
),
7113 gfc_add_modify (&block
, dest
,
7114 fold_convert (TREE_TYPE (dest
), tmp
));
7115 gfc_add_modify (&block
, strlen
, se
.string_length
);
7116 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7117 gfc_add_expr_to_block (&block
, tmp
);
7120 else if (!cm
->attr
.artificial
)
7122 /* Scalar component (excluding deferred parameters). */
7123 gfc_init_se (&se
, NULL
);
7124 gfc_init_se (&lse
, NULL
);
7126 gfc_conv_expr (&se
, expr
);
7127 if (cm
->ts
.type
== BT_CHARACTER
)
7128 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7130 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
7131 gfc_add_expr_to_block (&block
, tmp
);
7133 return gfc_finish_block (&block
);
7136 /* Assign a derived type constructor to a variable. */
7139 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7147 gfc_start_block (&block
);
7148 cm
= expr
->ts
.u
.derived
->components
;
7150 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7151 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7152 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7156 gcc_assert (cm
->backend_decl
== NULL
);
7157 gfc_init_se (&se
, NULL
);
7158 gfc_init_se (&lse
, NULL
);
7159 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7161 gfc_add_modify (&block
, lse
.expr
,
7162 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7164 return gfc_finish_block (&block
);
7167 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7168 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7170 /* Skip absent members in default initializers. */
7171 if (!c
->expr
&& !cm
->attr
.allocatable
)
7174 field
= cm
->backend_decl
;
7175 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7176 dest
, field
, NULL_TREE
);
7179 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7180 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7185 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7186 expr
->ts
.u
.derived
, init
);
7187 gfc_add_expr_to_block (&block
, tmp
);
7189 return gfc_finish_block (&block
);
7192 /* Build an expression for a constructor. If init is nonzero then
7193 this is part of a static variable initializer. */
7196 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7203 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7205 gcc_assert (se
->ss
== NULL
);
7206 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7207 type
= gfc_typenode_for_spec (&expr
->ts
);
7211 /* Create a temporary variable and fill it in. */
7212 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7213 /* The symtree in expr is NULL, if the code to generate is for
7214 initializing the static members only. */
7215 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7216 gfc_add_expr_to_block (&se
->pre
, tmp
);
7220 cm
= expr
->ts
.u
.derived
->components
;
7222 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7223 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7225 /* Skip absent members in default initializers and allocatable
7226 components. Although the latter have a default initializer
7227 of EXPR_NULL,... by default, the static nullify is not needed
7228 since this is done every time we come into scope. */
7229 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7232 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7233 && strcmp (cm
->name
, "_extends") == 0
7234 && cm
->initializer
->symtree
)
7238 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7239 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7240 vtab
= unshare_expr_without_location (vtab
);
7241 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7243 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7245 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7246 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7247 fold_convert (TREE_TYPE (cm
->backend_decl
),
7250 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7251 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7252 fold_convert (TREE_TYPE (cm
->backend_decl
),
7253 integer_zero_node
));
7256 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7257 TREE_TYPE (cm
->backend_decl
),
7258 cm
->attr
.dimension
, cm
->attr
.pointer
,
7259 cm
->attr
.proc_pointer
);
7260 val
= unshare_expr_without_location (val
);
7262 /* Append it to the constructor list. */
7263 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7266 se
->expr
= build_constructor (type
, v
);
7268 TREE_CONSTANT (se
->expr
) = 1;
7272 /* Translate a substring expression. */
7275 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7281 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7283 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7284 expr
->value
.character
.length
,
7285 expr
->value
.character
.string
);
7287 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7288 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7291 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7295 /* Entry point for expression translation. Evaluates a scalar quantity.
7296 EXPR is the expression to be translated, and SE is the state structure if
7297 called from within the scalarized. */
7300 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7305 if (ss
&& ss
->info
->expr
== expr
7306 && (ss
->info
->type
== GFC_SS_SCALAR
7307 || ss
->info
->type
== GFC_SS_REFERENCE
))
7309 gfc_ss_info
*ss_info
;
7312 /* Substitute a scalar expression evaluated outside the scalarization
7314 se
->expr
= ss_info
->data
.scalar
.value
;
7315 /* If the reference can be NULL, the value field contains the reference,
7316 not the value the reference points to (see gfc_add_loop_ss_code). */
7317 if (ss_info
->can_be_null_ref
)
7318 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7320 se
->string_length
= ss_info
->string_length
;
7321 gfc_advance_se_ss_chain (se
);
7325 /* We need to convert the expressions for the iso_c_binding derived types.
7326 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7327 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7328 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7329 updated to be an integer with a kind equal to the size of a (void *). */
7330 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7331 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7333 if (expr
->expr_type
== EXPR_VARIABLE
7334 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7335 || expr
->symtree
->n
.sym
->intmod_sym_id
7336 == ISOCBINDING_NULL_FUNPTR
))
7338 /* Set expr_type to EXPR_NULL, which will result in
7339 null_pointer_node being used below. */
7340 expr
->expr_type
= EXPR_NULL
;
7344 /* Update the type/kind of the expression to be what the new
7345 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7346 expr
->ts
.type
= BT_INTEGER
;
7347 expr
->ts
.f90_type
= BT_VOID
;
7348 expr
->ts
.kind
= gfc_index_integer_kind
;
7352 gfc_fix_class_refs (expr
);
7354 switch (expr
->expr_type
)
7357 gfc_conv_expr_op (se
, expr
);
7361 gfc_conv_function_expr (se
, expr
);
7365 gfc_conv_constant (se
, expr
);
7369 gfc_conv_variable (se
, expr
);
7373 se
->expr
= null_pointer_node
;
7376 case EXPR_SUBSTRING
:
7377 gfc_conv_substring_expr (se
, expr
);
7380 case EXPR_STRUCTURE
:
7381 gfc_conv_structure (se
, expr
, 0);
7385 gfc_conv_array_constructor_expr (se
, expr
);
7394 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7395 of an assignment. */
7397 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7399 gfc_conv_expr (se
, expr
);
7400 /* All numeric lvalues should have empty post chains. If not we need to
7401 figure out a way of rewriting an lvalue so that it has no post chain. */
7402 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7405 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7406 numeric expressions. Used for scalar values where inserting cleanup code
7409 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7413 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7414 gfc_conv_expr (se
, expr
);
7417 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7418 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7420 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7424 /* Helper to translate an expression and convert it to a particular type. */
7426 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7428 gfc_conv_expr_val (se
, expr
);
7429 se
->expr
= convert (type
, se
->expr
);
7433 /* Converts an expression so that it can be passed by reference. Scalar
7437 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7443 if (ss
&& ss
->info
->expr
== expr
7444 && ss
->info
->type
== GFC_SS_REFERENCE
)
7446 /* Returns a reference to the scalar evaluated outside the loop
7448 gfc_conv_expr (se
, expr
);
7450 if (expr
->ts
.type
== BT_CHARACTER
7451 && expr
->expr_type
!= EXPR_FUNCTION
)
7452 gfc_conv_string_parameter (se
);
7454 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7459 if (expr
->ts
.type
== BT_CHARACTER
)
7461 gfc_conv_expr (se
, expr
);
7462 gfc_conv_string_parameter (se
);
7466 if (expr
->expr_type
== EXPR_VARIABLE
)
7468 se
->want_pointer
= 1;
7469 gfc_conv_expr (se
, expr
);
7472 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7473 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7474 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7480 if (expr
->expr_type
== EXPR_FUNCTION
7481 && ((expr
->value
.function
.esym
7482 && expr
->value
.function
.esym
->result
->attr
.pointer
7483 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7484 || (!expr
->value
.function
.esym
&& !expr
->ref
7485 && expr
->symtree
->n
.sym
->attr
.pointer
7486 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7488 se
->want_pointer
= 1;
7489 gfc_conv_expr (se
, expr
);
7490 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7491 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7496 gfc_conv_expr (se
, expr
);
7498 /* Create a temporary var to hold the value. */
7499 if (TREE_CONSTANT (se
->expr
))
7501 tree tmp
= se
->expr
;
7502 STRIP_TYPE_NOPS (tmp
);
7503 var
= build_decl (input_location
,
7504 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7505 DECL_INITIAL (var
) = tmp
;
7506 TREE_STATIC (var
) = 1;
7511 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7512 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7514 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7516 /* Take the address of that value. */
7517 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7518 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
7519 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
7520 && expr
->ts
.u
.derived
->attr
.alloc_comp
7521 && expr
->expr_type
!= EXPR_VARIABLE
)
7525 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7526 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7528 /* The components shall be deallocated before
7529 their containing entity. */
7530 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7536 gfc_trans_pointer_assign (gfc_code
* code
)
7538 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7542 /* Generate code for a pointer assignment. */
7545 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7547 gfc_expr
*expr1_vptr
= NULL
;
7557 gfc_start_block (&block
);
7559 gfc_init_se (&lse
, NULL
);
7561 /* Check whether the expression is a scalar or not; we cannot use
7562 expr1->rank as it can be nonzero for proc pointers. */
7563 ss
= gfc_walk_expr (expr1
);
7564 scalar
= ss
== gfc_ss_terminator
;
7566 gfc_free_ss_chain (ss
);
7568 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7569 && expr2
->expr_type
!= EXPR_FUNCTION
)
7571 gfc_add_data_component (expr2
);
7572 /* The following is required as gfc_add_data_component doesn't
7573 update ts.type if there is a tailing REF_ARRAY. */
7574 expr2
->ts
.type
= BT_DERIVED
;
7579 /* Scalar pointers. */
7580 lse
.want_pointer
= 1;
7581 gfc_conv_expr (&lse
, expr1
);
7582 gfc_init_se (&rse
, NULL
);
7583 rse
.want_pointer
= 1;
7584 gfc_conv_expr (&rse
, expr2
);
7586 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7587 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7588 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7591 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7592 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7593 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7596 gfc_add_block_to_block (&block
, &lse
.pre
);
7597 gfc_add_block_to_block (&block
, &rse
.pre
);
7599 /* For string assignments to unlimited polymorphic pointers add an
7600 assignment of the string_length to the _len component of the
7602 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7603 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7604 && (expr2
->ts
.type
== BT_CHARACTER
||
7605 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7606 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7610 len_comp
= gfc_get_len_component (expr1
);
7611 gfc_init_se (&se
, NULL
);
7612 gfc_conv_expr (&se
, len_comp
);
7614 /* ptr % _len = len (str) */
7615 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7616 lse
.string_length
= se
.expr
;
7617 gfc_free_expr (len_comp
);
7620 /* Check character lengths if character expression. The test is only
7621 really added if -fbounds-check is enabled. Exclude deferred
7622 character length lefthand sides. */
7623 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7624 && !expr1
->ts
.deferred
7625 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7626 && !gfc_is_proc_ptr_comp (expr1
))
7628 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7629 gcc_assert (lse
.string_length
&& rse
.string_length
);
7630 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7631 lse
.string_length
, rse
.string_length
,
7635 /* The assignment to an deferred character length sets the string
7636 length to that of the rhs. */
7637 if (expr1
->ts
.deferred
)
7639 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7640 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7641 else if (lse
.string_length
!= NULL
)
7642 gfc_add_modify (&block
, lse
.string_length
,
7643 build_int_cst (gfc_charlen_type_node
, 0));
7646 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7647 rse
.expr
= gfc_class_data_get (rse
.expr
);
7649 gfc_add_modify (&block
, lse
.expr
,
7650 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7652 gfc_add_block_to_block (&block
, &rse
.post
);
7653 gfc_add_block_to_block (&block
, &lse
.post
);
7660 tree strlen_rhs
= NULL_TREE
;
7662 /* Array pointer. Find the last reference on the LHS and if it is an
7663 array section ref, we're dealing with bounds remapping. In this case,
7664 set it to AR_FULL so that gfc_conv_expr_descriptor does
7665 not see it and process the bounds remapping afterwards explicitly. */
7666 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7667 if (!remap
->next
&& remap
->type
== REF_ARRAY
7668 && remap
->u
.ar
.type
== AR_SECTION
)
7670 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7672 gfc_init_se (&lse
, NULL
);
7674 lse
.descriptor_only
= 1;
7675 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7676 && expr1
->ts
.type
== BT_CLASS
)
7677 expr1_vptr
= gfc_copy_expr (expr1
);
7678 gfc_conv_expr_descriptor (&lse
, expr1
);
7679 strlen_lhs
= lse
.string_length
;
7682 if (expr2
->expr_type
== EXPR_NULL
)
7684 /* Just set the data pointer to null. */
7685 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7687 else if (rank_remap
)
7689 /* If we are rank-remapping, just get the RHS's descriptor and
7690 process this later on. */
7691 gfc_init_se (&rse
, NULL
);
7692 rse
.direct_byref
= 1;
7693 rse
.byref_noassign
= 1;
7695 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7697 gfc_conv_function_expr (&rse
, expr2
);
7699 if (expr1
->ts
.type
!= BT_CLASS
)
7700 rse
.expr
= gfc_class_data_get (rse
.expr
);
7703 gfc_add_block_to_block (&block
, &rse
.pre
);
7704 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7705 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7707 gfc_add_vptr_component (expr1_vptr
);
7708 gfc_init_se (&rse
, NULL
);
7709 rse
.want_pointer
= 1;
7710 gfc_conv_expr (&rse
, expr1_vptr
);
7711 gfc_add_modify (&lse
.pre
, rse
.expr
,
7712 fold_convert (TREE_TYPE (rse
.expr
),
7713 gfc_class_vptr_get (tmp
)));
7714 rse
.expr
= gfc_class_data_get (tmp
);
7717 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7719 tree bound
[GFC_MAX_DIMENSIONS
];
7722 for (i
= 0; i
< expr2
->rank
; i
++)
7723 bound
[i
] = NULL_TREE
;
7724 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7725 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7727 GFC_ARRAY_POINTER_CONT
, false);
7728 tmp
= gfc_create_var (tmp
, "ptrtemp");
7729 lse
.descriptor_only
= 0;
7731 lse
.direct_byref
= 1;
7732 gfc_conv_expr_descriptor (&lse
, expr2
);
7733 strlen_rhs
= lse
.string_length
;
7738 gfc_conv_expr_descriptor (&rse
, expr2
);
7739 strlen_rhs
= rse
.string_length
;
7742 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7744 /* Assign directly to the LHS's descriptor. */
7745 lse
.descriptor_only
= 0;
7746 lse
.direct_byref
= 1;
7747 gfc_conv_expr_descriptor (&lse
, expr2
);
7748 strlen_rhs
= lse
.string_length
;
7750 /* If this is a subreference array pointer assignment, use the rhs
7751 descriptor element size for the lhs span. */
7752 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7754 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7755 gfc_init_se (&rse
, NULL
);
7756 rse
.descriptor_only
= 1;
7757 gfc_conv_expr (&rse
, expr2
);
7758 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7759 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7760 if (!INTEGER_CST_P (tmp
))
7761 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7762 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7765 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7767 gfc_init_se (&rse
, NULL
);
7768 rse
.want_pointer
= 1;
7769 gfc_conv_function_expr (&rse
, expr2
);
7770 if (expr1
->ts
.type
!= BT_CLASS
)
7772 rse
.expr
= gfc_class_data_get (rse
.expr
);
7773 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7777 gfc_add_block_to_block (&block
, &rse
.pre
);
7778 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7779 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7781 gfc_add_vptr_component (expr1_vptr
);
7782 gfc_init_se (&rse
, NULL
);
7783 rse
.want_pointer
= 1;
7784 gfc_conv_expr (&rse
, expr1_vptr
);
7785 gfc_add_modify (&lse
.pre
, rse
.expr
,
7786 fold_convert (TREE_TYPE (rse
.expr
),
7787 gfc_class_vptr_get (tmp
)));
7788 rse
.expr
= gfc_class_data_get (tmp
);
7789 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7794 /* Assign to a temporary descriptor and then copy that
7795 temporary to the pointer. */
7796 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7797 lse
.descriptor_only
= 0;
7799 lse
.direct_byref
= 1;
7800 gfc_conv_expr_descriptor (&lse
, expr2
);
7801 strlen_rhs
= lse
.string_length
;
7802 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7806 gfc_free_expr (expr1_vptr
);
7808 gfc_add_block_to_block (&block
, &lse
.pre
);
7810 gfc_add_block_to_block (&block
, &rse
.pre
);
7812 /* If we do bounds remapping, update LHS descriptor accordingly. */
7816 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7820 /* Do rank remapping. We already have the RHS's descriptor
7821 converted in rse and now have to build the correct LHS
7822 descriptor for it. */
7826 tree lbound
, ubound
;
7829 dtype
= gfc_conv_descriptor_dtype (desc
);
7830 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7831 gfc_add_modify (&block
, dtype
, tmp
);
7833 /* Copy data pointer. */
7834 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7835 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7837 /* Copy offset but adjust it such that it would correspond
7838 to a lbound of zero. */
7839 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7840 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7842 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7844 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7846 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7847 gfc_array_index_type
, stride
, lbound
);
7848 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7849 gfc_array_index_type
, offs
, tmp
);
7851 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7853 /* Set the bounds as declared for the LHS and calculate strides as
7854 well as another offset update accordingly. */
7855 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7857 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7862 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7864 /* Convert declared bounds. */
7865 gfc_init_se (&lower_se
, NULL
);
7866 gfc_init_se (&upper_se
, NULL
);
7867 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7868 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7870 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7871 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7873 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7874 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7876 lbound
= gfc_evaluate_now (lbound
, &block
);
7877 ubound
= gfc_evaluate_now (ubound
, &block
);
7879 gfc_add_block_to_block (&block
, &lower_se
.post
);
7880 gfc_add_block_to_block (&block
, &upper_se
.post
);
7882 /* Set bounds in descriptor. */
7883 gfc_conv_descriptor_lbound_set (&block
, desc
,
7884 gfc_rank_cst
[dim
], lbound
);
7885 gfc_conv_descriptor_ubound_set (&block
, desc
,
7886 gfc_rank_cst
[dim
], ubound
);
7889 stride
= gfc_evaluate_now (stride
, &block
);
7890 gfc_conv_descriptor_stride_set (&block
, desc
,
7891 gfc_rank_cst
[dim
], stride
);
7893 /* Update offset. */
7894 offs
= gfc_conv_descriptor_offset_get (desc
);
7895 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7896 gfc_array_index_type
, lbound
, stride
);
7897 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7898 gfc_array_index_type
, offs
, tmp
);
7899 offs
= gfc_evaluate_now (offs
, &block
);
7900 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7902 /* Update stride. */
7903 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7904 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7905 gfc_array_index_type
, stride
, tmp
);
7910 /* Bounds remapping. Just shift the lower bounds. */
7912 gcc_assert (expr1
->rank
== expr2
->rank
);
7914 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7918 gcc_assert (remap
->u
.ar
.start
[dim
]);
7919 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7920 gfc_init_se (&lbound_se
, NULL
);
7921 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7923 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7924 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7925 dim
, lbound_se
.expr
);
7926 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7931 /* Check string lengths if applicable. The check is only really added
7932 to the output code if -fbounds-check is enabled. */
7933 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7935 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7936 gcc_assert (strlen_lhs
&& strlen_rhs
);
7937 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7938 strlen_lhs
, strlen_rhs
, &block
);
7941 /* If rank remapping was done, check with -fcheck=bounds that
7942 the target is at least as large as the pointer. */
7943 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7949 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7950 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7952 lsize
= gfc_evaluate_now (lsize
, &block
);
7953 rsize
= gfc_evaluate_now (rsize
, &block
);
7954 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7957 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7958 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7962 gfc_add_block_to_block (&block
, &lse
.post
);
7964 gfc_add_block_to_block (&block
, &rse
.post
);
7967 return gfc_finish_block (&block
);
7971 /* Makes sure se is suitable for passing as a function string parameter. */
7972 /* TODO: Need to check all callers of this function. It may be abused. */
7975 gfc_conv_string_parameter (gfc_se
* se
)
7979 if (TREE_CODE (se
->expr
) == STRING_CST
)
7981 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7982 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7986 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7988 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7990 type
= TREE_TYPE (se
->expr
);
7991 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7995 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7997 type
= build_pointer_type (type
);
7998 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8002 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8006 /* Generate code for assignment of scalar variables. Includes character
8007 strings and derived types with allocatable components.
8008 If you know that the LHS has no allocations, set dealloc to false.
8010 DEEP_COPY has no effect if the typespec TS is not a derived type with
8011 allocatable components. Otherwise, if it is set, an explicit copy of each
8012 allocatable component is made. This is necessary as a simple copy of the
8013 whole object would copy array descriptors as is, so that the lhs's
8014 allocatable components would point to the rhs's after the assignment.
8015 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8016 necessary if the rhs is a non-pointer function, as the allocatable components
8017 are not accessible by other means than the function's result after the
8018 function has returned. It is even more subtle when temporaries are involved,
8019 as the two following examples show:
8020 1. When we evaluate an array constructor, a temporary is created. Thus
8021 there is theoretically no alias possible. However, no deep copy is
8022 made for this temporary, so that if the constructor is made of one or
8023 more variable with allocatable components, those components still point
8024 to the variable's: DEEP_COPY should be set for the assignment from the
8025 temporary to the lhs in that case.
8026 2. When assigning a scalar to an array, we evaluate the scalar value out
8027 of the loop, store it into a temporary variable, and assign from that.
8028 In that case, deep copying when assigning to the temporary would be a
8029 waste of resources; however deep copies should happen when assigning from
8030 the temporary to each array element: again DEEP_COPY should be set for
8031 the assignment from the temporary to the lhs. */
8034 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8035 bool l_is_temp
, bool deep_copy
, bool dealloc
)
8041 gfc_init_block (&block
);
8043 if (ts
.type
== BT_CHARACTER
)
8048 if (lse
->string_length
!= NULL_TREE
)
8050 gfc_conv_string_parameter (lse
);
8051 gfc_add_block_to_block (&block
, &lse
->pre
);
8052 llen
= lse
->string_length
;
8055 if (rse
->string_length
!= NULL_TREE
)
8057 gcc_assert (rse
->string_length
!= NULL_TREE
);
8058 gfc_conv_string_parameter (rse
);
8059 gfc_add_block_to_block (&block
, &rse
->pre
);
8060 rlen
= rse
->string_length
;
8063 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8064 rse
->expr
, ts
.kind
);
8066 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8068 tree tmp_var
= NULL_TREE
;
8071 /* Are the rhs and the lhs the same? */
8074 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8075 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8076 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8077 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8080 /* Deallocate the lhs allocated components as long as it is not
8081 the same as the rhs. This must be done following the assignment
8082 to prevent deallocating data that could be used in the rhs
8084 if (!l_is_temp
&& dealloc
)
8086 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8087 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8089 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8091 gfc_add_expr_to_block (&lse
->post
, tmp
);
8094 gfc_add_block_to_block (&block
, &rse
->pre
);
8095 gfc_add_block_to_block (&block
, &lse
->pre
);
8097 gfc_add_modify (&block
, lse
->expr
,
8098 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8100 /* Restore pointer address of coarray components. */
8101 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8103 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8104 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8106 gfc_add_expr_to_block (&block
, tmp
);
8109 /* Do a deep copy if the rhs is a variable, if it is not the
8113 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8114 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8116 gfc_add_expr_to_block (&block
, tmp
);
8119 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8121 gfc_add_block_to_block (&block
, &lse
->pre
);
8122 gfc_add_block_to_block (&block
, &rse
->pre
);
8123 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8124 TREE_TYPE (lse
->expr
), rse
->expr
);
8125 gfc_add_modify (&block
, lse
->expr
, tmp
);
8129 gfc_add_block_to_block (&block
, &lse
->pre
);
8130 gfc_add_block_to_block (&block
, &rse
->pre
);
8132 gfc_add_modify (&block
, lse
->expr
,
8133 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8136 gfc_add_block_to_block (&block
, &lse
->post
);
8137 gfc_add_block_to_block (&block
, &rse
->post
);
8139 return gfc_finish_block (&block
);
8143 /* There are quite a lot of restrictions on the optimisation in using an
8144 array function assign without a temporary. */
8147 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8150 bool seen_array_ref
;
8152 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8154 /* Play it safe with class functions assigned to a derived type. */
8155 if (gfc_is_alloc_class_array_function (expr2
)
8156 && expr1
->ts
.type
== BT_DERIVED
)
8159 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8160 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8163 /* Elemental functions are scalarized so that they don't need a
8164 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8165 they would need special treatment in gfc_trans_arrayfunc_assign. */
8166 if (expr2
->value
.function
.esym
!= NULL
8167 && expr2
->value
.function
.esym
->attr
.elemental
)
8170 /* Need a temporary if rhs is not FULL or a contiguous section. */
8171 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8174 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8175 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8178 /* Functions returning pointers or allocatables need temporaries. */
8179 c
= expr2
->value
.function
.esym
8180 ? (expr2
->value
.function
.esym
->attr
.pointer
8181 || expr2
->value
.function
.esym
->attr
.allocatable
)
8182 : (expr2
->symtree
->n
.sym
->attr
.pointer
8183 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8187 /* Character array functions need temporaries unless the
8188 character lengths are the same. */
8189 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8191 if (expr1
->ts
.u
.cl
->length
== NULL
8192 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8195 if (expr2
->ts
.u
.cl
->length
== NULL
8196 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8199 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8200 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8204 /* Check that no LHS component references appear during an array
8205 reference. This is needed because we do not have the means to
8206 span any arbitrary stride with an array descriptor. This check
8207 is not needed for the rhs because the function result has to be
8209 seen_array_ref
= false;
8210 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8212 if (ref
->type
== REF_ARRAY
)
8213 seen_array_ref
= true;
8214 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8218 /* Check for a dependency. */
8219 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8220 expr2
->value
.function
.esym
,
8221 expr2
->value
.function
.actual
,
8225 /* If we have reached here with an intrinsic function, we do not
8226 need a temporary except in the particular case that reallocation
8227 on assignment is active and the lhs is allocatable and a target. */
8228 if (expr2
->value
.function
.isym
)
8229 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8231 /* If the LHS is a dummy, we need a temporary if it is not
8233 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8236 /* If the lhs has been host_associated, is in common, a pointer or is
8237 a target and the function is not using a RESULT variable, aliasing
8238 can occur and a temporary is needed. */
8239 if ((sym
->attr
.host_assoc
8240 || sym
->attr
.in_common
8241 || sym
->attr
.pointer
8242 || sym
->attr
.cray_pointee
8243 || sym
->attr
.target
)
8244 && expr2
->symtree
!= NULL
8245 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8248 /* A PURE function can unconditionally be called without a temporary. */
8249 if (expr2
->value
.function
.esym
!= NULL
8250 && expr2
->value
.function
.esym
->attr
.pure
)
8253 /* Implicit_pure functions are those which could legally be declared
8255 if (expr2
->value
.function
.esym
!= NULL
8256 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8259 if (!sym
->attr
.use_assoc
8260 && !sym
->attr
.in_common
8261 && !sym
->attr
.pointer
8262 && !sym
->attr
.target
8263 && !sym
->attr
.cray_pointee
8264 && expr2
->value
.function
.esym
)
8266 /* A temporary is not needed if the function is not contained and
8267 the variable is local or host associated and not a pointer or
8269 if (!expr2
->value
.function
.esym
->attr
.contained
)
8272 /* A temporary is not needed if the lhs has never been host
8273 associated and the procedure is contained. */
8274 else if (!sym
->attr
.host_assoc
)
8277 /* A temporary is not needed if the variable is local and not
8278 a pointer, a target or a result. */
8280 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8284 /* Default to temporary use. */
8289 /* Provide the loop info so that the lhs descriptor can be built for
8290 reallocatable assignments from extrinsic function calls. */
8293 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8296 /* Signal that the function call should not be made by
8297 gfc_conv_loop_setup. */
8298 se
->ss
->is_alloc_lhs
= 1;
8299 gfc_init_loopinfo (loop
);
8300 gfc_add_ss_to_loop (loop
, *ss
);
8301 gfc_add_ss_to_loop (loop
, se
->ss
);
8302 gfc_conv_ss_startstride (loop
);
8303 gfc_conv_loop_setup (loop
, where
);
8304 gfc_copy_loopinfo_to_se (se
, loop
);
8305 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8306 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8307 se
->ss
->is_alloc_lhs
= 0;
8311 /* For assignment to a reallocatable lhs from intrinsic functions,
8312 replace the se.expr (ie. the result) with a temporary descriptor.
8313 Null the data field so that the library allocates space for the
8314 result. Free the data of the original descriptor after the function,
8315 in case it appears in an argument expression and transfer the
8316 result to the original descriptor. */
8319 fcncall_realloc_result (gfc_se
*se
, int rank
)
8328 /* Use the allocation done by the library. Substitute the lhs
8329 descriptor with a copy, whose data field is nulled.*/
8330 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8331 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8332 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8334 /* Unallocated, the descriptor does not have a dtype. */
8335 tmp
= gfc_conv_descriptor_dtype (desc
);
8336 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8338 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8339 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8340 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8342 /* Free the lhs after the function call and copy the result data to
8343 the lhs descriptor. */
8344 tmp
= gfc_conv_descriptor_data_get (desc
);
8345 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8346 boolean_type_node
, tmp
,
8347 build_int_cst (TREE_TYPE (tmp
), 0));
8348 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8349 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
8350 gfc_add_expr_to_block (&se
->post
, tmp
);
8352 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8353 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8355 /* Check that the shapes are the same between lhs and expression. */
8356 for (n
= 0 ; n
< rank
; n
++)
8359 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8360 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8361 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8362 gfc_array_index_type
, tmp
, tmp1
);
8363 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8364 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8365 gfc_array_index_type
, tmp
, tmp1
);
8366 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8367 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8368 gfc_array_index_type
, tmp
, tmp1
);
8369 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8370 boolean_type_node
, tmp
,
8371 gfc_index_zero_node
);
8372 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8373 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8374 boolean_type_node
, tmp
,
8378 /* 'zero_cond' being true is equal to lhs not being allocated or the
8379 shapes being different. */
8380 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8382 /* Now reset the bounds returned from the function call to bounds based
8383 on the lhs lbounds, except where the lhs is not allocated or the shapes
8384 of 'variable and 'expr' are different. Set the offset accordingly. */
8385 offset
= gfc_index_zero_node
;
8386 for (n
= 0 ; n
< rank
; n
++)
8390 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8391 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8392 gfc_array_index_type
, zero_cond
,
8393 gfc_index_one_node
, lbound
);
8394 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8396 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8397 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8398 gfc_array_index_type
, tmp
, lbound
);
8399 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8400 gfc_rank_cst
[n
], lbound
);
8401 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8402 gfc_rank_cst
[n
], tmp
);
8404 /* Set stride and accumulate the offset. */
8405 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8406 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8407 gfc_rank_cst
[n
], tmp
);
8408 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8409 gfc_array_index_type
, lbound
, tmp
);
8410 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8411 gfc_array_index_type
, offset
, tmp
);
8412 offset
= gfc_evaluate_now (offset
, &se
->post
);
8415 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8420 /* Try to translate array(:) = func (...), where func is a transformational
8421 array function, without using a temporary. Returns NULL if this isn't the
8425 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8429 gfc_component
*comp
= NULL
;
8432 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8435 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8437 comp
= gfc_get_proc_ptr_comp (expr2
);
8438 gcc_assert (expr2
->value
.function
.isym
8439 || (comp
&& comp
->attr
.dimension
)
8440 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8441 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8443 gfc_init_se (&se
, NULL
);
8444 gfc_start_block (&se
.pre
);
8445 se
.want_pointer
= 1;
8447 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8449 if (expr1
->ts
.type
== BT_DERIVED
8450 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8453 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8455 gfc_add_expr_to_block (&se
.pre
, tmp
);
8458 se
.direct_byref
= 1;
8459 se
.ss
= gfc_walk_expr (expr2
);
8460 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8462 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8463 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8464 Clearly, this cannot be done for an allocatable function result, since
8465 the shape of the result is unknown and, in any case, the function must
8466 correctly take care of the reallocation internally. For intrinsic
8467 calls, the array data is freed and the library takes care of allocation.
8468 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8470 if (flag_realloc_lhs
8471 && gfc_is_reallocatable_lhs (expr1
)
8472 && !gfc_expr_attr (expr1
).codimension
8473 && !gfc_is_coindexed (expr1
)
8474 && !(expr2
->value
.function
.esym
8475 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8477 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8479 if (!expr2
->value
.function
.isym
)
8481 ss
= gfc_walk_expr (expr1
);
8482 gcc_assert (ss
!= gfc_ss_terminator
);
8484 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8485 ss
->is_alloc_lhs
= 1;
8488 fcncall_realloc_result (&se
, expr1
->rank
);
8491 gfc_conv_function_expr (&se
, expr2
);
8492 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8495 gfc_cleanup_loop (&loop
);
8497 gfc_free_ss_chain (se
.ss
);
8499 return gfc_finish_block (&se
.pre
);
8503 /* Try to efficiently translate array(:) = 0. Return NULL if this
8507 gfc_trans_zero_assign (gfc_expr
* expr
)
8509 tree dest
, len
, type
;
8513 sym
= expr
->symtree
->n
.sym
;
8514 dest
= gfc_get_symbol_decl (sym
);
8516 type
= TREE_TYPE (dest
);
8517 if (POINTER_TYPE_P (type
))
8518 type
= TREE_TYPE (type
);
8519 if (!GFC_ARRAY_TYPE_P (type
))
8522 /* Determine the length of the array. */
8523 len
= GFC_TYPE_ARRAY_SIZE (type
);
8524 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8527 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8528 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8529 fold_convert (gfc_array_index_type
, tmp
));
8531 /* If we are zeroing a local array avoid taking its address by emitting
8533 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8534 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8535 dest
, build_constructor (TREE_TYPE (dest
),
8538 /* Convert arguments to the correct types. */
8539 dest
= fold_convert (pvoid_type_node
, dest
);
8540 len
= fold_convert (size_type_node
, len
);
8542 /* Construct call to __builtin_memset. */
8543 tmp
= build_call_expr_loc (input_location
,
8544 builtin_decl_explicit (BUILT_IN_MEMSET
),
8545 3, dest
, integer_zero_node
, len
);
8546 return fold_convert (void_type_node
, tmp
);
8550 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8551 that constructs the call to __builtin_memcpy. */
8554 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8558 /* Convert arguments to the correct types. */
8559 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8560 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8562 dst
= fold_convert (pvoid_type_node
, dst
);
8564 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8565 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8567 src
= fold_convert (pvoid_type_node
, src
);
8569 len
= fold_convert (size_type_node
, len
);
8571 /* Construct call to __builtin_memcpy. */
8572 tmp
= build_call_expr_loc (input_location
,
8573 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8575 return fold_convert (void_type_node
, tmp
);
8579 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8580 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8581 source/rhs, both are gfc_full_array_ref_p which have been checked for
8585 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8587 tree dst
, dlen
, dtype
;
8588 tree src
, slen
, stype
;
8591 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8592 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8594 dtype
= TREE_TYPE (dst
);
8595 if (POINTER_TYPE_P (dtype
))
8596 dtype
= TREE_TYPE (dtype
);
8597 stype
= TREE_TYPE (src
);
8598 if (POINTER_TYPE_P (stype
))
8599 stype
= TREE_TYPE (stype
);
8601 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8604 /* Determine the lengths of the arrays. */
8605 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8606 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8608 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8609 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8610 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8612 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8613 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8615 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8616 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8617 slen
, fold_convert (gfc_array_index_type
, tmp
));
8619 /* Sanity check that they are the same. This should always be
8620 the case, as we should already have checked for conformance. */
8621 if (!tree_int_cst_equal (slen
, dlen
))
8624 return gfc_build_memcpy_call (dst
, src
, dlen
);
8628 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8629 this can't be done. EXPR1 is the destination/lhs for which
8630 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8633 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8635 unsigned HOST_WIDE_INT nelem
;
8641 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8645 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8646 dtype
= TREE_TYPE (dst
);
8647 if (POINTER_TYPE_P (dtype
))
8648 dtype
= TREE_TYPE (dtype
);
8649 if (!GFC_ARRAY_TYPE_P (dtype
))
8652 /* Determine the lengths of the array. */
8653 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8654 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8657 /* Confirm that the constructor is the same size. */
8658 if (compare_tree_int (len
, nelem
) != 0)
8661 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8662 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8663 fold_convert (gfc_array_index_type
, tmp
));
8665 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8666 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8668 stype
= TREE_TYPE (src
);
8669 if (POINTER_TYPE_P (stype
))
8670 stype
= TREE_TYPE (stype
);
8672 return gfc_build_memcpy_call (dst
, src
, len
);
8676 /* Tells whether the expression is to be treated as a variable reference. */
8679 expr_is_variable (gfc_expr
*expr
)
8682 gfc_component
*comp
;
8683 gfc_symbol
*func_ifc
;
8685 if (expr
->expr_type
== EXPR_VARIABLE
)
8688 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8691 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8692 return expr_is_variable (arg
);
8695 /* A data-pointer-returning function should be considered as a variable
8697 if (expr
->expr_type
== EXPR_FUNCTION
8698 && expr
->ref
== NULL
)
8700 if (expr
->value
.function
.isym
!= NULL
)
8703 if (expr
->value
.function
.esym
!= NULL
)
8705 func_ifc
= expr
->value
.function
.esym
;
8710 gcc_assert (expr
->symtree
);
8711 func_ifc
= expr
->symtree
->n
.sym
;
8718 comp
= gfc_get_proc_ptr_comp (expr
);
8719 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8722 func_ifc
= comp
->ts
.interface
;
8726 if (expr
->expr_type
== EXPR_COMPCALL
)
8728 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8729 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8736 gcc_assert (func_ifc
->attr
.function
8737 && func_ifc
->result
!= NULL
);
8738 return func_ifc
->result
->attr
.pointer
;
8742 /* Is the lhs OK for automatic reallocation? */
8745 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8749 /* An allocatable variable with no reference. */
8750 if (expr
->symtree
->n
.sym
->attr
.allocatable
8754 /* All that can be left are allocatable components. */
8755 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8756 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8757 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8760 /* Find an allocatable component ref last. */
8761 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8762 if (ref
->type
== REF_COMPONENT
8764 && ref
->u
.c
.component
->attr
.allocatable
)
8771 /* Allocate or reallocate scalar lhs, as necessary. */
8774 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8788 if (!expr1
|| expr1
->rank
)
8791 if (!expr2
|| expr2
->rank
)
8794 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8796 /* Since this is a scalar lhs, we can afford to do this. That is,
8797 there is no risk of side effects being repeated. */
8798 gfc_init_se (&lse
, NULL
);
8799 lse
.want_pointer
= 1;
8800 gfc_conv_expr (&lse
, expr1
);
8802 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8803 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8805 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8806 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8807 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8809 tmp
= build3_v (COND_EXPR
, cond
,
8810 build1_v (GOTO_EXPR
, jump_label1
),
8811 build_empty_stmt (input_location
));
8812 gfc_add_expr_to_block (block
, tmp
);
8814 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8816 /* Use the rhs string length and the lhs element size. */
8817 size
= string_length
;
8818 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8819 tmp
= TYPE_SIZE_UNIT (tmp
);
8820 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8821 TREE_TYPE (tmp
), tmp
,
8822 fold_convert (TREE_TYPE (tmp
), size
));
8826 /* Otherwise use the length in bytes of the rhs. */
8827 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8828 size_in_bytes
= size
;
8831 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8832 size_in_bytes
, size_one_node
);
8834 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8836 tmp
= build_call_expr_loc (input_location
,
8837 builtin_decl_explicit (BUILT_IN_CALLOC
),
8838 2, build_one_cst (size_type_node
),
8840 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8841 gfc_add_modify (block
, lse
.expr
, tmp
);
8845 tmp
= build_call_expr_loc (input_location
,
8846 builtin_decl_explicit (BUILT_IN_MALLOC
),
8848 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8849 gfc_add_modify (block
, lse
.expr
, tmp
);
8852 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8854 /* Deferred characters need checking for lhs and rhs string
8855 length. Other deferred parameter variables will have to
8857 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8858 gfc_add_expr_to_block (block
, tmp
);
8860 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8861 gfc_add_expr_to_block (block
, tmp
);
8863 /* For a deferred length character, reallocate if lengths of lhs and
8864 rhs are different. */
8865 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8867 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8868 lse
.string_length
, size
);
8869 /* Jump past the realloc if the lengths are the same. */
8870 tmp
= build3_v (COND_EXPR
, cond
,
8871 build1_v (GOTO_EXPR
, jump_label2
),
8872 build_empty_stmt (input_location
));
8873 gfc_add_expr_to_block (block
, tmp
);
8874 tmp
= build_call_expr_loc (input_location
,
8875 builtin_decl_explicit (BUILT_IN_REALLOC
),
8876 2, fold_convert (pvoid_type_node
, lse
.expr
),
8878 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8879 gfc_add_modify (block
, lse
.expr
, tmp
);
8880 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8881 gfc_add_expr_to_block (block
, tmp
);
8883 /* Update the lhs character length. */
8884 size
= string_length
;
8885 gfc_add_modify (block
, lse
.string_length
, size
);
8889 /* Check for assignments of the type
8893 to make sure we do not check for reallocation unneccessarily. */
8897 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8899 gfc_actual_arglist
*a
;
8902 switch (expr2
->expr_type
)
8905 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8908 if (expr2
->value
.function
.esym
8909 && expr2
->value
.function
.esym
->attr
.elemental
)
8911 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8914 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8919 else if (expr2
->value
.function
.isym
8920 && expr2
->value
.function
.isym
->elemental
)
8922 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8925 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8934 switch (expr2
->value
.op
.op
)
8937 case INTRINSIC_UPLUS
:
8938 case INTRINSIC_UMINUS
:
8939 case INTRINSIC_PARENTHESES
:
8940 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8942 case INTRINSIC_PLUS
:
8943 case INTRINSIC_MINUS
:
8944 case INTRINSIC_TIMES
:
8945 case INTRINSIC_DIVIDE
:
8946 case INTRINSIC_POWER
:
8950 case INTRINSIC_NEQV
:
8957 case INTRINSIC_EQ_OS
:
8958 case INTRINSIC_NE_OS
:
8959 case INTRINSIC_GT_OS
:
8960 case INTRINSIC_GE_OS
:
8961 case INTRINSIC_LT_OS
:
8962 case INTRINSIC_LE_OS
:
8964 e1
= expr2
->value
.op
.op1
;
8965 e2
= expr2
->value
.op
.op2
;
8967 if (e1
->rank
== 0 && e2
->rank
> 0)
8968 return is_runtime_conformable (expr1
, e2
);
8969 else if (e1
->rank
> 0 && e2
->rank
== 0)
8970 return is_runtime_conformable (expr1
, e1
);
8971 else if (e1
->rank
> 0 && e2
->rank
> 0)
8972 return is_runtime_conformable (expr1
, e1
)
8973 && is_runtime_conformable (expr1
, e2
);
8989 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8990 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8991 init_flag indicates initialization expressions and dealloc that no
8992 deallocate prior assignment is needed (if in doubt, set true). */
8995 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9001 gfc_ss
*lss_section
;
9008 bool scalar_to_array
;
9012 /* Assignment of the form lhs = rhs. */
9013 gfc_start_block (&block
);
9015 gfc_init_se (&lse
, NULL
);
9016 gfc_init_se (&rse
, NULL
);
9019 lss
= gfc_walk_expr (expr1
);
9020 if (gfc_is_reallocatable_lhs (expr1
)
9021 && !(expr2
->expr_type
== EXPR_FUNCTION
9022 && expr2
->value
.function
.isym
!= NULL
))
9023 lss
->is_alloc_lhs
= 1;
9026 if ((expr1
->ts
.type
== BT_DERIVED
)
9027 && (gfc_is_alloc_class_array_function (expr2
)
9028 || gfc_is_alloc_class_scalar_function (expr2
)))
9029 expr2
->must_finalize
= 1;
9031 if (lss
!= gfc_ss_terminator
)
9033 /* The assignment needs scalarization. */
9036 /* Find a non-scalar SS from the lhs. */
9037 while (lss_section
!= gfc_ss_terminator
9038 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9039 lss_section
= lss_section
->next
;
9041 gcc_assert (lss_section
!= gfc_ss_terminator
);
9043 /* Initialize the scalarizer. */
9044 gfc_init_loopinfo (&loop
);
9047 rss
= gfc_walk_expr (expr2
);
9048 if (rss
== gfc_ss_terminator
)
9049 /* The rhs is scalar. Add a ss for the expression. */
9050 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9052 /* Associate the SS with the loop. */
9053 gfc_add_ss_to_loop (&loop
, lss
);
9054 gfc_add_ss_to_loop (&loop
, rss
);
9056 /* Calculate the bounds of the scalarization. */
9057 gfc_conv_ss_startstride (&loop
);
9058 /* Enable loop reversal. */
9059 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9060 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9061 /* Resolve any data dependencies in the statement. */
9062 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9063 /* Setup the scalarizing loops. */
9064 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9066 /* Setup the gfc_se structures. */
9067 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9068 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9071 gfc_mark_ss_chain_used (rss
, 1);
9072 if (loop
.temp_ss
== NULL
)
9075 gfc_mark_ss_chain_used (lss
, 1);
9079 lse
.ss
= loop
.temp_ss
;
9080 gfc_mark_ss_chain_used (lss
, 3);
9081 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9084 /* Allow the scalarizer to workshare array assignments. */
9085 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9086 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9088 /* Start the scalarized loop body. */
9089 gfc_start_scalarized_body (&loop
, &body
);
9092 gfc_init_block (&body
);
9094 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9096 /* Translate the expression. */
9097 gfc_conv_expr (&rse
, expr2
);
9099 /* Deal with the case of a scalar class function assigned to a derived type. */
9100 if (gfc_is_alloc_class_scalar_function (expr2
)
9101 && expr1
->ts
.type
== BT_DERIVED
)
9103 rse
.expr
= gfc_class_data_get (rse
.expr
);
9104 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9107 /* Stabilize a string length for temporaries. */
9108 if (expr2
->ts
.type
== BT_CHARACTER
)
9109 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9111 string_length
= NULL_TREE
;
9115 gfc_conv_tmp_array_ref (&lse
);
9116 if (expr2
->ts
.type
== BT_CHARACTER
)
9117 lse
.string_length
= string_length
;
9120 gfc_conv_expr (&lse
, expr1
);
9122 /* Assignments of scalar derived types with allocatable components
9123 to arrays must be done with a deep copy and the rhs temporary
9124 must have its components deallocated afterwards. */
9125 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9126 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9127 && !expr_is_variable (expr2
)
9128 && !gfc_is_constant_expr (expr2
)
9129 && expr1
->rank
&& !expr2
->rank
);
9130 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9132 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9133 && gfc_is_alloc_class_scalar_function (expr2
));
9134 if (scalar_to_array
&& dealloc
)
9136 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9137 gfc_add_expr_to_block (&loop
.post
, tmp
);
9140 /* When assigning a character function result to a deferred-length variable,
9141 the function call must happen before the (re)allocation of the lhs -
9142 otherwise the character length of the result is not known.
9143 NOTE: This relies on having the exact dependence of the length type
9144 parameter available to the caller; gfortran saves it in the .mod files. */
9145 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9146 gfc_add_block_to_block (&block
, &rse
.pre
);
9148 /* Nullify the allocatable components corresponding to those of the lhs
9149 derived type, so that the finalization of the function result does not
9150 affect the lhs of the assignment. Prepend is used to ensure that the
9151 nullification occurs before the call to the finalizer. In the case of
9152 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9153 as part of the deep copy. */
9154 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9155 && (gfc_is_alloc_class_array_function (expr2
)
9156 || gfc_is_alloc_class_scalar_function (expr2
)))
9159 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9160 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9161 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9162 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9165 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9166 l_is_temp
|| init_flag
,
9167 expr_is_variable (expr2
) || scalar_to_array
9168 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
9169 gfc_add_expr_to_block (&body
, tmp
);
9171 if (lss
== gfc_ss_terminator
)
9173 /* F2003: Add the code for reallocation on assignment. */
9174 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9175 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9178 /* Use the scalar assignment as is. */
9179 gfc_add_block_to_block (&block
, &body
);
9183 gcc_assert (lse
.ss
== gfc_ss_terminator
9184 && rse
.ss
== gfc_ss_terminator
);
9188 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9190 /* We need to copy the temporary to the actual lhs. */
9191 gfc_init_se (&lse
, NULL
);
9192 gfc_init_se (&rse
, NULL
);
9193 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9194 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9196 rse
.ss
= loop
.temp_ss
;
9199 gfc_conv_tmp_array_ref (&rse
);
9200 gfc_conv_expr (&lse
, expr1
);
9202 gcc_assert (lse
.ss
== gfc_ss_terminator
9203 && rse
.ss
== gfc_ss_terminator
);
9205 if (expr2
->ts
.type
== BT_CHARACTER
)
9206 rse
.string_length
= string_length
;
9208 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9209 false, false, dealloc
);
9210 gfc_add_expr_to_block (&body
, tmp
);
9213 /* F2003: Allocate or reallocate lhs of allocatable array. */
9214 if (flag_realloc_lhs
9215 && gfc_is_reallocatable_lhs (expr1
)
9216 && !gfc_expr_attr (expr1
).codimension
9217 && !gfc_is_coindexed (expr1
)
9219 && !is_runtime_conformable (expr1
, expr2
))
9221 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9222 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9223 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9224 if (tmp
!= NULL_TREE
)
9225 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9228 /* Generate the copying loops. */
9229 gfc_trans_scalarizing_loops (&loop
, &body
);
9231 /* Wrap the whole thing up. */
9232 gfc_add_block_to_block (&block
, &loop
.pre
);
9233 gfc_add_block_to_block (&block
, &loop
.post
);
9235 gfc_cleanup_loop (&loop
);
9238 return gfc_finish_block (&block
);
9242 /* Check whether EXPR is a copyable array. */
9245 copyable_array_p (gfc_expr
* expr
)
9247 if (expr
->expr_type
!= EXPR_VARIABLE
)
9250 /* First check it's an array. */
9251 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9254 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9257 /* Next check that it's of a simple enough type. */
9258 switch (expr
->ts
.type
)
9270 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9279 /* Translate an assignment. */
9282 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9287 /* Special case a single function returning an array. */
9288 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9290 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9295 /* Special case assigning an array to zero. */
9296 if (copyable_array_p (expr1
)
9297 && is_zero_initializer_p (expr2
))
9299 tmp
= gfc_trans_zero_assign (expr1
);
9304 /* Special case copying one array to another. */
9305 if (copyable_array_p (expr1
)
9306 && copyable_array_p (expr2
)
9307 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9308 && !gfc_check_dependency (expr1
, expr2
, 0))
9310 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9315 /* Special case initializing an array from a constant array constructor. */
9316 if (copyable_array_p (expr1
)
9317 && expr2
->expr_type
== EXPR_ARRAY
9318 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9320 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9325 /* Fallback to the scalarizer to generate explicit loops. */
9326 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9330 gfc_trans_init_assign (gfc_code
* code
)
9332 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9336 gfc_trans_assign (gfc_code
* code
)
9338 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);