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 "fold-const.h"
32 #include "stringpool.h"
33 #include "diagnostic-core.h" /* For fatal_error. */
34 #include "langhooks.h"
37 #include "constructor.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
47 /* Convert a scalar to an array descriptor. To be used for assumed-rank
51 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
53 enum gfc_array_kind akind
;
56 akind
= GFC_ARRAY_POINTER_CONT
;
57 else if (attr
.allocatable
)
58 akind
= GFC_ARRAY_ALLOCATABLE
;
60 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
62 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
63 scalar
= TREE_TYPE (scalar
);
64 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
65 akind
, !(attr
.pointer
|| attr
.target
));
69 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
73 type
= get_scalar_to_descriptor_type (scalar
, attr
);
74 desc
= gfc_create_var (type
, "desc");
75 DECL_ARTIFICIAL (desc
) = 1;
77 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
78 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
79 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
80 gfc_get_dtype (type
));
81 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
83 /* Copy pointer address back - but only if it could have changed and
84 if the actual argument is a pointer and not, e.g., NULL(). */
85 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
86 gfc_add_modify (&se
->post
, scalar
,
87 fold_convert (TREE_TYPE (scalar
),
88 gfc_conv_descriptor_data_get (desc
)));
93 /* This is the seed for an eventual trans-class.c
95 The following parameters should not be used directly since they might
96 in future implementations. Use the corresponding APIs. */
97 #define CLASS_DATA_FIELD 0
98 #define CLASS_VPTR_FIELD 1
99 #define CLASS_LEN_FIELD 2
100 #define VTABLE_HASH_FIELD 0
101 #define VTABLE_SIZE_FIELD 1
102 #define VTABLE_EXTENDS_FIELD 2
103 #define VTABLE_DEF_INIT_FIELD 3
104 #define VTABLE_COPY_FIELD 4
105 #define VTABLE_FINAL_FIELD 5
109 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
113 vec
<constructor_elt
, va_gc
> *init
= NULL
;
115 field
= TYPE_FIELDS (TREE_TYPE (decl
));
116 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
117 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
119 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
120 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
122 return build_constructor (TREE_TYPE (decl
), init
);
127 gfc_class_data_get (tree decl
)
130 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
131 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
132 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
134 return fold_build3_loc (input_location
, COMPONENT_REF
,
135 TREE_TYPE (data
), decl
, data
,
141 gfc_class_vptr_get (tree decl
)
144 /* For class arrays decl may be a temporary descriptor handle, the vptr is
145 then available through the saved descriptor. */
146 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
147 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
148 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
149 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
150 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
151 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
153 return fold_build3_loc (input_location
, COMPONENT_REF
,
154 TREE_TYPE (vptr
), decl
, vptr
,
160 gfc_class_len_get (tree decl
)
163 /* For class arrays decl may be a temporary descriptor handle, the len is
164 then available through the saved descriptor. */
165 if (TREE_CODE (decl
) == VAR_DECL
&& DECL_LANG_SPECIFIC (decl
)
166 && GFC_DECL_SAVED_DESCRIPTOR (decl
))
167 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
168 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
169 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
170 len
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
172 return fold_build3_loc (input_location
, COMPONENT_REF
,
173 TREE_TYPE (len
), decl
, len
,
178 /* Get the specified FIELD from the VPTR. */
181 vptr_field_get (tree vptr
, int fieldno
)
184 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
185 field
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
187 field
= fold_build3_loc (input_location
, COMPONENT_REF
,
188 TREE_TYPE (field
), vptr
, field
,
195 /* Get the field from the class' vptr. */
198 class_vtab_field_get (tree decl
, int fieldno
)
201 vptr
= gfc_class_vptr_get (decl
);
202 return vptr_field_get (vptr
, fieldno
);
206 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
208 #define VTAB_GET_FIELD_GEN(name, field) tree \
209 gfc_class_vtab_## name ##_get (tree cl) \
211 return class_vtab_field_get (cl, field); \
215 gfc_vptr_## name ##_get (tree vptr) \
217 return vptr_field_get (vptr, field); \
220 VTAB_GET_FIELD_GEN (hash
, VTABLE_HASH_FIELD
)
221 VTAB_GET_FIELD_GEN (extends
, VTABLE_EXTENDS_FIELD
)
222 VTAB_GET_FIELD_GEN (def_init
, VTABLE_DEF_INIT_FIELD
)
223 VTAB_GET_FIELD_GEN (copy
, VTABLE_COPY_FIELD
)
224 VTAB_GET_FIELD_GEN (final
, VTABLE_FINAL_FIELD
)
227 /* The size field is returned as an array index type. Therefore treat
228 it and only it specially. */
231 gfc_class_vtab_size_get (tree cl
)
234 size
= class_vtab_field_get (cl
, VTABLE_SIZE_FIELD
);
235 /* Always return size as an array index type. */
236 size
= fold_convert (gfc_array_index_type
, size
);
242 gfc_vptr_size_get (tree vptr
)
245 size
= vptr_field_get (vptr
, VTABLE_SIZE_FIELD
);
246 /* Always return size as an array index type. */
247 size
= fold_convert (gfc_array_index_type
, size
);
253 #undef CLASS_DATA_FIELD
254 #undef CLASS_VPTR_FIELD
255 #undef VTABLE_HASH_FIELD
256 #undef VTABLE_SIZE_FIELD
257 #undef VTABLE_EXTENDS_FIELD
258 #undef VTABLE_DEF_INIT_FIELD
259 #undef VTABLE_COPY_FIELD
260 #undef VTABLE_FINAL_FIELD
263 /* Search for the last _class ref in the chain of references of this
264 expression and cut the chain there. Albeit this routine is similiar
265 to class.c::gfc_add_component_ref (), is there a significant
266 difference: gfc_add_component_ref () concentrates on an array ref to
267 be the last ref in the chain. This routine is oblivious to the kind
268 of refs following. */
271 gfc_find_and_cut_at_last_class_ref (gfc_expr
*e
)
274 gfc_ref
*ref
, *class_ref
, *tail
;
276 /* Find the last class reference. */
278 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
280 if (ref
->type
== REF_COMPONENT
281 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
284 if (ref
->next
== NULL
)
288 /* Remove and store all subsequent references after the
292 tail
= class_ref
->next
;
293 class_ref
->next
= NULL
;
301 base_expr
= gfc_expr_to_initialize (e
);
303 /* Restore the original tail expression. */
306 gfc_free_ref_list (class_ref
->next
);
307 class_ref
->next
= tail
;
311 gfc_free_ref_list (e
->ref
);
318 /* Reset the vptr to the declared type, e.g. after deallocation. */
321 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
323 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
328 /* If we have a class array, we need go back to the class
330 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
331 && lhs
->ref
->next
->type
== REF_ARRAY
332 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
333 && lhs
->ref
->type
== REF_COMPONENT
334 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
336 gfc_free_ref_list (lhs
->ref
);
340 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
341 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
342 && ref
->next
->next
->type
== REF_ARRAY
343 && ref
->next
->next
->u
.ar
.type
== AR_FULL
344 && ref
->next
->type
== REF_COMPONENT
345 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
347 gfc_free_ref_list (ref
->next
);
351 gfc_add_vptr_component (lhs
);
353 if (UNLIMITED_POLY (e
))
354 rhs
= gfc_get_null_expr (NULL
);
357 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
358 rhs
= gfc_lval_expr_from_sym (vtab
);
360 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
361 gfc_add_expr_to_block (block
, tmp
);
367 /* Reset the len for unlimited polymorphic objects. */
370 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
374 e
= gfc_find_and_cut_at_last_class_ref (expr
);
375 gfc_add_len_component (e
);
376 gfc_init_se (&se_len
, NULL
);
377 gfc_conv_expr (&se_len
, e
);
378 gfc_add_modify (block
, se_len
.expr
,
379 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
384 /* Obtain the vptr of the last class reference in an expression.
385 Return NULL_TREE if no class reference is found. */
388 gfc_get_vptr_from_expr (tree expr
)
393 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
395 type
= TREE_TYPE (tmp
);
398 if (GFC_CLASS_TYPE_P (type
))
399 return gfc_class_vptr_get (tmp
);
400 if (type
!= TYPE_CANONICAL (type
))
401 type
= TYPE_CANONICAL (type
);
405 if (TREE_CODE (tmp
) == VAR_DECL
)
413 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
416 tree tmp
, tmp2
, type
;
418 gfc_conv_descriptor_data_set (block
, lhs_desc
,
419 gfc_conv_descriptor_data_get (rhs_desc
));
420 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
421 gfc_conv_descriptor_offset_get (rhs_desc
));
423 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
424 gfc_conv_descriptor_dtype (rhs_desc
));
426 /* Assign the dimension as range-ref. */
427 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
428 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
430 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
431 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
432 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
433 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
434 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
435 gfc_add_modify (block
, tmp
, tmp2
);
439 /* Takes a derived type expression and returns the address of a temporary
440 class object of the 'declared' type. If vptr is not NULL, this is
441 used for the temporary class object.
442 optional_alloc_ptr is false when the dummy is neither allocatable
443 nor a pointer; that's only relevant for the optional handling. */
445 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
446 gfc_typespec class_ts
, tree vptr
, bool optional
,
447 bool optional_alloc_ptr
)
450 tree cond_optional
= NULL_TREE
;
456 /* The derived type needs to be converted to a temporary
458 tmp
= gfc_typenode_for_spec (&class_ts
);
459 var
= gfc_create_var (tmp
, "class");
462 ctree
= gfc_class_vptr_get (var
);
464 if (vptr
!= NULL_TREE
)
466 /* Use the dynamic vptr. */
471 /* In this case the vtab corresponds to the derived type and the
472 vptr must point to it. */
473 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
475 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
477 gfc_add_modify (&parmse
->pre
, ctree
,
478 fold_convert (TREE_TYPE (ctree
), tmp
));
480 /* Now set the data field. */
481 ctree
= gfc_class_data_get (var
);
484 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
486 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
488 /* For an array reference in an elemental procedure call we need
489 to retain the ss to provide the scalarized array reference. */
490 gfc_conv_expr_reference (parmse
, e
);
491 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
493 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
495 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
496 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
501 ss
= gfc_walk_expr (e
);
502 if (ss
== gfc_ss_terminator
)
505 gfc_conv_expr_reference (parmse
, e
);
507 /* Scalar to an assumed-rank array. */
508 if (class_ts
.u
.derived
->components
->as
)
511 type
= get_scalar_to_descriptor_type (parmse
->expr
,
513 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
514 gfc_get_dtype (type
));
516 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
517 TREE_TYPE (parmse
->expr
),
518 cond_optional
, parmse
->expr
,
519 fold_convert (TREE_TYPE (parmse
->expr
),
521 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
525 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
527 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
529 fold_convert (TREE_TYPE (tmp
),
531 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
537 gfc_init_block (&block
);
540 gfc_conv_expr_descriptor (parmse
, e
);
542 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
544 gcc_assert (class_ts
.u
.derived
->components
->as
->type
546 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
550 if (gfc_expr_attr (e
).codimension
)
551 parmse
->expr
= fold_build1_loc (input_location
,
555 gfc_add_modify (&block
, ctree
, parmse
->expr
);
560 tmp
= gfc_finish_block (&block
);
562 gfc_init_block (&block
);
563 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
565 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
566 gfc_finish_block (&block
));
567 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
570 gfc_add_block_to_block (&parmse
->pre
, &block
);
574 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
575 && class_ts
.u
.derived
->components
->ts
.u
.derived
576 ->attr
.unlimited_polymorphic
)
578 /* Take care about initializing the _len component correctly. */
579 ctree
= gfc_class_len_get (var
);
580 if (UNLIMITED_POLY (e
))
585 len
= gfc_copy_expr (e
);
586 gfc_add_len_component (len
);
587 gfc_init_se (&se
, NULL
);
588 gfc_conv_expr (&se
, len
);
590 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
591 cond_optional
, se
.expr
,
592 fold_convert (TREE_TYPE (se
.expr
),
598 tmp
= integer_zero_node
;
599 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
602 /* Pass the address of the class object. */
603 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
605 if (optional
&& optional_alloc_ptr
)
606 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
607 TREE_TYPE (parmse
->expr
),
608 cond_optional
, parmse
->expr
,
609 fold_convert (TREE_TYPE (parmse
->expr
),
614 /* Create a new class container, which is required as scalar coarrays
615 have an array descriptor while normal scalars haven't. Optionally,
616 NULL pointer checks are added if the argument is OPTIONAL. */
619 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
620 gfc_typespec class_ts
, bool optional
)
622 tree var
, ctree
, tmp
;
627 gfc_init_block (&block
);
630 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
632 if (ref
->type
== REF_COMPONENT
633 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
637 if (class_ref
== NULL
638 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
639 tmp
= e
->symtree
->n
.sym
->backend_decl
;
642 /* Remove everything after the last class reference, convert the
643 expression and then recover its tailend once more. */
645 ref
= class_ref
->next
;
646 class_ref
->next
= NULL
;
647 gfc_init_se (&tmpse
, NULL
);
648 gfc_conv_expr (&tmpse
, e
);
649 class_ref
->next
= ref
;
653 var
= gfc_typenode_for_spec (&class_ts
);
654 var
= gfc_create_var (var
, "class");
656 ctree
= gfc_class_vptr_get (var
);
657 gfc_add_modify (&block
, ctree
,
658 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
660 ctree
= gfc_class_data_get (var
);
661 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
662 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
664 /* Pass the address of the class object. */
665 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
669 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
672 tmp
= gfc_finish_block (&block
);
674 gfc_init_block (&block
);
675 tmp2
= gfc_class_data_get (var
);
676 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
678 tmp2
= gfc_finish_block (&block
);
680 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
682 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
685 gfc_add_block_to_block (&parmse
->pre
, &block
);
689 /* Takes an intrinsic type expression and returns the address of a temporary
690 class object of the 'declared' type. */
692 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
693 gfc_typespec class_ts
)
701 /* The intrinsic type needs to be converted to a temporary
703 tmp
= gfc_typenode_for_spec (&class_ts
);
704 var
= gfc_create_var (tmp
, "class");
707 ctree
= gfc_class_vptr_get (var
);
709 vtab
= gfc_find_vtab (&e
->ts
);
711 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
712 gfc_add_modify (&parmse
->pre
, ctree
,
713 fold_convert (TREE_TYPE (ctree
), tmp
));
715 /* Now set the data field. */
716 ctree
= gfc_class_data_get (var
);
717 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
719 /* For an array reference in an elemental procedure call we need
720 to retain the ss to provide the scalarized array reference. */
721 gfc_conv_expr_reference (parmse
, e
);
722 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
723 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
727 ss
= gfc_walk_expr (e
);
728 if (ss
== gfc_ss_terminator
)
731 gfc_conv_expr_reference (parmse
, e
);
732 if (class_ts
.u
.derived
->components
->as
733 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
735 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
737 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
738 TREE_TYPE (ctree
), tmp
);
741 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
742 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
747 parmse
->use_offset
= 1;
748 gfc_conv_expr_descriptor (parmse
, e
);
749 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
751 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
752 TREE_TYPE (ctree
), parmse
->expr
);
753 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
756 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
760 gcc_assert (class_ts
.type
== BT_CLASS
);
761 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
762 && class_ts
.u
.derived
->components
->ts
.u
.derived
763 ->attr
.unlimited_polymorphic
)
765 ctree
= gfc_class_len_get (var
);
766 /* When the actual arg is a char array, then set the _len component of the
767 unlimited polymorphic entity, too. */
768 if (e
->ts
.type
== BT_CHARACTER
)
770 /* Start with parmse->string_length because this seems to be set to a
771 correct value more often. */
772 if (parmse
->string_length
)
773 tmp
= parmse
->string_length
;
774 /* When the string_length is not yet set, then try the backend_decl of
776 else if (e
->ts
.u
.cl
->backend_decl
)
777 tmp
= e
->ts
.u
.cl
->backend_decl
;
778 /* If both of the above approaches fail, then try to generate an
779 expression from the input, which is only feasible currently, when the
780 expression can be evaluated to a constant one. */
783 /* Try to simplify the expression. */
784 gfc_simplify_expr (e
, 0);
785 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
787 /* Amazingly all data is present to compute the length of a
788 constant string, but the expression is not yet there. */
789 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
791 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
792 e
->value
.character
.length
);
793 gfc_conv_const_charlen (e
->ts
.u
.cl
);
794 e
->ts
.u
.cl
->resolved
= 1;
795 tmp
= e
->ts
.u
.cl
->backend_decl
;
799 gfc_error ("Can't compute the length of the char array at %L.",
805 tmp
= integer_zero_node
;
807 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
809 else if (class_ts
.type
== BT_CLASS
810 && class_ts
.u
.derived
->components
811 && class_ts
.u
.derived
->components
->ts
.u
812 .derived
->attr
.unlimited_polymorphic
)
814 ctree
= gfc_class_len_get (var
);
815 gfc_add_modify (&parmse
->pre
, ctree
,
816 fold_convert (TREE_TYPE (ctree
),
819 /* Pass the address of the class object. */
820 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
824 /* Takes a scalarized class array expression and returns the
825 address of a temporary scalar class object of the 'declared'
827 OOP-TODO: This could be improved by adding code that branched on
828 the dynamic type being the same as the declared type. In this case
829 the original class expression can be passed directly.
830 optional_alloc_ptr is false when the dummy is neither allocatable
831 nor a pointer; that's relevant for the optional handling.
832 Set copyback to true if class container's _data and _vtab pointers
833 might get modified. */
836 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
837 bool elemental
, bool copyback
, bool optional
,
838 bool optional_alloc_ptr
)
844 tree cond
= NULL_TREE
;
845 tree slen
= NULL_TREE
;
849 bool full_array
= false;
851 gfc_init_block (&block
);
854 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
856 if (ref
->type
== REF_COMPONENT
857 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
860 if (ref
->next
== NULL
)
864 if ((ref
== NULL
|| class_ref
== ref
)
865 && (!class_ts
.u
.derived
->components
->as
866 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
869 /* Test for FULL_ARRAY. */
870 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
871 && gfc_expr_attr (e
).dimension
)
874 gfc_is_class_array_ref (e
, &full_array
);
876 /* The derived type needs to be converted to a temporary
878 tmp
= gfc_typenode_for_spec (&class_ts
);
879 var
= gfc_create_var (tmp
, "class");
882 ctree
= gfc_class_data_get (var
);
883 if (class_ts
.u
.derived
->components
->as
884 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
888 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
890 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
891 gfc_get_dtype (type
));
893 tmp
= gfc_class_data_get (parmse
->expr
);
894 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
895 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
897 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
900 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
904 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
905 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
906 TREE_TYPE (ctree
), parmse
->expr
);
907 gfc_add_modify (&block
, ctree
, parmse
->expr
);
910 /* Return the data component, except in the case of scalarized array
911 references, where nullification of the cannot occur and so there
913 if (!elemental
&& full_array
&& copyback
)
915 if (class_ts
.u
.derived
->components
->as
916 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
919 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
920 gfc_conv_descriptor_data_get (ctree
));
922 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
925 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
929 ctree
= gfc_class_vptr_get (var
);
931 /* The vptr is the second field of the actual argument.
932 First we have to find the corresponding class reference. */
935 if (class_ref
== NULL
936 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
938 tmp
= e
->symtree
->n
.sym
->backend_decl
;
939 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
940 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
941 slen
= integer_zero_node
;
945 /* Remove everything after the last class reference, convert the
946 expression and then recover its tailend once more. */
948 ref
= class_ref
->next
;
949 class_ref
->next
= NULL
;
950 gfc_init_se (&tmpse
, NULL
);
951 gfc_conv_expr (&tmpse
, e
);
952 class_ref
->next
= ref
;
954 slen
= tmpse
.string_length
;
957 gcc_assert (tmp
!= NULL_TREE
);
959 /* Dereference if needs be. */
960 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
961 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
963 vptr
= gfc_class_vptr_get (tmp
);
964 gfc_add_modify (&block
, ctree
,
965 fold_convert (TREE_TYPE (ctree
), vptr
));
967 /* Return the vptr component, except in the case of scalarized array
968 references, where the dynamic type cannot change. */
969 if (!elemental
&& full_array
&& copyback
)
970 gfc_add_modify (&parmse
->post
, vptr
,
971 fold_convert (TREE_TYPE (vptr
), ctree
));
973 /* For unlimited polymorphic objects also set the _len component. */
974 if (class_ts
.type
== BT_CLASS
975 && class_ts
.u
.derived
->components
976 && class_ts
.u
.derived
->components
->ts
.u
977 .derived
->attr
.unlimited_polymorphic
)
979 ctree
= gfc_class_len_get (var
);
980 if (UNLIMITED_POLY (e
))
981 tmp
= gfc_class_len_get (tmp
);
982 else if (e
->ts
.type
== BT_CHARACTER
)
984 gcc_assert (slen
!= NULL_TREE
);
988 tmp
= integer_zero_node
;
989 gfc_add_modify (&parmse
->pre
, ctree
,
990 fold_convert (TREE_TYPE (ctree
), tmp
));
997 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
998 /* parmse->pre may contain some preparatory instructions for the
999 temporary array descriptor. Those may only be executed when the
1000 optional argument is set, therefore add parmse->pre's instructions
1001 to block, which is later guarded by an if (optional_arg_given). */
1002 gfc_add_block_to_block (&parmse
->pre
, &block
);
1003 block
.head
= parmse
->pre
.head
;
1004 parmse
->pre
.head
= NULL_TREE
;
1005 tmp
= gfc_finish_block (&block
);
1007 if (optional_alloc_ptr
)
1008 tmp2
= build_empty_stmt (input_location
);
1011 gfc_init_block (&block
);
1013 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1014 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1015 null_pointer_node
));
1016 tmp2
= gfc_finish_block (&block
);
1019 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1021 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1024 gfc_add_block_to_block (&parmse
->pre
, &block
);
1026 /* Pass the address of the class object. */
1027 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1029 if (optional
&& optional_alloc_ptr
)
1030 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1031 TREE_TYPE (parmse
->expr
),
1033 fold_convert (TREE_TYPE (parmse
->expr
),
1034 null_pointer_node
));
1038 /* Given a class array declaration and an index, returns the address
1039 of the referenced element. */
1042 gfc_get_class_array_ref (tree index
, tree class_decl
)
1044 tree data
= gfc_class_data_get (class_decl
);
1045 tree size
= gfc_class_vtab_size_get (class_decl
);
1046 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1047 gfc_array_index_type
,
1050 data
= gfc_conv_descriptor_data_get (data
);
1051 ptr
= fold_convert (pvoid_type_node
, data
);
1052 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1053 return fold_convert (TREE_TYPE (data
), ptr
);
1057 /* Copies one class expression to another, assuming that if either
1058 'to' or 'from' are arrays they are packed. Should 'from' be
1059 NULL_TREE, the initialization expression for 'to' is used, assuming
1060 that the _vptr is set. */
1063 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1073 vec
<tree
, va_gc
> *args
;
1080 /* To prevent warnings on uninitialized variables. */
1081 from_len
= to_len
= NULL_TREE
;
1083 if (from
!= NULL_TREE
)
1084 fcn
= gfc_class_vtab_copy_get (from
);
1086 fcn
= gfc_class_vtab_copy_get (to
);
1088 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1090 if (from
!= NULL_TREE
)
1091 from_data
= gfc_class_data_get (from
);
1093 from_data
= gfc_class_vtab_def_init_get (to
);
1097 if (from
!= NULL_TREE
&& unlimited
)
1098 from_len
= gfc_class_len_get (from
);
1100 from_len
= integer_zero_node
;
1103 to_data
= gfc_class_data_get (to
);
1105 to_len
= gfc_class_len_get (to
);
1107 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1109 stmtblock_t loopbody
;
1114 gfc_init_block (&body
);
1115 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1116 gfc_array_index_type
, nelems
,
1117 gfc_index_one_node
);
1118 nelems
= gfc_evaluate_now (tmp
, &body
);
1119 index
= gfc_create_var (gfc_array_index_type
, "S");
1121 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
1123 from_ref
= gfc_get_class_array_ref (index
, from
);
1124 vec_safe_push (args
, from_ref
);
1127 vec_safe_push (args
, from_data
);
1129 to_ref
= gfc_get_class_array_ref (index
, to
);
1130 vec_safe_push (args
, to_ref
);
1132 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1134 /* Build the body of the loop. */
1135 gfc_init_block (&loopbody
);
1136 gfc_add_expr_to_block (&loopbody
, tmp
);
1138 /* Build the loop and return. */
1139 gfc_init_loopinfo (&loop
);
1141 loop
.from
[0] = gfc_index_zero_node
;
1142 loop
.loopvar
[0] = index
;
1143 loop
.to
[0] = nelems
;
1144 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1145 gfc_init_block (&ifbody
);
1146 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1147 stdcopy
= gfc_finish_block (&ifbody
);
1148 /* In initialization mode from_len is a constant zero. */
1149 if (unlimited
&& !integer_zerop (from_len
))
1151 vec_safe_push (args
, from_len
);
1152 vec_safe_push (args
, to_len
);
1153 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1154 /* Build the body of the loop. */
1155 gfc_init_block (&loopbody
);
1156 gfc_add_expr_to_block (&loopbody
, tmp
);
1158 /* Build the loop and return. */
1159 gfc_init_loopinfo (&loop
);
1161 loop
.from
[0] = gfc_index_zero_node
;
1162 loop
.loopvar
[0] = index
;
1163 loop
.to
[0] = nelems
;
1164 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1165 gfc_init_block (&ifbody
);
1166 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1167 extcopy
= gfc_finish_block (&ifbody
);
1169 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1170 boolean_type_node
, from_len
,
1172 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1173 void_type_node
, tmp
, extcopy
, stdcopy
);
1174 gfc_add_expr_to_block (&body
, tmp
);
1175 tmp
= gfc_finish_block (&body
);
1179 gfc_add_expr_to_block (&body
, stdcopy
);
1180 tmp
= gfc_finish_block (&body
);
1182 gfc_cleanup_loop (&loop
);
1186 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
1187 vec_safe_push (args
, from_data
);
1188 vec_safe_push (args
, to_data
);
1189 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1191 /* In initialization mode from_len is a constant zero. */
1192 if (unlimited
&& !integer_zerop (from_len
))
1194 vec_safe_push (args
, from_len
);
1195 vec_safe_push (args
, to_len
);
1196 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1197 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1198 boolean_type_node
, from_len
,
1200 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1201 void_type_node
, tmp
, extcopy
, stdcopy
);
1207 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1208 if (from
== NULL_TREE
)
1211 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1213 from_data
, null_pointer_node
);
1214 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1215 void_type_node
, cond
,
1216 tmp
, build_empty_stmt (input_location
));
1224 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1226 gfc_actual_arglist
*actual
;
1231 actual
= gfc_get_actual_arglist ();
1232 actual
->expr
= gfc_copy_expr (rhs
);
1233 actual
->next
= gfc_get_actual_arglist ();
1234 actual
->next
->expr
= gfc_copy_expr (lhs
);
1235 ppc
= gfc_copy_expr (obj
);
1236 gfc_add_vptr_component (ppc
);
1237 gfc_add_component_ref (ppc
, "_copy");
1238 ppc_code
= gfc_get_code (EXEC_CALL
);
1239 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1240 /* Although '_copy' is set to be elemental in class.c, it is
1241 not staying that way. Find out why, sometime.... */
1242 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1243 ppc_code
->ext
.actual
= actual
;
1244 ppc_code
->expr1
= ppc
;
1245 /* Since '_copy' is elemental, the scalarizer will take care
1246 of arrays in gfc_trans_call. */
1247 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1248 gfc_free_statements (ppc_code
);
1250 if (UNLIMITED_POLY(obj
))
1252 /* Check if rhs is non-NULL. */
1254 gfc_init_se (&src
, NULL
);
1255 gfc_conv_expr (&src
, rhs
);
1256 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1257 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1258 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1259 null_pointer_node
));
1260 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1261 build_empty_stmt (input_location
));
1267 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1268 A MEMCPY is needed to copy the full data from the default initializer
1269 of the dynamic type. */
1272 gfc_trans_class_init_assign (gfc_code
*code
)
1276 gfc_se dst
,src
,memsz
;
1277 gfc_expr
*lhs
, *rhs
, *sz
;
1279 gfc_start_block (&block
);
1281 lhs
= gfc_copy_expr (code
->expr1
);
1282 gfc_add_data_component (lhs
);
1284 rhs
= gfc_copy_expr (code
->expr1
);
1285 gfc_add_vptr_component (rhs
);
1287 /* Make sure that the component backend_decls have been built, which
1288 will not have happened if the derived types concerned have not
1290 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1291 gfc_add_def_init_component (rhs
);
1292 /* The _def_init is always scalar. */
1295 if (code
->expr1
->ts
.type
== BT_CLASS
1296 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1297 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1300 sz
= gfc_copy_expr (code
->expr1
);
1301 gfc_add_vptr_component (sz
);
1302 gfc_add_size_component (sz
);
1304 gfc_init_se (&dst
, NULL
);
1305 gfc_init_se (&src
, NULL
);
1306 gfc_init_se (&memsz
, NULL
);
1307 gfc_conv_expr (&dst
, lhs
);
1308 gfc_conv_expr (&src
, rhs
);
1309 gfc_conv_expr (&memsz
, sz
);
1310 gfc_add_block_to_block (&block
, &src
.pre
);
1311 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1313 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1315 if (UNLIMITED_POLY(code
->expr1
))
1317 /* Check if _def_init is non-NULL. */
1318 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1319 boolean_type_node
, src
.expr
,
1320 fold_convert (TREE_TYPE (src
.expr
),
1321 null_pointer_node
));
1322 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1323 tmp
, build_empty_stmt (input_location
));
1327 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1328 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1330 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1331 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1333 build_empty_stmt (input_location
));
1336 gfc_add_expr_to_block (&block
, tmp
);
1338 return gfc_finish_block (&block
);
1342 /* Translate an assignment to a CLASS object
1343 (pointer or ordinary assignment). */
1346 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1354 gfc_start_block (&block
);
1357 while (ref
&& ref
->next
)
1360 /* Class valued proc_pointer assignments do not need any further
1362 if (ref
&& ref
->type
== REF_COMPONENT
1363 && ref
->u
.c
.component
->attr
.proc_pointer
1364 && expr2
->expr_type
== EXPR_VARIABLE
1365 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1366 && op
== EXEC_POINTER_ASSIGN
)
1369 if (expr2
->ts
.type
!= BT_CLASS
)
1371 /* Insert an additional assignment which sets the '_vptr' field. */
1372 gfc_symbol
*vtab
= NULL
;
1375 lhs
= gfc_copy_expr (expr1
);
1376 gfc_add_vptr_component (lhs
);
1378 if (UNLIMITED_POLY (expr1
)
1379 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1381 rhs
= gfc_get_null_expr (&expr2
->where
);
1385 if (expr2
->expr_type
== EXPR_NULL
)
1386 vtab
= gfc_find_vtab (&expr1
->ts
);
1388 vtab
= gfc_find_vtab (&expr2
->ts
);
1391 rhs
= gfc_get_expr ();
1392 rhs
->expr_type
= EXPR_VARIABLE
;
1393 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1397 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1398 gfc_add_expr_to_block (&block
, tmp
);
1400 gfc_free_expr (lhs
);
1401 gfc_free_expr (rhs
);
1403 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1405 /* F2003:C717 only sequence and bind-C types can come here. */
1406 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1407 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1408 gfc_add_data_component (expr2
);
1411 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1413 /* Insert an additional assignment which sets the '_vptr' field. */
1414 lhs
= gfc_copy_expr (expr1
);
1415 gfc_add_vptr_component (lhs
);
1417 rhs
= gfc_copy_expr (expr2
);
1418 gfc_add_vptr_component (rhs
);
1420 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1421 gfc_add_expr_to_block (&block
, tmp
);
1423 gfc_free_expr (lhs
);
1424 gfc_free_expr (rhs
);
1427 /* Do the actual CLASS assignment. */
1428 if (expr2
->ts
.type
== BT_CLASS
1429 && !CLASS_DATA (expr2
)->attr
.dimension
)
1431 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1432 || !CLASS_DATA (expr2
)->attr
.dimension
)
1433 gfc_add_data_component (expr1
);
1437 if (op
== EXEC_ASSIGN
)
1438 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1439 else if (op
== EXEC_POINTER_ASSIGN
)
1440 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1444 gfc_add_expr_to_block (&block
, tmp
);
1446 return gfc_finish_block (&block
);
1450 /* End of prototype trans-class.c */
1454 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1456 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1457 gfc_warning (OPT_Wrealloc_lhs
,
1458 "Code for reallocating the allocatable array at %L will "
1460 else if (warn_realloc_lhs_all
)
1461 gfc_warning (OPT_Wrealloc_lhs_all
,
1462 "Code for reallocating the allocatable variable at %L "
1463 "will be added", where
);
1467 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1470 /* Copy the scalarization loop variables. */
1473 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1476 dest
->loop
= src
->loop
;
1480 /* Initialize a simple expression holder.
1482 Care must be taken when multiple se are created with the same parent.
1483 The child se must be kept in sync. The easiest way is to delay creation
1484 of a child se until after after the previous se has been translated. */
1487 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1489 memset (se
, 0, sizeof (gfc_se
));
1490 gfc_init_block (&se
->pre
);
1491 gfc_init_block (&se
->post
);
1493 se
->parent
= parent
;
1496 gfc_copy_se_loopvars (se
, parent
);
1500 /* Advances to the next SS in the chain. Use this rather than setting
1501 se->ss = se->ss->next because all the parents needs to be kept in sync.
1505 gfc_advance_se_ss_chain (gfc_se
* se
)
1510 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1513 /* Walk down the parent chain. */
1516 /* Simple consistency check. */
1517 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1518 || p
->parent
->ss
->nested_ss
== p
->ss
);
1520 /* If we were in a nested loop, the next scalarized expression can be
1521 on the parent ss' next pointer. Thus we should not take the next
1522 pointer blindly, but rather go up one nest level as long as next
1523 is the end of chain. */
1525 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1535 /* Ensures the result of the expression as either a temporary variable
1536 or a constant so that it can be used repeatedly. */
1539 gfc_make_safe_expr (gfc_se
* se
)
1543 if (CONSTANT_CLASS_P (se
->expr
))
1546 /* We need a temporary for this result. */
1547 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1548 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1553 /* Return an expression which determines if a dummy parameter is present.
1554 Also used for arguments to procedures with multiple entry points. */
1557 gfc_conv_expr_present (gfc_symbol
* sym
)
1561 gcc_assert (sym
->attr
.dummy
);
1562 decl
= gfc_get_symbol_decl (sym
);
1564 /* Intrinsic scalars with VALUE attribute which are passed by value
1565 use a hidden argument to denote the present status. */
1566 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1567 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1568 && !sym
->attr
.dimension
)
1570 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1573 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1575 strcpy (&name
[1], sym
->name
);
1576 tree_name
= get_identifier (name
);
1578 /* Walk function argument list to find hidden arg. */
1579 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1580 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1581 if (DECL_NAME (cond
) == tree_name
)
1588 if (TREE_CODE (decl
) != PARM_DECL
)
1590 /* Array parameters use a temporary descriptor, we want the real
1592 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1593 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1594 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1597 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1598 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1600 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1601 as actual argument to denote absent dummies. For array descriptors,
1602 we thus also need to check the array descriptor. For BT_CLASS, it
1603 can also occur for scalars and F2003 due to type->class wrapping and
1604 class->class wrapping. Note further that BT_CLASS always uses an
1605 array descriptor for arrays, also for explicit-shape/assumed-size. */
1607 if (!sym
->attr
.allocatable
1608 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1609 || (sym
->ts
.type
== BT_CLASS
1610 && !CLASS_DATA (sym
)->attr
.allocatable
1611 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1612 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1613 || sym
->ts
.type
== BT_CLASS
))
1617 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1618 || sym
->as
->type
== AS_ASSUMED_RANK
1619 || sym
->attr
.codimension
))
1620 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1622 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1623 if (sym
->ts
.type
== BT_CLASS
)
1624 tmp
= gfc_class_data_get (tmp
);
1625 tmp
= gfc_conv_array_data (tmp
);
1627 else if (sym
->ts
.type
== BT_CLASS
)
1628 tmp
= gfc_class_data_get (decl
);
1632 if (tmp
!= NULL_TREE
)
1634 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1635 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1636 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1637 boolean_type_node
, cond
, tmp
);
1645 /* Converts a missing, dummy argument into a null or zero. */
1648 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1653 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1657 /* Create a temporary and convert it to the correct type. */
1658 tmp
= gfc_get_int_type (kind
);
1659 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1662 /* Test for a NULL value. */
1663 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1664 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1665 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1666 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1670 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1672 build_zero_cst (TREE_TYPE (se
->expr
)));
1673 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1677 if (ts
.type
== BT_CHARACTER
)
1679 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1680 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1681 present
, se
->string_length
, tmp
);
1682 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1683 se
->string_length
= tmp
;
1689 /* Get the character length of an expression, looking through gfc_refs
1693 gfc_get_expr_charlen (gfc_expr
*e
)
1698 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1699 && e
->ts
.type
== BT_CHARACTER
);
1701 length
= NULL
; /* To silence compiler warning. */
1703 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1706 gfc_init_se (&tmpse
, NULL
);
1707 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1708 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1712 /* First candidate: if the variable is of type CHARACTER, the
1713 expression's length could be the length of the character
1715 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1716 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1718 /* Look through the reference chain for component references. */
1719 for (r
= e
->ref
; r
; r
= r
->next
)
1724 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1725 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1733 /* We should never got substring references here. These will be
1734 broken down by the scalarizer. */
1740 gcc_assert (length
!= NULL
);
1745 /* Return for an expression the backend decl of the coarray. */
1748 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1752 gfc_ref
*ref
, *comp_ref
= NULL
;
1754 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1756 /* Not-implemented diagnostic. */
1757 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1758 if (ref
->type
== REF_COMPONENT
)
1761 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1762 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1763 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1764 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1765 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1766 && !ref
->u
.c
.component
->attr
.codimension
1767 && (ref
->u
.c
.component
->attr
.pointer
1768 || ref
->u
.c
.component
->attr
.allocatable
)))
1769 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1770 "component of the coindexed coarray at %L is not yet "
1771 "supported", &expr
->where
);
1774 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1775 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1776 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1777 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1779 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1780 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1781 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1782 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1783 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1784 "not yet supported", &expr
->where
);
1788 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1789 general not possible as the required stride multiplier might be not
1790 a multiple of c_sizeof(b). In case of noncoindexed access, the
1791 scalarizer often takes care of it - for coarrays, it always fails. */
1792 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1793 if (ref
->type
== REF_COMPONENT
1794 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1795 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1796 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1797 && ref
->u
.c
.component
->attr
.codimension
)))
1801 for ( ; ref
; ref
= ref
->next
)
1802 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1804 for ( ; ref
; ref
= ref
->next
)
1805 if (ref
->type
== REF_COMPONENT
)
1806 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1807 "with an array partref is not yet supported",
1811 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1812 gcc_assert (caf_decl
);
1813 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1814 caf_decl
= gfc_class_data_get (caf_decl
);
1815 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1818 /* The following code assumes that the coarray is a component reachable via
1819 only scalar components/variables; the Fortran standard guarantees this. */
1821 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1822 if (ref
->type
== REF_COMPONENT
)
1824 gfc_component
*comp
= ref
->u
.c
.component
;
1826 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1827 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1828 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1829 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1830 comp
->backend_decl
, NULL_TREE
);
1831 if (comp
->ts
.type
== BT_CLASS
)
1832 caf_decl
= gfc_class_data_get (caf_decl
);
1833 if (comp
->attr
.codimension
)
1839 gcc_assert (found
&& caf_decl
);
1844 /* Obtain the Coarray token - and optionally also the offset. */
1847 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1852 /* Coarray token. */
1853 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1855 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1856 == GFC_ARRAY_ALLOCATABLE
1857 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1858 *token
= gfc_conv_descriptor_token (caf_decl
);
1860 else if (DECL_LANG_SPECIFIC (caf_decl
)
1861 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1862 *token
= GFC_DECL_TOKEN (caf_decl
);
1865 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1866 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1867 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1873 /* Offset between the coarray base address and the address wanted. */
1874 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1875 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1876 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1877 *offset
= build_int_cst (gfc_array_index_type
, 0);
1878 else if (DECL_LANG_SPECIFIC (caf_decl
)
1879 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1880 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1881 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1882 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1884 *offset
= build_int_cst (gfc_array_index_type
, 0);
1886 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1887 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1889 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1890 tmp
= gfc_conv_descriptor_data_get (tmp
);
1892 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1893 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1896 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1900 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1901 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1903 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1904 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1907 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1911 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1912 fold_convert (gfc_array_index_type
, *offset
),
1913 fold_convert (gfc_array_index_type
, tmp
));
1917 /* Convert the coindex of a coarray into an image index; the result is
1918 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1919 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1922 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1925 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1929 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1930 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1932 gcc_assert (ref
!= NULL
);
1934 img_idx
= integer_zero_node
;
1935 extent
= integer_one_node
;
1936 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1937 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1939 gfc_init_se (&se
, NULL
);
1940 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1941 gfc_add_block_to_block (block
, &se
.pre
);
1942 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1943 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1944 integer_type_node
, se
.expr
,
1945 fold_convert(integer_type_node
, lbound
));
1946 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1948 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1950 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1952 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1953 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1954 tmp
= fold_convert (integer_type_node
, tmp
);
1955 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1956 integer_type_node
, extent
, tmp
);
1960 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1962 gfc_init_se (&se
, NULL
);
1963 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1964 gfc_add_block_to_block (block
, &se
.pre
);
1965 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1966 lbound
= fold_convert (integer_type_node
, lbound
);
1967 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1968 integer_type_node
, se
.expr
, lbound
);
1969 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1971 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1973 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1975 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1976 ubound
= fold_convert (integer_type_node
, ubound
);
1977 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1978 integer_type_node
, ubound
, lbound
);
1979 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1980 tmp
, integer_one_node
);
1981 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1982 integer_type_node
, extent
, tmp
);
1985 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1986 img_idx
, integer_one_node
);
1991 /* For each character array constructor subexpression without a ts.u.cl->length,
1992 replace it by its first element (if there aren't any elements, the length
1993 should already be set to zero). */
1996 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1998 gfc_actual_arglist
* arg
;
2004 switch (e
->expr_type
)
2008 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2009 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2013 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2017 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2018 flatten_array_ctors_without_strlen (arg
->expr
);
2023 /* We've found what we're looking for. */
2024 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2029 gcc_assert (e
->value
.constructor
);
2031 c
= gfc_constructor_first (e
->value
.constructor
);
2035 flatten_array_ctors_without_strlen (new_expr
);
2036 gfc_replace_expr (e
, new_expr
);
2040 /* Otherwise, fall through to handle constructor elements. */
2041 case EXPR_STRUCTURE
:
2042 for (c
= gfc_constructor_first (e
->value
.constructor
);
2043 c
; c
= gfc_constructor_next (c
))
2044 flatten_array_ctors_without_strlen (c
->expr
);
2054 /* Generate code to initialize a string length variable. Returns the
2055 value. For array constructors, cl->length might be NULL and in this case,
2056 the first element of the constructor is needed. expr is the original
2057 expression so we can access it but can be NULL if this is not needed. */
2060 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2064 gfc_init_se (&se
, NULL
);
2068 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2071 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2072 "flatten" array constructors by taking their first element; all elements
2073 should be the same length or a cl->length should be present. */
2076 gfc_expr
* expr_flat
;
2078 expr_flat
= gfc_copy_expr (expr
);
2079 flatten_array_ctors_without_strlen (expr_flat
);
2080 gfc_resolve_expr (expr_flat
);
2082 gfc_conv_expr (&se
, expr_flat
);
2083 gfc_add_block_to_block (pblock
, &se
.pre
);
2084 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2086 gfc_free_expr (expr_flat
);
2090 /* Convert cl->length. */
2092 gcc_assert (cl
->length
);
2094 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2095 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2096 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2097 gfc_add_block_to_block (pblock
, &se
.pre
);
2099 if (cl
->backend_decl
)
2100 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2102 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2107 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2108 const char *name
, locus
*where
)
2118 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2119 type
= build_pointer_type (type
);
2121 gfc_init_se (&start
, se
);
2122 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2123 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2125 if (integer_onep (start
.expr
))
2126 gfc_conv_string_parameter (se
);
2131 /* Avoid multiple evaluation of substring start. */
2132 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2133 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2135 /* Change the start of the string. */
2136 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2139 tmp
= build_fold_indirect_ref_loc (input_location
,
2141 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2142 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2145 /* Length = end + 1 - start. */
2146 gfc_init_se (&end
, se
);
2147 if (ref
->u
.ss
.end
== NULL
)
2148 end
.expr
= se
->string_length
;
2151 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2152 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2156 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2157 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2159 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2161 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2162 boolean_type_node
, start
.expr
,
2165 /* Check lower bound. */
2166 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2168 build_int_cst (gfc_charlen_type_node
, 1));
2169 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2170 boolean_type_node
, nonempty
, fault
);
2172 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2173 "is less than one", name
);
2175 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2176 "is less than one");
2177 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2178 fold_convert (long_integer_type_node
,
2182 /* Check upper bound. */
2183 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2184 end
.expr
, se
->string_length
);
2185 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2186 boolean_type_node
, nonempty
, fault
);
2188 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2189 "exceeds string length (%%ld)", name
);
2191 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2192 "exceeds string length (%%ld)");
2193 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2194 fold_convert (long_integer_type_node
, end
.expr
),
2195 fold_convert (long_integer_type_node
,
2196 se
->string_length
));
2200 /* Try to calculate the length from the start and end expressions. */
2202 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2206 i_len
= mpz_get_si (length
) + 1;
2210 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2211 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2215 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2216 end
.expr
, start
.expr
);
2217 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2218 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2219 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2220 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2223 se
->string_length
= tmp
;
2227 /* Convert a derived type component reference. */
2230 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2237 c
= ref
->u
.c
.component
;
2239 if (c
->backend_decl
== NULL_TREE
2240 && ref
->u
.c
.sym
!= NULL
)
2241 gfc_get_derived_type (ref
->u
.c
.sym
);
2243 field
= c
->backend_decl
;
2244 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2247 /* Components can correspond to fields of different containing
2248 types, as components are created without context, whereas
2249 a concrete use of a component has the type of decl as context.
2250 So, if the type doesn't match, we search the corresponding
2251 FIELD_DECL in the parent type. To not waste too much time
2252 we cache this result in norestrict_decl. */
2254 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
2256 tree f2
= c
->norestrict_decl
;
2257 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2258 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2259 if (TREE_CODE (f2
) == FIELD_DECL
2260 && DECL_NAME (f2
) == DECL_NAME (field
))
2263 c
->norestrict_decl
= f2
;
2267 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2268 && strcmp ("_data", c
->name
) == 0)
2270 /* Found a ref to the _data component. Store the associated ref to
2271 the vptr in se->class_vptr. */
2272 se
->class_vptr
= gfc_class_vptr_get (decl
);
2275 se
->class_vptr
= NULL_TREE
;
2277 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2278 decl
, field
, NULL_TREE
);
2282 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2283 strlen () conditional below. */
2284 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2285 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2287 tmp
= c
->ts
.u
.cl
->backend_decl
;
2288 /* Components must always be constant length. */
2289 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2290 se
->string_length
= tmp
;
2293 if (gfc_deferred_strlen (c
, &field
))
2295 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2297 decl
, field
, NULL_TREE
);
2298 se
->string_length
= tmp
;
2301 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2302 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2303 && c
->ts
.type
!= BT_CHARACTER
)
2304 || c
->attr
.proc_pointer
)
2305 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2310 /* This function deals with component references to components of the
2311 parent type for derived type extensions. */
2313 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2321 c
= ref
->u
.c
.component
;
2323 /* Return if the component is in the parent type. */
2324 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2325 if (strcmp (c
->name
, cmp
->name
) == 0)
2328 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2329 parent
.type
= REF_COMPONENT
;
2331 parent
.u
.c
.sym
= dt
;
2332 parent
.u
.c
.component
= dt
->components
;
2334 if (dt
->backend_decl
== NULL
)
2335 gfc_get_derived_type (dt
);
2337 /* Build the reference and call self. */
2338 gfc_conv_component_ref (se
, &parent
);
2339 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2340 parent
.u
.c
.component
= c
;
2341 conv_parent_component_references (se
, &parent
);
2344 /* Return the contents of a variable. Also handles reference/pointer
2345 variables (all Fortran pointer references are implicit). */
2348 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2353 tree parent_decl
= NULL_TREE
;
2356 bool alternate_entry
;
2359 bool first_time
= true;
2361 sym
= expr
->symtree
->n
.sym
;
2362 is_classarray
= IS_CLASS_ARRAY (sym
);
2366 gfc_ss_info
*ss_info
= ss
->info
;
2368 /* Check that something hasn't gone horribly wrong. */
2369 gcc_assert (ss
!= gfc_ss_terminator
);
2370 gcc_assert (ss_info
->expr
== expr
);
2372 /* A scalarized term. We already know the descriptor. */
2373 se
->expr
= ss_info
->data
.array
.descriptor
;
2374 se
->string_length
= ss_info
->string_length
;
2375 ref
= ss_info
->data
.array
.ref
;
2377 gcc_assert (ref
->type
== REF_ARRAY
2378 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2380 gfc_conv_tmp_array_ref (se
);
2384 tree se_expr
= NULL_TREE
;
2386 se
->expr
= gfc_get_symbol_decl (sym
);
2388 /* Deal with references to a parent results or entries by storing
2389 the current_function_decl and moving to the parent_decl. */
2390 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2391 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2392 && sym
->result
== sym
;
2393 entry_master
= sym
->attr
.result
2394 && sym
->ns
->proc_name
->attr
.entry_master
2395 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2396 if (current_function_decl
)
2397 parent_decl
= DECL_CONTEXT (current_function_decl
);
2399 if ((se
->expr
== parent_decl
&& return_value
)
2400 || (sym
->ns
&& sym
->ns
->proc_name
2402 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2403 && (alternate_entry
|| entry_master
)))
2408 /* Special case for assigning the return value of a function.
2409 Self recursive functions must have an explicit return value. */
2410 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2411 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2413 /* Similarly for alternate entry points. */
2414 else if (alternate_entry
2415 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2418 gfc_entry_list
*el
= NULL
;
2420 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2423 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2428 else if (entry_master
2429 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2431 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2436 /* Procedure actual arguments. */
2437 else if (sym
->attr
.flavor
== FL_PROCEDURE
2438 && se
->expr
!= current_function_decl
)
2440 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2442 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2443 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2449 /* Dereference the expression, where needed. Since characters
2450 are entirely different from other types, they are treated
2452 if (sym
->ts
.type
== BT_CHARACTER
)
2454 /* Dereference character pointer dummy arguments
2456 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2458 || sym
->attr
.function
2459 || sym
->attr
.result
))
2460 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2464 else if (!sym
->attr
.value
)
2466 /* Dereference temporaries for class array dummy arguments. */
2467 if (sym
->attr
.dummy
&& is_classarray
2468 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2470 if (!se
->descriptor_only
)
2471 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2473 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2477 /* Dereference non-character scalar dummy arguments. */
2478 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2479 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2480 && (sym
->ts
.type
!= BT_CLASS
2481 || (!CLASS_DATA (sym
)->attr
.dimension
2482 && !(CLASS_DATA (sym
)->attr
.codimension
2483 && CLASS_DATA (sym
)->attr
.allocatable
))))
2484 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2487 /* Dereference scalar hidden result. */
2488 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2489 && (sym
->attr
.function
|| sym
->attr
.result
)
2490 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2491 && !sym
->attr
.always_explicit
)
2492 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2495 /* Dereference non-character, non-class pointer variables.
2496 These must be dummies, results, or scalars. */
2498 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2499 || gfc_is_associate_pointer (sym
)
2500 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2502 || sym
->attr
.function
2504 || (!sym
->attr
.dimension
2505 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2506 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2508 /* Now treat the class array pointer variables accordingly. */
2509 else if (sym
->ts
.type
== BT_CLASS
2511 && (CLASS_DATA (sym
)->attr
.dimension
2512 || CLASS_DATA (sym
)->attr
.codimension
)
2513 && ((CLASS_DATA (sym
)->as
2514 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2515 || CLASS_DATA (sym
)->attr
.allocatable
2516 || CLASS_DATA (sym
)->attr
.class_pointer
))
2517 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2519 /* And the case where a non-dummy, non-result, non-function,
2520 non-allotable and non-pointer classarray is present. This case was
2521 previously covered by the first if, but with introducing the
2522 condition !is_classarray there, that case has to be covered
2524 else if (sym
->ts
.type
== BT_CLASS
2526 && !sym
->attr
.function
2527 && !sym
->attr
.result
2528 && (CLASS_DATA (sym
)->attr
.dimension
2529 || CLASS_DATA (sym
)->attr
.codimension
)
2531 || !CLASS_DATA (sym
)->attr
.allocatable
)
2532 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2533 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2540 /* For character variables, also get the length. */
2541 if (sym
->ts
.type
== BT_CHARACTER
)
2543 /* If the character length of an entry isn't set, get the length from
2544 the master function instead. */
2545 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2546 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2548 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2549 gcc_assert (se
->string_length
);
2557 /* Return the descriptor if that's what we want and this is an array
2558 section reference. */
2559 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2561 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2562 /* Return the descriptor for array pointers and allocations. */
2563 if (se
->want_pointer
2564 && ref
->next
== NULL
&& (se
->descriptor_only
))
2567 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2568 /* Return a pointer to an element. */
2572 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2573 && se
->descriptor_only
2574 && !CLASS_DATA (sym
)->attr
.allocatable
2575 && !CLASS_DATA (sym
)->attr
.class_pointer
2576 && CLASS_DATA (sym
)->as
2577 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2578 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2579 /* Skip the first ref of a _data component, because for class
2580 arrays that one is already done by introducing a temporary
2581 array descriptor. */
2584 if (ref
->u
.c
.sym
->attr
.extension
)
2585 conv_parent_component_references (se
, ref
);
2587 gfc_conv_component_ref (se
, ref
);
2588 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2589 && se
->want_pointer
&& se
->descriptor_only
)
2595 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2596 expr
->symtree
->name
, &expr
->where
);
2606 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2608 if (se
->want_pointer
)
2610 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2611 gfc_conv_string_parameter (se
);
2613 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2618 /* Unary ops are easy... Or they would be if ! was a valid op. */
2621 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2626 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2627 /* Initialize the operand. */
2628 gfc_init_se (&operand
, se
);
2629 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2630 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2632 type
= gfc_typenode_for_spec (&expr
->ts
);
2634 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2635 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2636 All other unary operators have an equivalent GIMPLE unary operator. */
2637 if (code
== TRUTH_NOT_EXPR
)
2638 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2639 build_int_cst (type
, 0));
2641 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2645 /* Expand power operator to optimal multiplications when a value is raised
2646 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2647 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2648 Programming", 3rd Edition, 1998. */
2650 /* This code is mostly duplicated from expand_powi in the backend.
2651 We establish the "optimal power tree" lookup table with the defined size.
2652 The items in the table are the exponents used to calculate the index
2653 exponents. Any integer n less than the value can get an "addition chain",
2654 with the first node being one. */
2655 #define POWI_TABLE_SIZE 256
2657 /* The table is from builtins.c. */
2658 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2660 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2661 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2662 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2663 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2664 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2665 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2666 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2667 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2668 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2669 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2670 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2671 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2672 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2673 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2674 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2675 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2676 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2677 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2678 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2679 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2680 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2681 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2682 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2683 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2684 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2685 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2686 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2687 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2688 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2689 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2690 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2691 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2694 /* If n is larger than lookup table's max index, we use the "window
2696 #define POWI_WINDOW_SIZE 3
2698 /* Recursive function to expand the power operator. The temporary
2699 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2701 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2708 if (n
< POWI_TABLE_SIZE
)
2713 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2714 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2718 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2719 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2720 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2724 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2728 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2729 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2731 if (n
< POWI_TABLE_SIZE
)
2738 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2739 return 1. Else return 0 and a call to runtime library functions
2740 will have to be built. */
2742 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2747 tree vartmp
[POWI_TABLE_SIZE
];
2749 unsigned HOST_WIDE_INT n
;
2751 wide_int wrhs
= rhs
;
2753 /* If exponent is too large, we won't expand it anyway, so don't bother
2754 with large integer values. */
2755 if (!wi::fits_shwi_p (wrhs
))
2758 m
= wrhs
.to_shwi ();
2759 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2760 of the asymmetric range of the integer type. */
2761 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2763 type
= TREE_TYPE (lhs
);
2764 sgn
= tree_int_cst_sgn (rhs
);
2766 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2767 || optimize_size
) && (m
> 2 || m
< -1))
2773 se
->expr
= gfc_build_const (type
, integer_one_node
);
2777 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2778 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2780 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2781 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2782 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2783 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2786 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2789 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2790 boolean_type_node
, tmp
, cond
);
2791 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2792 tmp
, build_int_cst (type
, 1),
2793 build_int_cst (type
, 0));
2797 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2798 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2799 build_int_cst (type
, -1),
2800 build_int_cst (type
, 0));
2801 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2802 cond
, build_int_cst (type
, 1), tmp
);
2806 memset (vartmp
, 0, sizeof (vartmp
));
2810 tmp
= gfc_build_const (type
, integer_one_node
);
2811 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2815 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2821 /* Power op (**). Constant integer exponent has special handling. */
2824 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2826 tree gfc_int4_type_node
;
2829 int res_ikind_1
, res_ikind_2
;
2834 gfc_init_se (&lse
, se
);
2835 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2836 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2837 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2839 gfc_init_se (&rse
, se
);
2840 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2841 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2843 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2844 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2845 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2848 gfc_int4_type_node
= gfc_get_int_type (4);
2850 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2851 library routine. But in the end, we have to convert the result back
2852 if this case applies -- with res_ikind_K, we keep track whether operand K
2853 falls into this case. */
2857 kind
= expr
->value
.op
.op1
->ts
.kind
;
2858 switch (expr
->value
.op
.op2
->ts
.type
)
2861 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2866 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2867 res_ikind_2
= ikind
;
2889 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2891 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2918 switch (expr
->value
.op
.op1
->ts
.type
)
2921 if (kind
== 3) /* Case 16 was not handled properly above. */
2923 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2927 /* Use builtins for real ** int4. */
2933 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2937 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2941 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2945 /* Use the __builtin_powil() only if real(kind=16) is
2946 actually the C long double type. */
2947 if (!gfc_real16_is_float128
)
2948 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2956 /* If we don't have a good builtin for this, go for the
2957 library function. */
2959 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2963 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2972 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2976 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2984 se
->expr
= build_call_expr_loc (input_location
,
2985 fndecl
, 2, lse
.expr
, rse
.expr
);
2987 /* Convert the result back if it is of wrong integer kind. */
2988 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2990 /* We want the maximum of both operand kinds as result. */
2991 if (res_ikind_1
< res_ikind_2
)
2992 res_ikind_1
= res_ikind_2
;
2993 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2998 /* Generate code to allocate a string temporary. */
3001 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3006 if (gfc_can_put_var_on_stack (len
))
3008 /* Create a temporary variable to hold the result. */
3009 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3010 gfc_charlen_type_node
, len
,
3011 build_int_cst (gfc_charlen_type_node
, 1));
3012 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3014 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3015 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3017 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3019 var
= gfc_create_var (tmp
, "str");
3020 var
= gfc_build_addr_expr (type
, var
);
3024 /* Allocate a temporary to hold the result. */
3025 var
= gfc_create_var (type
, "pstr");
3026 gcc_assert (POINTER_TYPE_P (type
));
3027 tmp
= TREE_TYPE (type
);
3028 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3029 tmp
= TREE_TYPE (tmp
);
3030 tmp
= TYPE_SIZE_UNIT (tmp
);
3031 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3032 fold_convert (size_type_node
, len
),
3033 fold_convert (size_type_node
, tmp
));
3034 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3035 gfc_add_modify (&se
->pre
, var
, tmp
);
3037 /* Free the temporary afterwards. */
3038 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
3039 gfc_add_expr_to_block (&se
->post
, tmp
);
3046 /* Handle a string concatenation operation. A temporary will be allocated to
3050 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3053 tree len
, type
, var
, tmp
, fndecl
;
3055 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3056 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3057 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3059 gfc_init_se (&lse
, se
);
3060 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3061 gfc_conv_string_parameter (&lse
);
3062 gfc_init_se (&rse
, se
);
3063 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3064 gfc_conv_string_parameter (&rse
);
3066 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3067 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3069 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3070 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3071 if (len
== NULL_TREE
)
3073 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3074 TREE_TYPE (lse
.string_length
),
3075 lse
.string_length
, rse
.string_length
);
3078 type
= build_pointer_type (type
);
3080 var
= gfc_conv_string_tmp (se
, type
, len
);
3082 /* Do the actual concatenation. */
3083 if (expr
->ts
.kind
== 1)
3084 fndecl
= gfor_fndecl_concat_string
;
3085 else if (expr
->ts
.kind
== 4)
3086 fndecl
= gfor_fndecl_concat_string_char4
;
3090 tmp
= build_call_expr_loc (input_location
,
3091 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3092 rse
.string_length
, rse
.expr
);
3093 gfc_add_expr_to_block (&se
->pre
, tmp
);
3095 /* Add the cleanup for the operands. */
3096 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3097 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3100 se
->string_length
= len
;
3103 /* Translates an op expression. Common (binary) cases are handled by this
3104 function, others are passed on. Recursion is used in either case.
3105 We use the fact that (op1.ts == op2.ts) (except for the power
3107 Operators need no special handling for scalarized expressions as long as
3108 they call gfc_conv_simple_val to get their operands.
3109 Character strings get special handling. */
3112 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3114 enum tree_code code
;
3123 switch (expr
->value
.op
.op
)
3125 case INTRINSIC_PARENTHESES
:
3126 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3127 && flag_protect_parens
)
3129 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3130 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3135 case INTRINSIC_UPLUS
:
3136 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3139 case INTRINSIC_UMINUS
:
3140 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3144 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3147 case INTRINSIC_PLUS
:
3151 case INTRINSIC_MINUS
:
3155 case INTRINSIC_TIMES
:
3159 case INTRINSIC_DIVIDE
:
3160 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3161 an integer, we must round towards zero, so we use a
3163 if (expr
->ts
.type
== BT_INTEGER
)
3164 code
= TRUNC_DIV_EXPR
;
3169 case INTRINSIC_POWER
:
3170 gfc_conv_power_op (se
, expr
);
3173 case INTRINSIC_CONCAT
:
3174 gfc_conv_concat_op (se
, expr
);
3178 code
= TRUTH_ANDIF_EXPR
;
3183 code
= TRUTH_ORIF_EXPR
;
3187 /* EQV and NEQV only work on logicals, but since we represent them
3188 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3190 case INTRINSIC_EQ_OS
:
3198 case INTRINSIC_NE_OS
:
3199 case INTRINSIC_NEQV
:
3206 case INTRINSIC_GT_OS
:
3213 case INTRINSIC_GE_OS
:
3220 case INTRINSIC_LT_OS
:
3227 case INTRINSIC_LE_OS
:
3233 case INTRINSIC_USER
:
3234 case INTRINSIC_ASSIGN
:
3235 /* These should be converted into function calls by the frontend. */
3239 fatal_error (input_location
, "Unknown intrinsic op");
3243 /* The only exception to this is **, which is handled separately anyway. */
3244 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3246 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3250 gfc_init_se (&lse
, se
);
3251 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3252 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3255 gfc_init_se (&rse
, se
);
3256 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3257 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3261 gfc_conv_string_parameter (&lse
);
3262 gfc_conv_string_parameter (&rse
);
3264 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3265 rse
.string_length
, rse
.expr
,
3266 expr
->value
.op
.op1
->ts
.kind
,
3268 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3269 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3272 type
= gfc_typenode_for_spec (&expr
->ts
);
3276 /* The result of logical ops is always boolean_type_node. */
3277 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3278 lse
.expr
, rse
.expr
);
3279 se
->expr
= convert (type
, tmp
);
3282 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3284 /* Add the post blocks. */
3285 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3286 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3289 /* If a string's length is one, we convert it to a single character. */
3292 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3296 || !tree_fits_uhwi_p (len
)
3297 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3300 if (TREE_INT_CST_LOW (len
) == 1)
3302 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3303 return build_fold_indirect_ref_loc (input_location
, str
);
3307 && TREE_CODE (str
) == ADDR_EXPR
3308 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3309 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3310 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3311 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3312 && TREE_INT_CST_LOW (len
) > 1
3313 && TREE_INT_CST_LOW (len
)
3314 == (unsigned HOST_WIDE_INT
)
3315 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3317 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3318 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3319 if (TREE_CODE (ret
) == INTEGER_CST
)
3321 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3322 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3323 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3325 for (i
= 1; i
< length
; i
++)
3338 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3341 if (sym
->backend_decl
)
3343 /* This becomes the nominal_type in
3344 function.c:assign_parm_find_data_types. */
3345 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3346 /* This becomes the passed_type in
3347 function.c:assign_parm_find_data_types. C promotes char to
3348 integer for argument passing. */
3349 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3351 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3356 /* If we have a constant character expression, make it into an
3358 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3363 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3364 (int)(*expr
)->value
.character
.string
[0]);
3365 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3367 /* The expr needs to be compatible with a C int. If the
3368 conversion fails, then the 2 causes an ICE. */
3369 ts
.type
= BT_INTEGER
;
3370 ts
.kind
= gfc_c_int_kind
;
3371 gfc_convert_type (*expr
, &ts
, 2);
3374 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3376 if ((*expr
)->ref
== NULL
)
3378 se
->expr
= gfc_string_to_single_character
3379 (build_int_cst (integer_type_node
, 1),
3380 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3382 ((*expr
)->symtree
->n
.sym
)),
3387 gfc_conv_variable (se
, *expr
);
3388 se
->expr
= gfc_string_to_single_character
3389 (build_int_cst (integer_type_node
, 1),
3390 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3398 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3399 if STR is a string literal, otherwise return -1. */
3402 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3405 && TREE_CODE (str
) == ADDR_EXPR
3406 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3407 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3408 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3409 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3410 && tree_fits_uhwi_p (len
)
3411 && tree_to_uhwi (len
) >= 1
3412 && tree_to_uhwi (len
)
3413 == (unsigned HOST_WIDE_INT
)
3414 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3416 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3417 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3418 if (TREE_CODE (folded
) == INTEGER_CST
)
3420 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3421 int length
= TREE_STRING_LENGTH (string_cst
);
3422 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3424 for (; length
> 0; length
--)
3425 if (ptr
[length
- 1] != ' ')
3434 /* Helper to build a call to memcmp. */
3437 build_memcmp_call (tree s1
, tree s2
, tree n
)
3441 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3442 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3444 s1
= fold_convert (pvoid_type_node
, s1
);
3446 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3447 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3449 s2
= fold_convert (pvoid_type_node
, s2
);
3451 n
= fold_convert (size_type_node
, n
);
3453 tmp
= build_call_expr_loc (input_location
,
3454 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3457 return fold_convert (integer_type_node
, tmp
);
3460 /* Compare two strings. If they are all single characters, the result is the
3461 subtraction of them. Otherwise, we build a library call. */
3464 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3465 enum tree_code code
)
3471 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3472 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3474 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3475 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3477 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3479 /* Deal with single character specially. */
3480 sc1
= fold_convert (integer_type_node
, sc1
);
3481 sc2
= fold_convert (integer_type_node
, sc2
);
3482 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3486 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3488 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3490 /* If one string is a string literal with LEN_TRIM longer
3491 than the length of the second string, the strings
3493 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3494 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3495 return integer_one_node
;
3496 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3497 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3498 return integer_one_node
;
3501 /* We can compare via memcpy if the strings are known to be equal
3502 in length and they are
3504 - kind=4 and the comparison is for (in)equality. */
3506 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3507 && tree_int_cst_equal (len1
, len2
)
3508 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3513 chartype
= gfc_get_char_type (kind
);
3514 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3515 fold_convert (TREE_TYPE(len1
),
3516 TYPE_SIZE_UNIT(chartype
)),
3518 return build_memcmp_call (str1
, str2
, tmp
);
3521 /* Build a call for the comparison. */
3523 fndecl
= gfor_fndecl_compare_string
;
3525 fndecl
= gfor_fndecl_compare_string_char4
;
3529 return build_call_expr_loc (input_location
, fndecl
, 4,
3530 len1
, str1
, len2
, str2
);
3534 /* Return the backend_decl for a procedure pointer component. */
3537 get_proc_ptr_comp (gfc_expr
*e
)
3543 gfc_init_se (&comp_se
, NULL
);
3544 e2
= gfc_copy_expr (e
);
3545 /* We have to restore the expr type later so that gfc_free_expr frees
3546 the exact same thing that was allocated.
3547 TODO: This is ugly. */
3548 old_type
= e2
->expr_type
;
3549 e2
->expr_type
= EXPR_VARIABLE
;
3550 gfc_conv_expr (&comp_se
, e2
);
3551 e2
->expr_type
= old_type
;
3553 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3557 /* Convert a typebound function reference from a class object. */
3559 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3564 if (TREE_CODE (base_object
) != VAR_DECL
)
3566 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3567 gfc_add_modify (&se
->pre
, var
, base_object
);
3569 se
->expr
= gfc_class_vptr_get (base_object
);
3570 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3572 while (ref
&& ref
->next
)
3574 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3575 if (ref
->u
.c
.sym
->attr
.extension
)
3576 conv_parent_component_references (se
, ref
);
3577 gfc_conv_component_ref (se
, ref
);
3578 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3583 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3587 if (gfc_is_proc_ptr_comp (expr
))
3588 tmp
= get_proc_ptr_comp (expr
);
3589 else if (sym
->attr
.dummy
)
3591 tmp
= gfc_get_symbol_decl (sym
);
3592 if (sym
->attr
.proc_pointer
)
3593 tmp
= build_fold_indirect_ref_loc (input_location
,
3595 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3596 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3600 if (!sym
->backend_decl
)
3601 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3603 TREE_USED (sym
->backend_decl
) = 1;
3605 tmp
= sym
->backend_decl
;
3607 if (sym
->attr
.cray_pointee
)
3609 /* TODO - make the cray pointee a pointer to a procedure,
3610 assign the pointer to it and use it for the call. This
3612 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3613 gfc_get_symbol_decl (sym
->cp_pointer
));
3614 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3617 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3619 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3620 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3627 /* Initialize MAPPING. */
3630 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3632 mapping
->syms
= NULL
;
3633 mapping
->charlens
= NULL
;
3637 /* Free all memory held by MAPPING (but not MAPPING itself). */
3640 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3642 gfc_interface_sym_mapping
*sym
;
3643 gfc_interface_sym_mapping
*nextsym
;
3645 gfc_charlen
*nextcl
;
3647 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3649 nextsym
= sym
->next
;
3650 sym
->new_sym
->n
.sym
->formal
= NULL
;
3651 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3652 gfc_free_expr (sym
->expr
);
3653 free (sym
->new_sym
);
3656 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3659 gfc_free_expr (cl
->length
);
3665 /* Return a copy of gfc_charlen CL. Add the returned structure to
3666 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3668 static gfc_charlen
*
3669 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3672 gfc_charlen
*new_charlen
;
3674 new_charlen
= gfc_get_charlen ();
3675 new_charlen
->next
= mapping
->charlens
;
3676 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3678 mapping
->charlens
= new_charlen
;
3683 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3684 array variable that can be used as the actual argument for dummy
3685 argument SYM. Add any initialization code to BLOCK. PACKED is as
3686 for gfc_get_nodesc_array_type and DATA points to the first element
3687 in the passed array. */
3690 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3691 gfc_packed packed
, tree data
)
3696 type
= gfc_typenode_for_spec (&sym
->ts
);
3697 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3698 !sym
->attr
.target
&& !sym
->attr
.pointer
3699 && !sym
->attr
.proc_pointer
);
3701 var
= gfc_create_var (type
, "ifm");
3702 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3708 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3709 and offset of descriptorless array type TYPE given that it has the same
3710 size as DESC. Add any set-up code to BLOCK. */
3713 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3720 offset
= gfc_index_zero_node
;
3721 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3723 dim
= gfc_rank_cst
[n
];
3724 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3725 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3727 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3728 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3729 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3730 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3732 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3734 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3735 gfc_array_index_type
,
3736 gfc_conv_descriptor_ubound_get (desc
, dim
),
3737 gfc_conv_descriptor_lbound_get (desc
, dim
));
3738 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3739 gfc_array_index_type
,
3740 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3741 tmp
= gfc_evaluate_now (tmp
, block
);
3742 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3744 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3745 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3746 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3747 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3748 gfc_array_index_type
, offset
, tmp
);
3750 offset
= gfc_evaluate_now (offset
, block
);
3751 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3755 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3756 in SE. The caller may still use se->expr and se->string_length after
3757 calling this function. */
3760 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3761 gfc_symbol
* sym
, gfc_se
* se
,
3764 gfc_interface_sym_mapping
*sm
;
3768 gfc_symbol
*new_sym
;
3770 gfc_symtree
*new_symtree
;
3772 /* Create a new symbol to represent the actual argument. */
3773 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3774 new_sym
->ts
= sym
->ts
;
3775 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3776 new_sym
->attr
.referenced
= 1;
3777 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3778 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3779 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3780 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3781 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3782 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3783 new_sym
->attr
.function
= sym
->attr
.function
;
3785 /* Ensure that the interface is available and that
3786 descriptors are passed for array actual arguments. */
3787 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3789 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3790 new_sym
->attr
.always_explicit
3791 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3794 /* Create a fake symtree for it. */
3796 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3797 new_symtree
->n
.sym
= new_sym
;
3798 gcc_assert (new_symtree
== root
);
3800 /* Create a dummy->actual mapping. */
3801 sm
= XCNEW (gfc_interface_sym_mapping
);
3802 sm
->next
= mapping
->syms
;
3804 sm
->new_sym
= new_symtree
;
3805 sm
->expr
= gfc_copy_expr (expr
);
3808 /* Stabilize the argument's value. */
3809 if (!sym
->attr
.function
&& se
)
3810 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3812 if (sym
->ts
.type
== BT_CHARACTER
)
3814 /* Create a copy of the dummy argument's length. */
3815 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3816 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3818 /* If the length is specified as "*", record the length that
3819 the caller is passing. We should use the callee's length
3820 in all other cases. */
3821 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3823 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3824 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3831 /* Use the passed value as-is if the argument is a function. */
3832 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3835 /* If the argument is either a string or a pointer to a string,
3836 convert it to a boundless character type. */
3837 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3839 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3840 tmp
= build_pointer_type (tmp
);
3841 if (sym
->attr
.pointer
)
3842 value
= build_fold_indirect_ref_loc (input_location
,
3846 value
= fold_convert (tmp
, value
);
3849 /* If the argument is a scalar, a pointer to an array or an allocatable,
3851 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3852 value
= build_fold_indirect_ref_loc (input_location
,
3855 /* For character(*), use the actual argument's descriptor. */
3856 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3857 value
= build_fold_indirect_ref_loc (input_location
,
3860 /* If the argument is an array descriptor, use it to determine
3861 information about the actual argument's shape. */
3862 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3863 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3865 /* Get the actual argument's descriptor. */
3866 desc
= build_fold_indirect_ref_loc (input_location
,
3869 /* Create the replacement variable. */
3870 tmp
= gfc_conv_descriptor_data_get (desc
);
3871 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3874 /* Use DESC to work out the upper bounds, strides and offset. */
3875 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3878 /* Otherwise we have a packed array. */
3879 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3880 PACKED_FULL
, se
->expr
);
3882 new_sym
->backend_decl
= value
;
3886 /* Called once all dummy argument mappings have been added to MAPPING,
3887 but before the mapping is used to evaluate expressions. Pre-evaluate
3888 the length of each argument, adding any initialization code to PRE and
3889 any finalization code to POST. */
3892 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3893 stmtblock_t
* pre
, stmtblock_t
* post
)
3895 gfc_interface_sym_mapping
*sym
;
3899 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3900 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3901 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3903 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3904 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3905 gfc_init_se (&se
, NULL
);
3906 gfc_conv_expr (&se
, expr
);
3907 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3908 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3909 gfc_add_block_to_block (pre
, &se
.pre
);
3910 gfc_add_block_to_block (post
, &se
.post
);
3912 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3917 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3921 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3922 gfc_constructor_base base
)
3925 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3927 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3930 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3931 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3932 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3938 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3942 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3947 for (; ref
; ref
= ref
->next
)
3951 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3953 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3954 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3955 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3963 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3964 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3970 /* Convert intrinsic function calls into result expressions. */
3973 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3981 arg1
= expr
->value
.function
.actual
->expr
;
3982 if (expr
->value
.function
.actual
->next
)
3983 arg2
= expr
->value
.function
.actual
->next
->expr
;
3987 sym
= arg1
->symtree
->n
.sym
;
3989 if (sym
->attr
.dummy
)
3994 switch (expr
->value
.function
.isym
->id
)
3997 /* TODO figure out why this condition is necessary. */
3998 if (sym
->attr
.function
3999 && (arg1
->ts
.u
.cl
->length
== NULL
4000 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4001 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4004 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4008 if (!sym
->as
|| sym
->as
->rank
== 0)
4011 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4013 dup
= mpz_get_si (arg2
->value
.integer
);
4018 dup
= sym
->as
->rank
;
4022 for (; d
< dup
; d
++)
4026 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4028 gfc_free_expr (new_expr
);
4032 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4033 gfc_get_int_expr (gfc_default_integer_kind
,
4035 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4037 new_expr
= gfc_multiply (new_expr
, tmp
);
4043 case GFC_ISYM_LBOUND
:
4044 case GFC_ISYM_UBOUND
:
4045 /* TODO These implementations of lbound and ubound do not limit if
4046 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4048 if (!sym
->as
|| sym
->as
->rank
== 0)
4051 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4052 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4054 /* TODO: If the need arises, this could produce an array of
4058 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4060 if (sym
->as
->lower
[d
])
4061 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4065 if (sym
->as
->upper
[d
])
4066 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4074 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4078 gfc_replace_expr (expr
, new_expr
);
4084 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4085 gfc_interface_mapping
* mapping
)
4087 gfc_formal_arglist
*f
;
4088 gfc_actual_arglist
*actual
;
4090 actual
= expr
->value
.function
.actual
;
4091 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4093 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4098 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4101 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4106 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4108 for (d
= 0; d
< as
->rank
; d
++)
4110 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4111 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4114 expr
->value
.function
.esym
->as
= as
;
4117 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4119 expr
->value
.function
.esym
->ts
.u
.cl
->length
4120 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4122 gfc_apply_interface_mapping_to_expr (mapping
,
4123 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4128 /* EXPR is a copy of an expression that appeared in the interface
4129 associated with MAPPING. Walk it recursively looking for references to
4130 dummy arguments that MAPPING maps to actual arguments. Replace each such
4131 reference with a reference to the associated actual argument. */
4134 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4137 gfc_interface_sym_mapping
*sym
;
4138 gfc_actual_arglist
*actual
;
4143 /* Copying an expression does not copy its length, so do that here. */
4144 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4146 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4147 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4150 /* Apply the mapping to any references. */
4151 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4153 /* ...and to the expression's symbol, if it has one. */
4154 /* TODO Find out why the condition on expr->symtree had to be moved into
4155 the loop rather than being outside it, as originally. */
4156 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4157 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4159 if (sym
->new_sym
->n
.sym
->backend_decl
)
4160 expr
->symtree
= sym
->new_sym
;
4162 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4165 /* ...and to subexpressions in expr->value. */
4166 switch (expr
->expr_type
)
4171 case EXPR_SUBSTRING
:
4175 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4176 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4180 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4181 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4183 if (expr
->value
.function
.esym
== NULL
4184 && expr
->value
.function
.isym
!= NULL
4185 && expr
->value
.function
.actual
->expr
->symtree
4186 && gfc_map_intrinsic_function (expr
, mapping
))
4189 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4190 if (sym
->old
== expr
->value
.function
.esym
)
4192 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4193 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4194 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4199 case EXPR_STRUCTURE
:
4200 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4213 /* Evaluate interface expression EXPR using MAPPING. Store the result
4217 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4218 gfc_se
* se
, gfc_expr
* expr
)
4220 expr
= gfc_copy_expr (expr
);
4221 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4222 gfc_conv_expr (se
, expr
);
4223 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4224 gfc_free_expr (expr
);
4228 /* Returns a reference to a temporary array into which a component of
4229 an actual argument derived type array is copied and then returned
4230 after the function call. */
4232 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4233 sym_intent intent
, bool formal_ptr
)
4241 gfc_array_info
*info
;
4251 gfc_init_se (&lse
, NULL
);
4252 gfc_init_se (&rse
, NULL
);
4254 /* Walk the argument expression. */
4255 rss
= gfc_walk_expr (expr
);
4257 gcc_assert (rss
!= gfc_ss_terminator
);
4259 /* Initialize the scalarizer. */
4260 gfc_init_loopinfo (&loop
);
4261 gfc_add_ss_to_loop (&loop
, rss
);
4263 /* Calculate the bounds of the scalarization. */
4264 gfc_conv_ss_startstride (&loop
);
4266 /* Build an ss for the temporary. */
4267 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4268 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4270 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4271 if (GFC_ARRAY_TYPE_P (base_type
)
4272 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4273 base_type
= gfc_get_element_type (base_type
);
4275 if (expr
->ts
.type
== BT_CLASS
)
4276 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4278 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4279 ? expr
->ts
.u
.cl
->backend_decl
4283 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4285 /* Associate the SS with the loop. */
4286 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4288 /* Setup the scalarizing loops. */
4289 gfc_conv_loop_setup (&loop
, &expr
->where
);
4291 /* Pass the temporary descriptor back to the caller. */
4292 info
= &loop
.temp_ss
->info
->data
.array
;
4293 parmse
->expr
= info
->descriptor
;
4295 /* Setup the gfc_se structures. */
4296 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4297 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4300 lse
.ss
= loop
.temp_ss
;
4301 gfc_mark_ss_chain_used (rss
, 1);
4302 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4304 /* Start the scalarized loop body. */
4305 gfc_start_scalarized_body (&loop
, &body
);
4307 /* Translate the expression. */
4308 gfc_conv_expr (&rse
, expr
);
4310 /* Reset the offset for the function call since the loop
4311 is zero based on the data pointer. Note that the temp
4312 comes first in the loop chain since it is added second. */
4313 if (gfc_is_alloc_class_array_function (expr
))
4315 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4316 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4317 gfc_index_zero_node
);
4320 gfc_conv_tmp_array_ref (&lse
);
4322 if (intent
!= INTENT_OUT
)
4324 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
4325 gfc_add_expr_to_block (&body
, tmp
);
4326 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4327 gfc_trans_scalarizing_loops (&loop
, &body
);
4331 /* Make sure that the temporary declaration survives by merging
4332 all the loop declarations into the current context. */
4333 for (n
= 0; n
< loop
.dimen
; n
++)
4335 gfc_merge_block_scope (&body
);
4336 body
= loop
.code
[loop
.order
[n
]];
4338 gfc_merge_block_scope (&body
);
4341 /* Add the post block after the second loop, so that any
4342 freeing of allocated memory is done at the right time. */
4343 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4345 /**********Copy the temporary back again.*********/
4347 gfc_init_se (&lse
, NULL
);
4348 gfc_init_se (&rse
, NULL
);
4350 /* Walk the argument expression. */
4351 lss
= gfc_walk_expr (expr
);
4352 rse
.ss
= loop
.temp_ss
;
4355 /* Initialize the scalarizer. */
4356 gfc_init_loopinfo (&loop2
);
4357 gfc_add_ss_to_loop (&loop2
, lss
);
4359 dimen
= rse
.ss
->dimen
;
4361 /* Skip the write-out loop for this case. */
4362 if (gfc_is_alloc_class_array_function (expr
))
4363 goto class_array_fcn
;
4365 /* Calculate the bounds of the scalarization. */
4366 gfc_conv_ss_startstride (&loop2
);
4368 /* Setup the scalarizing loops. */
4369 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4371 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4372 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4374 gfc_mark_ss_chain_used (lss
, 1);
4375 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4377 /* Declare the variable to hold the temporary offset and start the
4378 scalarized loop body. */
4379 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4380 gfc_start_scalarized_body (&loop2
, &body
);
4382 /* Build the offsets for the temporary from the loop variables. The
4383 temporary array has lbounds of zero and strides of one in all
4384 dimensions, so this is very simple. The offset is only computed
4385 outside the innermost loop, so the overall transfer could be
4386 optimized further. */
4387 info
= &rse
.ss
->info
->data
.array
;
4389 tmp_index
= gfc_index_zero_node
;
4390 for (n
= dimen
- 1; n
> 0; n
--)
4393 tmp
= rse
.loop
->loopvar
[n
];
4394 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4395 tmp
, rse
.loop
->from
[n
]);
4396 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4399 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4400 gfc_array_index_type
,
4401 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4402 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4403 gfc_array_index_type
,
4404 tmp_str
, gfc_index_one_node
);
4406 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4407 gfc_array_index_type
, tmp
, tmp_str
);
4410 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4411 gfc_array_index_type
,
4412 tmp_index
, rse
.loop
->from
[0]);
4413 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4415 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4416 gfc_array_index_type
,
4417 rse
.loop
->loopvar
[0], offset
);
4419 /* Now use the offset for the reference. */
4420 tmp
= build_fold_indirect_ref_loc (input_location
,
4422 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4424 if (expr
->ts
.type
== BT_CHARACTER
)
4425 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4427 gfc_conv_expr (&lse
, expr
);
4429 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4431 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
4432 gfc_add_expr_to_block (&body
, tmp
);
4434 /* Generate the copying loops. */
4435 gfc_trans_scalarizing_loops (&loop2
, &body
);
4437 /* Wrap the whole thing up by adding the second loop to the post-block
4438 and following it by the post-block of the first loop. In this way,
4439 if the temporary needs freeing, it is done after use! */
4440 if (intent
!= INTENT_IN
)
4442 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4443 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4448 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4450 gfc_cleanup_loop (&loop
);
4451 gfc_cleanup_loop (&loop2
);
4453 /* Pass the string length to the argument expression. */
4454 if (expr
->ts
.type
== BT_CHARACTER
)
4455 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4457 /* Determine the offset for pointer formal arguments and set the
4461 size
= gfc_index_one_node
;
4462 offset
= gfc_index_zero_node
;
4463 for (n
= 0; n
< dimen
; n
++)
4465 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4467 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4468 gfc_array_index_type
, tmp
,
4469 gfc_index_one_node
);
4470 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4474 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4477 gfc_index_one_node
);
4478 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4479 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4480 gfc_array_index_type
,
4482 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4483 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4484 gfc_array_index_type
,
4485 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4486 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4487 gfc_array_index_type
,
4488 tmp
, gfc_index_one_node
);
4489 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4490 gfc_array_index_type
, size
, tmp
);
4493 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4497 /* We want either the address for the data or the address of the descriptor,
4498 depending on the mode of passing array arguments. */
4500 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4502 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4508 /* Generate the code for argument list functions. */
4511 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4513 /* Pass by value for g77 %VAL(arg), pass the address
4514 indirectly for %LOC, else by reference. Thus %REF
4515 is a "do-nothing" and %LOC is the same as an F95
4517 if (strncmp (name
, "%VAL", 4) == 0)
4518 gfc_conv_expr (se
, expr
);
4519 else if (strncmp (name
, "%LOC", 4) == 0)
4521 gfc_conv_expr_reference (se
, expr
);
4522 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4524 else if (strncmp (name
, "%REF", 4) == 0)
4525 gfc_conv_expr_reference (se
, expr
);
4527 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4531 /* Generate code for a procedure call. Note can return se->post != NULL.
4532 If se->direct_byref is set then se->expr contains the return parameter.
4533 Return nonzero, if the call has alternate specifiers.
4534 'expr' is only needed for procedure pointer components. */
4537 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4538 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4539 vec
<tree
, va_gc
> *append_args
)
4541 gfc_interface_mapping mapping
;
4542 vec
<tree
, va_gc
> *arglist
;
4543 vec
<tree
, va_gc
> *retargs
;
4547 gfc_array_info
*info
;
4554 vec
<tree
, va_gc
> *stringargs
;
4555 vec
<tree
, va_gc
> *optionalargs
;
4557 gfc_formal_arglist
*formal
;
4558 gfc_actual_arglist
*arg
;
4559 int has_alternate_specifier
= 0;
4560 bool need_interface_mapping
;
4568 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4569 gfc_component
*comp
= NULL
;
4576 optionalargs
= NULL
;
4581 comp
= gfc_get_proc_ptr_comp (expr
);
4585 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4587 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4588 if (se
->ss
->info
->useflags
)
4590 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4591 && sym
->result
->attr
.dimension
)
4592 || (comp
&& comp
->attr
.dimension
)
4593 || gfc_is_alloc_class_array_function (expr
));
4594 gcc_assert (se
->loop
!= NULL
);
4595 /* Access the previously obtained result. */
4596 gfc_conv_tmp_array_ref (se
);
4600 info
= &se
->ss
->info
->data
.array
;
4605 gfc_init_block (&post
);
4606 gfc_init_interface_mapping (&mapping
);
4609 formal
= gfc_sym_get_dummy_args (sym
);
4610 need_interface_mapping
= sym
->attr
.dimension
||
4611 (sym
->ts
.type
== BT_CHARACTER
4612 && sym
->ts
.u
.cl
->length
4613 && sym
->ts
.u
.cl
->length
->expr_type
4618 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4619 need_interface_mapping
= comp
->attr
.dimension
||
4620 (comp
->ts
.type
== BT_CHARACTER
4621 && comp
->ts
.u
.cl
->length
4622 && comp
->ts
.u
.cl
->length
->expr_type
4626 base_object
= NULL_TREE
;
4627 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4628 is the third and fourth argument to such a function call a value
4629 denoting the number of elements to copy (i.e., most of the time the
4630 length of a deferred length string). */
4631 ulim_copy
= formal
== NULL
&& UNLIMITED_POLY (sym
)
4632 && strcmp ("_copy", comp
->name
) == 0;
4634 /* Evaluate the arguments. */
4635 for (arg
= args
, argc
= 0; arg
!= NULL
;
4636 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
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 /* When no fsym is present, ulim_copy is set and this is a third or
4739 fourth argument, use call-by-value instead of by reference to
4740 hand the length properties to the copy routine (i.e., most of the
4741 time this will be a call to a __copy_character_* routine where the
4742 third and fourth arguments are the lengths of a deferred length
4744 if ((fsym
&& fsym
->attr
.value
)
4745 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4746 gfc_conv_expr (&parmse
, e
);
4748 gfc_conv_expr_reference (&parmse
, e
);
4750 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4751 && e
->expr_type
== EXPR_FUNCTION
)
4752 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4755 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4756 && gfc_is_class_container_ref (e
))
4758 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4760 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4761 && e
->symtree
->n
.sym
->attr
.optional
)
4763 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4764 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4765 TREE_TYPE (parmse
.expr
),
4767 fold_convert (TREE_TYPE (parmse
.expr
),
4768 null_pointer_node
));
4772 /* If we are passing an absent array as optional dummy to an
4773 elemental procedure, make sure that we pass NULL when the data
4774 pointer is NULL. We need this extra conditional because of
4775 scalarization which passes arrays elements to the procedure,
4776 ignoring the fact that the array can be absent/unallocated/... */
4777 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4779 tree descriptor_data
;
4781 descriptor_data
= ss
->info
->data
.array
.data
;
4782 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4784 fold_convert (TREE_TYPE (descriptor_data
),
4785 null_pointer_node
));
4787 = fold_build3_loc (input_location
, COND_EXPR
,
4788 TREE_TYPE (parmse
.expr
),
4789 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4790 fold_convert (TREE_TYPE (parmse
.expr
),
4795 /* The scalarizer does not repackage the reference to a class
4796 array - instead it returns a pointer to the data element. */
4797 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4798 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4799 fsym
->attr
.intent
!= INTENT_IN
4800 && (CLASS_DATA (fsym
)->attr
.class_pointer
4801 || CLASS_DATA (fsym
)->attr
.allocatable
),
4803 && e
->expr_type
== EXPR_VARIABLE
4804 && e
->symtree
->n
.sym
->attr
.optional
,
4805 CLASS_DATA (fsym
)->attr
.class_pointer
4806 || CLASS_DATA (fsym
)->attr
.allocatable
);
4813 gfc_init_se (&parmse
, NULL
);
4815 /* Check whether the expression is a scalar or not; we cannot use
4816 e->rank as it can be nonzero for functions arguments. */
4817 argss
= gfc_walk_expr (e
);
4818 scalar
= argss
== gfc_ss_terminator
;
4820 gfc_free_ss_chain (argss
);
4822 /* Special handling for passing scalar polymorphic coarrays;
4823 otherwise one passes "class->_data.data" instead of "&class". */
4824 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4825 && fsym
&& fsym
->ts
.type
== BT_CLASS
4826 && CLASS_DATA (fsym
)->attr
.codimension
4827 && !CLASS_DATA (fsym
)->attr
.dimension
)
4829 gfc_add_class_array_ref (e
);
4830 parmse
.want_coarray
= 1;
4834 /* A scalar or transformational function. */
4837 if (e
->expr_type
== EXPR_VARIABLE
4838 && e
->symtree
->n
.sym
->attr
.cray_pointee
4839 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4841 /* The Cray pointer needs to be converted to a pointer to
4842 a type given by the expression. */
4843 gfc_conv_expr (&parmse
, e
);
4844 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4845 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4846 parmse
.expr
= convert (type
, tmp
);
4848 else if (fsym
&& fsym
->attr
.value
)
4850 if (fsym
->ts
.type
== BT_CHARACTER
4851 && fsym
->ts
.is_c_interop
4852 && fsym
->ns
->proc_name
!= NULL
4853 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4856 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4857 if (parmse
.expr
== NULL
)
4858 gfc_conv_expr (&parmse
, e
);
4862 gfc_conv_expr (&parmse
, e
);
4863 if (fsym
->attr
.optional
4864 && fsym
->ts
.type
!= BT_CLASS
4865 && fsym
->ts
.type
!= BT_DERIVED
)
4867 if (e
->expr_type
!= EXPR_VARIABLE
4868 || !e
->symtree
->n
.sym
->attr
.optional
4870 vec_safe_push (optionalargs
, boolean_true_node
);
4873 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4874 if (!e
->symtree
->n
.sym
->attr
.value
)
4876 = fold_build3_loc (input_location
, COND_EXPR
,
4877 TREE_TYPE (parmse
.expr
),
4879 fold_convert (TREE_TYPE (parmse
.expr
),
4880 integer_zero_node
));
4882 vec_safe_push (optionalargs
, tmp
);
4887 else if (arg
->name
&& arg
->name
[0] == '%')
4888 /* Argument list functions %VAL, %LOC and %REF are signalled
4889 through arg->name. */
4890 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4891 else if ((e
->expr_type
== EXPR_FUNCTION
)
4892 && ((e
->value
.function
.esym
4893 && e
->value
.function
.esym
->result
->attr
.pointer
)
4894 || (!e
->value
.function
.esym
4895 && e
->symtree
->n
.sym
->attr
.pointer
))
4896 && fsym
&& fsym
->attr
.target
)
4898 gfc_conv_expr (&parmse
, e
);
4899 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4901 else if (e
->expr_type
== EXPR_FUNCTION
4902 && e
->symtree
->n
.sym
->result
4903 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4904 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4906 /* Functions returning procedure pointers. */
4907 gfc_conv_expr (&parmse
, e
);
4908 if (fsym
&& fsym
->attr
.proc_pointer
)
4909 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4913 if (e
->ts
.type
== BT_CLASS
&& fsym
4914 && fsym
->ts
.type
== BT_CLASS
4915 && (!CLASS_DATA (fsym
)->as
4916 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4917 && CLASS_DATA (e
)->attr
.codimension
)
4919 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4920 gcc_assert (!CLASS_DATA (fsym
)->as
);
4921 gfc_add_class_array_ref (e
);
4922 parmse
.want_coarray
= 1;
4923 gfc_conv_expr_reference (&parmse
, e
);
4924 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4926 && e
->expr_type
== EXPR_VARIABLE
);
4928 else if (e
->ts
.type
== BT_CLASS
&& fsym
4929 && fsym
->ts
.type
== BT_CLASS
4930 && !CLASS_DATA (fsym
)->as
4931 && !CLASS_DATA (e
)->as
4932 && strcmp (fsym
->ts
.u
.derived
->name
,
4933 e
->ts
.u
.derived
->name
))
4935 type
= gfc_typenode_for_spec (&fsym
->ts
);
4936 var
= gfc_create_var (type
, fsym
->name
);
4937 gfc_conv_expr (&parmse
, e
);
4938 if (fsym
->attr
.optional
4939 && e
->expr_type
== EXPR_VARIABLE
4940 && e
->symtree
->n
.sym
->attr
.optional
)
4944 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4945 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4946 boolean_type_node
, tmp
,
4947 fold_convert (TREE_TYPE (tmp
),
4948 null_pointer_node
));
4949 gfc_start_block (&block
);
4950 gfc_add_modify (&block
, var
,
4951 fold_build1_loc (input_location
,
4953 type
, parmse
.expr
));
4954 gfc_add_expr_to_block (&parmse
.pre
,
4955 fold_build3_loc (input_location
,
4956 COND_EXPR
, void_type_node
,
4957 cond
, gfc_finish_block (&block
),
4958 build_empty_stmt (input_location
)));
4959 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4960 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4961 TREE_TYPE (parmse
.expr
),
4963 fold_convert (TREE_TYPE (parmse
.expr
),
4964 null_pointer_node
));
4968 gfc_add_modify (&parmse
.pre
, var
,
4969 fold_build1_loc (input_location
,
4971 type
, parmse
.expr
));
4972 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4976 gfc_conv_expr_reference (&parmse
, e
);
4978 /* Catch base objects that are not variables. */
4979 if (e
->ts
.type
== BT_CLASS
4980 && e
->expr_type
!= EXPR_VARIABLE
4981 && expr
&& e
== expr
->base_expr
)
4982 base_object
= build_fold_indirect_ref_loc (input_location
,
4985 /* A class array element needs converting back to be a
4986 class object, if the formal argument is a class object. */
4987 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4988 && e
->ts
.type
== BT_CLASS
4989 && ((CLASS_DATA (fsym
)->as
4990 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4991 || CLASS_DATA (e
)->attr
.dimension
))
4992 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4993 fsym
->attr
.intent
!= INTENT_IN
4994 && (CLASS_DATA (fsym
)->attr
.class_pointer
4995 || CLASS_DATA (fsym
)->attr
.allocatable
),
4997 && e
->expr_type
== EXPR_VARIABLE
4998 && e
->symtree
->n
.sym
->attr
.optional
,
4999 CLASS_DATA (fsym
)->attr
.class_pointer
5000 || CLASS_DATA (fsym
)->attr
.allocatable
);
5002 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5003 allocated on entry, it must be deallocated. */
5004 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5005 && (fsym
->attr
.allocatable
5006 || (fsym
->ts
.type
== BT_CLASS
5007 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5012 gfc_init_block (&block
);
5014 if (e
->ts
.type
== BT_CLASS
)
5015 ptr
= gfc_class_data_get (ptr
);
5017 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5019 gfc_add_expr_to_block (&block
, tmp
);
5020 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5021 void_type_node
, ptr
,
5023 gfc_add_expr_to_block (&block
, tmp
);
5025 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5027 gfc_add_modify (&block
, ptr
,
5028 fold_convert (TREE_TYPE (ptr
),
5029 null_pointer_node
));
5030 gfc_add_expr_to_block (&block
, tmp
);
5032 else if (fsym
->ts
.type
== BT_CLASS
)
5035 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5036 tmp
= gfc_get_symbol_decl (vtab
);
5037 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5038 ptr
= gfc_class_vptr_get (parmse
.expr
);
5039 gfc_add_modify (&block
, ptr
,
5040 fold_convert (TREE_TYPE (ptr
), tmp
));
5041 gfc_add_expr_to_block (&block
, tmp
);
5044 if (fsym
->attr
.optional
5045 && e
->expr_type
== EXPR_VARIABLE
5046 && e
->symtree
->n
.sym
->attr
.optional
)
5048 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5050 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5051 gfc_finish_block (&block
),
5052 build_empty_stmt (input_location
));
5055 tmp
= gfc_finish_block (&block
);
5057 gfc_add_expr_to_block (&se
->pre
, tmp
);
5060 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5061 || fsym
->ts
.type
== BT_ASSUMED
)
5062 && e
->ts
.type
== BT_CLASS
5063 && !CLASS_DATA (e
)->attr
.dimension
5064 && !CLASS_DATA (e
)->attr
.codimension
)
5065 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5067 /* Wrap scalar variable in a descriptor. We need to convert
5068 the address of a pointer back to the pointer itself before,
5069 we can assign it to the data field. */
5071 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5072 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5075 if (TREE_CODE (tmp
) == ADDR_EXPR
5076 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5077 tmp
= TREE_OPERAND (tmp
, 0);
5078 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5080 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5083 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5084 && ((fsym
->attr
.pointer
5085 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5086 || (fsym
->attr
.proc_pointer
5087 && !(e
->expr_type
== EXPR_VARIABLE
5088 && e
->symtree
->n
.sym
->attr
.dummy
))
5089 || (fsym
->attr
.proc_pointer
5090 && e
->expr_type
== EXPR_VARIABLE
5091 && gfc_is_proc_ptr_comp (e
))
5092 || (fsym
->attr
.allocatable
5093 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5095 /* Scalar pointer dummy args require an extra level of
5096 indirection. The null pointer already contains
5097 this level of indirection. */
5098 parm_kind
= SCALAR_POINTER
;
5099 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5103 else if (e
->ts
.type
== BT_CLASS
5104 && fsym
&& fsym
->ts
.type
== BT_CLASS
5105 && (CLASS_DATA (fsym
)->attr
.dimension
5106 || CLASS_DATA (fsym
)->attr
.codimension
))
5108 /* Pass a class array. */
5109 parmse
.use_offset
= 1;
5110 gfc_conv_expr_descriptor (&parmse
, e
);
5112 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5113 allocated on entry, it must be deallocated. */
5114 if (fsym
->attr
.intent
== INTENT_OUT
5115 && CLASS_DATA (fsym
)->attr
.allocatable
)
5120 gfc_init_block (&block
);
5122 ptr
= gfc_class_data_get (ptr
);
5124 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5125 NULL_TREE
, NULL_TREE
,
5128 gfc_add_expr_to_block (&block
, tmp
);
5129 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5130 void_type_node
, ptr
,
5132 gfc_add_expr_to_block (&block
, tmp
);
5133 gfc_reset_vptr (&block
, e
);
5135 if (fsym
->attr
.optional
5136 && e
->expr_type
== EXPR_VARIABLE
5138 || (e
->ref
->type
== REF_ARRAY
5139 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5140 && e
->symtree
->n
.sym
->attr
.optional
)
5142 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5144 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5145 gfc_finish_block (&block
),
5146 build_empty_stmt (input_location
));
5149 tmp
= gfc_finish_block (&block
);
5151 gfc_add_expr_to_block (&se
->pre
, tmp
);
5154 /* The conversion does not repackage the reference to a class
5155 array - _data descriptor. */
5156 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5157 fsym
->attr
.intent
!= INTENT_IN
5158 && (CLASS_DATA (fsym
)->attr
.class_pointer
5159 || CLASS_DATA (fsym
)->attr
.allocatable
),
5161 && e
->expr_type
== EXPR_VARIABLE
5162 && e
->symtree
->n
.sym
->attr
.optional
,
5163 CLASS_DATA (fsym
)->attr
.class_pointer
5164 || CLASS_DATA (fsym
)->attr
.allocatable
);
5168 /* If the procedure requires an explicit interface, the actual
5169 argument is passed according to the corresponding formal
5170 argument. If the corresponding formal argument is a POINTER,
5171 ALLOCATABLE or assumed shape, we do not use g77's calling
5172 convention, and pass the address of the array descriptor
5173 instead. Otherwise we use g77's calling convention. */
5176 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
5177 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
5178 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
5180 f
= f
|| !comp
->attr
.always_explicit
;
5182 f
= f
|| !sym
->attr
.always_explicit
;
5184 /* If the argument is a function call that may not create
5185 a temporary for the result, we have to check that we
5186 can do it, i.e. that there is no alias between this
5187 argument and another one. */
5188 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5194 intent
= fsym
->attr
.intent
;
5196 intent
= INTENT_UNKNOWN
;
5198 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5200 parmse
.force_tmp
= 1;
5202 iarg
= e
->value
.function
.actual
->expr
;
5204 /* Temporary needed if aliasing due to host association. */
5205 if (sym
->attr
.contained
5207 && !sym
->attr
.implicit_pure
5208 && !sym
->attr
.use_assoc
5209 && iarg
->expr_type
== EXPR_VARIABLE
5210 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5211 parmse
.force_tmp
= 1;
5213 /* Ditto within module. */
5214 if (sym
->attr
.use_assoc
5216 && !sym
->attr
.implicit_pure
5217 && iarg
->expr_type
== EXPR_VARIABLE
5218 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5219 parmse
.force_tmp
= 1;
5222 if (e
->expr_type
== EXPR_VARIABLE
5223 && is_subref_array (e
))
5224 /* The actual argument is a component reference to an
5225 array of derived types. In this case, the argument
5226 is converted to a temporary, which is passed and then
5227 written back after the procedure call. */
5228 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5229 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5230 fsym
&& fsym
->attr
.pointer
);
5231 else if (gfc_is_class_array_ref (e
, NULL
)
5232 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5233 /* The actual argument is a component reference to an
5234 array of derived types. In this case, the argument
5235 is converted to a temporary, which is passed and then
5236 written back after the procedure call.
5237 OOP-TODO: Insert code so that if the dynamic type is
5238 the same as the declared type, copy-in/copy-out does
5240 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5241 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5242 fsym
&& fsym
->attr
.pointer
);
5244 else if (gfc_is_alloc_class_array_function (e
)
5245 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5246 /* See previous comment. For function actual argument,
5247 the write out is not needed so the intent is set as
5250 e
->must_finalize
= 1;
5251 gfc_conv_subref_array_arg (&parmse
, e
, f
,
5253 fsym
&& fsym
->attr
.pointer
);
5256 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
5258 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5259 allocated on entry, it must be deallocated. */
5260 if (fsym
&& fsym
->attr
.allocatable
5261 && fsym
->attr
.intent
== INTENT_OUT
)
5263 tmp
= build_fold_indirect_ref_loc (input_location
,
5265 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5266 if (fsym
->attr
.optional
5267 && e
->expr_type
== EXPR_VARIABLE
5268 && e
->symtree
->n
.sym
->attr
.optional
)
5269 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5271 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5272 tmp
, build_empty_stmt (input_location
));
5273 gfc_add_expr_to_block (&se
->pre
, tmp
);
5278 /* The case with fsym->attr.optional is that of a user subroutine
5279 with an interface indicating an optional argument. When we call
5280 an intrinsic subroutine, however, fsym is NULL, but we might still
5281 have an optional argument, so we proceed to the substitution
5283 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5285 /* If an optional argument is itself an optional dummy argument,
5286 check its presence and substitute a null if absent. This is
5287 only needed when passing an array to an elemental procedure
5288 as then array elements are accessed - or no NULL pointer is
5289 allowed and a "1" or "0" should be passed if not present.
5290 When passing a non-array-descriptor full array to a
5291 non-array-descriptor dummy, no check is needed. For
5292 array-descriptor actual to array-descriptor dummy, see
5293 PR 41911 for why a check has to be inserted.
5294 fsym == NULL is checked as intrinsics required the descriptor
5295 but do not always set fsym. */
5296 if (e
->expr_type
== EXPR_VARIABLE
5297 && e
->symtree
->n
.sym
->attr
.optional
5298 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
5299 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5303 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5304 || fsym
->as
->type
== AS_ASSUMED_RANK
5305 || fsym
->as
->type
== AS_DEFERRED
))))))
5306 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5307 e
->representation
.length
);
5312 /* Obtain the character length of an assumed character length
5313 length procedure from the typespec. */
5314 if (fsym
->ts
.type
== BT_CHARACTER
5315 && parmse
.string_length
== NULL_TREE
5316 && e
->ts
.type
== BT_PROCEDURE
5317 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5318 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5319 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5321 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5322 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5326 if (fsym
&& need_interface_mapping
&& e
)
5327 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5329 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5330 gfc_add_block_to_block (&post
, &parmse
.post
);
5332 /* Allocated allocatable components of derived types must be
5333 deallocated for non-variable scalars. Non-variable arrays are
5334 dealt with in trans-array.c(gfc_conv_array_parameter). */
5335 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5336 && e
->ts
.u
.derived
->attr
.alloc_comp
5337 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
5338 && e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)
5341 /* It is known the e returns a structure type with at least one
5342 allocatable component. When e is a function, ensure that the
5343 function is called once only by using a temporary variable. */
5344 if (!DECL_P (parmse
.expr
))
5345 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5346 parmse
.expr
, &se
->pre
);
5348 if (fsym
&& fsym
->attr
.value
)
5351 tmp
= build_fold_indirect_ref_loc (input_location
,
5354 parm_rank
= e
->rank
;
5362 case (SCALAR_POINTER
):
5363 tmp
= build_fold_indirect_ref_loc (input_location
,
5368 if (e
->expr_type
== EXPR_OP
5369 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5370 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5373 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5374 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5375 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5378 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5380 /* The derived type is passed to gfc_deallocate_alloc_comp.
5381 Therefore, class actuals can handled correctly but derived
5382 types passed to class formals need the _data component. */
5383 tmp
= gfc_class_data_get (tmp
);
5384 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5385 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5388 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5390 gfc_add_expr_to_block (&se
->post
, tmp
);
5393 /* Add argument checking of passing an unallocated/NULL actual to
5394 a nonallocatable/nonpointer dummy. */
5396 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5398 symbol_attribute attr
;
5402 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5403 attr
= gfc_expr_attr (e
);
5405 goto end_pointer_check
;
5407 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5408 allocatable to an optional dummy, cf. 12.5.2.12. */
5409 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5410 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5411 goto end_pointer_check
;
5415 /* If the actual argument is an optional pointer/allocatable and
5416 the formal argument takes an nonpointer optional value,
5417 it is invalid to pass a non-present argument on, even
5418 though there is no technical reason for this in gfortran.
5419 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5420 tree present
, null_ptr
, type
;
5422 if (attr
.allocatable
5423 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5424 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5425 "allocated or not present",
5426 e
->symtree
->n
.sym
->name
);
5427 else if (attr
.pointer
5428 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5429 msg
= xasprintf ("Pointer actual argument '%s' is not "
5430 "associated or not present",
5431 e
->symtree
->n
.sym
->name
);
5432 else if (attr
.proc_pointer
5433 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5434 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5435 "associated or not present",
5436 e
->symtree
->n
.sym
->name
);
5438 goto end_pointer_check
;
5440 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5441 type
= TREE_TYPE (present
);
5442 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5443 boolean_type_node
, present
,
5445 null_pointer_node
));
5446 type
= TREE_TYPE (parmse
.expr
);
5447 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5448 boolean_type_node
, parmse
.expr
,
5450 null_pointer_node
));
5451 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5452 boolean_type_node
, present
, null_ptr
);
5456 if (attr
.allocatable
5457 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5458 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5459 "allocated", e
->symtree
->n
.sym
->name
);
5460 else if (attr
.pointer
5461 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5462 msg
= xasprintf ("Pointer actual argument '%s' is not "
5463 "associated", e
->symtree
->n
.sym
->name
);
5464 else if (attr
.proc_pointer
5465 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5466 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5467 "associated", e
->symtree
->n
.sym
->name
);
5469 goto end_pointer_check
;
5473 /* If the argument is passed by value, we need to strip the
5475 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5476 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5478 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5479 boolean_type_node
, tmp
,
5480 fold_convert (TREE_TYPE (tmp
),
5481 null_pointer_node
));
5484 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5490 /* Deferred length dummies pass the character length by reference
5491 so that the value can be returned. */
5492 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5494 if (INDIRECT_REF_P (parmse
.string_length
))
5495 /* In chains of functions/procedure calls the string_length already
5496 is a pointer to the variable holding the length. Therefore
5497 remove the deref on call. */
5498 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5501 tmp
= parmse
.string_length
;
5502 if (TREE_CODE (tmp
) != VAR_DECL
)
5503 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5504 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5508 /* Character strings are passed as two parameters, a length and a
5509 pointer - except for Bind(c) which only passes the pointer.
5510 An unlimited polymorphic formal argument likewise does not
5512 if (parmse
.string_length
!= NULL_TREE
5513 && !sym
->attr
.is_bind_c
5514 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5515 vec_safe_push (stringargs
, parmse
.string_length
);
5517 /* When calling __copy for character expressions to unlimited
5518 polymorphic entities, the dst argument needs a string length. */
5519 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5520 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5521 && arg
->next
&& arg
->next
->expr
5522 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5523 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5524 vec_safe_push (stringargs
, parmse
.string_length
);
5526 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5527 pass the token and the offset as additional arguments. */
5528 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5529 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5530 && !fsym
->attr
.allocatable
)
5531 || (fsym
->ts
.type
== BT_CLASS
5532 && CLASS_DATA (fsym
)->attr
.codimension
5533 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5535 /* Token and offset. */
5536 vec_safe_push (stringargs
, null_pointer_node
);
5537 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5538 gcc_assert (fsym
->attr
.optional
);
5540 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5541 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5542 && !fsym
->attr
.allocatable
)
5543 || (fsym
->ts
.type
== BT_CLASS
5544 && CLASS_DATA (fsym
)->attr
.codimension
5545 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5547 tree caf_decl
, caf_type
;
5550 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5551 caf_type
= TREE_TYPE (caf_decl
);
5553 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5554 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5555 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5556 tmp
= gfc_conv_descriptor_token (caf_decl
);
5557 else if (DECL_LANG_SPECIFIC (caf_decl
)
5558 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5559 tmp
= GFC_DECL_TOKEN (caf_decl
);
5562 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5563 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5564 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5567 vec_safe_push (stringargs
, tmp
);
5569 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5570 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5571 offset
= build_int_cst (gfc_array_index_type
, 0);
5572 else if (DECL_LANG_SPECIFIC (caf_decl
)
5573 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5574 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5575 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5576 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5578 offset
= build_int_cst (gfc_array_index_type
, 0);
5580 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5581 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5584 gcc_assert (POINTER_TYPE_P (caf_type
));
5588 tmp2
= fsym
->ts
.type
== BT_CLASS
5589 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5590 if ((fsym
->ts
.type
!= BT_CLASS
5591 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5592 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5593 || (fsym
->ts
.type
== BT_CLASS
5594 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5595 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5597 if (fsym
->ts
.type
== BT_CLASS
)
5598 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5601 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5602 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5604 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5605 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5607 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5608 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5611 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5614 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5615 gfc_array_index_type
,
5616 fold_convert (gfc_array_index_type
, tmp2
),
5617 fold_convert (gfc_array_index_type
, tmp
));
5618 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5619 gfc_array_index_type
, offset
, tmp
);
5621 vec_safe_push (stringargs
, offset
);
5624 vec_safe_push (arglist
, parmse
.expr
);
5626 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5633 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5634 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5635 else if (ts
.type
== BT_CHARACTER
)
5637 if (ts
.u
.cl
->length
== NULL
)
5639 /* Assumed character length results are not allowed by 5.1.1.5 of the
5640 standard and are trapped in resolve.c; except in the case of SPREAD
5641 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5642 we take the character length of the first argument for the result.
5643 For dummies, we have to look through the formal argument list for
5644 this function and use the character length found there.*/
5646 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5647 else if (!sym
->attr
.dummy
)
5648 cl
.backend_decl
= (*stringargs
)[0];
5651 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5652 for (; formal
; formal
= formal
->next
)
5653 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5654 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5656 len
= cl
.backend_decl
;
5662 /* Calculate the length of the returned string. */
5663 gfc_init_se (&parmse
, NULL
);
5664 if (need_interface_mapping
)
5665 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5667 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5668 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5669 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5671 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5672 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5673 gfc_charlen_type_node
, tmp
,
5674 build_int_cst (gfc_charlen_type_node
, 0));
5675 cl
.backend_decl
= tmp
;
5678 /* Set up a charlen structure for it. */
5683 len
= cl
.backend_decl
;
5686 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5687 || (!comp
&& gfc_return_by_reference (sym
));
5690 if (se
->direct_byref
)
5692 /* Sometimes, too much indirection can be applied; e.g. for
5693 function_result = array_valued_recursive_function. */
5694 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5695 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5696 && GFC_DESCRIPTOR_TYPE_P
5697 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5698 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5701 /* If the lhs of an assignment x = f(..) is allocatable and
5702 f2003 is allowed, we must do the automatic reallocation.
5703 TODO - deal with intrinsics, without using a temporary. */
5704 if (flag_realloc_lhs
5705 && se
->ss
&& se
->ss
->loop_chain
5706 && se
->ss
->loop_chain
->is_alloc_lhs
5707 && !expr
->value
.function
.isym
5708 && sym
->result
->as
!= NULL
)
5710 /* Evaluate the bounds of the result, if known. */
5711 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5714 /* Perform the automatic reallocation. */
5715 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5717 gfc_add_expr_to_block (&se
->pre
, tmp
);
5719 /* Pass the temporary as the first argument. */
5720 result
= info
->descriptor
;
5723 result
= build_fold_indirect_ref_loc (input_location
,
5725 vec_safe_push (retargs
, se
->expr
);
5727 else if (comp
&& comp
->attr
.dimension
)
5729 gcc_assert (se
->loop
&& info
);
5731 /* Set the type of the array. */
5732 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5733 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5735 /* Evaluate the bounds of the result, if known. */
5736 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5738 /* If the lhs of an assignment x = f(..) is allocatable and
5739 f2003 is allowed, we must not generate the function call
5740 here but should just send back the results of the mapping.
5741 This is signalled by the function ss being flagged. */
5742 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5744 gfc_free_interface_mapping (&mapping
);
5745 return has_alternate_specifier
;
5748 /* Create a temporary to store the result. In case the function
5749 returns a pointer, the temporary will be a shallow copy and
5750 mustn't be deallocated. */
5751 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5752 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5753 tmp
, NULL_TREE
, false,
5754 !comp
->attr
.pointer
, callee_alloc
,
5755 &se
->ss
->info
->expr
->where
);
5757 /* Pass the temporary as the first argument. */
5758 result
= info
->descriptor
;
5759 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5760 vec_safe_push (retargs
, tmp
);
5762 else if (!comp
&& sym
->result
->attr
.dimension
)
5764 gcc_assert (se
->loop
&& info
);
5766 /* Set the type of the array. */
5767 tmp
= gfc_typenode_for_spec (&ts
);
5768 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5770 /* Evaluate the bounds of the result, if known. */
5771 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5773 /* If the lhs of an assignment x = f(..) is allocatable and
5774 f2003 is allowed, we must not generate the function call
5775 here but should just send back the results of the mapping.
5776 This is signalled by the function ss being flagged. */
5777 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5779 gfc_free_interface_mapping (&mapping
);
5780 return has_alternate_specifier
;
5783 /* Create a temporary to store the result. In case the function
5784 returns a pointer, the temporary will be a shallow copy and
5785 mustn't be deallocated. */
5786 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5787 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5788 tmp
, NULL_TREE
, false,
5789 !sym
->attr
.pointer
, callee_alloc
,
5790 &se
->ss
->info
->expr
->where
);
5792 /* Pass the temporary as the first argument. */
5793 result
= info
->descriptor
;
5794 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5795 vec_safe_push (retargs
, tmp
);
5797 else if (ts
.type
== BT_CHARACTER
)
5799 /* Pass the string length. */
5800 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5801 type
= build_pointer_type (type
);
5803 /* Return an address to a char[0:len-1]* temporary for
5804 character pointers. */
5805 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5806 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5808 var
= gfc_create_var (type
, "pstr");
5810 if ((!comp
&& sym
->attr
.allocatable
)
5811 || (comp
&& comp
->attr
.allocatable
))
5813 gfc_add_modify (&se
->pre
, var
,
5814 fold_convert (TREE_TYPE (var
),
5815 null_pointer_node
));
5816 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5817 gfc_add_expr_to_block (&se
->post
, tmp
);
5820 /* Provide an address expression for the function arguments. */
5821 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5824 var
= gfc_conv_string_tmp (se
, type
, len
);
5826 vec_safe_push (retargs
, var
);
5830 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5832 type
= gfc_get_complex_type (ts
.kind
);
5833 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5834 vec_safe_push (retargs
, var
);
5837 /* Add the string length to the argument list. */
5838 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5841 if (TREE_CODE (tmp
) != VAR_DECL
)
5842 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5843 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5844 vec_safe_push (retargs
, tmp
);
5846 else if (ts
.type
== BT_CHARACTER
)
5847 vec_safe_push (retargs
, len
);
5849 gfc_free_interface_mapping (&mapping
);
5851 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5852 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5853 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5854 vec_safe_reserve (retargs
, arglen
);
5856 /* Add the return arguments. */
5857 retargs
->splice (arglist
);
5859 /* Add the hidden present status for optional+value to the arguments. */
5860 retargs
->splice (optionalargs
);
5862 /* Add the hidden string length parameters to the arguments. */
5863 retargs
->splice (stringargs
);
5865 /* We may want to append extra arguments here. This is used e.g. for
5866 calls to libgfortran_matmul_??, which need extra information. */
5867 if (!vec_safe_is_empty (append_args
))
5868 retargs
->splice (append_args
);
5871 /* Generate the actual call. */
5872 if (base_object
== NULL_TREE
)
5873 conv_function_val (se
, sym
, expr
);
5875 conv_base_obj_fcn_val (se
, base_object
, expr
);
5877 /* If there are alternate return labels, function type should be
5878 integer. Can't modify the type in place though, since it can be shared
5879 with other functions. For dummy arguments, the typing is done to
5880 this result, even if it has to be repeated for each call. */
5881 if (has_alternate_specifier
5882 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5884 if (!sym
->attr
.dummy
)
5886 TREE_TYPE (sym
->backend_decl
)
5887 = build_function_type (integer_type_node
,
5888 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5889 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5892 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5895 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5896 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5898 /* Allocatable scalar function results must be freed and nullified
5899 after use. This necessitates the creation of a temporary to
5900 hold the result to prevent duplicate calls. */
5901 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
5902 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
5904 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5905 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
5907 tmp
= gfc_call_free (tmp
);
5908 gfc_add_expr_to_block (&post
, tmp
);
5909 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
5912 /* If we have a pointer function, but we don't want a pointer, e.g.
5915 where f is pointer valued, we have to dereference the result. */
5916 if (!se
->want_pointer
&& !byref
5917 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5918 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5919 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5921 /* f2c calling conventions require a scalar default real function to
5922 return a double precision result. Convert this back to default
5923 real. We only care about the cases that can happen in Fortran 77.
5925 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5926 && sym
->ts
.kind
== gfc_default_real_kind
5927 && !sym
->attr
.always_explicit
)
5928 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5930 /* A pure function may still have side-effects - it may modify its
5932 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5934 if (!sym
->attr
.pure
)
5935 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5940 /* Add the function call to the pre chain. There is no expression. */
5941 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5942 se
->expr
= NULL_TREE
;
5944 if (!se
->direct_byref
)
5946 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5948 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5950 /* Check the data pointer hasn't been modified. This would
5951 happen in a function returning a pointer. */
5952 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5953 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5956 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5959 se
->expr
= info
->descriptor
;
5960 /* Bundle in the string length. */
5961 se
->string_length
= len
;
5963 else if (ts
.type
== BT_CHARACTER
)
5965 /* Dereference for character pointer results. */
5966 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5967 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5968 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5972 se
->string_length
= len
;
5976 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5977 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5982 /* Follow the function call with the argument post block. */
5985 gfc_add_block_to_block (&se
->pre
, &post
);
5987 /* Transformational functions of derived types with allocatable
5988 components must have the result allocatable components copied. */
5989 arg
= expr
->value
.function
.actual
;
5990 if (result
&& arg
&& expr
->rank
5991 && expr
->value
.function
.isym
5992 && expr
->value
.function
.isym
->transformational
5993 && arg
->expr
->ts
.type
== BT_DERIVED
5994 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5997 /* Copy the allocatable components. We have to use a
5998 temporary here to prevent source allocatable components
5999 from being corrupted. */
6000 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6001 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6002 result
, tmp2
, expr
->rank
);
6003 gfc_add_expr_to_block (&se
->pre
, tmp
);
6004 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6006 gfc_add_expr_to_block (&se
->pre
, tmp
);
6008 /* Finally free the temporary's data field. */
6009 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6010 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6011 NULL_TREE
, NULL_TREE
, true,
6013 gfc_add_expr_to_block (&se
->pre
, tmp
);
6018 /* For a function with a class array result, save the result as
6019 a temporary, set the info fields needed by the scalarizer and
6020 call the finalization function of the temporary. Note that the
6021 nullification of allocatable components needed by the result
6022 is done in gfc_trans_assignment_1. */
6023 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6024 && se
->ss
&& se
->ss
->loop
)
6025 || gfc_is_alloc_class_scalar_function (expr
))
6026 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6027 && expr
->must_finalize
)
6032 if (se
->ss
&& se
->ss
->loop
)
6034 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6035 tmp
= gfc_class_data_get (se
->expr
);
6036 info
->descriptor
= tmp
;
6037 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6038 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6039 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6041 tree dim
= gfc_rank_cst
[n
];
6042 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6043 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6048 /* TODO Eliminate the doubling of temporaries. This
6049 one is necessary to ensure no memory leakage. */
6050 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6051 tmp
= gfc_class_data_get (se
->expr
);
6052 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6053 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6056 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6057 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6060 fold_convert (TREE_TYPE (final_fndecl
),
6061 null_pointer_node
));
6062 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6064 tmp
= build_call_expr_loc (input_location
,
6066 gfc_build_addr_expr (NULL
, tmp
),
6067 gfc_class_vtab_size_get (se
->expr
),
6068 boolean_false_node
);
6069 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6070 void_type_node
, is_final
, tmp
,
6071 build_empty_stmt (input_location
));
6073 if (se
->ss
&& se
->ss
->loop
)
6075 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6076 tmp
= gfc_call_free (convert (pvoid_type_node
, info
->data
));
6077 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6081 gfc_add_expr_to_block (&se
->post
, tmp
);
6082 tmp
= gfc_class_data_get (se
->expr
);
6083 tmp
= gfc_call_free (convert (pvoid_type_node
, tmp
));
6084 gfc_add_expr_to_block (&se
->post
, tmp
);
6086 expr
->must_finalize
= 0;
6089 gfc_add_block_to_block (&se
->post
, &post
);
6092 return has_alternate_specifier
;
6096 /* Fill a character string with spaces. */
6099 fill_with_spaces (tree start
, tree type
, tree size
)
6101 stmtblock_t block
, loop
;
6102 tree i
, el
, exit_label
, cond
, tmp
;
6104 /* For a simple char type, we can call memset(). */
6105 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6106 return build_call_expr_loc (input_location
,
6107 builtin_decl_explicit (BUILT_IN_MEMSET
),
6109 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6110 lang_hooks
.to_target_charset (' ')),
6113 /* Otherwise, we use a loop:
6114 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6118 /* Initialize variables. */
6119 gfc_init_block (&block
);
6120 i
= gfc_create_var (sizetype
, "i");
6121 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6122 el
= gfc_create_var (build_pointer_type (type
), "el");
6123 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6124 exit_label
= gfc_build_label_decl (NULL_TREE
);
6125 TREE_USED (exit_label
) = 1;
6129 gfc_init_block (&loop
);
6131 /* Exit condition. */
6132 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6133 build_zero_cst (sizetype
));
6134 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6135 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6136 build_empty_stmt (input_location
));
6137 gfc_add_expr_to_block (&loop
, tmp
);
6140 gfc_add_modify (&loop
,
6141 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6142 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6144 /* Increment loop variables. */
6145 gfc_add_modify (&loop
, i
,
6146 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6147 TYPE_SIZE_UNIT (type
)));
6148 gfc_add_modify (&loop
, el
,
6149 fold_build_pointer_plus_loc (input_location
,
6150 el
, TYPE_SIZE_UNIT (type
)));
6152 /* Making the loop... actually loop! */
6153 tmp
= gfc_finish_block (&loop
);
6154 tmp
= build1_v (LOOP_EXPR
, tmp
);
6155 gfc_add_expr_to_block (&block
, tmp
);
6157 /* The exit label. */
6158 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6159 gfc_add_expr_to_block (&block
, tmp
);
6162 return gfc_finish_block (&block
);
6166 /* Generate code to copy a string. */
6169 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6170 int dkind
, tree slength
, tree src
, int skind
)
6172 tree tmp
, dlen
, slen
;
6181 stmtblock_t tempblock
;
6183 gcc_assert (dkind
== skind
);
6185 if (slength
!= NULL_TREE
)
6187 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6188 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6192 slen
= build_int_cst (size_type_node
, 1);
6196 if (dlength
!= NULL_TREE
)
6198 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6199 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6203 dlen
= build_int_cst (size_type_node
, 1);
6207 /* Assign directly if the types are compatible. */
6208 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6209 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6211 gfc_add_modify (block
, dsc
, ssc
);
6215 /* Do nothing if the destination length is zero. */
6216 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6217 build_int_cst (size_type_node
, 0));
6219 /* The following code was previously in _gfortran_copy_string:
6221 // The two strings may overlap so we use memmove.
6223 copy_string (GFC_INTEGER_4 destlen, char * dest,
6224 GFC_INTEGER_4 srclen, const char * src)
6226 if (srclen >= destlen)
6228 // This will truncate if too long.
6229 memmove (dest, src, destlen);
6233 memmove (dest, src, srclen);
6235 memset (&dest[srclen], ' ', destlen - srclen);
6239 We're now doing it here for better optimization, but the logic
6242 /* For non-default character kinds, we have to multiply the string
6243 length by the base type size. */
6244 chartype
= gfc_get_char_type (dkind
);
6245 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6246 fold_convert (size_type_node
, slen
),
6247 fold_convert (size_type_node
,
6248 TYPE_SIZE_UNIT (chartype
)));
6249 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6250 fold_convert (size_type_node
, dlen
),
6251 fold_convert (size_type_node
,
6252 TYPE_SIZE_UNIT (chartype
)));
6254 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6255 dest
= fold_convert (pvoid_type_node
, dest
);
6257 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6259 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6260 src
= fold_convert (pvoid_type_node
, src
);
6262 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6264 /* Truncate string if source is too long. */
6265 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6267 tmp2
= build_call_expr_loc (input_location
,
6268 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6269 3, dest
, src
, dlen
);
6271 /* Else copy and pad with spaces. */
6272 tmp3
= build_call_expr_loc (input_location
,
6273 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6274 3, dest
, src
, slen
);
6276 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6277 tmp4
= fill_with_spaces (tmp4
, chartype
,
6278 fold_build2_loc (input_location
, MINUS_EXPR
,
6279 TREE_TYPE(dlen
), dlen
, slen
));
6281 gfc_init_block (&tempblock
);
6282 gfc_add_expr_to_block (&tempblock
, tmp3
);
6283 gfc_add_expr_to_block (&tempblock
, tmp4
);
6284 tmp3
= gfc_finish_block (&tempblock
);
6286 /* The whole copy_string function is there. */
6287 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6289 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6290 build_empty_stmt (input_location
));
6291 gfc_add_expr_to_block (block
, tmp
);
6295 /* Translate a statement function.
6296 The value of a statement function reference is obtained by evaluating the
6297 expression using the values of the actual arguments for the values of the
6298 corresponding dummy arguments. */
6301 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6305 gfc_formal_arglist
*fargs
;
6306 gfc_actual_arglist
*args
;
6309 gfc_saved_var
*saved_vars
;
6315 sym
= expr
->symtree
->n
.sym
;
6316 args
= expr
->value
.function
.actual
;
6317 gfc_init_se (&lse
, NULL
);
6318 gfc_init_se (&rse
, NULL
);
6321 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6323 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6324 temp_vars
= XCNEWVEC (tree
, n
);
6326 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6327 fargs
= fargs
->next
, n
++)
6329 /* Each dummy shall be specified, explicitly or implicitly, to be
6331 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6334 if (fsym
->ts
.type
== BT_CHARACTER
)
6336 /* Copy string arguments. */
6339 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6340 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6342 /* Create a temporary to hold the value. */
6343 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6344 fsym
->ts
.u
.cl
->backend_decl
6345 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6347 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6348 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6350 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6352 gfc_conv_expr (&rse
, args
->expr
);
6353 gfc_conv_string_parameter (&rse
);
6354 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6355 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6357 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6358 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6359 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6360 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6364 /* For everything else, just evaluate the expression. */
6366 /* Create a temporary to hold the value. */
6367 type
= gfc_typenode_for_spec (&fsym
->ts
);
6368 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6370 gfc_conv_expr (&lse
, args
->expr
);
6372 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6373 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6374 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6380 /* Use the temporary variables in place of the real ones. */
6381 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6382 fargs
= fargs
->next
, n
++)
6383 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6385 gfc_conv_expr (se
, sym
->value
);
6387 if (sym
->ts
.type
== BT_CHARACTER
)
6389 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6391 /* Force the expression to the correct length. */
6392 if (!INTEGER_CST_P (se
->string_length
)
6393 || tree_int_cst_lt (se
->string_length
,
6394 sym
->ts
.u
.cl
->backend_decl
))
6396 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6397 tmp
= gfc_create_var (type
, sym
->name
);
6398 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6399 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6400 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6404 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6407 /* Restore the original variables. */
6408 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6409 fargs
= fargs
->next
, n
++)
6410 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6416 /* Translate a function expression. */
6419 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6423 if (expr
->value
.function
.isym
)
6425 gfc_conv_intrinsic_function (se
, expr
);
6429 /* expr.value.function.esym is the resolved (specific) function symbol for
6430 most functions. However this isn't set for dummy procedures. */
6431 sym
= expr
->value
.function
.esym
;
6433 sym
= expr
->symtree
->n
.sym
;
6435 /* The IEEE_ARITHMETIC functions are caught here. */
6436 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6437 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6440 /* We distinguish statement functions from general functions to improve
6441 runtime performance. */
6442 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6444 gfc_conv_statement_function (se
, expr
);
6448 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6453 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6456 is_zero_initializer_p (gfc_expr
* expr
)
6458 if (expr
->expr_type
!= EXPR_CONSTANT
)
6461 /* We ignore constants with prescribed memory representations for now. */
6462 if (expr
->representation
.string
)
6465 switch (expr
->ts
.type
)
6468 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6471 return mpfr_zero_p (expr
->value
.real
)
6472 && MPFR_SIGN (expr
->value
.real
) >= 0;
6475 return expr
->value
.logical
== 0;
6478 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6479 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6480 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6481 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6491 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6496 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6497 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6499 gfc_conv_tmp_array_ref (se
);
6503 /* Build a static initializer. EXPR is the expression for the initial value.
6504 The other parameters describe the variable of the component being
6505 initialized. EXPR may be null. */
6508 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6509 bool array
, bool pointer
, bool procptr
)
6513 if (!(expr
|| pointer
|| procptr
))
6516 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6517 (these are the only two iso_c_binding derived types that can be
6518 used as initialization expressions). If so, we need to modify
6519 the 'expr' to be that for a (void *). */
6520 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6521 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6523 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6525 /* The derived symbol has already been converted to a (void *). Use
6527 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6528 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6530 gfc_init_se (&se
, NULL
);
6531 gfc_conv_constant (&se
, expr
);
6532 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6536 if (array
&& !procptr
)
6539 /* Arrays need special handling. */
6541 ctor
= gfc_build_null_descriptor (type
);
6542 /* Special case assigning an array to zero. */
6543 else if (is_zero_initializer_p (expr
))
6544 ctor
= build_constructor (type
, NULL
);
6546 ctor
= gfc_conv_array_initializer (type
, expr
);
6547 TREE_STATIC (ctor
) = 1;
6550 else if (pointer
|| procptr
)
6552 if (ts
->type
== BT_CLASS
&& !procptr
)
6554 gfc_init_se (&se
, NULL
);
6555 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6556 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6557 TREE_STATIC (se
.expr
) = 1;
6560 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6561 return fold_convert (type
, null_pointer_node
);
6564 gfc_init_se (&se
, NULL
);
6565 se
.want_pointer
= 1;
6566 gfc_conv_expr (&se
, expr
);
6567 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6577 gfc_init_se (&se
, NULL
);
6578 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6579 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6581 gfc_conv_structure (&se
, expr
, 1);
6582 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6583 TREE_STATIC (se
.expr
) = 1;
6588 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6589 TREE_STATIC (ctor
) = 1;
6594 gfc_init_se (&se
, NULL
);
6595 gfc_conv_constant (&se
, expr
);
6596 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6603 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6609 gfc_array_info
*lss_array
;
6616 gfc_start_block (&block
);
6618 /* Initialize the scalarizer. */
6619 gfc_init_loopinfo (&loop
);
6621 gfc_init_se (&lse
, NULL
);
6622 gfc_init_se (&rse
, NULL
);
6625 rss
= gfc_walk_expr (expr
);
6626 if (rss
== gfc_ss_terminator
)
6627 /* The rhs is scalar. Add a ss for the expression. */
6628 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6630 /* Create a SS for the destination. */
6631 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6633 lss_array
= &lss
->info
->data
.array
;
6634 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6635 lss_array
->descriptor
= dest
;
6636 lss_array
->data
= gfc_conv_array_data (dest
);
6637 lss_array
->offset
= gfc_conv_array_offset (dest
);
6638 for (n
= 0; n
< cm
->as
->rank
; n
++)
6640 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6641 lss_array
->stride
[n
] = gfc_index_one_node
;
6643 mpz_init (lss_array
->shape
[n
]);
6644 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6645 cm
->as
->lower
[n
]->value
.integer
);
6646 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6649 /* Associate the SS with the loop. */
6650 gfc_add_ss_to_loop (&loop
, lss
);
6651 gfc_add_ss_to_loop (&loop
, rss
);
6653 /* Calculate the bounds of the scalarization. */
6654 gfc_conv_ss_startstride (&loop
);
6656 /* Setup the scalarizing loops. */
6657 gfc_conv_loop_setup (&loop
, &expr
->where
);
6659 /* Setup the gfc_se structures. */
6660 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6661 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6664 gfc_mark_ss_chain_used (rss
, 1);
6666 gfc_mark_ss_chain_used (lss
, 1);
6668 /* Start the scalarized loop body. */
6669 gfc_start_scalarized_body (&loop
, &body
);
6671 gfc_conv_tmp_array_ref (&lse
);
6672 if (cm
->ts
.type
== BT_CHARACTER
)
6673 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6675 gfc_conv_expr (&rse
, expr
);
6677 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6678 gfc_add_expr_to_block (&body
, tmp
);
6680 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6682 /* Generate the copying loops. */
6683 gfc_trans_scalarizing_loops (&loop
, &body
);
6685 /* Wrap the whole thing up. */
6686 gfc_add_block_to_block (&block
, &loop
.pre
);
6687 gfc_add_block_to_block (&block
, &loop
.post
);
6689 gcc_assert (lss_array
->shape
!= NULL
);
6690 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6691 gfc_cleanup_loop (&loop
);
6693 return gfc_finish_block (&block
);
6698 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6708 gfc_expr
*arg
= NULL
;
6710 gfc_start_block (&block
);
6711 gfc_init_se (&se
, NULL
);
6713 /* Get the descriptor for the expressions. */
6714 se
.want_pointer
= 0;
6715 gfc_conv_expr_descriptor (&se
, expr
);
6716 gfc_add_block_to_block (&block
, &se
.pre
);
6717 gfc_add_modify (&block
, dest
, se
.expr
);
6719 /* Deal with arrays of derived types with allocatable components. */
6720 if (cm
->ts
.type
== BT_DERIVED
6721 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6722 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6725 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6726 && CLASS_DATA(cm
)->attr
.allocatable
)
6728 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6729 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6734 tmp
= TREE_TYPE (dest
);
6735 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6736 tmp
, expr
->rank
, NULL_TREE
);
6740 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6741 TREE_TYPE(cm
->backend_decl
),
6742 cm
->as
->rank
, NULL_TREE
);
6744 gfc_add_expr_to_block (&block
, tmp
);
6745 gfc_add_block_to_block (&block
, &se
.post
);
6747 if (expr
->expr_type
!= EXPR_VARIABLE
)
6748 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6751 /* We need to know if the argument of a conversion function is a
6752 variable, so that the correct lower bound can be used. */
6753 if (expr
->expr_type
== EXPR_FUNCTION
6754 && expr
->value
.function
.isym
6755 && expr
->value
.function
.isym
->conversion
6756 && expr
->value
.function
.actual
->expr
6757 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6758 arg
= expr
->value
.function
.actual
->expr
;
6760 /* Obtain the array spec of full array references. */
6762 as
= gfc_get_full_arrayspec_from_expr (arg
);
6764 as
= gfc_get_full_arrayspec_from_expr (expr
);
6766 /* Shift the lbound and ubound of temporaries to being unity,
6767 rather than zero, based. Always calculate the offset. */
6768 offset
= gfc_conv_descriptor_offset_get (dest
);
6769 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6770 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6772 for (n
= 0; n
< expr
->rank
; n
++)
6777 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6778 TODO It looks as if gfc_conv_expr_descriptor should return
6779 the correct bounds and that the following should not be
6780 necessary. This would simplify gfc_conv_intrinsic_bound
6782 if (as
&& as
->lower
[n
])
6785 gfc_init_se (&lbse
, NULL
);
6786 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6787 gfc_add_block_to_block (&block
, &lbse
.pre
);
6788 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6792 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6793 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6797 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6800 lbound
= gfc_index_one_node
;
6802 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6804 /* Shift the bounds and set the offset accordingly. */
6805 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6806 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6807 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6808 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6810 gfc_conv_descriptor_ubound_set (&block
, dest
,
6811 gfc_rank_cst
[n
], tmp
);
6812 gfc_conv_descriptor_lbound_set (&block
, dest
,
6813 gfc_rank_cst
[n
], lbound
);
6815 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6816 gfc_conv_descriptor_lbound_get (dest
,
6818 gfc_conv_descriptor_stride_get (dest
,
6820 gfc_add_modify (&block
, tmp2
, tmp
);
6821 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6823 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6828 /* If a conversion expression has a null data pointer
6829 argument, nullify the allocatable component. */
6833 if (arg
->symtree
->n
.sym
->attr
.allocatable
6834 || arg
->symtree
->n
.sym
->attr
.pointer
)
6836 non_null_expr
= gfc_finish_block (&block
);
6837 gfc_start_block (&block
);
6838 gfc_conv_descriptor_data_set (&block
, dest
,
6840 null_expr
= gfc_finish_block (&block
);
6841 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6842 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6843 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6844 return build3_v (COND_EXPR
, tmp
,
6845 null_expr
, non_null_expr
);
6849 return gfc_finish_block (&block
);
6853 /* Allocate or reallocate scalar component, as necessary. */
6856 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6866 tree lhs_cl_size
= NULL_TREE
;
6871 if (!expr2
|| expr2
->rank
)
6874 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6876 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6878 char name
[GFC_MAX_SYMBOL_LEN
+9];
6879 gfc_component
*strlen
;
6880 /* Use the rhs string length and the lhs element size. */
6881 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6882 if (!expr2
->ts
.u
.cl
->backend_decl
)
6884 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6885 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6888 size
= expr2
->ts
.u
.cl
->backend_decl
;
6890 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6892 sprintf (name
, "_%s_length", cm
->name
);
6893 strlen
= gfc_find_component (sym
, name
, true, true);
6894 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6895 gfc_charlen_type_node
,
6896 TREE_OPERAND (comp
, 0),
6897 strlen
->backend_decl
, NULL_TREE
);
6899 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
6900 tmp
= TYPE_SIZE_UNIT (tmp
);
6901 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6902 TREE_TYPE (tmp
), tmp
,
6903 fold_convert (TREE_TYPE (tmp
), size
));
6907 /* Otherwise use the length in bytes of the rhs. */
6908 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
6909 size_in_bytes
= size
;
6912 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
6913 size_in_bytes
, size_one_node
);
6915 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
6917 tmp
= build_call_expr_loc (input_location
,
6918 builtin_decl_explicit (BUILT_IN_CALLOC
),
6919 2, build_one_cst (size_type_node
),
6921 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
6922 gfc_add_modify (block
, comp
, tmp
);
6926 tmp
= build_call_expr_loc (input_location
,
6927 builtin_decl_explicit (BUILT_IN_MALLOC
),
6929 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
6930 ptr
= gfc_class_data_get (comp
);
6933 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
6934 gfc_add_modify (block
, ptr
, tmp
);
6937 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6938 /* Update the lhs character length. */
6939 gfc_add_modify (block
, lhs_cl_size
, size
);
6943 /* Assign a single component of a derived type constructor. */
6946 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
6947 gfc_symbol
*sym
, bool init
)
6955 gfc_start_block (&block
);
6957 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6959 /* Only care about pointers here, not about allocatables. */
6960 gfc_init_se (&se
, NULL
);
6961 /* Pointer component. */
6962 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6963 && !cm
->attr
.proc_pointer
)
6965 /* Array pointer. */
6966 if (expr
->expr_type
== EXPR_NULL
)
6967 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6970 se
.direct_byref
= 1;
6972 gfc_conv_expr_descriptor (&se
, expr
);
6973 gfc_add_block_to_block (&block
, &se
.pre
);
6974 gfc_add_block_to_block (&block
, &se
.post
);
6979 /* Scalar pointers. */
6980 se
.want_pointer
= 1;
6981 gfc_conv_expr (&se
, expr
);
6982 gfc_add_block_to_block (&block
, &se
.pre
);
6984 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6985 && expr
->symtree
->n
.sym
->attr
.dummy
)
6986 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6988 gfc_add_modify (&block
, dest
,
6989 fold_convert (TREE_TYPE (dest
), se
.expr
));
6990 gfc_add_block_to_block (&block
, &se
.post
);
6993 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6995 /* NULL initialization for CLASS components. */
6996 tmp
= gfc_trans_structure_assign (dest
,
6997 gfc_class_initializer (&cm
->ts
, expr
),
6999 gfc_add_expr_to_block (&block
, tmp
);
7001 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7002 && !cm
->attr
.proc_pointer
)
7004 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7005 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7006 else if (cm
->attr
.allocatable
)
7008 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7009 gfc_add_expr_to_block (&block
, tmp
);
7013 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7014 gfc_add_expr_to_block (&block
, tmp
);
7017 else if (cm
->ts
.type
== BT_CLASS
7018 && CLASS_DATA (cm
)->attr
.dimension
7019 && CLASS_DATA (cm
)->attr
.allocatable
7020 && expr
->ts
.type
== BT_DERIVED
)
7022 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7023 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7024 tmp
= gfc_class_vptr_get (dest
);
7025 gfc_add_modify (&block
, tmp
,
7026 fold_convert (TREE_TYPE (tmp
), vtab
));
7027 tmp
= gfc_class_data_get (dest
);
7028 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7029 gfc_add_expr_to_block (&block
, tmp
);
7031 else if (init
&& (cm
->attr
.allocatable
7032 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
)))
7034 /* Take care about non-array allocatable components here. The alloc_*
7035 routine below is motivated by the alloc_scalar_allocatable_for_
7036 assignment() routine, but with the realloc portions removed and
7038 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7043 /* The remainder of these instructions follow the if (cm->attr.pointer)
7044 if (!cm->attr.dimension) part above. */
7045 gfc_init_se (&se
, NULL
);
7046 gfc_conv_expr (&se
, expr
);
7047 gfc_add_block_to_block (&block
, &se
.pre
);
7049 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7050 && expr
->symtree
->n
.sym
->attr
.dummy
)
7051 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7053 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7055 tmp
= gfc_class_data_get (dest
);
7056 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7057 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7058 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7059 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7060 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7063 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7065 /* For deferred strings insert a memcpy. */
7066 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7069 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7070 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7072 : expr
->ts
.u
.cl
->backend_decl
);
7073 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7074 gfc_add_expr_to_block (&block
, tmp
);
7077 gfc_add_modify (&block
, tmp
,
7078 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7079 gfc_add_block_to_block (&block
, &se
.post
);
7081 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7083 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7085 tree dealloc
= NULL_TREE
;
7086 gfc_init_se (&se
, NULL
);
7087 gfc_conv_expr (&se
, expr
);
7088 gfc_add_block_to_block (&block
, &se
.pre
);
7089 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7090 expression in a temporary variable and deallocate the allocatable
7091 components. Then we can the copy the expression to the result. */
7092 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7093 && expr
->expr_type
!= EXPR_VARIABLE
)
7095 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7096 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7099 gfc_add_modify (&block
, dest
,
7100 fold_convert (TREE_TYPE (dest
), se
.expr
));
7101 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7102 && expr
->expr_type
!= EXPR_NULL
)
7104 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7106 gfc_add_expr_to_block (&block
, tmp
);
7107 if (dealloc
!= NULL_TREE
)
7108 gfc_add_expr_to_block (&block
, dealloc
);
7110 gfc_add_block_to_block (&block
, &se
.post
);
7114 /* Nested constructors. */
7115 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7116 gfc_add_expr_to_block (&block
, tmp
);
7119 else if (gfc_deferred_strlen (cm
, &tmp
))
7123 gcc_assert (strlen
);
7124 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7126 TREE_OPERAND (dest
, 0),
7129 if (expr
->expr_type
== EXPR_NULL
)
7131 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7132 gfc_add_modify (&block
, dest
, tmp
);
7133 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7134 gfc_add_modify (&block
, strlen
, tmp
);
7139 gfc_init_se (&se
, NULL
);
7140 gfc_conv_expr (&se
, expr
);
7141 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7142 tmp
= build_call_expr_loc (input_location
,
7143 builtin_decl_explicit (BUILT_IN_MALLOC
),
7145 gfc_add_modify (&block
, dest
,
7146 fold_convert (TREE_TYPE (dest
), tmp
));
7147 gfc_add_modify (&block
, strlen
, se
.string_length
);
7148 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7149 gfc_add_expr_to_block (&block
, tmp
);
7152 else if (!cm
->attr
.artificial
)
7154 /* Scalar component (excluding deferred parameters). */
7155 gfc_init_se (&se
, NULL
);
7156 gfc_init_se (&lse
, NULL
);
7158 gfc_conv_expr (&se
, expr
);
7159 if (cm
->ts
.type
== BT_CHARACTER
)
7160 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7162 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
7163 gfc_add_expr_to_block (&block
, tmp
);
7165 return gfc_finish_block (&block
);
7168 /* Assign a derived type constructor to a variable. */
7171 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7179 gfc_start_block (&block
);
7180 cm
= expr
->ts
.u
.derived
->components
;
7182 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7183 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7184 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7188 gcc_assert (cm
->backend_decl
== NULL
);
7189 gfc_init_se (&se
, NULL
);
7190 gfc_init_se (&lse
, NULL
);
7191 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7193 gfc_add_modify (&block
, lse
.expr
,
7194 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7196 return gfc_finish_block (&block
);
7199 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7200 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7202 /* Skip absent members in default initializers. */
7203 if (!c
->expr
&& !cm
->attr
.allocatable
)
7206 field
= cm
->backend_decl
;
7207 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7208 dest
, field
, NULL_TREE
);
7211 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7212 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7217 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7218 expr
->ts
.u
.derived
, init
);
7219 gfc_add_expr_to_block (&block
, tmp
);
7221 return gfc_finish_block (&block
);
7224 /* Build an expression for a constructor. If init is nonzero then
7225 this is part of a static variable initializer. */
7228 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7235 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7237 gcc_assert (se
->ss
== NULL
);
7238 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7239 type
= gfc_typenode_for_spec (&expr
->ts
);
7243 /* Create a temporary variable and fill it in. */
7244 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7245 /* The symtree in expr is NULL, if the code to generate is for
7246 initializing the static members only. */
7247 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7248 gfc_add_expr_to_block (&se
->pre
, tmp
);
7252 cm
= expr
->ts
.u
.derived
->components
;
7254 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7255 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7257 /* Skip absent members in default initializers and allocatable
7258 components. Although the latter have a default initializer
7259 of EXPR_NULL,... by default, the static nullify is not needed
7260 since this is done every time we come into scope. */
7261 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7264 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7265 && strcmp (cm
->name
, "_extends") == 0
7266 && cm
->initializer
->symtree
)
7270 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7271 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7272 vtab
= unshare_expr_without_location (vtab
);
7273 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7275 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7277 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7278 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7279 fold_convert (TREE_TYPE (cm
->backend_decl
),
7282 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7283 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7284 fold_convert (TREE_TYPE (cm
->backend_decl
),
7285 integer_zero_node
));
7288 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7289 TREE_TYPE (cm
->backend_decl
),
7290 cm
->attr
.dimension
, cm
->attr
.pointer
,
7291 cm
->attr
.proc_pointer
);
7292 val
= unshare_expr_without_location (val
);
7294 /* Append it to the constructor list. */
7295 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7298 se
->expr
= build_constructor (type
, v
);
7300 TREE_CONSTANT (se
->expr
) = 1;
7304 /* Translate a substring expression. */
7307 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7313 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7315 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7316 expr
->value
.character
.length
,
7317 expr
->value
.character
.string
);
7319 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7320 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7323 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7327 /* Entry point for expression translation. Evaluates a scalar quantity.
7328 EXPR is the expression to be translated, and SE is the state structure if
7329 called from within the scalarized. */
7332 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7337 if (ss
&& ss
->info
->expr
== expr
7338 && (ss
->info
->type
== GFC_SS_SCALAR
7339 || ss
->info
->type
== GFC_SS_REFERENCE
))
7341 gfc_ss_info
*ss_info
;
7344 /* Substitute a scalar expression evaluated outside the scalarization
7346 se
->expr
= ss_info
->data
.scalar
.value
;
7347 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7348 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7350 se
->string_length
= ss_info
->string_length
;
7351 gfc_advance_se_ss_chain (se
);
7355 /* We need to convert the expressions for the iso_c_binding derived types.
7356 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7357 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7358 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7359 updated to be an integer with a kind equal to the size of a (void *). */
7360 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7361 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7363 if (expr
->expr_type
== EXPR_VARIABLE
7364 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7365 || expr
->symtree
->n
.sym
->intmod_sym_id
7366 == ISOCBINDING_NULL_FUNPTR
))
7368 /* Set expr_type to EXPR_NULL, which will result in
7369 null_pointer_node being used below. */
7370 expr
->expr_type
= EXPR_NULL
;
7374 /* Update the type/kind of the expression to be what the new
7375 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7376 expr
->ts
.type
= BT_INTEGER
;
7377 expr
->ts
.f90_type
= BT_VOID
;
7378 expr
->ts
.kind
= gfc_index_integer_kind
;
7382 gfc_fix_class_refs (expr
);
7384 switch (expr
->expr_type
)
7387 gfc_conv_expr_op (se
, expr
);
7391 gfc_conv_function_expr (se
, expr
);
7395 gfc_conv_constant (se
, expr
);
7399 gfc_conv_variable (se
, expr
);
7403 se
->expr
= null_pointer_node
;
7406 case EXPR_SUBSTRING
:
7407 gfc_conv_substring_expr (se
, expr
);
7410 case EXPR_STRUCTURE
:
7411 gfc_conv_structure (se
, expr
, 0);
7415 gfc_conv_array_constructor_expr (se
, expr
);
7424 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7425 of an assignment. */
7427 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7429 gfc_conv_expr (se
, expr
);
7430 /* All numeric lvalues should have empty post chains. If not we need to
7431 figure out a way of rewriting an lvalue so that it has no post chain. */
7432 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7435 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7436 numeric expressions. Used for scalar values where inserting cleanup code
7439 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7443 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7444 gfc_conv_expr (se
, expr
);
7447 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7448 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7450 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7454 /* Helper to translate an expression and convert it to a particular type. */
7456 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7458 gfc_conv_expr_val (se
, expr
);
7459 se
->expr
= convert (type
, se
->expr
);
7463 /* Converts an expression so that it can be passed by reference. Scalar
7467 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7473 if (ss
&& ss
->info
->expr
== expr
7474 && ss
->info
->type
== GFC_SS_REFERENCE
)
7476 /* Returns a reference to the scalar evaluated outside the loop
7478 gfc_conv_expr (se
, expr
);
7480 if (expr
->ts
.type
== BT_CHARACTER
7481 && expr
->expr_type
!= EXPR_FUNCTION
)
7482 gfc_conv_string_parameter (se
);
7484 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7489 if (expr
->ts
.type
== BT_CHARACTER
)
7491 gfc_conv_expr (se
, expr
);
7492 gfc_conv_string_parameter (se
);
7496 if (expr
->expr_type
== EXPR_VARIABLE
)
7498 se
->want_pointer
= 1;
7499 gfc_conv_expr (se
, expr
);
7502 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7503 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7504 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7510 if (expr
->expr_type
== EXPR_FUNCTION
7511 && ((expr
->value
.function
.esym
7512 && expr
->value
.function
.esym
->result
->attr
.pointer
7513 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7514 || (!expr
->value
.function
.esym
&& !expr
->ref
7515 && expr
->symtree
->n
.sym
->attr
.pointer
7516 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7518 se
->want_pointer
= 1;
7519 gfc_conv_expr (se
, expr
);
7520 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7521 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7526 gfc_conv_expr (se
, expr
);
7528 /* Create a temporary var to hold the value. */
7529 if (TREE_CONSTANT (se
->expr
))
7531 tree tmp
= se
->expr
;
7532 STRIP_TYPE_NOPS (tmp
);
7533 var
= build_decl (input_location
,
7534 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7535 DECL_INITIAL (var
) = tmp
;
7536 TREE_STATIC (var
) = 1;
7541 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7542 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7544 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7546 /* Take the address of that value. */
7547 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7548 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
7549 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
7550 && expr
->ts
.u
.derived
->attr
.alloc_comp
7551 && expr
->expr_type
!= EXPR_VARIABLE
)
7555 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7556 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
7558 /* The components shall be deallocated before
7559 their containing entity. */
7560 gfc_prepend_expr_to_block (&se
->post
, tmp
);
7566 gfc_trans_pointer_assign (gfc_code
* code
)
7568 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7572 /* Generate code for a pointer assignment. */
7575 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7577 gfc_expr
*expr1_vptr
= NULL
;
7587 gfc_start_block (&block
);
7589 gfc_init_se (&lse
, NULL
);
7591 /* Check whether the expression is a scalar or not; we cannot use
7592 expr1->rank as it can be nonzero for proc pointers. */
7593 ss
= gfc_walk_expr (expr1
);
7594 scalar
= ss
== gfc_ss_terminator
;
7596 gfc_free_ss_chain (ss
);
7598 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7599 && expr2
->expr_type
!= EXPR_FUNCTION
)
7601 gfc_add_data_component (expr2
);
7602 /* The following is required as gfc_add_data_component doesn't
7603 update ts.type if there is a tailing REF_ARRAY. */
7604 expr2
->ts
.type
= BT_DERIVED
;
7609 /* Scalar pointers. */
7610 lse
.want_pointer
= 1;
7611 gfc_conv_expr (&lse
, expr1
);
7612 gfc_init_se (&rse
, NULL
);
7613 rse
.want_pointer
= 1;
7614 gfc_conv_expr (&rse
, expr2
);
7616 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7617 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7618 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7621 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7622 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7623 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7626 gfc_add_block_to_block (&block
, &lse
.pre
);
7627 gfc_add_block_to_block (&block
, &rse
.pre
);
7629 /* For string assignments to unlimited polymorphic pointers add an
7630 assignment of the string_length to the _len component of the
7632 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7633 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7634 && (expr2
->ts
.type
== BT_CHARACTER
||
7635 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7636 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7640 len_comp
= gfc_get_len_component (expr1
);
7641 gfc_init_se (&se
, NULL
);
7642 gfc_conv_expr (&se
, len_comp
);
7644 /* ptr % _len = len (str) */
7645 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7646 lse
.string_length
= se
.expr
;
7647 gfc_free_expr (len_comp
);
7650 /* Check character lengths if character expression. The test is only
7651 really added if -fbounds-check is enabled. Exclude deferred
7652 character length lefthand sides. */
7653 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7654 && !expr1
->ts
.deferred
7655 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7656 && !gfc_is_proc_ptr_comp (expr1
))
7658 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7659 gcc_assert (lse
.string_length
&& rse
.string_length
);
7660 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7661 lse
.string_length
, rse
.string_length
,
7665 /* The assignment to an deferred character length sets the string
7666 length to that of the rhs. */
7667 if (expr1
->ts
.deferred
)
7669 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7670 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7671 else if (lse
.string_length
!= NULL
)
7672 gfc_add_modify (&block
, lse
.string_length
,
7673 build_int_cst (gfc_charlen_type_node
, 0));
7676 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7677 rse
.expr
= gfc_class_data_get (rse
.expr
);
7679 gfc_add_modify (&block
, lse
.expr
,
7680 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7682 gfc_add_block_to_block (&block
, &rse
.post
);
7683 gfc_add_block_to_block (&block
, &lse
.post
);
7690 tree strlen_rhs
= NULL_TREE
;
7692 /* Array pointer. Find the last reference on the LHS and if it is an
7693 array section ref, we're dealing with bounds remapping. In this case,
7694 set it to AR_FULL so that gfc_conv_expr_descriptor does
7695 not see it and process the bounds remapping afterwards explicitly. */
7696 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7697 if (!remap
->next
&& remap
->type
== REF_ARRAY
7698 && remap
->u
.ar
.type
== AR_SECTION
)
7700 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7702 gfc_init_se (&lse
, NULL
);
7704 lse
.descriptor_only
= 1;
7705 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7706 && expr1
->ts
.type
== BT_CLASS
)
7707 expr1_vptr
= gfc_copy_expr (expr1
);
7708 gfc_conv_expr_descriptor (&lse
, expr1
);
7709 strlen_lhs
= lse
.string_length
;
7712 if (expr2
->expr_type
== EXPR_NULL
)
7714 /* Just set the data pointer to null. */
7715 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7717 else if (rank_remap
)
7719 /* If we are rank-remapping, just get the RHS's descriptor and
7720 process this later on. */
7721 gfc_init_se (&rse
, NULL
);
7722 rse
.direct_byref
= 1;
7723 rse
.byref_noassign
= 1;
7725 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7727 gfc_conv_function_expr (&rse
, expr2
);
7729 if (expr1
->ts
.type
!= BT_CLASS
)
7730 rse
.expr
= gfc_class_data_get (rse
.expr
);
7733 gfc_add_block_to_block (&block
, &rse
.pre
);
7734 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7735 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7737 gfc_add_vptr_component (expr1_vptr
);
7738 gfc_init_se (&rse
, NULL
);
7739 rse
.want_pointer
= 1;
7740 gfc_conv_expr (&rse
, expr1_vptr
);
7741 gfc_add_modify (&lse
.pre
, rse
.expr
,
7742 fold_convert (TREE_TYPE (rse
.expr
),
7743 gfc_class_vptr_get (tmp
)));
7744 rse
.expr
= gfc_class_data_get (tmp
);
7747 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7749 tree bound
[GFC_MAX_DIMENSIONS
];
7752 for (i
= 0; i
< expr2
->rank
; i
++)
7753 bound
[i
] = NULL_TREE
;
7754 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7755 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7757 GFC_ARRAY_POINTER_CONT
, false);
7758 tmp
= gfc_create_var (tmp
, "ptrtemp");
7759 lse
.descriptor_only
= 0;
7761 lse
.direct_byref
= 1;
7762 gfc_conv_expr_descriptor (&lse
, expr2
);
7763 strlen_rhs
= lse
.string_length
;
7768 gfc_conv_expr_descriptor (&rse
, expr2
);
7769 strlen_rhs
= rse
.string_length
;
7772 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7774 /* Assign directly to the LHS's descriptor. */
7775 lse
.descriptor_only
= 0;
7776 lse
.direct_byref
= 1;
7777 gfc_conv_expr_descriptor (&lse
, expr2
);
7778 strlen_rhs
= lse
.string_length
;
7780 /* If this is a subreference array pointer assignment, use the rhs
7781 descriptor element size for the lhs span. */
7782 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7784 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7785 gfc_init_se (&rse
, NULL
);
7786 rse
.descriptor_only
= 1;
7787 gfc_conv_expr (&rse
, expr2
);
7788 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7789 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7790 if (!INTEGER_CST_P (tmp
))
7791 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7792 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7795 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7797 gfc_init_se (&rse
, NULL
);
7798 rse
.want_pointer
= 1;
7799 gfc_conv_function_expr (&rse
, expr2
);
7800 if (expr1
->ts
.type
!= BT_CLASS
)
7802 rse
.expr
= gfc_class_data_get (rse
.expr
);
7803 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7807 gfc_add_block_to_block (&block
, &rse
.pre
);
7808 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7809 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7811 gfc_add_vptr_component (expr1_vptr
);
7812 gfc_init_se (&rse
, NULL
);
7813 rse
.want_pointer
= 1;
7814 gfc_conv_expr (&rse
, expr1_vptr
);
7815 gfc_add_modify (&lse
.pre
, rse
.expr
,
7816 fold_convert (TREE_TYPE (rse
.expr
),
7817 gfc_class_vptr_get (tmp
)));
7818 rse
.expr
= gfc_class_data_get (tmp
);
7819 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7824 /* Assign to a temporary descriptor and then copy that
7825 temporary to the pointer. */
7826 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7827 lse
.descriptor_only
= 0;
7829 lse
.direct_byref
= 1;
7830 gfc_conv_expr_descriptor (&lse
, expr2
);
7831 strlen_rhs
= lse
.string_length
;
7832 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7836 gfc_free_expr (expr1_vptr
);
7838 gfc_add_block_to_block (&block
, &lse
.pre
);
7840 gfc_add_block_to_block (&block
, &rse
.pre
);
7842 /* If we do bounds remapping, update LHS descriptor accordingly. */
7846 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7850 /* Do rank remapping. We already have the RHS's descriptor
7851 converted in rse and now have to build the correct LHS
7852 descriptor for it. */
7856 tree lbound
, ubound
;
7859 dtype
= gfc_conv_descriptor_dtype (desc
);
7860 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7861 gfc_add_modify (&block
, dtype
, tmp
);
7863 /* Copy data pointer. */
7864 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7865 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7867 /* Copy offset but adjust it such that it would correspond
7868 to a lbound of zero. */
7869 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7870 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7872 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7874 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7876 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7877 gfc_array_index_type
, stride
, lbound
);
7878 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7879 gfc_array_index_type
, offs
, tmp
);
7881 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7883 /* Set the bounds as declared for the LHS and calculate strides as
7884 well as another offset update accordingly. */
7885 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7887 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7892 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7894 /* Convert declared bounds. */
7895 gfc_init_se (&lower_se
, NULL
);
7896 gfc_init_se (&upper_se
, NULL
);
7897 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7898 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7900 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7901 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7903 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7904 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7906 lbound
= gfc_evaluate_now (lbound
, &block
);
7907 ubound
= gfc_evaluate_now (ubound
, &block
);
7909 gfc_add_block_to_block (&block
, &lower_se
.post
);
7910 gfc_add_block_to_block (&block
, &upper_se
.post
);
7912 /* Set bounds in descriptor. */
7913 gfc_conv_descriptor_lbound_set (&block
, desc
,
7914 gfc_rank_cst
[dim
], lbound
);
7915 gfc_conv_descriptor_ubound_set (&block
, desc
,
7916 gfc_rank_cst
[dim
], ubound
);
7919 stride
= gfc_evaluate_now (stride
, &block
);
7920 gfc_conv_descriptor_stride_set (&block
, desc
,
7921 gfc_rank_cst
[dim
], stride
);
7923 /* Update offset. */
7924 offs
= gfc_conv_descriptor_offset_get (desc
);
7925 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7926 gfc_array_index_type
, lbound
, stride
);
7927 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7928 gfc_array_index_type
, offs
, tmp
);
7929 offs
= gfc_evaluate_now (offs
, &block
);
7930 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7932 /* Update stride. */
7933 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7934 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7935 gfc_array_index_type
, stride
, tmp
);
7940 /* Bounds remapping. Just shift the lower bounds. */
7942 gcc_assert (expr1
->rank
== expr2
->rank
);
7944 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7948 gcc_assert (remap
->u
.ar
.start
[dim
]);
7949 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7950 gfc_init_se (&lbound_se
, NULL
);
7951 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7953 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7954 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7955 dim
, lbound_se
.expr
);
7956 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7961 /* Check string lengths if applicable. The check is only really added
7962 to the output code if -fbounds-check is enabled. */
7963 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7965 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7966 gcc_assert (strlen_lhs
&& strlen_rhs
);
7967 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7968 strlen_lhs
, strlen_rhs
, &block
);
7971 /* If rank remapping was done, check with -fcheck=bounds that
7972 the target is at least as large as the pointer. */
7973 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7979 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7980 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7982 lsize
= gfc_evaluate_now (lsize
, &block
);
7983 rsize
= gfc_evaluate_now (rsize
, &block
);
7984 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7987 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7988 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7992 gfc_add_block_to_block (&block
, &lse
.post
);
7994 gfc_add_block_to_block (&block
, &rse
.post
);
7997 return gfc_finish_block (&block
);
8001 /* Makes sure se is suitable for passing as a function string parameter. */
8002 /* TODO: Need to check all callers of this function. It may be abused. */
8005 gfc_conv_string_parameter (gfc_se
* se
)
8009 if (TREE_CODE (se
->expr
) == STRING_CST
)
8011 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8012 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8016 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8018 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8020 type
= TREE_TYPE (se
->expr
);
8021 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8025 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8027 type
= build_pointer_type (type
);
8028 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8032 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8036 /* Generate code for assignment of scalar variables. Includes character
8037 strings and derived types with allocatable components.
8038 If you know that the LHS has no allocations, set dealloc to false.
8040 DEEP_COPY has no effect if the typespec TS is not a derived type with
8041 allocatable components. Otherwise, if it is set, an explicit copy of each
8042 allocatable component is made. This is necessary as a simple copy of the
8043 whole object would copy array descriptors as is, so that the lhs's
8044 allocatable components would point to the rhs's after the assignment.
8045 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8046 necessary if the rhs is a non-pointer function, as the allocatable components
8047 are not accessible by other means than the function's result after the
8048 function has returned. It is even more subtle when temporaries are involved,
8049 as the two following examples show:
8050 1. When we evaluate an array constructor, a temporary is created. Thus
8051 there is theoretically no alias possible. However, no deep copy is
8052 made for this temporary, so that if the constructor is made of one or
8053 more variable with allocatable components, those components still point
8054 to the variable's: DEEP_COPY should be set for the assignment from the
8055 temporary to the lhs in that case.
8056 2. When assigning a scalar to an array, we evaluate the scalar value out
8057 of the loop, store it into a temporary variable, and assign from that.
8058 In that case, deep copying when assigning to the temporary would be a
8059 waste of resources; however deep copies should happen when assigning from
8060 the temporary to each array element: again DEEP_COPY should be set for
8061 the assignment from the temporary to the lhs. */
8064 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8065 bool l_is_temp
, bool deep_copy
, bool dealloc
)
8071 gfc_init_block (&block
);
8073 if (ts
.type
== BT_CHARACTER
)
8078 if (lse
->string_length
!= NULL_TREE
)
8080 gfc_conv_string_parameter (lse
);
8081 gfc_add_block_to_block (&block
, &lse
->pre
);
8082 llen
= lse
->string_length
;
8085 if (rse
->string_length
!= NULL_TREE
)
8087 gcc_assert (rse
->string_length
!= NULL_TREE
);
8088 gfc_conv_string_parameter (rse
);
8089 gfc_add_block_to_block (&block
, &rse
->pre
);
8090 rlen
= rse
->string_length
;
8093 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8094 rse
->expr
, ts
.kind
);
8096 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8098 tree tmp_var
= NULL_TREE
;
8101 /* Are the rhs and the lhs the same? */
8104 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8105 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8106 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8107 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8110 /* Deallocate the lhs allocated components as long as it is not
8111 the same as the rhs. This must be done following the assignment
8112 to prevent deallocating data that could be used in the rhs
8114 if (!l_is_temp
&& dealloc
)
8116 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8117 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8119 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8121 gfc_add_expr_to_block (&lse
->post
, tmp
);
8124 gfc_add_block_to_block (&block
, &rse
->pre
);
8125 gfc_add_block_to_block (&block
, &lse
->pre
);
8127 gfc_add_modify (&block
, lse
->expr
,
8128 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8130 /* Restore pointer address of coarray components. */
8131 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8133 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8134 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8136 gfc_add_expr_to_block (&block
, tmp
);
8139 /* Do a deep copy if the rhs is a variable, if it is not the
8143 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8144 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8146 gfc_add_expr_to_block (&block
, tmp
);
8149 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8151 gfc_add_block_to_block (&block
, &lse
->pre
);
8152 gfc_add_block_to_block (&block
, &rse
->pre
);
8153 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8154 TREE_TYPE (lse
->expr
), rse
->expr
);
8155 gfc_add_modify (&block
, lse
->expr
, tmp
);
8159 gfc_add_block_to_block (&block
, &lse
->pre
);
8160 gfc_add_block_to_block (&block
, &rse
->pre
);
8162 gfc_add_modify (&block
, lse
->expr
,
8163 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8166 gfc_add_block_to_block (&block
, &lse
->post
);
8167 gfc_add_block_to_block (&block
, &rse
->post
);
8169 return gfc_finish_block (&block
);
8173 /* There are quite a lot of restrictions on the optimisation in using an
8174 array function assign without a temporary. */
8177 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8180 bool seen_array_ref
;
8182 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8184 /* Play it safe with class functions assigned to a derived type. */
8185 if (gfc_is_alloc_class_array_function (expr2
)
8186 && expr1
->ts
.type
== BT_DERIVED
)
8189 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8190 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8193 /* Elemental functions are scalarized so that they don't need a
8194 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8195 they would need special treatment in gfc_trans_arrayfunc_assign. */
8196 if (expr2
->value
.function
.esym
!= NULL
8197 && expr2
->value
.function
.esym
->attr
.elemental
)
8200 /* Need a temporary if rhs is not FULL or a contiguous section. */
8201 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8204 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8205 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8208 /* Functions returning pointers or allocatables need temporaries. */
8209 c
= expr2
->value
.function
.esym
8210 ? (expr2
->value
.function
.esym
->attr
.pointer
8211 || expr2
->value
.function
.esym
->attr
.allocatable
)
8212 : (expr2
->symtree
->n
.sym
->attr
.pointer
8213 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8217 /* Character array functions need temporaries unless the
8218 character lengths are the same. */
8219 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8221 if (expr1
->ts
.u
.cl
->length
== NULL
8222 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8225 if (expr2
->ts
.u
.cl
->length
== NULL
8226 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8229 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8230 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8234 /* Check that no LHS component references appear during an array
8235 reference. This is needed because we do not have the means to
8236 span any arbitrary stride with an array descriptor. This check
8237 is not needed for the rhs because the function result has to be
8239 seen_array_ref
= false;
8240 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8242 if (ref
->type
== REF_ARRAY
)
8243 seen_array_ref
= true;
8244 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8248 /* Check for a dependency. */
8249 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8250 expr2
->value
.function
.esym
,
8251 expr2
->value
.function
.actual
,
8255 /* If we have reached here with an intrinsic function, we do not
8256 need a temporary except in the particular case that reallocation
8257 on assignment is active and the lhs is allocatable and a target. */
8258 if (expr2
->value
.function
.isym
)
8259 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8261 /* If the LHS is a dummy, we need a temporary if it is not
8263 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8266 /* If the lhs has been host_associated, is in common, a pointer or is
8267 a target and the function is not using a RESULT variable, aliasing
8268 can occur and a temporary is needed. */
8269 if ((sym
->attr
.host_assoc
8270 || sym
->attr
.in_common
8271 || sym
->attr
.pointer
8272 || sym
->attr
.cray_pointee
8273 || sym
->attr
.target
)
8274 && expr2
->symtree
!= NULL
8275 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8278 /* A PURE function can unconditionally be called without a temporary. */
8279 if (expr2
->value
.function
.esym
!= NULL
8280 && expr2
->value
.function
.esym
->attr
.pure
)
8283 /* Implicit_pure functions are those which could legally be declared
8285 if (expr2
->value
.function
.esym
!= NULL
8286 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8289 if (!sym
->attr
.use_assoc
8290 && !sym
->attr
.in_common
8291 && !sym
->attr
.pointer
8292 && !sym
->attr
.target
8293 && !sym
->attr
.cray_pointee
8294 && expr2
->value
.function
.esym
)
8296 /* A temporary is not needed if the function is not contained and
8297 the variable is local or host associated and not a pointer or
8299 if (!expr2
->value
.function
.esym
->attr
.contained
)
8302 /* A temporary is not needed if the lhs has never been host
8303 associated and the procedure is contained. */
8304 else if (!sym
->attr
.host_assoc
)
8307 /* A temporary is not needed if the variable is local and not
8308 a pointer, a target or a result. */
8310 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8314 /* Default to temporary use. */
8319 /* Provide the loop info so that the lhs descriptor can be built for
8320 reallocatable assignments from extrinsic function calls. */
8323 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8326 /* Signal that the function call should not be made by
8327 gfc_conv_loop_setup. */
8328 se
->ss
->is_alloc_lhs
= 1;
8329 gfc_init_loopinfo (loop
);
8330 gfc_add_ss_to_loop (loop
, *ss
);
8331 gfc_add_ss_to_loop (loop
, se
->ss
);
8332 gfc_conv_ss_startstride (loop
);
8333 gfc_conv_loop_setup (loop
, where
);
8334 gfc_copy_loopinfo_to_se (se
, loop
);
8335 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8336 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8337 se
->ss
->is_alloc_lhs
= 0;
8341 /* For assignment to a reallocatable lhs from intrinsic functions,
8342 replace the se.expr (ie. the result) with a temporary descriptor.
8343 Null the data field so that the library allocates space for the
8344 result. Free the data of the original descriptor after the function,
8345 in case it appears in an argument expression and transfer the
8346 result to the original descriptor. */
8349 fcncall_realloc_result (gfc_se
*se
, int rank
)
8358 /* Use the allocation done by the library. Substitute the lhs
8359 descriptor with a copy, whose data field is nulled.*/
8360 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8361 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8362 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8364 /* Unallocated, the descriptor does not have a dtype. */
8365 tmp
= gfc_conv_descriptor_dtype (desc
);
8366 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8368 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8369 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8370 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8372 /* Free the lhs after the function call and copy the result data to
8373 the lhs descriptor. */
8374 tmp
= gfc_conv_descriptor_data_get (desc
);
8375 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8376 boolean_type_node
, tmp
,
8377 build_int_cst (TREE_TYPE (tmp
), 0));
8378 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8379 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
8380 gfc_add_expr_to_block (&se
->post
, tmp
);
8382 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8383 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8385 /* Check that the shapes are the same between lhs and expression. */
8386 for (n
= 0 ; n
< rank
; n
++)
8389 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8390 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8391 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8392 gfc_array_index_type
, tmp
, tmp1
);
8393 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8394 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8395 gfc_array_index_type
, tmp
, tmp1
);
8396 tmp1
= 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
, tmp1
);
8399 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8400 boolean_type_node
, tmp
,
8401 gfc_index_zero_node
);
8402 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8403 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8404 boolean_type_node
, tmp
,
8408 /* 'zero_cond' being true is equal to lhs not being allocated or the
8409 shapes being different. */
8410 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8412 /* Now reset the bounds returned from the function call to bounds based
8413 on the lhs lbounds, except where the lhs is not allocated or the shapes
8414 of 'variable and 'expr' are different. Set the offset accordingly. */
8415 offset
= gfc_index_zero_node
;
8416 for (n
= 0 ; n
< rank
; n
++)
8420 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8421 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8422 gfc_array_index_type
, zero_cond
,
8423 gfc_index_one_node
, lbound
);
8424 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8426 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8427 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8428 gfc_array_index_type
, tmp
, lbound
);
8429 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8430 gfc_rank_cst
[n
], lbound
);
8431 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8432 gfc_rank_cst
[n
], tmp
);
8434 /* Set stride and accumulate the offset. */
8435 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8436 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8437 gfc_rank_cst
[n
], tmp
);
8438 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8439 gfc_array_index_type
, lbound
, tmp
);
8440 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8441 gfc_array_index_type
, offset
, tmp
);
8442 offset
= gfc_evaluate_now (offset
, &se
->post
);
8445 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8450 /* Try to translate array(:) = func (...), where func is a transformational
8451 array function, without using a temporary. Returns NULL if this isn't the
8455 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8459 gfc_component
*comp
= NULL
;
8462 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8465 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8467 comp
= gfc_get_proc_ptr_comp (expr2
);
8468 gcc_assert (expr2
->value
.function
.isym
8469 || (comp
&& comp
->attr
.dimension
)
8470 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8471 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8473 gfc_init_se (&se
, NULL
);
8474 gfc_start_block (&se
.pre
);
8475 se
.want_pointer
= 1;
8477 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8479 if (expr1
->ts
.type
== BT_DERIVED
8480 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8483 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8485 gfc_add_expr_to_block (&se
.pre
, tmp
);
8488 se
.direct_byref
= 1;
8489 se
.ss
= gfc_walk_expr (expr2
);
8490 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8492 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8493 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8494 Clearly, this cannot be done for an allocatable function result, since
8495 the shape of the result is unknown and, in any case, the function must
8496 correctly take care of the reallocation internally. For intrinsic
8497 calls, the array data is freed and the library takes care of allocation.
8498 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8500 if (flag_realloc_lhs
8501 && gfc_is_reallocatable_lhs (expr1
)
8502 && !gfc_expr_attr (expr1
).codimension
8503 && !gfc_is_coindexed (expr1
)
8504 && !(expr2
->value
.function
.esym
8505 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8507 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8509 if (!expr2
->value
.function
.isym
)
8511 ss
= gfc_walk_expr (expr1
);
8512 gcc_assert (ss
!= gfc_ss_terminator
);
8514 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8515 ss
->is_alloc_lhs
= 1;
8518 fcncall_realloc_result (&se
, expr1
->rank
);
8521 gfc_conv_function_expr (&se
, expr2
);
8522 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8525 gfc_cleanup_loop (&loop
);
8527 gfc_free_ss_chain (se
.ss
);
8529 return gfc_finish_block (&se
.pre
);
8533 /* Try to efficiently translate array(:) = 0. Return NULL if this
8537 gfc_trans_zero_assign (gfc_expr
* expr
)
8539 tree dest
, len
, type
;
8543 sym
= expr
->symtree
->n
.sym
;
8544 dest
= gfc_get_symbol_decl (sym
);
8546 type
= TREE_TYPE (dest
);
8547 if (POINTER_TYPE_P (type
))
8548 type
= TREE_TYPE (type
);
8549 if (!GFC_ARRAY_TYPE_P (type
))
8552 /* Determine the length of the array. */
8553 len
= GFC_TYPE_ARRAY_SIZE (type
);
8554 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8557 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8558 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8559 fold_convert (gfc_array_index_type
, tmp
));
8561 /* If we are zeroing a local array avoid taking its address by emitting
8563 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8564 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8565 dest
, build_constructor (TREE_TYPE (dest
),
8568 /* Convert arguments to the correct types. */
8569 dest
= fold_convert (pvoid_type_node
, dest
);
8570 len
= fold_convert (size_type_node
, len
);
8572 /* Construct call to __builtin_memset. */
8573 tmp
= build_call_expr_loc (input_location
,
8574 builtin_decl_explicit (BUILT_IN_MEMSET
),
8575 3, dest
, integer_zero_node
, len
);
8576 return fold_convert (void_type_node
, tmp
);
8580 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8581 that constructs the call to __builtin_memcpy. */
8584 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8588 /* Convert arguments to the correct types. */
8589 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8590 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8592 dst
= fold_convert (pvoid_type_node
, dst
);
8594 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8595 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8597 src
= fold_convert (pvoid_type_node
, src
);
8599 len
= fold_convert (size_type_node
, len
);
8601 /* Construct call to __builtin_memcpy. */
8602 tmp
= build_call_expr_loc (input_location
,
8603 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8605 return fold_convert (void_type_node
, tmp
);
8609 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8610 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8611 source/rhs, both are gfc_full_array_ref_p which have been checked for
8615 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8617 tree dst
, dlen
, dtype
;
8618 tree src
, slen
, stype
;
8621 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8622 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8624 dtype
= TREE_TYPE (dst
);
8625 if (POINTER_TYPE_P (dtype
))
8626 dtype
= TREE_TYPE (dtype
);
8627 stype
= TREE_TYPE (src
);
8628 if (POINTER_TYPE_P (stype
))
8629 stype
= TREE_TYPE (stype
);
8631 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8634 /* Determine the lengths of the arrays. */
8635 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8636 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8638 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8639 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8640 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8642 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8643 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8645 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8646 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8647 slen
, fold_convert (gfc_array_index_type
, tmp
));
8649 /* Sanity check that they are the same. This should always be
8650 the case, as we should already have checked for conformance. */
8651 if (!tree_int_cst_equal (slen
, dlen
))
8654 return gfc_build_memcpy_call (dst
, src
, dlen
);
8658 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8659 this can't be done. EXPR1 is the destination/lhs for which
8660 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8663 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8665 unsigned HOST_WIDE_INT nelem
;
8671 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8675 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8676 dtype
= TREE_TYPE (dst
);
8677 if (POINTER_TYPE_P (dtype
))
8678 dtype
= TREE_TYPE (dtype
);
8679 if (!GFC_ARRAY_TYPE_P (dtype
))
8682 /* Determine the lengths of the array. */
8683 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8684 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8687 /* Confirm that the constructor is the same size. */
8688 if (compare_tree_int (len
, nelem
) != 0)
8691 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8692 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8693 fold_convert (gfc_array_index_type
, tmp
));
8695 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8696 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8698 stype
= TREE_TYPE (src
);
8699 if (POINTER_TYPE_P (stype
))
8700 stype
= TREE_TYPE (stype
);
8702 return gfc_build_memcpy_call (dst
, src
, len
);
8706 /* Tells whether the expression is to be treated as a variable reference. */
8709 expr_is_variable (gfc_expr
*expr
)
8712 gfc_component
*comp
;
8713 gfc_symbol
*func_ifc
;
8715 if (expr
->expr_type
== EXPR_VARIABLE
)
8718 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8721 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8722 return expr_is_variable (arg
);
8725 /* A data-pointer-returning function should be considered as a variable
8727 if (expr
->expr_type
== EXPR_FUNCTION
8728 && expr
->ref
== NULL
)
8730 if (expr
->value
.function
.isym
!= NULL
)
8733 if (expr
->value
.function
.esym
!= NULL
)
8735 func_ifc
= expr
->value
.function
.esym
;
8740 gcc_assert (expr
->symtree
);
8741 func_ifc
= expr
->symtree
->n
.sym
;
8748 comp
= gfc_get_proc_ptr_comp (expr
);
8749 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8752 func_ifc
= comp
->ts
.interface
;
8756 if (expr
->expr_type
== EXPR_COMPCALL
)
8758 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8759 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8766 gcc_assert (func_ifc
->attr
.function
8767 && func_ifc
->result
!= NULL
);
8768 return func_ifc
->result
->attr
.pointer
;
8772 /* Is the lhs OK for automatic reallocation? */
8775 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8779 /* An allocatable variable with no reference. */
8780 if (expr
->symtree
->n
.sym
->attr
.allocatable
8784 /* All that can be left are allocatable components. */
8785 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8786 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8787 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8790 /* Find an allocatable component ref last. */
8791 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8792 if (ref
->type
== REF_COMPONENT
8794 && ref
->u
.c
.component
->attr
.allocatable
)
8801 /* Allocate or reallocate scalar lhs, as necessary. */
8804 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8818 if (!expr1
|| expr1
->rank
)
8821 if (!expr2
|| expr2
->rank
)
8824 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8826 /* Since this is a scalar lhs, we can afford to do this. That is,
8827 there is no risk of side effects being repeated. */
8828 gfc_init_se (&lse
, NULL
);
8829 lse
.want_pointer
= 1;
8830 gfc_conv_expr (&lse
, expr1
);
8832 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8833 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8835 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8836 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8837 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8839 tmp
= build3_v (COND_EXPR
, cond
,
8840 build1_v (GOTO_EXPR
, jump_label1
),
8841 build_empty_stmt (input_location
));
8842 gfc_add_expr_to_block (block
, tmp
);
8844 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8846 /* Use the rhs string length and the lhs element size. */
8847 size
= string_length
;
8848 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8849 tmp
= TYPE_SIZE_UNIT (tmp
);
8850 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8851 TREE_TYPE (tmp
), tmp
,
8852 fold_convert (TREE_TYPE (tmp
), size
));
8856 /* Otherwise use the length in bytes of the rhs. */
8857 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8858 size_in_bytes
= size
;
8861 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8862 size_in_bytes
, size_one_node
);
8864 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8866 tmp
= build_call_expr_loc (input_location
,
8867 builtin_decl_explicit (BUILT_IN_CALLOC
),
8868 2, build_one_cst (size_type_node
),
8870 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8871 gfc_add_modify (block
, lse
.expr
, tmp
);
8875 tmp
= build_call_expr_loc (input_location
,
8876 builtin_decl_explicit (BUILT_IN_MALLOC
),
8878 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8879 gfc_add_modify (block
, lse
.expr
, tmp
);
8882 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8884 /* Deferred characters need checking for lhs and rhs string
8885 length. Other deferred parameter variables will have to
8887 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8888 gfc_add_expr_to_block (block
, tmp
);
8890 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8891 gfc_add_expr_to_block (block
, tmp
);
8893 /* For a deferred length character, reallocate if lengths of lhs and
8894 rhs are different. */
8895 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8897 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8898 lse
.string_length
, size
);
8899 /* Jump past the realloc if the lengths are the same. */
8900 tmp
= build3_v (COND_EXPR
, cond
,
8901 build1_v (GOTO_EXPR
, jump_label2
),
8902 build_empty_stmt (input_location
));
8903 gfc_add_expr_to_block (block
, tmp
);
8904 tmp
= build_call_expr_loc (input_location
,
8905 builtin_decl_explicit (BUILT_IN_REALLOC
),
8906 2, fold_convert (pvoid_type_node
, lse
.expr
),
8908 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8909 gfc_add_modify (block
, lse
.expr
, tmp
);
8910 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8911 gfc_add_expr_to_block (block
, tmp
);
8913 /* Update the lhs character length. */
8914 size
= string_length
;
8915 gfc_add_modify (block
, lse
.string_length
, size
);
8919 /* Check for assignments of the type
8923 to make sure we do not check for reallocation unneccessarily. */
8927 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8929 gfc_actual_arglist
*a
;
8932 switch (expr2
->expr_type
)
8935 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8938 if (expr2
->value
.function
.esym
8939 && expr2
->value
.function
.esym
->attr
.elemental
)
8941 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8944 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8949 else if (expr2
->value
.function
.isym
8950 && expr2
->value
.function
.isym
->elemental
)
8952 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8955 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8964 switch (expr2
->value
.op
.op
)
8967 case INTRINSIC_UPLUS
:
8968 case INTRINSIC_UMINUS
:
8969 case INTRINSIC_PARENTHESES
:
8970 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8972 case INTRINSIC_PLUS
:
8973 case INTRINSIC_MINUS
:
8974 case INTRINSIC_TIMES
:
8975 case INTRINSIC_DIVIDE
:
8976 case INTRINSIC_POWER
:
8980 case INTRINSIC_NEQV
:
8987 case INTRINSIC_EQ_OS
:
8988 case INTRINSIC_NE_OS
:
8989 case INTRINSIC_GT_OS
:
8990 case INTRINSIC_GE_OS
:
8991 case INTRINSIC_LT_OS
:
8992 case INTRINSIC_LE_OS
:
8994 e1
= expr2
->value
.op
.op1
;
8995 e2
= expr2
->value
.op
.op2
;
8997 if (e1
->rank
== 0 && e2
->rank
> 0)
8998 return is_runtime_conformable (expr1
, e2
);
8999 else if (e1
->rank
> 0 && e2
->rank
== 0)
9000 return is_runtime_conformable (expr1
, e1
);
9001 else if (e1
->rank
> 0 && e2
->rank
> 0)
9002 return is_runtime_conformable (expr1
, e1
)
9003 && is_runtime_conformable (expr1
, e2
);
9019 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9020 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9021 init_flag indicates initialization expressions and dealloc that no
9022 deallocate prior assignment is needed (if in doubt, set true). */
9025 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9031 gfc_ss
*lss_section
;
9038 bool scalar_to_array
;
9042 /* Assignment of the form lhs = rhs. */
9043 gfc_start_block (&block
);
9045 gfc_init_se (&lse
, NULL
);
9046 gfc_init_se (&rse
, NULL
);
9049 lss
= gfc_walk_expr (expr1
);
9050 if (gfc_is_reallocatable_lhs (expr1
)
9051 && !(expr2
->expr_type
== EXPR_FUNCTION
9052 && expr2
->value
.function
.isym
!= NULL
))
9053 lss
->is_alloc_lhs
= 1;
9056 if ((expr1
->ts
.type
== BT_DERIVED
)
9057 && (gfc_is_alloc_class_array_function (expr2
)
9058 || gfc_is_alloc_class_scalar_function (expr2
)))
9059 expr2
->must_finalize
= 1;
9061 if (lss
!= gfc_ss_terminator
)
9063 /* The assignment needs scalarization. */
9066 /* Find a non-scalar SS from the lhs. */
9067 while (lss_section
!= gfc_ss_terminator
9068 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9069 lss_section
= lss_section
->next
;
9071 gcc_assert (lss_section
!= gfc_ss_terminator
);
9073 /* Initialize the scalarizer. */
9074 gfc_init_loopinfo (&loop
);
9077 rss
= gfc_walk_expr (expr2
);
9078 if (rss
== gfc_ss_terminator
)
9079 /* The rhs is scalar. Add a ss for the expression. */
9080 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9082 /* Associate the SS with the loop. */
9083 gfc_add_ss_to_loop (&loop
, lss
);
9084 gfc_add_ss_to_loop (&loop
, rss
);
9086 /* Calculate the bounds of the scalarization. */
9087 gfc_conv_ss_startstride (&loop
);
9088 /* Enable loop reversal. */
9089 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9090 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9091 /* Resolve any data dependencies in the statement. */
9092 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9093 /* Setup the scalarizing loops. */
9094 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9096 /* Setup the gfc_se structures. */
9097 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9098 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9101 gfc_mark_ss_chain_used (rss
, 1);
9102 if (loop
.temp_ss
== NULL
)
9105 gfc_mark_ss_chain_used (lss
, 1);
9109 lse
.ss
= loop
.temp_ss
;
9110 gfc_mark_ss_chain_used (lss
, 3);
9111 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9114 /* Allow the scalarizer to workshare array assignments. */
9115 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9116 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9118 /* Start the scalarized loop body. */
9119 gfc_start_scalarized_body (&loop
, &body
);
9122 gfc_init_block (&body
);
9124 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9126 /* Translate the expression. */
9127 gfc_conv_expr (&rse
, expr2
);
9129 /* Deal with the case of a scalar class function assigned to a derived type. */
9130 if (gfc_is_alloc_class_scalar_function (expr2
)
9131 && expr1
->ts
.type
== BT_DERIVED
)
9133 rse
.expr
= gfc_class_data_get (rse
.expr
);
9134 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9137 /* Stabilize a string length for temporaries. */
9138 if (expr2
->ts
.type
== BT_CHARACTER
)
9139 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9141 string_length
= NULL_TREE
;
9145 gfc_conv_tmp_array_ref (&lse
);
9146 if (expr2
->ts
.type
== BT_CHARACTER
)
9147 lse
.string_length
= string_length
;
9150 gfc_conv_expr (&lse
, expr1
);
9152 /* Assignments of scalar derived types with allocatable components
9153 to arrays must be done with a deep copy and the rhs temporary
9154 must have its components deallocated afterwards. */
9155 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9156 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9157 && !expr_is_variable (expr2
)
9158 && !gfc_is_constant_expr (expr2
)
9159 && expr1
->rank
&& !expr2
->rank
);
9160 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9162 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9163 && gfc_is_alloc_class_scalar_function (expr2
));
9164 if (scalar_to_array
&& dealloc
)
9166 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9167 gfc_add_expr_to_block (&loop
.post
, tmp
);
9170 /* When assigning a character function result to a deferred-length variable,
9171 the function call must happen before the (re)allocation of the lhs -
9172 otherwise the character length of the result is not known.
9173 NOTE: This relies on having the exact dependence of the length type
9174 parameter available to the caller; gfortran saves it in the .mod files. */
9175 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9176 gfc_add_block_to_block (&block
, &rse
.pre
);
9178 /* Nullify the allocatable components corresponding to those of the lhs
9179 derived type, so that the finalization of the function result does not
9180 affect the lhs of the assignment. Prepend is used to ensure that the
9181 nullification occurs before the call to the finalizer. In the case of
9182 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9183 as part of the deep copy. */
9184 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9185 && (gfc_is_alloc_class_array_function (expr2
)
9186 || gfc_is_alloc_class_scalar_function (expr2
)))
9189 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9190 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9191 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9192 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9195 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9196 l_is_temp
|| init_flag
,
9197 expr_is_variable (expr2
) || scalar_to_array
9198 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
9199 gfc_add_expr_to_block (&body
, tmp
);
9201 if (lss
== gfc_ss_terminator
)
9203 /* F2003: Add the code for reallocation on assignment. */
9204 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9205 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9208 /* Use the scalar assignment as is. */
9209 gfc_add_block_to_block (&block
, &body
);
9213 gcc_assert (lse
.ss
== gfc_ss_terminator
9214 && rse
.ss
== gfc_ss_terminator
);
9218 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9220 /* We need to copy the temporary to the actual lhs. */
9221 gfc_init_se (&lse
, NULL
);
9222 gfc_init_se (&rse
, NULL
);
9223 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9224 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9226 rse
.ss
= loop
.temp_ss
;
9229 gfc_conv_tmp_array_ref (&rse
);
9230 gfc_conv_expr (&lse
, expr1
);
9232 gcc_assert (lse
.ss
== gfc_ss_terminator
9233 && rse
.ss
== gfc_ss_terminator
);
9235 if (expr2
->ts
.type
== BT_CHARACTER
)
9236 rse
.string_length
= string_length
;
9238 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9239 false, false, dealloc
);
9240 gfc_add_expr_to_block (&body
, tmp
);
9243 /* F2003: Allocate or reallocate lhs of allocatable array. */
9244 if (flag_realloc_lhs
9245 && gfc_is_reallocatable_lhs (expr1
)
9246 && !gfc_expr_attr (expr1
).codimension
9247 && !gfc_is_coindexed (expr1
)
9249 && !is_runtime_conformable (expr1
, expr2
))
9251 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9252 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9253 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9254 if (tmp
!= NULL_TREE
)
9255 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9258 /* Generate the copying loops. */
9259 gfc_trans_scalarizing_loops (&loop
, &body
);
9261 /* Wrap the whole thing up. */
9262 gfc_add_block_to_block (&block
, &loop
.pre
);
9263 gfc_add_block_to_block (&block
, &loop
.post
);
9265 gfc_cleanup_loop (&loop
);
9268 return gfc_finish_block (&block
);
9272 /* Check whether EXPR is a copyable array. */
9275 copyable_array_p (gfc_expr
* expr
)
9277 if (expr
->expr_type
!= EXPR_VARIABLE
)
9280 /* First check it's an array. */
9281 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9284 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9287 /* Next check that it's of a simple enough type. */
9288 switch (expr
->ts
.type
)
9300 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9309 /* Translate an assignment. */
9312 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9317 /* Special case a single function returning an array. */
9318 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9320 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9325 /* Special case assigning an array to zero. */
9326 if (copyable_array_p (expr1
)
9327 && is_zero_initializer_p (expr2
))
9329 tmp
= gfc_trans_zero_assign (expr1
);
9334 /* Special case copying one array to another. */
9335 if (copyable_array_p (expr1
)
9336 && copyable_array_p (expr2
)
9337 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9338 && !gfc_check_dependency (expr1
, expr2
, 0))
9340 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9345 /* Special case initializing an array from a constant array constructor. */
9346 if (copyable_array_p (expr1
)
9347 && expr2
->expr_type
== EXPR_ARRAY
9348 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9350 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9355 /* Fallback to the scalarizer to generate explicit loops. */
9356 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9360 gfc_trans_init_assign (gfc_code
* code
)
9362 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9366 gfc_trans_assign (gfc_code
* code
)
9368 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);