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 "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
34 #include "fold-const.h"
35 #include "langhooks.h"
38 #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
, *array_ref
;
276 /* Find the last class reference. */
279 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
281 if (ref
->type
== REF_ARRAY
282 && ref
->u
.ar
.type
!= AR_ELEMENT
)
285 if (ref
->type
== REF_COMPONENT
286 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
288 /* Component to the right of a part reference with nonzero rank
289 must not have the ALLOCATABLE attribute. If attempts are
290 made to reference such a component reference, an error results
291 followed by anICE. */
293 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
)
298 if (ref
->next
== NULL
)
302 /* Remove and store all subsequent references after the
306 tail
= class_ref
->next
;
307 class_ref
->next
= NULL
;
315 base_expr
= gfc_expr_to_initialize (e
);
317 /* Restore the original tail expression. */
320 gfc_free_ref_list (class_ref
->next
);
321 class_ref
->next
= tail
;
325 gfc_free_ref_list (e
->ref
);
332 /* Reset the vptr to the declared type, e.g. after deallocation. */
335 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
342 /* Evaluate the expression and obtain the vptr from it. */
343 gfc_init_se (&se
, NULL
);
345 gfc_conv_expr_descriptor (&se
, e
);
347 gfc_conv_expr (&se
, e
);
348 gfc_add_block_to_block (block
, &se
.pre
);
349 vptr
= gfc_get_vptr_from_expr (se
.expr
);
351 /* If a vptr is not found, we can do nothing more. */
352 if (vptr
== NULL_TREE
)
355 if (UNLIMITED_POLY (e
))
356 gfc_add_modify (block
, vptr
, build_int_cst (TREE_TYPE (vptr
), 0));
359 /* Return the vptr to the address of the declared type. */
360 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
361 vtable
= vtab
->backend_decl
;
362 if (vtable
== NULL_TREE
)
363 vtable
= gfc_get_symbol_decl (vtab
);
364 vtable
= gfc_build_addr_expr (NULL
, vtable
);
365 vtable
= fold_convert (TREE_TYPE (vptr
), vtable
);
366 gfc_add_modify (block
, vptr
, vtable
);
371 /* Reset the len for unlimited polymorphic objects. */
374 gfc_reset_len (stmtblock_t
*block
, gfc_expr
*expr
)
378 e
= gfc_find_and_cut_at_last_class_ref (expr
);
381 gfc_add_len_component (e
);
382 gfc_init_se (&se_len
, NULL
);
383 gfc_conv_expr (&se_len
, e
);
384 gfc_add_modify (block
, se_len
.expr
,
385 fold_convert (TREE_TYPE (se_len
.expr
), integer_zero_node
));
390 /* Obtain the vptr of the last class reference in an expression.
391 Return NULL_TREE if no class reference is found. */
394 gfc_get_vptr_from_expr (tree expr
)
399 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
401 type
= TREE_TYPE (tmp
);
404 if (GFC_CLASS_TYPE_P (type
))
405 return gfc_class_vptr_get (tmp
);
406 if (type
!= TYPE_CANONICAL (type
))
407 type
= TYPE_CANONICAL (type
);
411 if (TREE_CODE (tmp
) == VAR_DECL
)
419 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
422 tree tmp
, tmp2
, type
;
424 gfc_conv_descriptor_data_set (block
, lhs_desc
,
425 gfc_conv_descriptor_data_get (rhs_desc
));
426 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
427 gfc_conv_descriptor_offset_get (rhs_desc
));
429 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
430 gfc_conv_descriptor_dtype (rhs_desc
));
432 /* Assign the dimension as range-ref. */
433 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
434 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
436 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
437 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
438 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
439 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
440 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
441 gfc_add_modify (block
, tmp
, tmp2
);
445 /* Takes a derived type expression and returns the address of a temporary
446 class object of the 'declared' type. If vptr is not NULL, this is
447 used for the temporary class object.
448 optional_alloc_ptr is false when the dummy is neither allocatable
449 nor a pointer; that's only relevant for the optional handling. */
451 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
452 gfc_typespec class_ts
, tree vptr
, bool optional
,
453 bool optional_alloc_ptr
)
456 tree cond_optional
= NULL_TREE
;
462 /* The derived type needs to be converted to a temporary
464 tmp
= gfc_typenode_for_spec (&class_ts
);
465 var
= gfc_create_var (tmp
, "class");
468 ctree
= gfc_class_vptr_get (var
);
470 if (vptr
!= NULL_TREE
)
472 /* Use the dynamic vptr. */
477 /* In this case the vtab corresponds to the derived type and the
478 vptr must point to it. */
479 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
481 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
483 gfc_add_modify (&parmse
->pre
, ctree
,
484 fold_convert (TREE_TYPE (ctree
), tmp
));
486 /* Now set the data field. */
487 ctree
= gfc_class_data_get (var
);
490 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
492 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
494 /* For an array reference in an elemental procedure call we need
495 to retain the ss to provide the scalarized array reference. */
496 gfc_conv_expr_reference (parmse
, e
);
497 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
499 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
501 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
502 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
507 ss
= gfc_walk_expr (e
);
508 if (ss
== gfc_ss_terminator
)
511 gfc_conv_expr_reference (parmse
, e
);
513 /* Scalar to an assumed-rank array. */
514 if (class_ts
.u
.derived
->components
->as
)
517 type
= get_scalar_to_descriptor_type (parmse
->expr
,
519 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
520 gfc_get_dtype (type
));
522 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
523 TREE_TYPE (parmse
->expr
),
524 cond_optional
, parmse
->expr
,
525 fold_convert (TREE_TYPE (parmse
->expr
),
527 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
531 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
533 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
535 fold_convert (TREE_TYPE (tmp
),
537 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
543 gfc_init_block (&block
);
546 gfc_conv_expr_descriptor (parmse
, e
);
548 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
550 gcc_assert (class_ts
.u
.derived
->components
->as
->type
552 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
556 if (gfc_expr_attr (e
).codimension
)
557 parmse
->expr
= fold_build1_loc (input_location
,
561 gfc_add_modify (&block
, ctree
, parmse
->expr
);
566 tmp
= gfc_finish_block (&block
);
568 gfc_init_block (&block
);
569 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
571 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
572 gfc_finish_block (&block
));
573 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
576 gfc_add_block_to_block (&parmse
->pre
, &block
);
580 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
581 && class_ts
.u
.derived
->components
->ts
.u
.derived
582 ->attr
.unlimited_polymorphic
)
584 /* Take care about initializing the _len component correctly. */
585 ctree
= gfc_class_len_get (var
);
586 if (UNLIMITED_POLY (e
))
591 len
= gfc_copy_expr (e
);
592 gfc_add_len_component (len
);
593 gfc_init_se (&se
, NULL
);
594 gfc_conv_expr (&se
, len
);
596 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
.expr
),
597 cond_optional
, se
.expr
,
598 fold_convert (TREE_TYPE (se
.expr
),
604 tmp
= integer_zero_node
;
605 gfc_add_modify (&parmse
->pre
, ctree
, fold_convert (TREE_TYPE (ctree
),
608 /* Pass the address of the class object. */
609 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
611 if (optional
&& optional_alloc_ptr
)
612 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
613 TREE_TYPE (parmse
->expr
),
614 cond_optional
, parmse
->expr
,
615 fold_convert (TREE_TYPE (parmse
->expr
),
620 /* Create a new class container, which is required as scalar coarrays
621 have an array descriptor while normal scalars haven't. Optionally,
622 NULL pointer checks are added if the argument is OPTIONAL. */
625 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
626 gfc_typespec class_ts
, bool optional
)
628 tree var
, ctree
, tmp
;
633 gfc_init_block (&block
);
636 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
638 if (ref
->type
== REF_COMPONENT
639 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
643 if (class_ref
== NULL
644 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
645 tmp
= e
->symtree
->n
.sym
->backend_decl
;
648 /* Remove everything after the last class reference, convert the
649 expression and then recover its tailend once more. */
651 ref
= class_ref
->next
;
652 class_ref
->next
= NULL
;
653 gfc_init_se (&tmpse
, NULL
);
654 gfc_conv_expr (&tmpse
, e
);
655 class_ref
->next
= ref
;
659 var
= gfc_typenode_for_spec (&class_ts
);
660 var
= gfc_create_var (var
, "class");
662 ctree
= gfc_class_vptr_get (var
);
663 gfc_add_modify (&block
, ctree
,
664 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
666 ctree
= gfc_class_data_get (var
);
667 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
668 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
670 /* Pass the address of the class object. */
671 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
675 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
678 tmp
= gfc_finish_block (&block
);
680 gfc_init_block (&block
);
681 tmp2
= gfc_class_data_get (var
);
682 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
684 tmp2
= gfc_finish_block (&block
);
686 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
688 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
691 gfc_add_block_to_block (&parmse
->pre
, &block
);
695 /* Takes an intrinsic type expression and returns the address of a temporary
696 class object of the 'declared' type. */
698 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
699 gfc_typespec class_ts
)
707 /* The intrinsic type needs to be converted to a temporary
709 tmp
= gfc_typenode_for_spec (&class_ts
);
710 var
= gfc_create_var (tmp
, "class");
713 ctree
= gfc_class_vptr_get (var
);
715 vtab
= gfc_find_vtab (&e
->ts
);
717 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
718 gfc_add_modify (&parmse
->pre
, ctree
,
719 fold_convert (TREE_TYPE (ctree
), tmp
));
721 /* Now set the data field. */
722 ctree
= gfc_class_data_get (var
);
723 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
725 /* For an array reference in an elemental procedure call we need
726 to retain the ss to provide the scalarized array reference. */
727 gfc_conv_expr_reference (parmse
, e
);
728 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
729 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
733 ss
= gfc_walk_expr (e
);
734 if (ss
== gfc_ss_terminator
)
737 gfc_conv_expr_reference (parmse
, e
);
738 if (class_ts
.u
.derived
->components
->as
739 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
741 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
743 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
744 TREE_TYPE (ctree
), tmp
);
747 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
748 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
753 parmse
->use_offset
= 1;
754 gfc_conv_expr_descriptor (parmse
, e
);
755 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
757 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
758 TREE_TYPE (ctree
), parmse
->expr
);
759 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
762 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
766 gcc_assert (class_ts
.type
== BT_CLASS
);
767 if (class_ts
.u
.derived
->components
->ts
.type
== BT_DERIVED
768 && class_ts
.u
.derived
->components
->ts
.u
.derived
769 ->attr
.unlimited_polymorphic
)
771 ctree
= gfc_class_len_get (var
);
772 /* When the actual arg is a char array, then set the _len component of the
773 unlimited polymorphic entity, too. */
774 if (e
->ts
.type
== BT_CHARACTER
)
776 /* Start with parmse->string_length because this seems to be set to a
777 correct value more often. */
778 if (parmse
->string_length
)
779 tmp
= parmse
->string_length
;
780 /* When the string_length is not yet set, then try the backend_decl of
782 else if (e
->ts
.u
.cl
->backend_decl
)
783 tmp
= e
->ts
.u
.cl
->backend_decl
;
784 /* If both of the above approaches fail, then try to generate an
785 expression from the input, which is only feasible currently, when the
786 expression can be evaluated to a constant one. */
789 /* Try to simplify the expression. */
790 gfc_simplify_expr (e
, 0);
791 if (e
->expr_type
== EXPR_CONSTANT
&& !e
->ts
.u
.cl
->resolved
)
793 /* Amazingly all data is present to compute the length of a
794 constant string, but the expression is not yet there. */
795 e
->ts
.u
.cl
->length
= gfc_get_constant_expr (BT_INTEGER
, 4,
797 mpz_set_ui (e
->ts
.u
.cl
->length
->value
.integer
,
798 e
->value
.character
.length
);
799 gfc_conv_const_charlen (e
->ts
.u
.cl
);
800 e
->ts
.u
.cl
->resolved
= 1;
801 tmp
= e
->ts
.u
.cl
->backend_decl
;
805 gfc_error ("Can't compute the length of the char array at %L.",
811 tmp
= integer_zero_node
;
813 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
815 else if (class_ts
.type
== BT_CLASS
816 && class_ts
.u
.derived
->components
817 && class_ts
.u
.derived
->components
->ts
.u
818 .derived
->attr
.unlimited_polymorphic
)
820 ctree
= gfc_class_len_get (var
);
821 gfc_add_modify (&parmse
->pre
, ctree
,
822 fold_convert (TREE_TYPE (ctree
),
825 /* Pass the address of the class object. */
826 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
830 /* Takes a scalarized class array expression and returns the
831 address of a temporary scalar class object of the 'declared'
833 OOP-TODO: This could be improved by adding code that branched on
834 the dynamic type being the same as the declared type. In this case
835 the original class expression can be passed directly.
836 optional_alloc_ptr is false when the dummy is neither allocatable
837 nor a pointer; that's relevant for the optional handling.
838 Set copyback to true if class container's _data and _vtab pointers
839 might get modified. */
842 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
843 bool elemental
, bool copyback
, bool optional
,
844 bool optional_alloc_ptr
)
850 tree cond
= NULL_TREE
;
851 tree slen
= NULL_TREE
;
855 bool full_array
= false;
857 gfc_init_block (&block
);
860 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
862 if (ref
->type
== REF_COMPONENT
863 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
866 if (ref
->next
== NULL
)
870 if ((ref
== NULL
|| class_ref
== ref
)
871 && (!class_ts
.u
.derived
->components
->as
872 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
875 /* Test for FULL_ARRAY. */
876 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
877 && gfc_expr_attr (e
).dimension
)
880 gfc_is_class_array_ref (e
, &full_array
);
882 /* The derived type needs to be converted to a temporary
884 tmp
= gfc_typenode_for_spec (&class_ts
);
885 var
= gfc_create_var (tmp
, "class");
888 ctree
= gfc_class_data_get (var
);
889 if (class_ts
.u
.derived
->components
->as
890 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
894 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
896 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
897 gfc_get_dtype (type
));
899 tmp
= gfc_class_data_get (parmse
->expr
);
900 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
901 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
903 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
906 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
910 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
911 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
912 TREE_TYPE (ctree
), parmse
->expr
);
913 gfc_add_modify (&block
, ctree
, parmse
->expr
);
916 /* Return the data component, except in the case of scalarized array
917 references, where nullification of the cannot occur and so there
919 if (!elemental
&& full_array
&& copyback
)
921 if (class_ts
.u
.derived
->components
->as
922 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
925 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
926 gfc_conv_descriptor_data_get (ctree
));
928 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
931 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
935 ctree
= gfc_class_vptr_get (var
);
937 /* The vptr is the second field of the actual argument.
938 First we have to find the corresponding class reference. */
941 if (class_ref
== NULL
942 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
944 tmp
= e
->symtree
->n
.sym
->backend_decl
;
945 if (DECL_LANG_SPECIFIC (tmp
) && GFC_DECL_SAVED_DESCRIPTOR (tmp
))
946 tmp
= GFC_DECL_SAVED_DESCRIPTOR (tmp
);
947 slen
= integer_zero_node
;
951 /* Remove everything after the last class reference, convert the
952 expression and then recover its tailend once more. */
954 ref
= class_ref
->next
;
955 class_ref
->next
= NULL
;
956 gfc_init_se (&tmpse
, NULL
);
957 gfc_conv_expr (&tmpse
, e
);
958 class_ref
->next
= ref
;
960 slen
= tmpse
.string_length
;
963 gcc_assert (tmp
!= NULL_TREE
);
965 /* Dereference if needs be. */
966 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
967 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
969 vptr
= gfc_class_vptr_get (tmp
);
970 gfc_add_modify (&block
, ctree
,
971 fold_convert (TREE_TYPE (ctree
), vptr
));
973 /* Return the vptr component, except in the case of scalarized array
974 references, where the dynamic type cannot change. */
975 if (!elemental
&& full_array
&& copyback
)
976 gfc_add_modify (&parmse
->post
, vptr
,
977 fold_convert (TREE_TYPE (vptr
), ctree
));
979 /* For unlimited polymorphic objects also set the _len component. */
980 if (class_ts
.type
== BT_CLASS
981 && class_ts
.u
.derived
->components
982 && class_ts
.u
.derived
->components
->ts
.u
983 .derived
->attr
.unlimited_polymorphic
)
985 ctree
= gfc_class_len_get (var
);
986 if (UNLIMITED_POLY (e
))
987 tmp
= gfc_class_len_get (tmp
);
988 else if (e
->ts
.type
== BT_CHARACTER
)
990 gcc_assert (slen
!= NULL_TREE
);
994 tmp
= integer_zero_node
;
995 gfc_add_modify (&parmse
->pre
, ctree
,
996 fold_convert (TREE_TYPE (ctree
), tmp
));
1003 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
1004 /* parmse->pre may contain some preparatory instructions for the
1005 temporary array descriptor. Those may only be executed when the
1006 optional argument is set, therefore add parmse->pre's instructions
1007 to block, which is later guarded by an if (optional_arg_given). */
1008 gfc_add_block_to_block (&parmse
->pre
, &block
);
1009 block
.head
= parmse
->pre
.head
;
1010 parmse
->pre
.head
= NULL_TREE
;
1011 tmp
= gfc_finish_block (&block
);
1013 if (optional_alloc_ptr
)
1014 tmp2
= build_empty_stmt (input_location
);
1017 gfc_init_block (&block
);
1019 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
1020 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
1021 null_pointer_node
));
1022 tmp2
= gfc_finish_block (&block
);
1025 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
1027 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
1030 gfc_add_block_to_block (&parmse
->pre
, &block
);
1032 /* Pass the address of the class object. */
1033 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
1035 if (optional
&& optional_alloc_ptr
)
1036 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
1037 TREE_TYPE (parmse
->expr
),
1039 fold_convert (TREE_TYPE (parmse
->expr
),
1040 null_pointer_node
));
1044 /* Given a class array declaration and an index, returns the address
1045 of the referenced element. */
1048 gfc_get_class_array_ref (tree index
, tree class_decl
, tree data_comp
)
1050 tree data
= data_comp
!= NULL_TREE
? data_comp
:
1051 gfc_class_data_get (class_decl
);
1052 tree size
= gfc_class_vtab_size_get (class_decl
);
1053 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
1054 gfc_array_index_type
,
1057 data
= gfc_conv_descriptor_data_get (data
);
1058 ptr
= fold_convert (pvoid_type_node
, data
);
1059 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
1060 return fold_convert (TREE_TYPE (data
), ptr
);
1064 /* Copies one class expression to another, assuming that if either
1065 'to' or 'from' are arrays they are packed. Should 'from' be
1066 NULL_TREE, the initialization expression for 'to' is used, assuming
1067 that the _vptr is set. */
1070 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
, bool unlimited
)
1080 vec
<tree
, va_gc
> *args
;
1085 bool is_from_desc
= false, is_to_class
= false;
1088 /* To prevent warnings on uninitialized variables. */
1089 from_len
= to_len
= NULL_TREE
;
1091 if (from
!= NULL_TREE
)
1092 fcn
= gfc_class_vtab_copy_get (from
);
1094 fcn
= gfc_class_vtab_copy_get (to
);
1096 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
1098 if (from
!= NULL_TREE
)
1100 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from
));
1104 from
= GFC_DECL_SAVED_DESCRIPTOR (from
);
1108 from_data
= gfc_class_data_get (from
);
1109 is_from_desc
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
));
1113 from_data
= gfc_class_vtab_def_init_get (to
);
1117 if (from
!= NULL_TREE
&& unlimited
)
1118 from_len
= gfc_class_len_get (from
);
1120 from_len
= integer_zero_node
;
1123 if (GFC_CLASS_TYPE_P (TREE_TYPE (to
)))
1126 to_data
= gfc_class_data_get (to
);
1128 to_len
= gfc_class_len_get (to
);
1131 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1134 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
1136 stmtblock_t loopbody
;
1141 gfc_init_block (&body
);
1142 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1143 gfc_array_index_type
, nelems
,
1144 gfc_index_one_node
);
1145 nelems
= gfc_evaluate_now (tmp
, &body
);
1146 index
= gfc_create_var (gfc_array_index_type
, "S");
1150 from_ref
= gfc_get_class_array_ref (index
, from
, from_data
);
1151 vec_safe_push (args
, from_ref
);
1154 vec_safe_push (args
, from_data
);
1157 to_ref
= gfc_get_class_array_ref (index
, to
, to_data
);
1160 tmp
= gfc_conv_array_data (to
);
1161 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1162 to_ref
= gfc_build_addr_expr (NULL_TREE
,
1163 gfc_build_array_ref (tmp
, index
, to
));
1165 vec_safe_push (args
, to_ref
);
1167 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1169 /* Build the body of the loop. */
1170 gfc_init_block (&loopbody
);
1171 gfc_add_expr_to_block (&loopbody
, tmp
);
1173 /* Build the loop and return. */
1174 gfc_init_loopinfo (&loop
);
1176 loop
.from
[0] = gfc_index_zero_node
;
1177 loop
.loopvar
[0] = index
;
1178 loop
.to
[0] = nelems
;
1179 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1180 gfc_init_block (&ifbody
);
1181 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1182 stdcopy
= gfc_finish_block (&ifbody
);
1183 /* In initialization mode from_len is a constant zero. */
1184 if (unlimited
&& !integer_zerop (from_len
))
1186 vec_safe_push (args
, from_len
);
1187 vec_safe_push (args
, to_len
);
1188 tmp
= build_call_vec (fcn_type
, fcn
, args
);
1189 /* Build the body of the loop. */
1190 gfc_init_block (&loopbody
);
1191 gfc_add_expr_to_block (&loopbody
, tmp
);
1193 /* Build the loop and return. */
1194 gfc_init_loopinfo (&loop
);
1196 loop
.from
[0] = gfc_index_zero_node
;
1197 loop
.loopvar
[0] = index
;
1198 loop
.to
[0] = nelems
;
1199 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
1200 gfc_init_block (&ifbody
);
1201 gfc_add_block_to_block (&ifbody
, &loop
.pre
);
1202 extcopy
= gfc_finish_block (&ifbody
);
1204 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1205 boolean_type_node
, from_len
,
1207 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1208 void_type_node
, tmp
, extcopy
, stdcopy
);
1209 gfc_add_expr_to_block (&body
, tmp
);
1210 tmp
= gfc_finish_block (&body
);
1214 gfc_add_expr_to_block (&body
, stdcopy
);
1215 tmp
= gfc_finish_block (&body
);
1217 gfc_cleanup_loop (&loop
);
1221 gcc_assert (!is_from_desc
);
1222 vec_safe_push (args
, from_data
);
1223 vec_safe_push (args
, to_data
);
1224 stdcopy
= build_call_vec (fcn_type
, fcn
, args
);
1226 /* In initialization mode from_len is a constant zero. */
1227 if (unlimited
&& !integer_zerop (from_len
))
1229 vec_safe_push (args
, from_len
);
1230 vec_safe_push (args
, to_len
);
1231 extcopy
= build_call_vec (fcn_type
, fcn
, args
);
1232 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
1233 boolean_type_node
, from_len
,
1235 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1236 void_type_node
, tmp
, extcopy
, stdcopy
);
1242 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1243 if (from
== NULL_TREE
)
1246 cond
= fold_build2_loc (input_location
, NE_EXPR
,
1248 from_data
, null_pointer_node
);
1249 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
1250 void_type_node
, cond
,
1251 tmp
, build_empty_stmt (input_location
));
1259 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
1261 gfc_actual_arglist
*actual
;
1266 actual
= gfc_get_actual_arglist ();
1267 actual
->expr
= gfc_copy_expr (rhs
);
1268 actual
->next
= gfc_get_actual_arglist ();
1269 actual
->next
->expr
= gfc_copy_expr (lhs
);
1270 ppc
= gfc_copy_expr (obj
);
1271 gfc_add_vptr_component (ppc
);
1272 gfc_add_component_ref (ppc
, "_copy");
1273 ppc_code
= gfc_get_code (EXEC_CALL
);
1274 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
1275 /* Although '_copy' is set to be elemental in class.c, it is
1276 not staying that way. Find out why, sometime.... */
1277 ppc_code
->resolved_sym
->attr
.elemental
= 1;
1278 ppc_code
->ext
.actual
= actual
;
1279 ppc_code
->expr1
= ppc
;
1280 /* Since '_copy' is elemental, the scalarizer will take care
1281 of arrays in gfc_trans_call. */
1282 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
1283 gfc_free_statements (ppc_code
);
1285 if (UNLIMITED_POLY(obj
))
1287 /* Check if rhs is non-NULL. */
1289 gfc_init_se (&src
, NULL
);
1290 gfc_conv_expr (&src
, rhs
);
1291 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1292 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1293 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
1294 null_pointer_node
));
1295 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
1296 build_empty_stmt (input_location
));
1302 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1303 A MEMCPY is needed to copy the full data from the default initializer
1304 of the dynamic type. */
1307 gfc_trans_class_init_assign (gfc_code
*code
)
1311 gfc_se dst
,src
,memsz
;
1312 gfc_expr
*lhs
, *rhs
, *sz
;
1314 gfc_start_block (&block
);
1316 lhs
= gfc_copy_expr (code
->expr1
);
1317 gfc_add_data_component (lhs
);
1319 rhs
= gfc_copy_expr (code
->expr1
);
1320 gfc_add_vptr_component (rhs
);
1322 /* Make sure that the component backend_decls have been built, which
1323 will not have happened if the derived types concerned have not
1325 gfc_get_derived_type (rhs
->ts
.u
.derived
);
1326 gfc_add_def_init_component (rhs
);
1327 /* The _def_init is always scalar. */
1330 if (code
->expr1
->ts
.type
== BT_CLASS
1331 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
1332 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
1335 sz
= gfc_copy_expr (code
->expr1
);
1336 gfc_add_vptr_component (sz
);
1337 gfc_add_size_component (sz
);
1339 gfc_init_se (&dst
, NULL
);
1340 gfc_init_se (&src
, NULL
);
1341 gfc_init_se (&memsz
, NULL
);
1342 gfc_conv_expr (&dst
, lhs
);
1343 gfc_conv_expr (&src
, rhs
);
1344 gfc_conv_expr (&memsz
, sz
);
1345 gfc_add_block_to_block (&block
, &src
.pre
);
1346 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1348 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1350 if (UNLIMITED_POLY(code
->expr1
))
1352 /* Check if _def_init is non-NULL. */
1353 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1354 boolean_type_node
, src
.expr
,
1355 fold_convert (TREE_TYPE (src
.expr
),
1356 null_pointer_node
));
1357 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1358 tmp
, build_empty_stmt (input_location
));
1362 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1363 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1365 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1366 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1368 build_empty_stmt (input_location
));
1371 gfc_add_expr_to_block (&block
, tmp
);
1373 return gfc_finish_block (&block
);
1377 /* Translate an assignment to a CLASS object
1378 (pointer or ordinary assignment). */
1381 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1389 gfc_start_block (&block
);
1392 while (ref
&& ref
->next
)
1395 /* Class valued proc_pointer assignments do not need any further
1397 if (ref
&& ref
->type
== REF_COMPONENT
1398 && ref
->u
.c
.component
->attr
.proc_pointer
1399 && expr2
->expr_type
== EXPR_VARIABLE
1400 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1401 && op
== EXEC_POINTER_ASSIGN
)
1404 if (expr2
->ts
.type
!= BT_CLASS
)
1406 /* Insert an additional assignment which sets the '_vptr' field. */
1407 gfc_symbol
*vtab
= NULL
;
1410 lhs
= gfc_copy_expr (expr1
);
1411 gfc_add_vptr_component (lhs
);
1413 if (UNLIMITED_POLY (expr1
)
1414 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1416 rhs
= gfc_get_null_expr (&expr2
->where
);
1420 if (expr2
->expr_type
== EXPR_NULL
)
1421 vtab
= gfc_find_vtab (&expr1
->ts
);
1423 vtab
= gfc_find_vtab (&expr2
->ts
);
1426 rhs
= gfc_get_expr ();
1427 rhs
->expr_type
= EXPR_VARIABLE
;
1428 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1432 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1433 gfc_add_expr_to_block (&block
, tmp
);
1435 gfc_free_expr (lhs
);
1436 gfc_free_expr (rhs
);
1438 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1440 /* F2003:C717 only sequence and bind-C types can come here. */
1441 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1442 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1443 gfc_add_data_component (expr2
);
1446 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1448 /* Insert an additional assignment which sets the '_vptr' field. */
1449 lhs
= gfc_copy_expr (expr1
);
1450 gfc_add_vptr_component (lhs
);
1452 rhs
= gfc_copy_expr (expr2
);
1453 gfc_add_vptr_component (rhs
);
1455 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1456 gfc_add_expr_to_block (&block
, tmp
);
1458 gfc_free_expr (lhs
);
1459 gfc_free_expr (rhs
);
1462 /* Do the actual CLASS assignment. */
1463 if (expr2
->ts
.type
== BT_CLASS
1464 && !CLASS_DATA (expr2
)->attr
.dimension
)
1466 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1467 || !CLASS_DATA (expr2
)->attr
.dimension
)
1468 gfc_add_data_component (expr1
);
1472 if (op
== EXEC_ASSIGN
)
1473 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1474 else if (op
== EXEC_POINTER_ASSIGN
)
1475 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1479 gfc_add_expr_to_block (&block
, tmp
);
1481 return gfc_finish_block (&block
);
1485 /* End of prototype trans-class.c */
1489 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1491 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1492 gfc_warning (OPT_Wrealloc_lhs
,
1493 "Code for reallocating the allocatable array at %L will "
1495 else if (warn_realloc_lhs_all
)
1496 gfc_warning (OPT_Wrealloc_lhs_all
,
1497 "Code for reallocating the allocatable variable at %L "
1498 "will be added", where
);
1502 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1505 /* Copy the scalarization loop variables. */
1508 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1511 dest
->loop
= src
->loop
;
1515 /* Initialize a simple expression holder.
1517 Care must be taken when multiple se are created with the same parent.
1518 The child se must be kept in sync. The easiest way is to delay creation
1519 of a child se until after after the previous se has been translated. */
1522 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1524 memset (se
, 0, sizeof (gfc_se
));
1525 gfc_init_block (&se
->pre
);
1526 gfc_init_block (&se
->post
);
1528 se
->parent
= parent
;
1531 gfc_copy_se_loopvars (se
, parent
);
1535 /* Advances to the next SS in the chain. Use this rather than setting
1536 se->ss = se->ss->next because all the parents needs to be kept in sync.
1540 gfc_advance_se_ss_chain (gfc_se
* se
)
1545 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1548 /* Walk down the parent chain. */
1551 /* Simple consistency check. */
1552 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1553 || p
->parent
->ss
->nested_ss
== p
->ss
);
1555 /* If we were in a nested loop, the next scalarized expression can be
1556 on the parent ss' next pointer. Thus we should not take the next
1557 pointer blindly, but rather go up one nest level as long as next
1558 is the end of chain. */
1560 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1570 /* Ensures the result of the expression as either a temporary variable
1571 or a constant so that it can be used repeatedly. */
1574 gfc_make_safe_expr (gfc_se
* se
)
1578 if (CONSTANT_CLASS_P (se
->expr
))
1581 /* We need a temporary for this result. */
1582 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1583 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1588 /* Return an expression which determines if a dummy parameter is present.
1589 Also used for arguments to procedures with multiple entry points. */
1592 gfc_conv_expr_present (gfc_symbol
* sym
)
1596 gcc_assert (sym
->attr
.dummy
);
1597 decl
= gfc_get_symbol_decl (sym
);
1599 /* Intrinsic scalars with VALUE attribute which are passed by value
1600 use a hidden argument to denote the present status. */
1601 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1602 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1603 && !sym
->attr
.dimension
)
1605 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1608 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1610 strcpy (&name
[1], sym
->name
);
1611 tree_name
= get_identifier (name
);
1613 /* Walk function argument list to find hidden arg. */
1614 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1615 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1616 if (DECL_NAME (cond
) == tree_name
)
1623 if (TREE_CODE (decl
) != PARM_DECL
)
1625 /* Array parameters use a temporary descriptor, we want the real
1627 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1628 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1629 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1632 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1633 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1635 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1636 as actual argument to denote absent dummies. For array descriptors,
1637 we thus also need to check the array descriptor. For BT_CLASS, it
1638 can also occur for scalars and F2003 due to type->class wrapping and
1639 class->class wrapping. Note further that BT_CLASS always uses an
1640 array descriptor for arrays, also for explicit-shape/assumed-size. */
1642 if (!sym
->attr
.allocatable
1643 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1644 || (sym
->ts
.type
== BT_CLASS
1645 && !CLASS_DATA (sym
)->attr
.allocatable
1646 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1647 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1648 || sym
->ts
.type
== BT_CLASS
))
1652 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1653 || sym
->as
->type
== AS_ASSUMED_RANK
1654 || sym
->attr
.codimension
))
1655 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1657 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1658 if (sym
->ts
.type
== BT_CLASS
)
1659 tmp
= gfc_class_data_get (tmp
);
1660 tmp
= gfc_conv_array_data (tmp
);
1662 else if (sym
->ts
.type
== BT_CLASS
)
1663 tmp
= gfc_class_data_get (decl
);
1667 if (tmp
!= NULL_TREE
)
1669 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1670 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1671 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1672 boolean_type_node
, cond
, tmp
);
1680 /* Converts a missing, dummy argument into a null or zero. */
1683 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1688 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1692 /* Create a temporary and convert it to the correct type. */
1693 tmp
= gfc_get_int_type (kind
);
1694 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1697 /* Test for a NULL value. */
1698 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1699 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1700 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1701 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1705 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1707 build_zero_cst (TREE_TYPE (se
->expr
)));
1708 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1712 if (ts
.type
== BT_CHARACTER
)
1714 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1715 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1716 present
, se
->string_length
, tmp
);
1717 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1718 se
->string_length
= tmp
;
1724 /* Get the character length of an expression, looking through gfc_refs
1728 gfc_get_expr_charlen (gfc_expr
*e
)
1733 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1734 && e
->ts
.type
== BT_CHARACTER
);
1736 length
= NULL
; /* To silence compiler warning. */
1738 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1741 gfc_init_se (&tmpse
, NULL
);
1742 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1743 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1747 /* First candidate: if the variable is of type CHARACTER, the
1748 expression's length could be the length of the character
1750 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1751 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1753 /* Look through the reference chain for component references. */
1754 for (r
= e
->ref
; r
; r
= r
->next
)
1759 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1760 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1768 /* We should never got substring references here. These will be
1769 broken down by the scalarizer. */
1775 gcc_assert (length
!= NULL
);
1780 /* Return for an expression the backend decl of the coarray. */
1783 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1787 gfc_ref
*ref
, *comp_ref
= NULL
;
1789 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1791 /* Not-implemented diagnostic. */
1792 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1793 if (ref
->type
== REF_COMPONENT
)
1796 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1797 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
1798 && (CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
1799 || CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
1800 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1801 && !ref
->u
.c
.component
->attr
.codimension
1802 && (ref
->u
.c
.component
->attr
.pointer
1803 || ref
->u
.c
.component
->attr
.allocatable
)))
1804 gfc_error ("Sorry, coindexed access to a pointer or allocatable "
1805 "component of the coindexed coarray at %L is not yet "
1806 "supported", &expr
->where
);
1809 && ((expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1810 && CLASS_DATA (expr
->symtree
->n
.sym
)->attr
.alloc_comp
)
1811 || (expr
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
1812 && expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)))
1814 && ((comp_ref
->u
.c
.component
->ts
.type
== BT_CLASS
1815 && CLASS_DATA (comp_ref
->u
.c
.component
)->attr
.alloc_comp
)
1816 || (comp_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
1817 && comp_ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
))))
1818 gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
1819 "not yet supported", &expr
->where
);
1823 /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
1824 general not possible as the required stride multiplier might be not
1825 a multiple of c_sizeof(b). In case of noncoindexed access, the
1826 scalarizer often takes care of it - for coarrays, it always fails. */
1827 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1828 if (ref
->type
== REF_COMPONENT
1829 && ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
1830 && CLASS_DATA (ref
->u
.c
.component
)->attr
.codimension
)
1831 || (ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1832 && ref
->u
.c
.component
->attr
.codimension
)))
1836 for ( ; ref
; ref
= ref
->next
)
1837 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.dimen
)
1839 for ( ; ref
; ref
= ref
->next
)
1840 if (ref
->type
== REF_COMPONENT
)
1841 gfc_error ("Sorry, coindexed access at %L to a scalar component "
1842 "with an array partref is not yet supported",
1846 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1847 gcc_assert (caf_decl
);
1848 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1849 caf_decl
= gfc_class_data_get (caf_decl
);
1850 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1853 /* The following code assumes that the coarray is a component reachable via
1854 only scalar components/variables; the Fortran standard guarantees this. */
1856 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1857 if (ref
->type
== REF_COMPONENT
)
1859 gfc_component
*comp
= ref
->u
.c
.component
;
1861 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1862 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1863 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1864 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1865 comp
->backend_decl
, NULL_TREE
);
1866 if (comp
->ts
.type
== BT_CLASS
)
1867 caf_decl
= gfc_class_data_get (caf_decl
);
1868 if (comp
->attr
.codimension
)
1874 gcc_assert (found
&& caf_decl
);
1879 /* Obtain the Coarray token - and optionally also the offset. */
1882 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1887 /* Coarray token. */
1888 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1890 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1891 == GFC_ARRAY_ALLOCATABLE
1892 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1893 *token
= gfc_conv_descriptor_token (caf_decl
);
1895 else if (DECL_LANG_SPECIFIC (caf_decl
)
1896 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1897 *token
= GFC_DECL_TOKEN (caf_decl
);
1900 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1901 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1902 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1908 /* Offset between the coarray base address and the address wanted. */
1909 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1910 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1911 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1912 *offset
= build_int_cst (gfc_array_index_type
, 0);
1913 else if (DECL_LANG_SPECIFIC (caf_decl
)
1914 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1915 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1916 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1917 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1919 *offset
= build_int_cst (gfc_array_index_type
, 0);
1921 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1922 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1924 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1925 tmp
= gfc_conv_descriptor_data_get (tmp
);
1927 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1928 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1931 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1935 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1936 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1938 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1939 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1942 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1946 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1947 fold_convert (gfc_array_index_type
, *offset
),
1948 fold_convert (gfc_array_index_type
, tmp
));
1952 /* Convert the coindex of a coarray into an image index; the result is
1953 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1954 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1957 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1960 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1964 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1965 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1967 gcc_assert (ref
!= NULL
);
1969 img_idx
= integer_zero_node
;
1970 extent
= integer_one_node
;
1971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1972 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1974 gfc_init_se (&se
, NULL
);
1975 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1976 gfc_add_block_to_block (block
, &se
.pre
);
1977 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1978 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1979 integer_type_node
, se
.expr
,
1980 fold_convert(integer_type_node
, lbound
));
1981 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1983 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1985 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1987 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1988 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1989 tmp
= fold_convert (integer_type_node
, tmp
);
1990 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1991 integer_type_node
, extent
, tmp
);
1995 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1997 gfc_init_se (&se
, NULL
);
1998 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1999 gfc_add_block_to_block (block
, &se
.pre
);
2000 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
2001 lbound
= fold_convert (integer_type_node
, lbound
);
2002 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2003 integer_type_node
, se
.expr
, lbound
);
2004 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
2006 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2008 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
2010 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
2011 ubound
= fold_convert (integer_type_node
, ubound
);
2012 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2013 integer_type_node
, ubound
, lbound
);
2014 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2015 tmp
, integer_one_node
);
2016 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
2017 integer_type_node
, extent
, tmp
);
2020 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
2021 img_idx
, integer_one_node
);
2026 /* For each character array constructor subexpression without a ts.u.cl->length,
2027 replace it by its first element (if there aren't any elements, the length
2028 should already be set to zero). */
2031 flatten_array_ctors_without_strlen (gfc_expr
* e
)
2033 gfc_actual_arglist
* arg
;
2039 switch (e
->expr_type
)
2043 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
2044 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
2048 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2052 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2053 flatten_array_ctors_without_strlen (arg
->expr
);
2058 /* We've found what we're looking for. */
2059 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
2064 gcc_assert (e
->value
.constructor
);
2066 c
= gfc_constructor_first (e
->value
.constructor
);
2070 flatten_array_ctors_without_strlen (new_expr
);
2071 gfc_replace_expr (e
, new_expr
);
2075 /* Otherwise, fall through to handle constructor elements. */
2076 case EXPR_STRUCTURE
:
2077 for (c
= gfc_constructor_first (e
->value
.constructor
);
2078 c
; c
= gfc_constructor_next (c
))
2079 flatten_array_ctors_without_strlen (c
->expr
);
2089 /* Generate code to initialize a string length variable. Returns the
2090 value. For array constructors, cl->length might be NULL and in this case,
2091 the first element of the constructor is needed. expr is the original
2092 expression so we can access it but can be NULL if this is not needed. */
2095 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
2099 gfc_init_se (&se
, NULL
);
2103 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
2106 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2107 "flatten" array constructors by taking their first element; all elements
2108 should be the same length or a cl->length should be present. */
2111 gfc_expr
* expr_flat
;
2113 expr_flat
= gfc_copy_expr (expr
);
2114 flatten_array_ctors_without_strlen (expr_flat
);
2115 gfc_resolve_expr (expr_flat
);
2117 gfc_conv_expr (&se
, expr_flat
);
2118 gfc_add_block_to_block (pblock
, &se
.pre
);
2119 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
2121 gfc_free_expr (expr_flat
);
2125 /* Convert cl->length. */
2127 gcc_assert (cl
->length
);
2129 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
2130 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2131 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
2132 gfc_add_block_to_block (pblock
, &se
.pre
);
2134 if (cl
->backend_decl
)
2135 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
2137 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
2142 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
2143 const char *name
, locus
*where
)
2153 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
2154 type
= build_pointer_type (type
);
2156 gfc_init_se (&start
, se
);
2157 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
2158 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
2160 if (integer_onep (start
.expr
))
2161 gfc_conv_string_parameter (se
);
2166 /* Avoid multiple evaluation of substring start. */
2167 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2168 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
2170 /* Change the start of the string. */
2171 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
2174 tmp
= build_fold_indirect_ref_loc (input_location
,
2176 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
2177 se
->expr
= gfc_build_addr_expr (type
, tmp
);
2180 /* Length = end + 1 - start. */
2181 gfc_init_se (&end
, se
);
2182 if (ref
->u
.ss
.end
== NULL
)
2183 end
.expr
= se
->string_length
;
2186 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
2187 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
2191 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
2192 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
2194 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2196 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
2197 boolean_type_node
, start
.expr
,
2200 /* Check lower bound. */
2201 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
2203 build_int_cst (gfc_charlen_type_node
, 1));
2204 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2205 boolean_type_node
, nonempty
, fault
);
2207 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2208 "is less than one", name
);
2210 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
2211 "is less than one");
2212 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2213 fold_convert (long_integer_type_node
,
2217 /* Check upper bound. */
2218 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
2219 end
.expr
, se
->string_length
);
2220 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
2221 boolean_type_node
, nonempty
, fault
);
2223 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2224 "exceeds string length (%%ld)", name
);
2226 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
2227 "exceeds string length (%%ld)");
2228 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
2229 fold_convert (long_integer_type_node
, end
.expr
),
2230 fold_convert (long_integer_type_node
,
2231 se
->string_length
));
2235 /* Try to calculate the length from the start and end expressions. */
2237 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
2241 i_len
= mpz_get_si (length
) + 1;
2245 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
2246 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
2250 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
2251 end
.expr
, start
.expr
);
2252 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
2253 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
2254 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
2255 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
2258 se
->string_length
= tmp
;
2262 /* Convert a derived type component reference. */
2265 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
2272 c
= ref
->u
.c
.component
;
2274 if (c
->backend_decl
== NULL_TREE
2275 && ref
->u
.c
.sym
!= NULL
)
2276 gfc_get_derived_type (ref
->u
.c
.sym
);
2278 field
= c
->backend_decl
;
2279 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
2282 /* Components can correspond to fields of different containing
2283 types, as components are created without context, whereas
2284 a concrete use of a component has the type of decl as context.
2285 So, if the type doesn't match, we search the corresponding
2286 FIELD_DECL in the parent type. To not waste too much time
2287 we cache this result in norestrict_decl. */
2289 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
2291 tree f2
= c
->norestrict_decl
;
2292 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
2293 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
2294 if (TREE_CODE (f2
) == FIELD_DECL
2295 && DECL_NAME (f2
) == DECL_NAME (field
))
2298 c
->norestrict_decl
= f2
;
2302 if (ref
->u
.c
.sym
&& ref
->u
.c
.sym
->ts
.type
== BT_CLASS
2303 && strcmp ("_data", c
->name
) == 0)
2305 /* Found a ref to the _data component. Store the associated ref to
2306 the vptr in se->class_vptr. */
2307 se
->class_vptr
= gfc_class_vptr_get (decl
);
2310 se
->class_vptr
= NULL_TREE
;
2312 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
2313 decl
, field
, NULL_TREE
);
2317 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2318 strlen () conditional below. */
2319 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
2320 && !(c
->attr
.allocatable
&& c
->ts
.deferred
))
2322 tmp
= c
->ts
.u
.cl
->backend_decl
;
2323 /* Components must always be constant length. */
2324 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
2325 se
->string_length
= tmp
;
2328 if (gfc_deferred_strlen (c
, &field
))
2330 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2332 decl
, field
, NULL_TREE
);
2333 se
->string_length
= tmp
;
2336 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
2337 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
2338 && c
->ts
.type
!= BT_CHARACTER
)
2339 || c
->attr
.proc_pointer
)
2340 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2345 /* This function deals with component references to components of the
2346 parent type for derived type extensions. */
2348 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
2356 c
= ref
->u
.c
.component
;
2358 /* Return if the component is in the parent type. */
2359 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
2360 if (strcmp (c
->name
, cmp
->name
) == 0)
2363 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2364 parent
.type
= REF_COMPONENT
;
2366 parent
.u
.c
.sym
= dt
;
2367 parent
.u
.c
.component
= dt
->components
;
2369 if (dt
->backend_decl
== NULL
)
2370 gfc_get_derived_type (dt
);
2372 /* Build the reference and call self. */
2373 gfc_conv_component_ref (se
, &parent
);
2374 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
2375 parent
.u
.c
.component
= c
;
2376 conv_parent_component_references (se
, &parent
);
2379 /* Return the contents of a variable. Also handles reference/pointer
2380 variables (all Fortran pointer references are implicit). */
2383 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
2388 tree parent_decl
= NULL_TREE
;
2391 bool alternate_entry
;
2394 bool first_time
= true;
2396 sym
= expr
->symtree
->n
.sym
;
2397 is_classarray
= IS_CLASS_ARRAY (sym
);
2401 gfc_ss_info
*ss_info
= ss
->info
;
2403 /* Check that something hasn't gone horribly wrong. */
2404 gcc_assert (ss
!= gfc_ss_terminator
);
2405 gcc_assert (ss_info
->expr
== expr
);
2407 /* A scalarized term. We already know the descriptor. */
2408 se
->expr
= ss_info
->data
.array
.descriptor
;
2409 se
->string_length
= ss_info
->string_length
;
2410 ref
= ss_info
->data
.array
.ref
;
2412 gcc_assert (ref
->type
== REF_ARRAY
2413 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2415 gfc_conv_tmp_array_ref (se
);
2419 tree se_expr
= NULL_TREE
;
2421 se
->expr
= gfc_get_symbol_decl (sym
);
2423 /* Deal with references to a parent results or entries by storing
2424 the current_function_decl and moving to the parent_decl. */
2425 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2426 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2427 && sym
->result
== sym
;
2428 entry_master
= sym
->attr
.result
2429 && sym
->ns
->proc_name
->attr
.entry_master
2430 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2431 if (current_function_decl
)
2432 parent_decl
= DECL_CONTEXT (current_function_decl
);
2434 if ((se
->expr
== parent_decl
&& return_value
)
2435 || (sym
->ns
&& sym
->ns
->proc_name
2437 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2438 && (alternate_entry
|| entry_master
)))
2443 /* Special case for assigning the return value of a function.
2444 Self recursive functions must have an explicit return value. */
2445 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2446 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2448 /* Similarly for alternate entry points. */
2449 else if (alternate_entry
2450 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2453 gfc_entry_list
*el
= NULL
;
2455 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2458 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2463 else if (entry_master
2464 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2466 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2471 /* Procedure actual arguments. */
2472 else if (sym
->attr
.flavor
== FL_PROCEDURE
2473 && se
->expr
!= current_function_decl
)
2475 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2477 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2478 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2484 /* Dereference the expression, where needed. Since characters
2485 are entirely different from other types, they are treated
2487 if (sym
->ts
.type
== BT_CHARACTER
)
2489 /* Dereference character pointer dummy arguments
2491 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2493 || sym
->attr
.function
2494 || sym
->attr
.result
))
2495 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2499 else if (!sym
->attr
.value
)
2501 /* Dereference temporaries for class array dummy arguments. */
2502 if (sym
->attr
.dummy
&& is_classarray
2503 && GFC_ARRAY_TYPE_P (TREE_TYPE (se
->expr
)))
2505 if (!se
->descriptor_only
)
2506 se
->expr
= GFC_DECL_SAVED_DESCRIPTOR (se
->expr
);
2508 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2512 /* Dereference non-character scalar dummy arguments. */
2513 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2514 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
)
2515 && (sym
->ts
.type
!= BT_CLASS
2516 || (!CLASS_DATA (sym
)->attr
.dimension
2517 && !(CLASS_DATA (sym
)->attr
.codimension
2518 && CLASS_DATA (sym
)->attr
.allocatable
))))
2519 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2522 /* Dereference scalar hidden result. */
2523 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2524 && (sym
->attr
.function
|| sym
->attr
.result
)
2525 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2526 && !sym
->attr
.always_explicit
)
2527 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2530 /* Dereference non-character, non-class pointer variables.
2531 These must be dummies, results, or scalars. */
2533 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
2534 || gfc_is_associate_pointer (sym
)
2535 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2537 || sym
->attr
.function
2539 || (!sym
->attr
.dimension
2540 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2541 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2543 /* Now treat the class array pointer variables accordingly. */
2544 else if (sym
->ts
.type
== BT_CLASS
2546 && (CLASS_DATA (sym
)->attr
.dimension
2547 || CLASS_DATA (sym
)->attr
.codimension
)
2548 && ((CLASS_DATA (sym
)->as
2549 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
2550 || CLASS_DATA (sym
)->attr
.allocatable
2551 || CLASS_DATA (sym
)->attr
.class_pointer
))
2552 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2554 /* And the case where a non-dummy, non-result, non-function,
2555 non-allotable and non-pointer classarray is present. This case was
2556 previously covered by the first if, but with introducing the
2557 condition !is_classarray there, that case has to be covered
2559 else if (sym
->ts
.type
== BT_CLASS
2561 && !sym
->attr
.function
2562 && !sym
->attr
.result
2563 && (CLASS_DATA (sym
)->attr
.dimension
2564 || CLASS_DATA (sym
)->attr
.codimension
)
2566 || !CLASS_DATA (sym
)->attr
.allocatable
)
2567 && !CLASS_DATA (sym
)->attr
.class_pointer
)
2568 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2575 /* For character variables, also get the length. */
2576 if (sym
->ts
.type
== BT_CHARACTER
)
2578 /* If the character length of an entry isn't set, get the length from
2579 the master function instead. */
2580 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2581 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2583 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2584 gcc_assert (se
->string_length
);
2592 /* Return the descriptor if that's what we want and this is an array
2593 section reference. */
2594 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2596 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2597 /* Return the descriptor for array pointers and allocations. */
2598 if (se
->want_pointer
2599 && ref
->next
== NULL
&& (se
->descriptor_only
))
2602 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2603 /* Return a pointer to an element. */
2607 if (first_time
&& is_classarray
&& sym
->attr
.dummy
2608 && se
->descriptor_only
2609 && !CLASS_DATA (sym
)->attr
.allocatable
2610 && !CLASS_DATA (sym
)->attr
.class_pointer
2611 && CLASS_DATA (sym
)->as
2612 && CLASS_DATA (sym
)->as
->type
!= AS_ASSUMED_RANK
2613 && strcmp ("_data", ref
->u
.c
.component
->name
) == 0)
2614 /* Skip the first ref of a _data component, because for class
2615 arrays that one is already done by introducing a temporary
2616 array descriptor. */
2619 if (ref
->u
.c
.sym
->attr
.extension
)
2620 conv_parent_component_references (se
, ref
);
2622 gfc_conv_component_ref (se
, ref
);
2623 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2624 && se
->want_pointer
&& se
->descriptor_only
)
2630 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2631 expr
->symtree
->name
, &expr
->where
);
2641 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2643 if (se
->want_pointer
)
2645 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2646 gfc_conv_string_parameter (se
);
2648 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2653 /* Unary ops are easy... Or they would be if ! was a valid op. */
2656 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2661 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2662 /* Initialize the operand. */
2663 gfc_init_se (&operand
, se
);
2664 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2665 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2667 type
= gfc_typenode_for_spec (&expr
->ts
);
2669 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2670 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2671 All other unary operators have an equivalent GIMPLE unary operator. */
2672 if (code
== TRUTH_NOT_EXPR
)
2673 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2674 build_int_cst (type
, 0));
2676 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2680 /* Expand power operator to optimal multiplications when a value is raised
2681 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2682 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2683 Programming", 3rd Edition, 1998. */
2685 /* This code is mostly duplicated from expand_powi in the backend.
2686 We establish the "optimal power tree" lookup table with the defined size.
2687 The items in the table are the exponents used to calculate the index
2688 exponents. Any integer n less than the value can get an "addition chain",
2689 with the first node being one. */
2690 #define POWI_TABLE_SIZE 256
2692 /* The table is from builtins.c. */
2693 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2695 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2696 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2697 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2698 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2699 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2700 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2701 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2702 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2703 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2704 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2705 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2706 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2707 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2708 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2709 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2710 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2711 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2712 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2713 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2714 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2715 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2716 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2717 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2718 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2719 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2720 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2721 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2722 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2723 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2724 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2725 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2726 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2729 /* If n is larger than lookup table's max index, we use the "window
2731 #define POWI_WINDOW_SIZE 3
2733 /* Recursive function to expand the power operator. The temporary
2734 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2736 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2743 if (n
< POWI_TABLE_SIZE
)
2748 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2749 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2753 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2754 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2755 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2759 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2763 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2764 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2766 if (n
< POWI_TABLE_SIZE
)
2773 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2774 return 1. Else return 0 and a call to runtime library functions
2775 will have to be built. */
2777 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2782 tree vartmp
[POWI_TABLE_SIZE
];
2784 unsigned HOST_WIDE_INT n
;
2786 wide_int wrhs
= rhs
;
2788 /* If exponent is too large, we won't expand it anyway, so don't bother
2789 with large integer values. */
2790 if (!wi::fits_shwi_p (wrhs
))
2793 m
= wrhs
.to_shwi ();
2794 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2795 of the asymmetric range of the integer type. */
2796 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2798 type
= TREE_TYPE (lhs
);
2799 sgn
= tree_int_cst_sgn (rhs
);
2801 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2802 || optimize_size
) && (m
> 2 || m
< -1))
2808 se
->expr
= gfc_build_const (type
, integer_one_node
);
2812 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2813 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2815 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2816 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2817 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2818 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2821 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2824 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2825 boolean_type_node
, tmp
, cond
);
2826 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2827 tmp
, build_int_cst (type
, 1),
2828 build_int_cst (type
, 0));
2832 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2833 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2834 build_int_cst (type
, -1),
2835 build_int_cst (type
, 0));
2836 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2837 cond
, build_int_cst (type
, 1), tmp
);
2841 memset (vartmp
, 0, sizeof (vartmp
));
2845 tmp
= gfc_build_const (type
, integer_one_node
);
2846 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2850 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2856 /* Power op (**). Constant integer exponent has special handling. */
2859 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2861 tree gfc_int4_type_node
;
2864 int res_ikind_1
, res_ikind_2
;
2869 gfc_init_se (&lse
, se
);
2870 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2871 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2872 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2874 gfc_init_se (&rse
, se
);
2875 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2876 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2878 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2879 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2880 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2883 gfc_int4_type_node
= gfc_get_int_type (4);
2885 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2886 library routine. But in the end, we have to convert the result back
2887 if this case applies -- with res_ikind_K, we keep track whether operand K
2888 falls into this case. */
2892 kind
= expr
->value
.op
.op1
->ts
.kind
;
2893 switch (expr
->value
.op
.op2
->ts
.type
)
2896 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2901 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2902 res_ikind_2
= ikind
;
2924 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2926 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2953 switch (expr
->value
.op
.op1
->ts
.type
)
2956 if (kind
== 3) /* Case 16 was not handled properly above. */
2958 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2962 /* Use builtins for real ** int4. */
2968 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2972 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2976 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2980 /* Use the __builtin_powil() only if real(kind=16) is
2981 actually the C long double type. */
2982 if (!gfc_real16_is_float128
)
2983 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2991 /* If we don't have a good builtin for this, go for the
2992 library function. */
2994 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2998 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
3007 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
3011 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
3019 se
->expr
= build_call_expr_loc (input_location
,
3020 fndecl
, 2, lse
.expr
, rse
.expr
);
3022 /* Convert the result back if it is of wrong integer kind. */
3023 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
3025 /* We want the maximum of both operand kinds as result. */
3026 if (res_ikind_1
< res_ikind_2
)
3027 res_ikind_1
= res_ikind_2
;
3028 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
3033 /* Generate code to allocate a string temporary. */
3036 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
3041 if (gfc_can_put_var_on_stack (len
))
3043 /* Create a temporary variable to hold the result. */
3044 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3045 gfc_charlen_type_node
, len
,
3046 build_int_cst (gfc_charlen_type_node
, 1));
3047 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3049 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
3050 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
3052 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
3054 var
= gfc_create_var (tmp
, "str");
3055 var
= gfc_build_addr_expr (type
, var
);
3059 /* Allocate a temporary to hold the result. */
3060 var
= gfc_create_var (type
, "pstr");
3061 gcc_assert (POINTER_TYPE_P (type
));
3062 tmp
= TREE_TYPE (type
);
3063 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
3064 tmp
= TREE_TYPE (tmp
);
3065 tmp
= TYPE_SIZE_UNIT (tmp
);
3066 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
3067 fold_convert (size_type_node
, len
),
3068 fold_convert (size_type_node
, tmp
));
3069 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
3070 gfc_add_modify (&se
->pre
, var
, tmp
);
3072 /* Free the temporary afterwards. */
3073 tmp
= gfc_call_free (var
);
3074 gfc_add_expr_to_block (&se
->post
, tmp
);
3081 /* Handle a string concatenation operation. A temporary will be allocated to
3085 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
3088 tree len
, type
, var
, tmp
, fndecl
;
3090 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
3091 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
3092 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
3094 gfc_init_se (&lse
, se
);
3095 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3096 gfc_conv_string_parameter (&lse
);
3097 gfc_init_se (&rse
, se
);
3098 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3099 gfc_conv_string_parameter (&rse
);
3101 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3102 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3104 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
3105 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3106 if (len
== NULL_TREE
)
3108 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
3109 TREE_TYPE (lse
.string_length
),
3110 lse
.string_length
, rse
.string_length
);
3113 type
= build_pointer_type (type
);
3115 var
= gfc_conv_string_tmp (se
, type
, len
);
3117 /* Do the actual concatenation. */
3118 if (expr
->ts
.kind
== 1)
3119 fndecl
= gfor_fndecl_concat_string
;
3120 else if (expr
->ts
.kind
== 4)
3121 fndecl
= gfor_fndecl_concat_string_char4
;
3125 tmp
= build_call_expr_loc (input_location
,
3126 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
3127 rse
.string_length
, rse
.expr
);
3128 gfc_add_expr_to_block (&se
->pre
, tmp
);
3130 /* Add the cleanup for the operands. */
3131 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3132 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3135 se
->string_length
= len
;
3138 /* Translates an op expression. Common (binary) cases are handled by this
3139 function, others are passed on. Recursion is used in either case.
3140 We use the fact that (op1.ts == op2.ts) (except for the power
3142 Operators need no special handling for scalarized expressions as long as
3143 they call gfc_conv_simple_val to get their operands.
3144 Character strings get special handling. */
3147 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
3149 enum tree_code code
;
3158 switch (expr
->value
.op
.op
)
3160 case INTRINSIC_PARENTHESES
:
3161 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
3162 && flag_protect_parens
)
3164 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
3165 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
3170 case INTRINSIC_UPLUS
:
3171 gfc_conv_expr (se
, expr
->value
.op
.op1
);
3174 case INTRINSIC_UMINUS
:
3175 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
3179 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
3182 case INTRINSIC_PLUS
:
3186 case INTRINSIC_MINUS
:
3190 case INTRINSIC_TIMES
:
3194 case INTRINSIC_DIVIDE
:
3195 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3196 an integer, we must round towards zero, so we use a
3198 if (expr
->ts
.type
== BT_INTEGER
)
3199 code
= TRUNC_DIV_EXPR
;
3204 case INTRINSIC_POWER
:
3205 gfc_conv_power_op (se
, expr
);
3208 case INTRINSIC_CONCAT
:
3209 gfc_conv_concat_op (se
, expr
);
3213 code
= TRUTH_ANDIF_EXPR
;
3218 code
= TRUTH_ORIF_EXPR
;
3222 /* EQV and NEQV only work on logicals, but since we represent them
3223 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3225 case INTRINSIC_EQ_OS
:
3233 case INTRINSIC_NE_OS
:
3234 case INTRINSIC_NEQV
:
3241 case INTRINSIC_GT_OS
:
3248 case INTRINSIC_GE_OS
:
3255 case INTRINSIC_LT_OS
:
3262 case INTRINSIC_LE_OS
:
3268 case INTRINSIC_USER
:
3269 case INTRINSIC_ASSIGN
:
3270 /* These should be converted into function calls by the frontend. */
3274 fatal_error (input_location
, "Unknown intrinsic op");
3278 /* The only exception to this is **, which is handled separately anyway. */
3279 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
3281 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
3285 gfc_init_se (&lse
, se
);
3286 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
3287 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3290 gfc_init_se (&rse
, se
);
3291 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
3292 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3296 gfc_conv_string_parameter (&lse
);
3297 gfc_conv_string_parameter (&rse
);
3299 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
3300 rse
.string_length
, rse
.expr
,
3301 expr
->value
.op
.op1
->ts
.kind
,
3303 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
3304 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
3307 type
= gfc_typenode_for_spec (&expr
->ts
);
3311 /* The result of logical ops is always boolean_type_node. */
3312 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
3313 lse
.expr
, rse
.expr
);
3314 se
->expr
= convert (type
, tmp
);
3317 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
3319 /* Add the post blocks. */
3320 gfc_add_block_to_block (&se
->post
, &rse
.post
);
3321 gfc_add_block_to_block (&se
->post
, &lse
.post
);
3324 /* If a string's length is one, we convert it to a single character. */
3327 gfc_string_to_single_character (tree len
, tree str
, int kind
)
3331 || !tree_fits_uhwi_p (len
)
3332 || !POINTER_TYPE_P (TREE_TYPE (str
)))
3335 if (TREE_INT_CST_LOW (len
) == 1)
3337 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
3338 return build_fold_indirect_ref_loc (input_location
, str
);
3342 && TREE_CODE (str
) == ADDR_EXPR
3343 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3344 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3345 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3346 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3347 && TREE_INT_CST_LOW (len
) > 1
3348 && TREE_INT_CST_LOW (len
)
3349 == (unsigned HOST_WIDE_INT
)
3350 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3352 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
3353 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
3354 if (TREE_CODE (ret
) == INTEGER_CST
)
3356 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3357 int i
, length
= TREE_STRING_LENGTH (string_cst
);
3358 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3360 for (i
= 1; i
< length
; i
++)
3373 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
3376 if (sym
->backend_decl
)
3378 /* This becomes the nominal_type in
3379 function.c:assign_parm_find_data_types. */
3380 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
3381 /* This becomes the passed_type in
3382 function.c:assign_parm_find_data_types. C promotes char to
3383 integer for argument passing. */
3384 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
3386 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
3391 /* If we have a constant character expression, make it into an
3393 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
3398 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
3399 (int)(*expr
)->value
.character
.string
[0]);
3400 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
3402 /* The expr needs to be compatible with a C int. If the
3403 conversion fails, then the 2 causes an ICE. */
3404 ts
.type
= BT_INTEGER
;
3405 ts
.kind
= gfc_c_int_kind
;
3406 gfc_convert_type (*expr
, &ts
, 2);
3409 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
3411 if ((*expr
)->ref
== NULL
)
3413 se
->expr
= gfc_string_to_single_character
3414 (build_int_cst (integer_type_node
, 1),
3415 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3417 ((*expr
)->symtree
->n
.sym
)),
3422 gfc_conv_variable (se
, *expr
);
3423 se
->expr
= gfc_string_to_single_character
3424 (build_int_cst (integer_type_node
, 1),
3425 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
3433 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3434 if STR is a string literal, otherwise return -1. */
3437 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
3440 && TREE_CODE (str
) == ADDR_EXPR
3441 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
3442 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
3443 && array_ref_low_bound (TREE_OPERAND (str
, 0))
3444 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
3445 && tree_fits_uhwi_p (len
)
3446 && tree_to_uhwi (len
) >= 1
3447 && tree_to_uhwi (len
)
3448 == (unsigned HOST_WIDE_INT
)
3449 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
3451 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
3452 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
3453 if (TREE_CODE (folded
) == INTEGER_CST
)
3455 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
3456 int length
= TREE_STRING_LENGTH (string_cst
);
3457 const char *ptr
= TREE_STRING_POINTER (string_cst
);
3459 for (; length
> 0; length
--)
3460 if (ptr
[length
- 1] != ' ')
3469 /* Helper to build a call to memcmp. */
3472 build_memcmp_call (tree s1
, tree s2
, tree n
)
3476 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3477 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3479 s1
= fold_convert (pvoid_type_node
, s1
);
3481 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3482 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3484 s2
= fold_convert (pvoid_type_node
, s2
);
3486 n
= fold_convert (size_type_node
, n
);
3488 tmp
= build_call_expr_loc (input_location
,
3489 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3492 return fold_convert (integer_type_node
, tmp
);
3495 /* Compare two strings. If they are all single characters, the result is the
3496 subtraction of them. Otherwise, we build a library call. */
3499 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3500 enum tree_code code
)
3506 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3507 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3509 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3510 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3512 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3514 /* Deal with single character specially. */
3515 sc1
= fold_convert (integer_type_node
, sc1
);
3516 sc2
= fold_convert (integer_type_node
, sc2
);
3517 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3521 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3523 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3525 /* If one string is a string literal with LEN_TRIM longer
3526 than the length of the second string, the strings
3528 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3529 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3530 return integer_one_node
;
3531 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3532 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3533 return integer_one_node
;
3536 /* We can compare via memcpy if the strings are known to be equal
3537 in length and they are
3539 - kind=4 and the comparison is for (in)equality. */
3541 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3542 && tree_int_cst_equal (len1
, len2
)
3543 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3548 chartype
= gfc_get_char_type (kind
);
3549 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3550 fold_convert (TREE_TYPE(len1
),
3551 TYPE_SIZE_UNIT(chartype
)),
3553 return build_memcmp_call (str1
, str2
, tmp
);
3556 /* Build a call for the comparison. */
3558 fndecl
= gfor_fndecl_compare_string
;
3560 fndecl
= gfor_fndecl_compare_string_char4
;
3564 return build_call_expr_loc (input_location
, fndecl
, 4,
3565 len1
, str1
, len2
, str2
);
3569 /* Return the backend_decl for a procedure pointer component. */
3572 get_proc_ptr_comp (gfc_expr
*e
)
3578 gfc_init_se (&comp_se
, NULL
);
3579 e2
= gfc_copy_expr (e
);
3580 /* We have to restore the expr type later so that gfc_free_expr frees
3581 the exact same thing that was allocated.
3582 TODO: This is ugly. */
3583 old_type
= e2
->expr_type
;
3584 e2
->expr_type
= EXPR_VARIABLE
;
3585 gfc_conv_expr (&comp_se
, e2
);
3586 e2
->expr_type
= old_type
;
3588 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3592 /* Convert a typebound function reference from a class object. */
3594 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3599 if (TREE_CODE (base_object
) != VAR_DECL
)
3601 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3602 gfc_add_modify (&se
->pre
, var
, base_object
);
3604 se
->expr
= gfc_class_vptr_get (base_object
);
3605 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3607 while (ref
&& ref
->next
)
3609 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3610 if (ref
->u
.c
.sym
->attr
.extension
)
3611 conv_parent_component_references (se
, ref
);
3612 gfc_conv_component_ref (se
, ref
);
3613 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3618 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3622 if (gfc_is_proc_ptr_comp (expr
))
3623 tmp
= get_proc_ptr_comp (expr
);
3624 else if (sym
->attr
.dummy
)
3626 tmp
= gfc_get_symbol_decl (sym
);
3627 if (sym
->attr
.proc_pointer
)
3628 tmp
= build_fold_indirect_ref_loc (input_location
,
3630 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3631 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3635 if (!sym
->backend_decl
)
3636 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3638 TREE_USED (sym
->backend_decl
) = 1;
3640 tmp
= sym
->backend_decl
;
3642 if (sym
->attr
.cray_pointee
)
3644 /* TODO - make the cray pointee a pointer to a procedure,
3645 assign the pointer to it and use it for the call. This
3647 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3648 gfc_get_symbol_decl (sym
->cp_pointer
));
3649 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3652 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3654 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3655 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3662 /* Initialize MAPPING. */
3665 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3667 mapping
->syms
= NULL
;
3668 mapping
->charlens
= NULL
;
3672 /* Free all memory held by MAPPING (but not MAPPING itself). */
3675 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3677 gfc_interface_sym_mapping
*sym
;
3678 gfc_interface_sym_mapping
*nextsym
;
3680 gfc_charlen
*nextcl
;
3682 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3684 nextsym
= sym
->next
;
3685 sym
->new_sym
->n
.sym
->formal
= NULL
;
3686 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3687 gfc_free_expr (sym
->expr
);
3688 free (sym
->new_sym
);
3691 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3694 gfc_free_expr (cl
->length
);
3700 /* Return a copy of gfc_charlen CL. Add the returned structure to
3701 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3703 static gfc_charlen
*
3704 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3707 gfc_charlen
*new_charlen
;
3709 new_charlen
= gfc_get_charlen ();
3710 new_charlen
->next
= mapping
->charlens
;
3711 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3713 mapping
->charlens
= new_charlen
;
3718 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3719 array variable that can be used as the actual argument for dummy
3720 argument SYM. Add any initialization code to BLOCK. PACKED is as
3721 for gfc_get_nodesc_array_type and DATA points to the first element
3722 in the passed array. */
3725 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3726 gfc_packed packed
, tree data
)
3731 type
= gfc_typenode_for_spec (&sym
->ts
);
3732 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3733 !sym
->attr
.target
&& !sym
->attr
.pointer
3734 && !sym
->attr
.proc_pointer
);
3736 var
= gfc_create_var (type
, "ifm");
3737 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3743 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3744 and offset of descriptorless array type TYPE given that it has the same
3745 size as DESC. Add any set-up code to BLOCK. */
3748 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3755 offset
= gfc_index_zero_node
;
3756 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3758 dim
= gfc_rank_cst
[n
];
3759 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3760 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3762 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3763 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3764 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3765 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3767 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3769 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3770 gfc_array_index_type
,
3771 gfc_conv_descriptor_ubound_get (desc
, dim
),
3772 gfc_conv_descriptor_lbound_get (desc
, dim
));
3773 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3774 gfc_array_index_type
,
3775 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3776 tmp
= gfc_evaluate_now (tmp
, block
);
3777 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3779 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3780 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3781 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3782 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3783 gfc_array_index_type
, offset
, tmp
);
3785 offset
= gfc_evaluate_now (offset
, block
);
3786 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3790 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3791 in SE. The caller may still use se->expr and se->string_length after
3792 calling this function. */
3795 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3796 gfc_symbol
* sym
, gfc_se
* se
,
3799 gfc_interface_sym_mapping
*sm
;
3803 gfc_symbol
*new_sym
;
3805 gfc_symtree
*new_symtree
;
3807 /* Create a new symbol to represent the actual argument. */
3808 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3809 new_sym
->ts
= sym
->ts
;
3810 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3811 new_sym
->attr
.referenced
= 1;
3812 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3813 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3814 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3815 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3816 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3817 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3818 new_sym
->attr
.function
= sym
->attr
.function
;
3820 /* Ensure that the interface is available and that
3821 descriptors are passed for array actual arguments. */
3822 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3824 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3825 new_sym
->attr
.always_explicit
3826 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3829 /* Create a fake symtree for it. */
3831 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3832 new_symtree
->n
.sym
= new_sym
;
3833 gcc_assert (new_symtree
== root
);
3835 /* Create a dummy->actual mapping. */
3836 sm
= XCNEW (gfc_interface_sym_mapping
);
3837 sm
->next
= mapping
->syms
;
3839 sm
->new_sym
= new_symtree
;
3840 sm
->expr
= gfc_copy_expr (expr
);
3843 /* Stabilize the argument's value. */
3844 if (!sym
->attr
.function
&& se
)
3845 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3847 if (sym
->ts
.type
== BT_CHARACTER
)
3849 /* Create a copy of the dummy argument's length. */
3850 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3851 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3853 /* If the length is specified as "*", record the length that
3854 the caller is passing. We should use the callee's length
3855 in all other cases. */
3856 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3858 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3859 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3866 /* Use the passed value as-is if the argument is a function. */
3867 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3870 /* If the argument is either a string or a pointer to a string,
3871 convert it to a boundless character type. */
3872 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3874 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3875 tmp
= build_pointer_type (tmp
);
3876 if (sym
->attr
.pointer
)
3877 value
= build_fold_indirect_ref_loc (input_location
,
3881 value
= fold_convert (tmp
, value
);
3884 /* If the argument is a scalar, a pointer to an array or an allocatable,
3886 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3887 value
= build_fold_indirect_ref_loc (input_location
,
3890 /* For character(*), use the actual argument's descriptor. */
3891 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3892 value
= build_fold_indirect_ref_loc (input_location
,
3895 /* If the argument is an array descriptor, use it to determine
3896 information about the actual argument's shape. */
3897 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3898 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3900 /* Get the actual argument's descriptor. */
3901 desc
= build_fold_indirect_ref_loc (input_location
,
3904 /* Create the replacement variable. */
3905 tmp
= gfc_conv_descriptor_data_get (desc
);
3906 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3909 /* Use DESC to work out the upper bounds, strides and offset. */
3910 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3913 /* Otherwise we have a packed array. */
3914 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3915 PACKED_FULL
, se
->expr
);
3917 new_sym
->backend_decl
= value
;
3921 /* Called once all dummy argument mappings have been added to MAPPING,
3922 but before the mapping is used to evaluate expressions. Pre-evaluate
3923 the length of each argument, adding any initialization code to PRE and
3924 any finalization code to POST. */
3927 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3928 stmtblock_t
* pre
, stmtblock_t
* post
)
3930 gfc_interface_sym_mapping
*sym
;
3934 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3935 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3936 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3938 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3939 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3940 gfc_init_se (&se
, NULL
);
3941 gfc_conv_expr (&se
, expr
);
3942 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3943 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3944 gfc_add_block_to_block (pre
, &se
.pre
);
3945 gfc_add_block_to_block (post
, &se
.post
);
3947 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3952 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3956 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3957 gfc_constructor_base base
)
3960 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3962 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3965 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3966 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3967 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3973 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3977 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3982 for (; ref
; ref
= ref
->next
)
3986 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3988 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3989 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3990 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3998 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3999 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
4005 /* Convert intrinsic function calls into result expressions. */
4008 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
4016 arg1
= expr
->value
.function
.actual
->expr
;
4017 if (expr
->value
.function
.actual
->next
)
4018 arg2
= expr
->value
.function
.actual
->next
->expr
;
4022 sym
= arg1
->symtree
->n
.sym
;
4024 if (sym
->attr
.dummy
)
4029 switch (expr
->value
.function
.isym
->id
)
4032 /* TODO figure out why this condition is necessary. */
4033 if (sym
->attr
.function
4034 && (arg1
->ts
.u
.cl
->length
== NULL
4035 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4036 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
4039 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
4043 if (!sym
->as
|| sym
->as
->rank
== 0)
4046 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4048 dup
= mpz_get_si (arg2
->value
.integer
);
4053 dup
= sym
->as
->rank
;
4057 for (; d
< dup
; d
++)
4061 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
4063 gfc_free_expr (new_expr
);
4067 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
4068 gfc_get_int_expr (gfc_default_integer_kind
,
4070 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
4072 new_expr
= gfc_multiply (new_expr
, tmp
);
4078 case GFC_ISYM_LBOUND
:
4079 case GFC_ISYM_UBOUND
:
4080 /* TODO These implementations of lbound and ubound do not limit if
4081 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4083 if (!sym
->as
|| sym
->as
->rank
== 0)
4086 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
4087 d
= mpz_get_si (arg2
->value
.integer
) - 1;
4089 /* TODO: If the need arises, this could produce an array of
4093 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
4095 if (sym
->as
->lower
[d
])
4096 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
4100 if (sym
->as
->upper
[d
])
4101 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
4109 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
4113 gfc_replace_expr (expr
, new_expr
);
4119 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
4120 gfc_interface_mapping
* mapping
)
4122 gfc_formal_arglist
*f
;
4123 gfc_actual_arglist
*actual
;
4125 actual
= expr
->value
.function
.actual
;
4126 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
4128 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
4133 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
4136 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
4141 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
4143 for (d
= 0; d
< as
->rank
; d
++)
4145 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
4146 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
4149 expr
->value
.function
.esym
->as
= as
;
4152 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
4154 expr
->value
.function
.esym
->ts
.u
.cl
->length
4155 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4157 gfc_apply_interface_mapping_to_expr (mapping
,
4158 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
4163 /* EXPR is a copy of an expression that appeared in the interface
4164 associated with MAPPING. Walk it recursively looking for references to
4165 dummy arguments that MAPPING maps to actual arguments. Replace each such
4166 reference with a reference to the associated actual argument. */
4169 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
4172 gfc_interface_sym_mapping
*sym
;
4173 gfc_actual_arglist
*actual
;
4178 /* Copying an expression does not copy its length, so do that here. */
4179 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
4181 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
4182 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
4185 /* Apply the mapping to any references. */
4186 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
4188 /* ...and to the expression's symbol, if it has one. */
4189 /* TODO Find out why the condition on expr->symtree had to be moved into
4190 the loop rather than being outside it, as originally. */
4191 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4192 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
4194 if (sym
->new_sym
->n
.sym
->backend_decl
)
4195 expr
->symtree
= sym
->new_sym
;
4197 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
4200 /* ...and to subexpressions in expr->value. */
4201 switch (expr
->expr_type
)
4206 case EXPR_SUBSTRING
:
4210 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
4211 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
4215 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
4216 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
4218 if (expr
->value
.function
.esym
== NULL
4219 && expr
->value
.function
.isym
!= NULL
4220 && expr
->value
.function
.actual
->expr
->symtree
4221 && gfc_map_intrinsic_function (expr
, mapping
))
4224 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
4225 if (sym
->old
== expr
->value
.function
.esym
)
4227 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
4228 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
4229 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
4234 case EXPR_STRUCTURE
:
4235 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
4248 /* Evaluate interface expression EXPR using MAPPING. Store the result
4252 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
4253 gfc_se
* se
, gfc_expr
* expr
)
4255 expr
= gfc_copy_expr (expr
);
4256 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
4257 gfc_conv_expr (se
, expr
);
4258 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
4259 gfc_free_expr (expr
);
4263 /* Returns a reference to a temporary array into which a component of
4264 an actual argument derived type array is copied and then returned
4265 after the function call. */
4267 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
4268 sym_intent intent
, bool formal_ptr
)
4276 gfc_array_info
*info
;
4286 gfc_init_se (&lse
, NULL
);
4287 gfc_init_se (&rse
, NULL
);
4289 /* Walk the argument expression. */
4290 rss
= gfc_walk_expr (expr
);
4292 gcc_assert (rss
!= gfc_ss_terminator
);
4294 /* Initialize the scalarizer. */
4295 gfc_init_loopinfo (&loop
);
4296 gfc_add_ss_to_loop (&loop
, rss
);
4298 /* Calculate the bounds of the scalarization. */
4299 gfc_conv_ss_startstride (&loop
);
4301 /* Build an ss for the temporary. */
4302 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
4303 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
4305 base_type
= gfc_typenode_for_spec (&expr
->ts
);
4306 if (GFC_ARRAY_TYPE_P (base_type
)
4307 || GFC_DESCRIPTOR_TYPE_P (base_type
))
4308 base_type
= gfc_get_element_type (base_type
);
4310 if (expr
->ts
.type
== BT_CLASS
)
4311 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
4313 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
4314 ? expr
->ts
.u
.cl
->backend_decl
4318 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
4320 /* Associate the SS with the loop. */
4321 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
4323 /* Setup the scalarizing loops. */
4324 gfc_conv_loop_setup (&loop
, &expr
->where
);
4326 /* Pass the temporary descriptor back to the caller. */
4327 info
= &loop
.temp_ss
->info
->data
.array
;
4328 parmse
->expr
= info
->descriptor
;
4330 /* Setup the gfc_se structures. */
4331 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4332 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4335 lse
.ss
= loop
.temp_ss
;
4336 gfc_mark_ss_chain_used (rss
, 1);
4337 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4339 /* Start the scalarized loop body. */
4340 gfc_start_scalarized_body (&loop
, &body
);
4342 /* Translate the expression. */
4343 gfc_conv_expr (&rse
, expr
);
4345 /* Reset the offset for the function call since the loop
4346 is zero based on the data pointer. Note that the temp
4347 comes first in the loop chain since it is added second. */
4348 if (gfc_is_alloc_class_array_function (expr
))
4350 tmp
= loop
.ss
->loop_chain
->info
->data
.array
.descriptor
;
4351 gfc_conv_descriptor_offset_set (&loop
.pre
, tmp
,
4352 gfc_index_zero_node
);
4355 gfc_conv_tmp_array_ref (&lse
);
4357 if (intent
!= INTENT_OUT
)
4359 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
4360 gfc_add_expr_to_block (&body
, tmp
);
4361 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4362 gfc_trans_scalarizing_loops (&loop
, &body
);
4366 /* Make sure that the temporary declaration survives by merging
4367 all the loop declarations into the current context. */
4368 for (n
= 0; n
< loop
.dimen
; n
++)
4370 gfc_merge_block_scope (&body
);
4371 body
= loop
.code
[loop
.order
[n
]];
4373 gfc_merge_block_scope (&body
);
4376 /* Add the post block after the second loop, so that any
4377 freeing of allocated memory is done at the right time. */
4378 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
4380 /**********Copy the temporary back again.*********/
4382 gfc_init_se (&lse
, NULL
);
4383 gfc_init_se (&rse
, NULL
);
4385 /* Walk the argument expression. */
4386 lss
= gfc_walk_expr (expr
);
4387 rse
.ss
= loop
.temp_ss
;
4390 /* Initialize the scalarizer. */
4391 gfc_init_loopinfo (&loop2
);
4392 gfc_add_ss_to_loop (&loop2
, lss
);
4394 dimen
= rse
.ss
->dimen
;
4396 /* Skip the write-out loop for this case. */
4397 if (gfc_is_alloc_class_array_function (expr
))
4398 goto class_array_fcn
;
4400 /* Calculate the bounds of the scalarization. */
4401 gfc_conv_ss_startstride (&loop2
);
4403 /* Setup the scalarizing loops. */
4404 gfc_conv_loop_setup (&loop2
, &expr
->where
);
4406 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
4407 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
4409 gfc_mark_ss_chain_used (lss
, 1);
4410 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
4412 /* Declare the variable to hold the temporary offset and start the
4413 scalarized loop body. */
4414 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
4415 gfc_start_scalarized_body (&loop2
, &body
);
4417 /* Build the offsets for the temporary from the loop variables. The
4418 temporary array has lbounds of zero and strides of one in all
4419 dimensions, so this is very simple. The offset is only computed
4420 outside the innermost loop, so the overall transfer could be
4421 optimized further. */
4422 info
= &rse
.ss
->info
->data
.array
;
4424 tmp_index
= gfc_index_zero_node
;
4425 for (n
= dimen
- 1; n
> 0; n
--)
4428 tmp
= rse
.loop
->loopvar
[n
];
4429 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4430 tmp
, rse
.loop
->from
[n
]);
4431 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4434 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
4435 gfc_array_index_type
,
4436 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
4437 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
4438 gfc_array_index_type
,
4439 tmp_str
, gfc_index_one_node
);
4441 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
4442 gfc_array_index_type
, tmp
, tmp_str
);
4445 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
4446 gfc_array_index_type
,
4447 tmp_index
, rse
.loop
->from
[0]);
4448 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
4450 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
4451 gfc_array_index_type
,
4452 rse
.loop
->loopvar
[0], offset
);
4454 /* Now use the offset for the reference. */
4455 tmp
= build_fold_indirect_ref_loc (input_location
,
4457 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
4459 if (expr
->ts
.type
== BT_CHARACTER
)
4460 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
4462 gfc_conv_expr (&lse
, expr
);
4464 gcc_assert (lse
.ss
== gfc_ss_terminator
);
4466 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true);
4467 gfc_add_expr_to_block (&body
, tmp
);
4469 /* Generate the copying loops. */
4470 gfc_trans_scalarizing_loops (&loop2
, &body
);
4472 /* Wrap the whole thing up by adding the second loop to the post-block
4473 and following it by the post-block of the first loop. In this way,
4474 if the temporary needs freeing, it is done after use! */
4475 if (intent
!= INTENT_IN
)
4477 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4478 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4483 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4485 gfc_cleanup_loop (&loop
);
4486 gfc_cleanup_loop (&loop2
);
4488 /* Pass the string length to the argument expression. */
4489 if (expr
->ts
.type
== BT_CHARACTER
)
4490 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4492 /* Determine the offset for pointer formal arguments and set the
4496 size
= gfc_index_one_node
;
4497 offset
= gfc_index_zero_node
;
4498 for (n
= 0; n
< dimen
; n
++)
4500 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4502 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4503 gfc_array_index_type
, tmp
,
4504 gfc_index_one_node
);
4505 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4509 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4512 gfc_index_one_node
);
4513 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4514 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4515 gfc_array_index_type
,
4517 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4518 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4519 gfc_array_index_type
,
4520 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4521 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4522 gfc_array_index_type
,
4523 tmp
, gfc_index_one_node
);
4524 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4525 gfc_array_index_type
, size
, tmp
);
4528 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4532 /* We want either the address for the data or the address of the descriptor,
4533 depending on the mode of passing array arguments. */
4535 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4537 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4543 /* Generate the code for argument list functions. */
4546 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4548 /* Pass by value for g77 %VAL(arg), pass the address
4549 indirectly for %LOC, else by reference. Thus %REF
4550 is a "do-nothing" and %LOC is the same as an F95
4552 if (strncmp (name
, "%VAL", 4) == 0)
4553 gfc_conv_expr (se
, expr
);
4554 else if (strncmp (name
, "%LOC", 4) == 0)
4556 gfc_conv_expr_reference (se
, expr
);
4557 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4559 else if (strncmp (name
, "%REF", 4) == 0)
4560 gfc_conv_expr_reference (se
, expr
);
4562 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4566 /* This function tells whether the middle-end representation of the expression
4567 E given as input may point to data otherwise accessible through a variable
4569 It is assumed that the only expressions that may alias are variables,
4570 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4572 This function is used to decide whether freeing an expression's allocatable
4573 components is safe or should be avoided.
4575 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4576 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4577 is necessary because for array constructors, aliasing depends on how
4579 - If E is an array constructor used as argument to an elemental procedure,
4580 the array, which is generated through shallow copy by the scalarizer,
4581 is used directly and can alias the expressions it was copied from.
4582 - If E is an array constructor used as argument to a non-elemental
4583 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4584 the array as in the previous case, but then that array is used
4585 to initialize a new descriptor through deep copy. There is no alias
4586 possible in that case.
4587 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4591 expr_may_alias_variables (gfc_expr
*e
, bool array_may_alias
)
4595 if (e
->expr_type
== EXPR_VARIABLE
)
4597 else if (e
->expr_type
== EXPR_FUNCTION
)
4599 gfc_symbol
*proc_ifc
= gfc_get_proc_ifc_for_expr (e
);
4601 if ((proc_ifc
->result
->ts
.type
== BT_CLASS
4602 && proc_ifc
->result
->ts
.u
.derived
->attr
.is_class
4603 && CLASS_DATA (proc_ifc
->result
)->attr
.class_pointer
)
4604 || proc_ifc
->result
->attr
.pointer
)
4609 else if (e
->expr_type
!= EXPR_ARRAY
|| !array_may_alias
)
4612 for (c
= gfc_constructor_first (e
->value
.constructor
);
4613 c
; c
= gfc_constructor_next (c
))
4615 && expr_may_alias_variables (c
->expr
, array_may_alias
))
4622 /* Generate code for a procedure call. Note can return se->post != NULL.
4623 If se->direct_byref is set then se->expr contains the return parameter.
4624 Return nonzero, if the call has alternate specifiers.
4625 'expr' is only needed for procedure pointer components. */
4628 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4629 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4630 vec
<tree
, va_gc
> *append_args
)
4632 gfc_interface_mapping mapping
;
4633 vec
<tree
, va_gc
> *arglist
;
4634 vec
<tree
, va_gc
> *retargs
;
4638 gfc_array_info
*info
;
4645 vec
<tree
, va_gc
> *stringargs
;
4646 vec
<tree
, va_gc
> *optionalargs
;
4648 gfc_formal_arglist
*formal
;
4649 gfc_actual_arglist
*arg
;
4650 int has_alternate_specifier
= 0;
4651 bool need_interface_mapping
;
4659 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4660 gfc_component
*comp
= NULL
;
4667 optionalargs
= NULL
;
4672 comp
= gfc_get_proc_ptr_comp (expr
);
4674 bool elemental_proc
= (comp
4675 && comp
->ts
.interface
4676 && comp
->ts
.interface
->attr
.elemental
)
4677 || (comp
&& comp
->attr
.elemental
)
4678 || sym
->attr
.elemental
;
4682 if (!elemental_proc
)
4684 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4685 if (se
->ss
->info
->useflags
)
4687 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4688 && sym
->result
->attr
.dimension
)
4689 || (comp
&& comp
->attr
.dimension
)
4690 || gfc_is_alloc_class_array_function (expr
));
4691 gcc_assert (se
->loop
!= NULL
);
4692 /* Access the previously obtained result. */
4693 gfc_conv_tmp_array_ref (se
);
4697 info
= &se
->ss
->info
->data
.array
;
4702 gfc_init_block (&post
);
4703 gfc_init_interface_mapping (&mapping
);
4706 formal
= gfc_sym_get_dummy_args (sym
);
4707 need_interface_mapping
= sym
->attr
.dimension
||
4708 (sym
->ts
.type
== BT_CHARACTER
4709 && sym
->ts
.u
.cl
->length
4710 && sym
->ts
.u
.cl
->length
->expr_type
4715 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4716 need_interface_mapping
= comp
->attr
.dimension
||
4717 (comp
->ts
.type
== BT_CHARACTER
4718 && comp
->ts
.u
.cl
->length
4719 && comp
->ts
.u
.cl
->length
->expr_type
4723 base_object
= NULL_TREE
;
4724 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4725 is the third and fourth argument to such a function call a value
4726 denoting the number of elements to copy (i.e., most of the time the
4727 length of a deferred length string). */
4728 ulim_copy
= formal
== NULL
&& UNLIMITED_POLY (sym
)
4729 && strcmp ("_copy", comp
->name
) == 0;
4731 /* Evaluate the arguments. */
4732 for (arg
= args
, argc
= 0; arg
!= NULL
;
4733 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
, ++argc
)
4736 fsym
= formal
? formal
->sym
: NULL
;
4737 parm_kind
= MISSING
;
4739 /* If the procedure requires an explicit interface, the actual
4740 argument is passed according to the corresponding formal
4741 argument. If the corresponding formal argument is a POINTER,
4742 ALLOCATABLE or assumed shape, we do not use g77's calling
4743 convention, and pass the address of the array descriptor
4744 instead. Otherwise we use g77's calling convention, in other words
4745 pass the array data pointer without descriptor. */
4746 bool nodesc_arg
= fsym
!= NULL
4747 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4749 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
4750 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4752 nodesc_arg
= nodesc_arg
|| !comp
->attr
.always_explicit
;
4754 nodesc_arg
= nodesc_arg
|| !sym
->attr
.always_explicit
;
4756 /* Class array expressions are sometimes coming completely unadorned
4757 with either arrayspec or _data component. Correct that here.
4758 OOP-TODO: Move this to the frontend. */
4759 if (e
&& e
->expr_type
== EXPR_VARIABLE
4761 && e
->ts
.type
== BT_CLASS
4762 && (CLASS_DATA (e
)->attr
.codimension
4763 || CLASS_DATA (e
)->attr
.dimension
))
4765 gfc_typespec temp_ts
= e
->ts
;
4766 gfc_add_class_array_ref (e
);
4772 if (se
->ignore_optional
)
4774 /* Some intrinsics have already been resolved to the correct
4778 else if (arg
->label
)
4780 has_alternate_specifier
= 1;
4785 gfc_init_se (&parmse
, NULL
);
4787 /* For scalar arguments with VALUE attribute which are passed by
4788 value, pass "0" and a hidden argument gives the optional
4790 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4791 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4792 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4794 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4796 vec_safe_push (optionalargs
, boolean_false_node
);
4800 /* Pass a NULL pointer for an absent arg. */
4801 parmse
.expr
= null_pointer_node
;
4802 if (arg
->missing_arg_type
== BT_CHARACTER
)
4803 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4808 else if (arg
->expr
->expr_type
== EXPR_NULL
4809 && fsym
&& !fsym
->attr
.pointer
4810 && (fsym
->ts
.type
!= BT_CLASS
4811 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4813 /* Pass a NULL pointer to denote an absent arg. */
4814 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4815 && (fsym
->ts
.type
!= BT_CLASS
4816 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4817 gfc_init_se (&parmse
, NULL
);
4818 parmse
.expr
= null_pointer_node
;
4819 if (arg
->missing_arg_type
== BT_CHARACTER
)
4820 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4822 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4823 && e
->ts
.type
== BT_DERIVED
)
4825 /* The derived type needs to be converted to a temporary
4827 gfc_init_se (&parmse
, se
);
4828 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4830 && e
->expr_type
== EXPR_VARIABLE
4831 && e
->symtree
->n
.sym
->attr
.optional
,
4832 CLASS_DATA (fsym
)->attr
.class_pointer
4833 || CLASS_DATA (fsym
)->attr
.allocatable
);
4835 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4837 /* The intrinsic type needs to be converted to a temporary
4838 CLASS object for the unlimited polymorphic formal. */
4839 gfc_init_se (&parmse
, se
);
4840 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4842 else if (se
->ss
&& se
->ss
->info
->useflags
)
4848 /* An elemental function inside a scalarized loop. */
4849 gfc_init_se (&parmse
, se
);
4850 parm_kind
= ELEMENTAL
;
4852 /* When no fsym is present, ulim_copy is set and this is a third or
4853 fourth argument, use call-by-value instead of by reference to
4854 hand the length properties to the copy routine (i.e., most of the
4855 time this will be a call to a __copy_character_* routine where the
4856 third and fourth arguments are the lengths of a deferred length
4858 if ((fsym
&& fsym
->attr
.value
)
4859 || (ulim_copy
&& (argc
== 2 || argc
== 3)))
4860 gfc_conv_expr (&parmse
, e
);
4862 gfc_conv_expr_reference (&parmse
, e
);
4864 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4865 && e
->expr_type
== EXPR_FUNCTION
)
4866 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4869 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4870 && gfc_is_class_container_ref (e
))
4872 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4874 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4875 && e
->symtree
->n
.sym
->attr
.optional
)
4877 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4878 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4879 TREE_TYPE (parmse
.expr
),
4881 fold_convert (TREE_TYPE (parmse
.expr
),
4882 null_pointer_node
));
4886 /* If we are passing an absent array as optional dummy to an
4887 elemental procedure, make sure that we pass NULL when the data
4888 pointer is NULL. We need this extra conditional because of
4889 scalarization which passes arrays elements to the procedure,
4890 ignoring the fact that the array can be absent/unallocated/... */
4891 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4893 tree descriptor_data
;
4895 descriptor_data
= ss
->info
->data
.array
.data
;
4896 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4898 fold_convert (TREE_TYPE (descriptor_data
),
4899 null_pointer_node
));
4901 = fold_build3_loc (input_location
, COND_EXPR
,
4902 TREE_TYPE (parmse
.expr
),
4903 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4904 fold_convert (TREE_TYPE (parmse
.expr
),
4909 /* The scalarizer does not repackage the reference to a class
4910 array - instead it returns a pointer to the data element. */
4911 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4912 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4913 fsym
->attr
.intent
!= INTENT_IN
4914 && (CLASS_DATA (fsym
)->attr
.class_pointer
4915 || CLASS_DATA (fsym
)->attr
.allocatable
),
4917 && e
->expr_type
== EXPR_VARIABLE
4918 && e
->symtree
->n
.sym
->attr
.optional
,
4919 CLASS_DATA (fsym
)->attr
.class_pointer
4920 || CLASS_DATA (fsym
)->attr
.allocatable
);
4927 gfc_init_se (&parmse
, NULL
);
4929 /* Check whether the expression is a scalar or not; we cannot use
4930 e->rank as it can be nonzero for functions arguments. */
4931 argss
= gfc_walk_expr (e
);
4932 scalar
= argss
== gfc_ss_terminator
;
4934 gfc_free_ss_chain (argss
);
4936 /* Special handling for passing scalar polymorphic coarrays;
4937 otherwise one passes "class->_data.data" instead of "&class". */
4938 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4939 && fsym
&& fsym
->ts
.type
== BT_CLASS
4940 && CLASS_DATA (fsym
)->attr
.codimension
4941 && !CLASS_DATA (fsym
)->attr
.dimension
)
4943 gfc_add_class_array_ref (e
);
4944 parmse
.want_coarray
= 1;
4948 /* A scalar or transformational function. */
4951 if (e
->expr_type
== EXPR_VARIABLE
4952 && e
->symtree
->n
.sym
->attr
.cray_pointee
4953 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4955 /* The Cray pointer needs to be converted to a pointer to
4956 a type given by the expression. */
4957 gfc_conv_expr (&parmse
, e
);
4958 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4959 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4960 parmse
.expr
= convert (type
, tmp
);
4962 else if (fsym
&& fsym
->attr
.value
)
4964 if (fsym
->ts
.type
== BT_CHARACTER
4965 && fsym
->ts
.is_c_interop
4966 && fsym
->ns
->proc_name
!= NULL
4967 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4970 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4971 if (parmse
.expr
== NULL
)
4972 gfc_conv_expr (&parmse
, e
);
4976 gfc_conv_expr (&parmse
, e
);
4977 if (fsym
->attr
.optional
4978 && fsym
->ts
.type
!= BT_CLASS
4979 && fsym
->ts
.type
!= BT_DERIVED
)
4981 if (e
->expr_type
!= EXPR_VARIABLE
4982 || !e
->symtree
->n
.sym
->attr
.optional
4984 vec_safe_push (optionalargs
, boolean_true_node
);
4987 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4988 if (!e
->symtree
->n
.sym
->attr
.value
)
4990 = fold_build3_loc (input_location
, COND_EXPR
,
4991 TREE_TYPE (parmse
.expr
),
4993 fold_convert (TREE_TYPE (parmse
.expr
),
4994 integer_zero_node
));
4996 vec_safe_push (optionalargs
, tmp
);
5001 else if (arg
->name
&& arg
->name
[0] == '%')
5002 /* Argument list functions %VAL, %LOC and %REF are signalled
5003 through arg->name. */
5004 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
5005 else if ((e
->expr_type
== EXPR_FUNCTION
)
5006 && ((e
->value
.function
.esym
5007 && e
->value
.function
.esym
->result
->attr
.pointer
)
5008 || (!e
->value
.function
.esym
5009 && e
->symtree
->n
.sym
->attr
.pointer
))
5010 && fsym
&& fsym
->attr
.target
)
5012 gfc_conv_expr (&parmse
, e
);
5013 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5015 else if (e
->expr_type
== EXPR_FUNCTION
5016 && e
->symtree
->n
.sym
->result
5017 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
5018 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
5020 /* Functions returning procedure pointers. */
5021 gfc_conv_expr (&parmse
, e
);
5022 if (fsym
&& fsym
->attr
.proc_pointer
)
5023 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5027 if (e
->ts
.type
== BT_CLASS
&& fsym
5028 && fsym
->ts
.type
== BT_CLASS
5029 && (!CLASS_DATA (fsym
)->as
5030 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
5031 && CLASS_DATA (e
)->attr
.codimension
)
5033 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
5034 gcc_assert (!CLASS_DATA (fsym
)->as
);
5035 gfc_add_class_array_ref (e
);
5036 parmse
.want_coarray
= 1;
5037 gfc_conv_expr_reference (&parmse
, e
);
5038 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
5040 && e
->expr_type
== EXPR_VARIABLE
);
5042 else if (e
->ts
.type
== BT_CLASS
&& fsym
5043 && fsym
->ts
.type
== BT_CLASS
5044 && !CLASS_DATA (fsym
)->as
5045 && !CLASS_DATA (e
)->as
5046 && strcmp (fsym
->ts
.u
.derived
->name
,
5047 e
->ts
.u
.derived
->name
))
5049 type
= gfc_typenode_for_spec (&fsym
->ts
);
5050 var
= gfc_create_var (type
, fsym
->name
);
5051 gfc_conv_expr (&parmse
, e
);
5052 if (fsym
->attr
.optional
5053 && e
->expr_type
== EXPR_VARIABLE
5054 && e
->symtree
->n
.sym
->attr
.optional
)
5058 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5059 cond
= fold_build2_loc (input_location
, NE_EXPR
,
5060 boolean_type_node
, tmp
,
5061 fold_convert (TREE_TYPE (tmp
),
5062 null_pointer_node
));
5063 gfc_start_block (&block
);
5064 gfc_add_modify (&block
, var
,
5065 fold_build1_loc (input_location
,
5067 type
, parmse
.expr
));
5068 gfc_add_expr_to_block (&parmse
.pre
,
5069 fold_build3_loc (input_location
,
5070 COND_EXPR
, void_type_node
,
5071 cond
, gfc_finish_block (&block
),
5072 build_empty_stmt (input_location
)));
5073 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5074 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
5075 TREE_TYPE (parmse
.expr
),
5077 fold_convert (TREE_TYPE (parmse
.expr
),
5078 null_pointer_node
));
5082 gfc_add_modify (&parmse
.pre
, var
,
5083 fold_build1_loc (input_location
,
5085 type
, parmse
.expr
));
5086 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5090 gfc_conv_expr_reference (&parmse
, e
);
5092 /* Catch base objects that are not variables. */
5093 if (e
->ts
.type
== BT_CLASS
5094 && e
->expr_type
!= EXPR_VARIABLE
5095 && expr
&& e
== expr
->base_expr
)
5096 base_object
= build_fold_indirect_ref_loc (input_location
,
5099 /* A class array element needs converting back to be a
5100 class object, if the formal argument is a class object. */
5101 if (fsym
&& fsym
->ts
.type
== BT_CLASS
5102 && e
->ts
.type
== BT_CLASS
5103 && ((CLASS_DATA (fsym
)->as
5104 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
5105 || CLASS_DATA (e
)->attr
.dimension
))
5106 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5107 fsym
->attr
.intent
!= INTENT_IN
5108 && (CLASS_DATA (fsym
)->attr
.class_pointer
5109 || CLASS_DATA (fsym
)->attr
.allocatable
),
5111 && e
->expr_type
== EXPR_VARIABLE
5112 && e
->symtree
->n
.sym
->attr
.optional
,
5113 CLASS_DATA (fsym
)->attr
.class_pointer
5114 || CLASS_DATA (fsym
)->attr
.allocatable
);
5116 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5117 allocated on entry, it must be deallocated. */
5118 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
5119 && (fsym
->attr
.allocatable
5120 || (fsym
->ts
.type
== BT_CLASS
5121 && CLASS_DATA (fsym
)->attr
.allocatable
)))
5126 gfc_init_block (&block
);
5128 if (e
->ts
.type
== BT_CLASS
)
5129 ptr
= gfc_class_data_get (ptr
);
5131 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
5133 gfc_add_expr_to_block (&block
, tmp
);
5134 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5135 void_type_node
, ptr
,
5137 gfc_add_expr_to_block (&block
, tmp
);
5139 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
5141 gfc_add_modify (&block
, ptr
,
5142 fold_convert (TREE_TYPE (ptr
),
5143 null_pointer_node
));
5144 gfc_add_expr_to_block (&block
, tmp
);
5146 else if (fsym
->ts
.type
== BT_CLASS
)
5149 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
5150 tmp
= gfc_get_symbol_decl (vtab
);
5151 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5152 ptr
= gfc_class_vptr_get (parmse
.expr
);
5153 gfc_add_modify (&block
, ptr
,
5154 fold_convert (TREE_TYPE (ptr
), tmp
));
5155 gfc_add_expr_to_block (&block
, tmp
);
5158 if (fsym
->attr
.optional
5159 && e
->expr_type
== EXPR_VARIABLE
5160 && e
->symtree
->n
.sym
->attr
.optional
)
5162 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5164 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5165 gfc_finish_block (&block
),
5166 build_empty_stmt (input_location
));
5169 tmp
= gfc_finish_block (&block
);
5171 gfc_add_expr_to_block (&se
->pre
, tmp
);
5174 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
5175 || fsym
->ts
.type
== BT_ASSUMED
)
5176 && e
->ts
.type
== BT_CLASS
5177 && !CLASS_DATA (e
)->attr
.dimension
5178 && !CLASS_DATA (e
)->attr
.codimension
)
5179 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
5181 /* Wrap scalar variable in a descriptor. We need to convert
5182 the address of a pointer back to the pointer itself before,
5183 we can assign it to the data field. */
5185 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
5186 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
5189 if (TREE_CODE (tmp
) == ADDR_EXPR
5190 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
5191 tmp
= TREE_OPERAND (tmp
, 0);
5192 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
5194 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
5197 else if (fsym
&& e
->expr_type
!= EXPR_NULL
5198 && ((fsym
->attr
.pointer
5199 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
5200 || (fsym
->attr
.proc_pointer
5201 && !(e
->expr_type
== EXPR_VARIABLE
5202 && e
->symtree
->n
.sym
->attr
.dummy
))
5203 || (fsym
->attr
.proc_pointer
5204 && e
->expr_type
== EXPR_VARIABLE
5205 && gfc_is_proc_ptr_comp (e
))
5206 || (fsym
->attr
.allocatable
5207 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
5209 /* Scalar pointer dummy args require an extra level of
5210 indirection. The null pointer already contains
5211 this level of indirection. */
5212 parm_kind
= SCALAR_POINTER
;
5213 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
5217 else if (e
->ts
.type
== BT_CLASS
5218 && fsym
&& fsym
->ts
.type
== BT_CLASS
5219 && (CLASS_DATA (fsym
)->attr
.dimension
5220 || CLASS_DATA (fsym
)->attr
.codimension
))
5222 /* Pass a class array. */
5223 parmse
.use_offset
= 1;
5224 gfc_conv_expr_descriptor (&parmse
, e
);
5226 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5227 allocated on entry, it must be deallocated. */
5228 if (fsym
->attr
.intent
== INTENT_OUT
5229 && CLASS_DATA (fsym
)->attr
.allocatable
)
5234 gfc_init_block (&block
);
5236 ptr
= gfc_class_data_get (ptr
);
5238 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
5239 NULL_TREE
, NULL_TREE
,
5242 gfc_add_expr_to_block (&block
, tmp
);
5243 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5244 void_type_node
, ptr
,
5246 gfc_add_expr_to_block (&block
, tmp
);
5247 gfc_reset_vptr (&block
, e
);
5249 if (fsym
->attr
.optional
5250 && e
->expr_type
== EXPR_VARIABLE
5252 || (e
->ref
->type
== REF_ARRAY
5253 && e
->ref
->u
.ar
.type
!= AR_FULL
))
5254 && e
->symtree
->n
.sym
->attr
.optional
)
5256 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5258 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5259 gfc_finish_block (&block
),
5260 build_empty_stmt (input_location
));
5263 tmp
= gfc_finish_block (&block
);
5265 gfc_add_expr_to_block (&se
->pre
, tmp
);
5268 /* The conversion does not repackage the reference to a class
5269 array - _data descriptor. */
5270 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
5271 fsym
->attr
.intent
!= INTENT_IN
5272 && (CLASS_DATA (fsym
)->attr
.class_pointer
5273 || CLASS_DATA (fsym
)->attr
.allocatable
),
5275 && e
->expr_type
== EXPR_VARIABLE
5276 && e
->symtree
->n
.sym
->attr
.optional
,
5277 CLASS_DATA (fsym
)->attr
.class_pointer
5278 || CLASS_DATA (fsym
)->attr
.allocatable
);
5282 /* If the argument is a function call that may not create
5283 a temporary for the result, we have to check that we
5284 can do it, i.e. that there is no alias between this
5285 argument and another one. */
5286 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
5292 intent
= fsym
->attr
.intent
;
5294 intent
= INTENT_UNKNOWN
;
5296 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
5298 parmse
.force_tmp
= 1;
5300 iarg
= e
->value
.function
.actual
->expr
;
5302 /* Temporary needed if aliasing due to host association. */
5303 if (sym
->attr
.contained
5305 && !sym
->attr
.implicit_pure
5306 && !sym
->attr
.use_assoc
5307 && iarg
->expr_type
== EXPR_VARIABLE
5308 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
5309 parmse
.force_tmp
= 1;
5311 /* Ditto within module. */
5312 if (sym
->attr
.use_assoc
5314 && !sym
->attr
.implicit_pure
5315 && iarg
->expr_type
== EXPR_VARIABLE
5316 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
5317 parmse
.force_tmp
= 1;
5320 if (e
->expr_type
== EXPR_VARIABLE
5321 && is_subref_array (e
))
5322 /* The actual argument is a component reference to an
5323 array of derived types. In this case, the argument
5324 is converted to a temporary, which is passed and then
5325 written back after the procedure call. */
5326 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5327 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5328 fsym
&& fsym
->attr
.pointer
);
5329 else if (gfc_is_class_array_ref (e
, NULL
)
5330 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5331 /* The actual argument is a component reference to an
5332 array of derived types. In this case, the argument
5333 is converted to a temporary, which is passed and then
5334 written back after the procedure call.
5335 OOP-TODO: Insert code so that if the dynamic type is
5336 the same as the declared type, copy-in/copy-out does
5338 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5339 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
5340 fsym
&& fsym
->attr
.pointer
);
5342 else if (gfc_is_alloc_class_array_function (e
)
5343 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
5344 /* See previous comment. For function actual argument,
5345 the write out is not needed so the intent is set as
5348 e
->must_finalize
= 1;
5349 gfc_conv_subref_array_arg (&parmse
, e
, nodesc_arg
,
5351 fsym
&& fsym
->attr
.pointer
);
5354 gfc_conv_array_parameter (&parmse
, e
, nodesc_arg
, fsym
,
5357 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5358 allocated on entry, it must be deallocated. */
5359 if (fsym
&& fsym
->attr
.allocatable
5360 && fsym
->attr
.intent
== INTENT_OUT
)
5362 tmp
= build_fold_indirect_ref_loc (input_location
,
5364 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
5365 if (fsym
->attr
.optional
5366 && e
->expr_type
== EXPR_VARIABLE
5367 && e
->symtree
->n
.sym
->attr
.optional
)
5368 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5370 gfc_conv_expr_present (e
->symtree
->n
.sym
),
5371 tmp
, build_empty_stmt (input_location
));
5372 gfc_add_expr_to_block (&se
->pre
, tmp
);
5377 /* The case with fsym->attr.optional is that of a user subroutine
5378 with an interface indicating an optional argument. When we call
5379 an intrinsic subroutine, however, fsym is NULL, but we might still
5380 have an optional argument, so we proceed to the substitution
5382 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
5384 /* If an optional argument is itself an optional dummy argument,
5385 check its presence and substitute a null if absent. This is
5386 only needed when passing an array to an elemental procedure
5387 as then array elements are accessed - or no NULL pointer is
5388 allowed and a "1" or "0" should be passed if not present.
5389 When passing a non-array-descriptor full array to a
5390 non-array-descriptor dummy, no check is needed. For
5391 array-descriptor actual to array-descriptor dummy, see
5392 PR 41911 for why a check has to be inserted.
5393 fsym == NULL is checked as intrinsics required the descriptor
5394 but do not always set fsym. */
5395 if (e
->expr_type
== EXPR_VARIABLE
5396 && e
->symtree
->n
.sym
->attr
.optional
5397 && ((e
->rank
!= 0 && elemental_proc
)
5398 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
5402 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5403 || fsym
->as
->type
== AS_ASSUMED_RANK
5404 || fsym
->as
->type
== AS_DEFERRED
))))))
5405 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
5406 e
->representation
.length
);
5411 /* Obtain the character length of an assumed character length
5412 length procedure from the typespec. */
5413 if (fsym
->ts
.type
== BT_CHARACTER
5414 && parmse
.string_length
== NULL_TREE
5415 && e
->ts
.type
== BT_PROCEDURE
5416 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
5417 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
5418 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5420 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
5421 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
5425 if (fsym
&& need_interface_mapping
&& e
)
5426 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
5428 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5429 gfc_add_block_to_block (&post
, &parmse
.post
);
5431 /* Allocated allocatable components of derived types must be
5432 deallocated for non-variable scalars, array arguments to elemental
5433 procedures, and array arguments with descriptor to non-elemental
5434 procedures. As bounds information for descriptorless arrays is no
5435 longer available here, they are dealt with in trans-array.c
5436 (gfc_conv_array_parameter). */
5437 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
5438 && e
->ts
.u
.derived
->attr
.alloc_comp
5439 && (e
->rank
== 0 || elemental_proc
|| !nodesc_arg
)
5440 && !expr_may_alias_variables (e
, elemental_proc
))
5443 /* It is known the e returns a structure type with at least one
5444 allocatable component. When e is a function, ensure that the
5445 function is called once only by using a temporary variable. */
5446 if (!DECL_P (parmse
.expr
))
5447 parmse
.expr
= gfc_evaluate_now_loc (input_location
,
5448 parmse
.expr
, &se
->pre
);
5450 if (fsym
&& fsym
->attr
.value
)
5453 tmp
= build_fold_indirect_ref_loc (input_location
,
5456 parm_rank
= e
->rank
;
5464 case (SCALAR_POINTER
):
5465 tmp
= build_fold_indirect_ref_loc (input_location
,
5470 if (e
->expr_type
== EXPR_OP
5471 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
5472 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
5475 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
5476 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
5477 gfc_add_expr_to_block (&se
->post
, local_tmp
);
5480 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
5482 /* The derived type is passed to gfc_deallocate_alloc_comp.
5483 Therefore, class actuals can handled correctly but derived
5484 types passed to class formals need the _data component. */
5485 tmp
= gfc_class_data_get (tmp
);
5486 if (!CLASS_DATA (fsym
)->attr
.dimension
)
5487 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
5490 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
5492 gfc_add_expr_to_block (&se
->post
, tmp
);
5495 /* Add argument checking of passing an unallocated/NULL actual to
5496 a nonallocatable/nonpointer dummy. */
5498 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
5500 symbol_attribute attr
;
5504 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
5505 attr
= gfc_expr_attr (e
);
5507 goto end_pointer_check
;
5509 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5510 allocatable to an optional dummy, cf. 12.5.2.12. */
5511 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
5512 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5513 goto end_pointer_check
;
5517 /* If the actual argument is an optional pointer/allocatable and
5518 the formal argument takes an nonpointer optional value,
5519 it is invalid to pass a non-present argument on, even
5520 though there is no technical reason for this in gfortran.
5521 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5522 tree present
, null_ptr
, type
;
5524 if (attr
.allocatable
5525 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5526 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5527 "allocated or not present",
5528 e
->symtree
->n
.sym
->name
);
5529 else if (attr
.pointer
5530 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5531 msg
= xasprintf ("Pointer actual argument '%s' is not "
5532 "associated or not present",
5533 e
->symtree
->n
.sym
->name
);
5534 else if (attr
.proc_pointer
5535 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5536 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5537 "associated or not present",
5538 e
->symtree
->n
.sym
->name
);
5540 goto end_pointer_check
;
5542 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
5543 type
= TREE_TYPE (present
);
5544 present
= fold_build2_loc (input_location
, EQ_EXPR
,
5545 boolean_type_node
, present
,
5547 null_pointer_node
));
5548 type
= TREE_TYPE (parmse
.expr
);
5549 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
5550 boolean_type_node
, parmse
.expr
,
5552 null_pointer_node
));
5553 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
5554 boolean_type_node
, present
, null_ptr
);
5558 if (attr
.allocatable
5559 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
5560 msg
= xasprintf ("Allocatable actual argument '%s' is not "
5561 "allocated", e
->symtree
->n
.sym
->name
);
5562 else if (attr
.pointer
5563 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
5564 msg
= xasprintf ("Pointer actual argument '%s' is not "
5565 "associated", e
->symtree
->n
.sym
->name
);
5566 else if (attr
.proc_pointer
5567 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
5568 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
5569 "associated", e
->symtree
->n
.sym
->name
);
5571 goto end_pointer_check
;
5575 /* If the argument is passed by value, we need to strip the
5577 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
5578 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5580 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
5581 boolean_type_node
, tmp
,
5582 fold_convert (TREE_TYPE (tmp
),
5583 null_pointer_node
));
5586 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5592 /* Deferred length dummies pass the character length by reference
5593 so that the value can be returned. */
5594 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5596 if (INDIRECT_REF_P (parmse
.string_length
))
5597 /* In chains of functions/procedure calls the string_length already
5598 is a pointer to the variable holding the length. Therefore
5599 remove the deref on call. */
5600 parmse
.string_length
= TREE_OPERAND (parmse
.string_length
, 0);
5603 tmp
= parmse
.string_length
;
5604 if (TREE_CODE (tmp
) != VAR_DECL
)
5605 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5606 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5610 /* Character strings are passed as two parameters, a length and a
5611 pointer - except for Bind(c) which only passes the pointer.
5612 An unlimited polymorphic formal argument likewise does not
5614 if (parmse
.string_length
!= NULL_TREE
5615 && !sym
->attr
.is_bind_c
5616 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5617 vec_safe_push (stringargs
, parmse
.string_length
);
5619 /* When calling __copy for character expressions to unlimited
5620 polymorphic entities, the dst argument needs a string length. */
5621 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5622 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5623 && arg
->next
&& arg
->next
->expr
5624 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5625 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5626 vec_safe_push (stringargs
, parmse
.string_length
);
5628 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5629 pass the token and the offset as additional arguments. */
5630 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5631 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5632 && !fsym
->attr
.allocatable
)
5633 || (fsym
->ts
.type
== BT_CLASS
5634 && CLASS_DATA (fsym
)->attr
.codimension
5635 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5637 /* Token and offset. */
5638 vec_safe_push (stringargs
, null_pointer_node
);
5639 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5640 gcc_assert (fsym
->attr
.optional
);
5642 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5643 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5644 && !fsym
->attr
.allocatable
)
5645 || (fsym
->ts
.type
== BT_CLASS
5646 && CLASS_DATA (fsym
)->attr
.codimension
5647 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5649 tree caf_decl
, caf_type
;
5652 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5653 caf_type
= TREE_TYPE (caf_decl
);
5655 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5656 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5657 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5658 tmp
= gfc_conv_descriptor_token (caf_decl
);
5659 else if (DECL_LANG_SPECIFIC (caf_decl
)
5660 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5661 tmp
= GFC_DECL_TOKEN (caf_decl
);
5664 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5665 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5666 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5669 vec_safe_push (stringargs
, tmp
);
5671 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5672 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5673 offset
= build_int_cst (gfc_array_index_type
, 0);
5674 else if (DECL_LANG_SPECIFIC (caf_decl
)
5675 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5676 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5677 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5678 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5680 offset
= build_int_cst (gfc_array_index_type
, 0);
5682 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5683 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5686 gcc_assert (POINTER_TYPE_P (caf_type
));
5690 tmp2
= fsym
->ts
.type
== BT_CLASS
5691 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5692 if ((fsym
->ts
.type
!= BT_CLASS
5693 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5694 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5695 || (fsym
->ts
.type
== BT_CLASS
5696 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5697 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5699 if (fsym
->ts
.type
== BT_CLASS
)
5700 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5703 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5704 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5706 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5707 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5709 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5710 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5713 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5716 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5717 gfc_array_index_type
,
5718 fold_convert (gfc_array_index_type
, tmp2
),
5719 fold_convert (gfc_array_index_type
, tmp
));
5720 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5721 gfc_array_index_type
, offset
, tmp
);
5723 vec_safe_push (stringargs
, offset
);
5726 vec_safe_push (arglist
, parmse
.expr
);
5728 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5735 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5736 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5737 else if (ts
.type
== BT_CHARACTER
)
5739 if (ts
.u
.cl
->length
== NULL
)
5741 /* Assumed character length results are not allowed by 5.1.1.5 of the
5742 standard and are trapped in resolve.c; except in the case of SPREAD
5743 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5744 we take the character length of the first argument for the result.
5745 For dummies, we have to look through the formal argument list for
5746 this function and use the character length found there.*/
5748 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5749 else if (!sym
->attr
.dummy
)
5750 cl
.backend_decl
= (*stringargs
)[0];
5753 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5754 for (; formal
; formal
= formal
->next
)
5755 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5756 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5758 len
= cl
.backend_decl
;
5764 /* Calculate the length of the returned string. */
5765 gfc_init_se (&parmse
, NULL
);
5766 if (need_interface_mapping
)
5767 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5769 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5770 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5771 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5773 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5774 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5775 gfc_charlen_type_node
, tmp
,
5776 build_int_cst (gfc_charlen_type_node
, 0));
5777 cl
.backend_decl
= tmp
;
5780 /* Set up a charlen structure for it. */
5785 len
= cl
.backend_decl
;
5788 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5789 || (!comp
&& gfc_return_by_reference (sym
));
5792 if (se
->direct_byref
)
5794 /* Sometimes, too much indirection can be applied; e.g. for
5795 function_result = array_valued_recursive_function. */
5796 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5797 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5798 && GFC_DESCRIPTOR_TYPE_P
5799 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5800 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5803 /* If the lhs of an assignment x = f(..) is allocatable and
5804 f2003 is allowed, we must do the automatic reallocation.
5805 TODO - deal with intrinsics, without using a temporary. */
5806 if (flag_realloc_lhs
5807 && se
->ss
&& se
->ss
->loop_chain
5808 && se
->ss
->loop_chain
->is_alloc_lhs
5809 && !expr
->value
.function
.isym
5810 && sym
->result
->as
!= NULL
)
5812 /* Evaluate the bounds of the result, if known. */
5813 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5816 /* Perform the automatic reallocation. */
5817 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5819 gfc_add_expr_to_block (&se
->pre
, tmp
);
5821 /* Pass the temporary as the first argument. */
5822 result
= info
->descriptor
;
5825 result
= build_fold_indirect_ref_loc (input_location
,
5827 vec_safe_push (retargs
, se
->expr
);
5829 else if (comp
&& comp
->attr
.dimension
)
5831 gcc_assert (se
->loop
&& info
);
5833 /* Set the type of the array. */
5834 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5835 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5837 /* Evaluate the bounds of the result, if known. */
5838 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5840 /* If the lhs of an assignment x = f(..) is allocatable and
5841 f2003 is allowed, we must not generate the function call
5842 here but should just send back the results of the mapping.
5843 This is signalled by the function ss being flagged. */
5844 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5846 gfc_free_interface_mapping (&mapping
);
5847 return has_alternate_specifier
;
5850 /* Create a temporary to store the result. In case the function
5851 returns a pointer, the temporary will be a shallow copy and
5852 mustn't be deallocated. */
5853 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5854 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5855 tmp
, NULL_TREE
, false,
5856 !comp
->attr
.pointer
, callee_alloc
,
5857 &se
->ss
->info
->expr
->where
);
5859 /* Pass the temporary as the first argument. */
5860 result
= info
->descriptor
;
5861 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5862 vec_safe_push (retargs
, tmp
);
5864 else if (!comp
&& sym
->result
->attr
.dimension
)
5866 gcc_assert (se
->loop
&& info
);
5868 /* Set the type of the array. */
5869 tmp
= gfc_typenode_for_spec (&ts
);
5870 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5872 /* Evaluate the bounds of the result, if known. */
5873 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5875 /* If the lhs of an assignment x = f(..) is allocatable and
5876 f2003 is allowed, we must not generate the function call
5877 here but should just send back the results of the mapping.
5878 This is signalled by the function ss being flagged. */
5879 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5881 gfc_free_interface_mapping (&mapping
);
5882 return has_alternate_specifier
;
5885 /* Create a temporary to store the result. In case the function
5886 returns a pointer, the temporary will be a shallow copy and
5887 mustn't be deallocated. */
5888 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5889 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5890 tmp
, NULL_TREE
, false,
5891 !sym
->attr
.pointer
, callee_alloc
,
5892 &se
->ss
->info
->expr
->where
);
5894 /* Pass the temporary as the first argument. */
5895 result
= info
->descriptor
;
5896 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5897 vec_safe_push (retargs
, tmp
);
5899 else if (ts
.type
== BT_CHARACTER
)
5901 /* Pass the string length. */
5902 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5903 type
= build_pointer_type (type
);
5905 /* Return an address to a char[0:len-1]* temporary for
5906 character pointers. */
5907 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5908 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5910 var
= gfc_create_var (type
, "pstr");
5912 if ((!comp
&& sym
->attr
.allocatable
)
5913 || (comp
&& comp
->attr
.allocatable
))
5915 gfc_add_modify (&se
->pre
, var
,
5916 fold_convert (TREE_TYPE (var
),
5917 null_pointer_node
));
5918 tmp
= gfc_call_free (var
);
5919 gfc_add_expr_to_block (&se
->post
, tmp
);
5922 /* Provide an address expression for the function arguments. */
5923 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5926 var
= gfc_conv_string_tmp (se
, type
, len
);
5928 vec_safe_push (retargs
, var
);
5932 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5934 type
= gfc_get_complex_type (ts
.kind
);
5935 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5936 vec_safe_push (retargs
, var
);
5939 /* Add the string length to the argument list. */
5940 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5943 if (TREE_CODE (tmp
) != VAR_DECL
)
5944 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5945 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5946 vec_safe_push (retargs
, tmp
);
5948 else if (ts
.type
== BT_CHARACTER
)
5949 vec_safe_push (retargs
, len
);
5951 gfc_free_interface_mapping (&mapping
);
5953 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5954 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5955 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5956 vec_safe_reserve (retargs
, arglen
);
5958 /* Add the return arguments. */
5959 vec_safe_splice (retargs
, arglist
);
5961 /* Add the hidden present status for optional+value to the arguments. */
5962 vec_safe_splice (retargs
, optionalargs
);
5964 /* Add the hidden string length parameters to the arguments. */
5965 vec_safe_splice (retargs
, stringargs
);
5967 /* We may want to append extra arguments here. This is used e.g. for
5968 calls to libgfortran_matmul_??, which need extra information. */
5969 vec_safe_splice (retargs
, append_args
);
5973 /* Generate the actual call. */
5974 if (base_object
== NULL_TREE
)
5975 conv_function_val (se
, sym
, expr
);
5977 conv_base_obj_fcn_val (se
, base_object
, expr
);
5979 /* If there are alternate return labels, function type should be
5980 integer. Can't modify the type in place though, since it can be shared
5981 with other functions. For dummy arguments, the typing is done to
5982 this result, even if it has to be repeated for each call. */
5983 if (has_alternate_specifier
5984 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5986 if (!sym
->attr
.dummy
)
5988 TREE_TYPE (sym
->backend_decl
)
5989 = build_function_type (integer_type_node
,
5990 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5991 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5994 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5997 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5998 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
6000 /* Allocatable scalar function results must be freed and nullified
6001 after use. This necessitates the creation of a temporary to
6002 hold the result to prevent duplicate calls. */
6003 if (!byref
&& sym
->ts
.type
!= BT_CHARACTER
6004 && sym
->attr
.allocatable
&& !sym
->attr
.dimension
)
6006 tmp
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6007 gfc_add_modify (&se
->pre
, tmp
, se
->expr
);
6009 tmp
= gfc_call_free (tmp
);
6010 gfc_add_expr_to_block (&post
, tmp
);
6011 gfc_add_modify (&post
, se
->expr
, build_int_cst (TREE_TYPE (se
->expr
), 0));
6014 /* If we have a pointer function, but we don't want a pointer, e.g.
6017 where f is pointer valued, we have to dereference the result. */
6018 if (!se
->want_pointer
&& !byref
6019 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6020 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
6021 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6023 /* f2c calling conventions require a scalar default real function to
6024 return a double precision result. Convert this back to default
6025 real. We only care about the cases that can happen in Fortran 77.
6027 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
6028 && sym
->ts
.kind
== gfc_default_real_kind
6029 && !sym
->attr
.always_explicit
)
6030 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
6032 /* A pure function may still have side-effects - it may modify its
6034 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6036 if (!sym
->attr
.pure
)
6037 TREE_SIDE_EFFECTS (se
->expr
) = 1;
6042 /* Add the function call to the pre chain. There is no expression. */
6043 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
6044 se
->expr
= NULL_TREE
;
6046 if (!se
->direct_byref
)
6048 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
6050 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6052 /* Check the data pointer hasn't been modified. This would
6053 happen in a function returning a pointer. */
6054 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
6055 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6058 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
6061 se
->expr
= info
->descriptor
;
6062 /* Bundle in the string length. */
6063 se
->string_length
= len
;
6065 else if (ts
.type
== BT_CHARACTER
)
6067 /* Dereference for character pointer results. */
6068 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
6069 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
6070 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6074 se
->string_length
= len
;
6078 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
6079 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
6084 /* Follow the function call with the argument post block. */
6087 gfc_add_block_to_block (&se
->pre
, &post
);
6089 /* Transformational functions of derived types with allocatable
6090 components must have the result allocatable components copied. */
6091 arg
= expr
->value
.function
.actual
;
6092 if (result
&& arg
&& expr
->rank
6093 && expr
->value
.function
.isym
6094 && expr
->value
.function
.isym
->transformational
6095 && arg
->expr
->ts
.type
== BT_DERIVED
6096 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
6099 /* Copy the allocatable components. We have to use a
6100 temporary here to prevent source allocatable components
6101 from being corrupted. */
6102 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
6103 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
6104 result
, tmp2
, expr
->rank
);
6105 gfc_add_expr_to_block (&se
->pre
, tmp
);
6106 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
6108 gfc_add_expr_to_block (&se
->pre
, tmp
);
6110 /* Finally free the temporary's data field. */
6111 tmp
= gfc_conv_descriptor_data_get (tmp2
);
6112 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
6113 NULL_TREE
, NULL_TREE
, true,
6115 gfc_add_expr_to_block (&se
->pre
, tmp
);
6120 /* For a function with a class array result, save the result as
6121 a temporary, set the info fields needed by the scalarizer and
6122 call the finalization function of the temporary. Note that the
6123 nullification of allocatable components needed by the result
6124 is done in gfc_trans_assignment_1. */
6125 if (expr
&& ((gfc_is_alloc_class_array_function (expr
)
6126 && se
->ss
&& se
->ss
->loop
)
6127 || gfc_is_alloc_class_scalar_function (expr
))
6128 && se
->expr
&& GFC_CLASS_TYPE_P (TREE_TYPE (se
->expr
))
6129 && expr
->must_finalize
)
6134 if (se
->ss
&& se
->ss
->loop
)
6136 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->ss
->loop
->pre
);
6137 tmp
= gfc_class_data_get (se
->expr
);
6138 info
->descriptor
= tmp
;
6139 info
->data
= gfc_conv_descriptor_data_get (tmp
);
6140 info
->offset
= gfc_conv_descriptor_offset_get (tmp
);
6141 for (n
= 0; n
< se
->ss
->loop
->dimen
; n
++)
6143 tree dim
= gfc_rank_cst
[n
];
6144 se
->ss
->loop
->to
[n
] = gfc_conv_descriptor_ubound_get (tmp
, dim
);
6145 se
->ss
->loop
->from
[n
] = gfc_conv_descriptor_lbound_get (tmp
, dim
);
6150 /* TODO Eliminate the doubling of temporaries. This
6151 one is necessary to ensure no memory leakage. */
6152 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
6153 tmp
= gfc_class_data_get (se
->expr
);
6154 tmp
= gfc_conv_scalar_to_descriptor (se
, tmp
,
6155 CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
);
6158 final_fndecl
= gfc_class_vtab_final_get (se
->expr
);
6159 is_final
= fold_build2_loc (input_location
, NE_EXPR
,
6162 fold_convert (TREE_TYPE (final_fndecl
),
6163 null_pointer_node
));
6164 final_fndecl
= build_fold_indirect_ref_loc (input_location
,
6166 tmp
= build_call_expr_loc (input_location
,
6168 gfc_build_addr_expr (NULL
, tmp
),
6169 gfc_class_vtab_size_get (se
->expr
),
6170 boolean_false_node
);
6171 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6172 void_type_node
, is_final
, tmp
,
6173 build_empty_stmt (input_location
));
6175 if (se
->ss
&& se
->ss
->loop
)
6177 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6178 tmp
= gfc_call_free (info
->data
);
6179 gfc_add_expr_to_block (&se
->ss
->loop
->post
, tmp
);
6183 gfc_add_expr_to_block (&se
->post
, tmp
);
6184 tmp
= gfc_class_data_get (se
->expr
);
6185 tmp
= gfc_call_free (tmp
);
6186 gfc_add_expr_to_block (&se
->post
, tmp
);
6188 expr
->must_finalize
= 0;
6191 gfc_add_block_to_block (&se
->post
, &post
);
6194 return has_alternate_specifier
;
6198 /* Fill a character string with spaces. */
6201 fill_with_spaces (tree start
, tree type
, tree size
)
6203 stmtblock_t block
, loop
;
6204 tree i
, el
, exit_label
, cond
, tmp
;
6206 /* For a simple char type, we can call memset(). */
6207 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
6208 return build_call_expr_loc (input_location
,
6209 builtin_decl_explicit (BUILT_IN_MEMSET
),
6211 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
6212 lang_hooks
.to_target_charset (' ')),
6215 /* Otherwise, we use a loop:
6216 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6220 /* Initialize variables. */
6221 gfc_init_block (&block
);
6222 i
= gfc_create_var (sizetype
, "i");
6223 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
6224 el
= gfc_create_var (build_pointer_type (type
), "el");
6225 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
6226 exit_label
= gfc_build_label_decl (NULL_TREE
);
6227 TREE_USED (exit_label
) = 1;
6231 gfc_init_block (&loop
);
6233 /* Exit condition. */
6234 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
6235 build_zero_cst (sizetype
));
6236 tmp
= build1_v (GOTO_EXPR
, exit_label
);
6237 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6238 build_empty_stmt (input_location
));
6239 gfc_add_expr_to_block (&loop
, tmp
);
6242 gfc_add_modify (&loop
,
6243 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
6244 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
6246 /* Increment loop variables. */
6247 gfc_add_modify (&loop
, i
,
6248 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
6249 TYPE_SIZE_UNIT (type
)));
6250 gfc_add_modify (&loop
, el
,
6251 fold_build_pointer_plus_loc (input_location
,
6252 el
, TYPE_SIZE_UNIT (type
)));
6254 /* Making the loop... actually loop! */
6255 tmp
= gfc_finish_block (&loop
);
6256 tmp
= build1_v (LOOP_EXPR
, tmp
);
6257 gfc_add_expr_to_block (&block
, tmp
);
6259 /* The exit label. */
6260 tmp
= build1_v (LABEL_EXPR
, exit_label
);
6261 gfc_add_expr_to_block (&block
, tmp
);
6264 return gfc_finish_block (&block
);
6268 /* Generate code to copy a string. */
6271 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
6272 int dkind
, tree slength
, tree src
, int skind
)
6274 tree tmp
, dlen
, slen
;
6283 stmtblock_t tempblock
;
6285 gcc_assert (dkind
== skind
);
6287 if (slength
!= NULL_TREE
)
6289 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
6290 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
6294 slen
= build_int_cst (size_type_node
, 1);
6298 if (dlength
!= NULL_TREE
)
6300 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
6301 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
6305 dlen
= build_int_cst (size_type_node
, 1);
6309 /* Assign directly if the types are compatible. */
6310 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
6311 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
6313 gfc_add_modify (block
, dsc
, ssc
);
6317 /* Do nothing if the destination length is zero. */
6318 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
6319 build_int_cst (size_type_node
, 0));
6321 /* The following code was previously in _gfortran_copy_string:
6323 // The two strings may overlap so we use memmove.
6325 copy_string (GFC_INTEGER_4 destlen, char * dest,
6326 GFC_INTEGER_4 srclen, const char * src)
6328 if (srclen >= destlen)
6330 // This will truncate if too long.
6331 memmove (dest, src, destlen);
6335 memmove (dest, src, srclen);
6337 memset (&dest[srclen], ' ', destlen - srclen);
6341 We're now doing it here for better optimization, but the logic
6344 /* For non-default character kinds, we have to multiply the string
6345 length by the base type size. */
6346 chartype
= gfc_get_char_type (dkind
);
6347 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6348 fold_convert (size_type_node
, slen
),
6349 fold_convert (size_type_node
,
6350 TYPE_SIZE_UNIT (chartype
)));
6351 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
6352 fold_convert (size_type_node
, dlen
),
6353 fold_convert (size_type_node
,
6354 TYPE_SIZE_UNIT (chartype
)));
6356 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
6357 dest
= fold_convert (pvoid_type_node
, dest
);
6359 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
6361 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
6362 src
= fold_convert (pvoid_type_node
, src
);
6364 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6366 /* Truncate string if source is too long. */
6367 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
6369 tmp2
= build_call_expr_loc (input_location
,
6370 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6371 3, dest
, src
, dlen
);
6373 /* Else copy and pad with spaces. */
6374 tmp3
= build_call_expr_loc (input_location
,
6375 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
6376 3, dest
, src
, slen
);
6378 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
6379 tmp4
= fill_with_spaces (tmp4
, chartype
,
6380 fold_build2_loc (input_location
, MINUS_EXPR
,
6381 TREE_TYPE(dlen
), dlen
, slen
));
6383 gfc_init_block (&tempblock
);
6384 gfc_add_expr_to_block (&tempblock
, tmp3
);
6385 gfc_add_expr_to_block (&tempblock
, tmp4
);
6386 tmp3
= gfc_finish_block (&tempblock
);
6388 /* The whole copy_string function is there. */
6389 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
6391 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
6392 build_empty_stmt (input_location
));
6393 gfc_add_expr_to_block (block
, tmp
);
6397 /* Translate a statement function.
6398 The value of a statement function reference is obtained by evaluating the
6399 expression using the values of the actual arguments for the values of the
6400 corresponding dummy arguments. */
6403 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
6407 gfc_formal_arglist
*fargs
;
6408 gfc_actual_arglist
*args
;
6411 gfc_saved_var
*saved_vars
;
6417 sym
= expr
->symtree
->n
.sym
;
6418 args
= expr
->value
.function
.actual
;
6419 gfc_init_se (&lse
, NULL
);
6420 gfc_init_se (&rse
, NULL
);
6423 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
6425 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
6426 temp_vars
= XCNEWVEC (tree
, n
);
6428 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6429 fargs
= fargs
->next
, n
++)
6431 /* Each dummy shall be specified, explicitly or implicitly, to be
6433 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
6436 if (fsym
->ts
.type
== BT_CHARACTER
)
6438 /* Copy string arguments. */
6441 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
6442 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
6444 /* Create a temporary to hold the value. */
6445 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
6446 fsym
->ts
.u
.cl
->backend_decl
6447 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
6449 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
6450 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6452 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
6454 gfc_conv_expr (&rse
, args
->expr
);
6455 gfc_conv_string_parameter (&rse
);
6456 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6457 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
6459 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
6460 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
6461 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6462 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
6466 /* For everything else, just evaluate the expression. */
6468 /* Create a temporary to hold the value. */
6469 type
= gfc_typenode_for_spec (&fsym
->ts
);
6470 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
6472 gfc_conv_expr (&lse
, args
->expr
);
6474 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
6475 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
6476 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
6482 /* Use the temporary variables in place of the real ones. */
6483 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6484 fargs
= fargs
->next
, n
++)
6485 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
6487 gfc_conv_expr (se
, sym
->value
);
6489 if (sym
->ts
.type
== BT_CHARACTER
)
6491 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
6493 /* Force the expression to the correct length. */
6494 if (!INTEGER_CST_P (se
->string_length
)
6495 || tree_int_cst_lt (se
->string_length
,
6496 sym
->ts
.u
.cl
->backend_decl
))
6498 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
6499 tmp
= gfc_create_var (type
, sym
->name
);
6500 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
6501 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
6502 sym
->ts
.kind
, se
->string_length
, se
->expr
,
6506 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
6509 /* Restore the original variables. */
6510 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
6511 fargs
= fargs
->next
, n
++)
6512 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
6518 /* Translate a function expression. */
6521 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
6525 if (expr
->value
.function
.isym
)
6527 gfc_conv_intrinsic_function (se
, expr
);
6531 /* expr.value.function.esym is the resolved (specific) function symbol for
6532 most functions. However this isn't set for dummy procedures. */
6533 sym
= expr
->value
.function
.esym
;
6535 sym
= expr
->symtree
->n
.sym
;
6537 /* The IEEE_ARITHMETIC functions are caught here. */
6538 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6539 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
6542 /* We distinguish statement functions from general functions to improve
6543 runtime performance. */
6544 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
6546 gfc_conv_statement_function (se
, expr
);
6550 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
6555 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6558 is_zero_initializer_p (gfc_expr
* expr
)
6560 if (expr
->expr_type
!= EXPR_CONSTANT
)
6563 /* We ignore constants with prescribed memory representations for now. */
6564 if (expr
->representation
.string
)
6567 switch (expr
->ts
.type
)
6570 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
6573 return mpfr_zero_p (expr
->value
.real
)
6574 && MPFR_SIGN (expr
->value
.real
) >= 0;
6577 return expr
->value
.logical
== 0;
6580 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
6581 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
6582 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
6583 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
6593 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
6598 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
6599 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
6601 gfc_conv_tmp_array_ref (se
);
6605 /* Build a static initializer. EXPR is the expression for the initial value.
6606 The other parameters describe the variable of the component being
6607 initialized. EXPR may be null. */
6610 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
6611 bool array
, bool pointer
, bool procptr
)
6615 if (!(expr
|| pointer
|| procptr
))
6618 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6619 (these are the only two iso_c_binding derived types that can be
6620 used as initialization expressions). If so, we need to modify
6621 the 'expr' to be that for a (void *). */
6622 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
6623 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
6625 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
6627 /* The derived symbol has already been converted to a (void *). Use
6629 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
6630 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
6632 gfc_init_se (&se
, NULL
);
6633 gfc_conv_constant (&se
, expr
);
6634 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6638 if (array
&& !procptr
)
6641 /* Arrays need special handling. */
6643 ctor
= gfc_build_null_descriptor (type
);
6644 /* Special case assigning an array to zero. */
6645 else if (is_zero_initializer_p (expr
))
6646 ctor
= build_constructor (type
, NULL
);
6648 ctor
= gfc_conv_array_initializer (type
, expr
);
6649 TREE_STATIC (ctor
) = 1;
6652 else if (pointer
|| procptr
)
6654 if (ts
->type
== BT_CLASS
&& !procptr
)
6656 gfc_init_se (&se
, NULL
);
6657 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6658 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6659 TREE_STATIC (se
.expr
) = 1;
6662 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
6663 return fold_convert (type
, null_pointer_node
);
6666 gfc_init_se (&se
, NULL
);
6667 se
.want_pointer
= 1;
6668 gfc_conv_expr (&se
, expr
);
6669 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6679 gfc_init_se (&se
, NULL
);
6680 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6681 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6683 gfc_conv_structure (&se
, expr
, 1);
6684 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6685 TREE_STATIC (se
.expr
) = 1;
6690 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6691 TREE_STATIC (ctor
) = 1;
6696 gfc_init_se (&se
, NULL
);
6697 gfc_conv_constant (&se
, expr
);
6698 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6705 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6711 gfc_array_info
*lss_array
;
6718 gfc_start_block (&block
);
6720 /* Initialize the scalarizer. */
6721 gfc_init_loopinfo (&loop
);
6723 gfc_init_se (&lse
, NULL
);
6724 gfc_init_se (&rse
, NULL
);
6727 rss
= gfc_walk_expr (expr
);
6728 if (rss
== gfc_ss_terminator
)
6729 /* The rhs is scalar. Add a ss for the expression. */
6730 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6732 /* Create a SS for the destination. */
6733 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6735 lss_array
= &lss
->info
->data
.array
;
6736 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6737 lss_array
->descriptor
= dest
;
6738 lss_array
->data
= gfc_conv_array_data (dest
);
6739 lss_array
->offset
= gfc_conv_array_offset (dest
);
6740 for (n
= 0; n
< cm
->as
->rank
; n
++)
6742 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6743 lss_array
->stride
[n
] = gfc_index_one_node
;
6745 mpz_init (lss_array
->shape
[n
]);
6746 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6747 cm
->as
->lower
[n
]->value
.integer
);
6748 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6751 /* Associate the SS with the loop. */
6752 gfc_add_ss_to_loop (&loop
, lss
);
6753 gfc_add_ss_to_loop (&loop
, rss
);
6755 /* Calculate the bounds of the scalarization. */
6756 gfc_conv_ss_startstride (&loop
);
6758 /* Setup the scalarizing loops. */
6759 gfc_conv_loop_setup (&loop
, &expr
->where
);
6761 /* Setup the gfc_se structures. */
6762 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6763 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6766 gfc_mark_ss_chain_used (rss
, 1);
6768 gfc_mark_ss_chain_used (lss
, 1);
6770 /* Start the scalarized loop body. */
6771 gfc_start_scalarized_body (&loop
, &body
);
6773 gfc_conv_tmp_array_ref (&lse
);
6774 if (cm
->ts
.type
== BT_CHARACTER
)
6775 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6777 gfc_conv_expr (&rse
, expr
);
6779 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
6780 gfc_add_expr_to_block (&body
, tmp
);
6782 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6784 /* Generate the copying loops. */
6785 gfc_trans_scalarizing_loops (&loop
, &body
);
6787 /* Wrap the whole thing up. */
6788 gfc_add_block_to_block (&block
, &loop
.pre
);
6789 gfc_add_block_to_block (&block
, &loop
.post
);
6791 gcc_assert (lss_array
->shape
!= NULL
);
6792 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6793 gfc_cleanup_loop (&loop
);
6795 return gfc_finish_block (&block
);
6800 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6810 gfc_expr
*arg
= NULL
;
6812 gfc_start_block (&block
);
6813 gfc_init_se (&se
, NULL
);
6815 /* Get the descriptor for the expressions. */
6816 se
.want_pointer
= 0;
6817 gfc_conv_expr_descriptor (&se
, expr
);
6818 gfc_add_block_to_block (&block
, &se
.pre
);
6819 gfc_add_modify (&block
, dest
, se
.expr
);
6821 /* Deal with arrays of derived types with allocatable components. */
6822 if (cm
->ts
.type
== BT_DERIVED
6823 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6824 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6827 else if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
6828 && CLASS_DATA(cm
)->attr
.allocatable
)
6830 if (cm
->ts
.u
.derived
->attr
.alloc_comp
)
6831 tmp
= gfc_copy_alloc_comp (expr
->ts
.u
.derived
,
6836 tmp
= TREE_TYPE (dest
);
6837 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6838 tmp
, expr
->rank
, NULL_TREE
);
6842 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6843 TREE_TYPE(cm
->backend_decl
),
6844 cm
->as
->rank
, NULL_TREE
);
6846 gfc_add_expr_to_block (&block
, tmp
);
6847 gfc_add_block_to_block (&block
, &se
.post
);
6849 if (expr
->expr_type
!= EXPR_VARIABLE
)
6850 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6853 /* We need to know if the argument of a conversion function is a
6854 variable, so that the correct lower bound can be used. */
6855 if (expr
->expr_type
== EXPR_FUNCTION
6856 && expr
->value
.function
.isym
6857 && expr
->value
.function
.isym
->conversion
6858 && expr
->value
.function
.actual
->expr
6859 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6860 arg
= expr
->value
.function
.actual
->expr
;
6862 /* Obtain the array spec of full array references. */
6864 as
= gfc_get_full_arrayspec_from_expr (arg
);
6866 as
= gfc_get_full_arrayspec_from_expr (expr
);
6868 /* Shift the lbound and ubound of temporaries to being unity,
6869 rather than zero, based. Always calculate the offset. */
6870 offset
= gfc_conv_descriptor_offset_get (dest
);
6871 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6872 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6874 for (n
= 0; n
< expr
->rank
; n
++)
6879 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6880 TODO It looks as if gfc_conv_expr_descriptor should return
6881 the correct bounds and that the following should not be
6882 necessary. This would simplify gfc_conv_intrinsic_bound
6884 if (as
&& as
->lower
[n
])
6887 gfc_init_se (&lbse
, NULL
);
6888 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6889 gfc_add_block_to_block (&block
, &lbse
.pre
);
6890 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6894 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6895 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6899 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6902 lbound
= gfc_index_one_node
;
6904 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6906 /* Shift the bounds and set the offset accordingly. */
6907 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6908 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6909 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6910 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6912 gfc_conv_descriptor_ubound_set (&block
, dest
,
6913 gfc_rank_cst
[n
], tmp
);
6914 gfc_conv_descriptor_lbound_set (&block
, dest
,
6915 gfc_rank_cst
[n
], lbound
);
6917 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6918 gfc_conv_descriptor_lbound_get (dest
,
6920 gfc_conv_descriptor_stride_get (dest
,
6922 gfc_add_modify (&block
, tmp2
, tmp
);
6923 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6925 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6930 /* If a conversion expression has a null data pointer
6931 argument, nullify the allocatable component. */
6935 if (arg
->symtree
->n
.sym
->attr
.allocatable
6936 || arg
->symtree
->n
.sym
->attr
.pointer
)
6938 non_null_expr
= gfc_finish_block (&block
);
6939 gfc_start_block (&block
);
6940 gfc_conv_descriptor_data_set (&block
, dest
,
6942 null_expr
= gfc_finish_block (&block
);
6943 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6944 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6945 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6946 return build3_v (COND_EXPR
, tmp
,
6947 null_expr
, non_null_expr
);
6951 return gfc_finish_block (&block
);
6955 /* Allocate or reallocate scalar component, as necessary. */
6958 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t
*block
,
6968 tree lhs_cl_size
= NULL_TREE
;
6973 if (!expr2
|| expr2
->rank
)
6976 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
6978 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
6980 char name
[GFC_MAX_SYMBOL_LEN
+9];
6981 gfc_component
*strlen
;
6982 /* Use the rhs string length and the lhs element size. */
6983 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6984 if (!expr2
->ts
.u
.cl
->backend_decl
)
6986 gfc_conv_string_length (expr2
->ts
.u
.cl
, expr2
, block
);
6987 gcc_assert (expr2
->ts
.u
.cl
->backend_decl
);
6990 size
= expr2
->ts
.u
.cl
->backend_decl
;
6992 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
6994 sprintf (name
, "_%s_length", cm
->name
);
6995 strlen
= gfc_find_component (sym
, name
, true, true);
6996 lhs_cl_size
= fold_build3_loc (input_location
, COMPONENT_REF
,
6997 gfc_charlen_type_node
,
6998 TREE_OPERAND (comp
, 0),
6999 strlen
->backend_decl
, NULL_TREE
);
7001 tmp
= TREE_TYPE (gfc_typenode_for_spec (&cm
->ts
));
7002 tmp
= TYPE_SIZE_UNIT (tmp
);
7003 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7004 TREE_TYPE (tmp
), tmp
,
7005 fold_convert (TREE_TYPE (tmp
), size
));
7007 else if (cm
->ts
.type
== BT_CLASS
)
7009 gcc_assert (expr2
->ts
.type
== BT_CLASS
|| expr2
->ts
.type
== BT_DERIVED
);
7010 if (expr2
->ts
.type
== BT_DERIVED
)
7012 tmp
= gfc_get_symbol_decl (expr2
->ts
.u
.derived
);
7013 size
= TYPE_SIZE_UNIT (tmp
);
7019 e2vtab
= gfc_find_and_cut_at_last_class_ref (expr2
);
7020 gfc_add_vptr_component (e2vtab
);
7021 gfc_add_size_component (e2vtab
);
7022 gfc_init_se (&se
, NULL
);
7023 gfc_conv_expr (&se
, e2vtab
);
7024 gfc_add_block_to_block (block
, &se
.pre
);
7025 size
= fold_convert (size_type_node
, se
.expr
);
7026 gfc_free_expr (e2vtab
);
7028 size_in_bytes
= size
;
7032 /* Otherwise use the length in bytes of the rhs. */
7033 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm
->ts
));
7034 size_in_bytes
= size
;
7037 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7038 size_in_bytes
, size_one_node
);
7040 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
7042 tmp
= build_call_expr_loc (input_location
,
7043 builtin_decl_explicit (BUILT_IN_CALLOC
),
7044 2, build_one_cst (size_type_node
),
7046 tmp
= fold_convert (TREE_TYPE (comp
), tmp
);
7047 gfc_add_modify (block
, comp
, tmp
);
7051 tmp
= build_call_expr_loc (input_location
,
7052 builtin_decl_explicit (BUILT_IN_MALLOC
),
7054 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp
)))
7055 ptr
= gfc_class_data_get (comp
);
7058 tmp
= fold_convert (TREE_TYPE (ptr
), tmp
);
7059 gfc_add_modify (block
, ptr
, tmp
);
7062 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7063 /* Update the lhs character length. */
7064 gfc_add_modify (block
, lhs_cl_size
, size
);
7068 /* Assign a single component of a derived type constructor. */
7071 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
,
7072 gfc_symbol
*sym
, bool init
)
7080 gfc_start_block (&block
);
7082 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
7084 /* Only care about pointers here, not about allocatables. */
7085 gfc_init_se (&se
, NULL
);
7086 /* Pointer component. */
7087 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7088 && !cm
->attr
.proc_pointer
)
7090 /* Array pointer. */
7091 if (expr
->expr_type
== EXPR_NULL
)
7092 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7095 se
.direct_byref
= 1;
7097 gfc_conv_expr_descriptor (&se
, expr
);
7098 gfc_add_block_to_block (&block
, &se
.pre
);
7099 gfc_add_block_to_block (&block
, &se
.post
);
7104 /* Scalar pointers. */
7105 se
.want_pointer
= 1;
7106 gfc_conv_expr (&se
, expr
);
7107 gfc_add_block_to_block (&block
, &se
.pre
);
7109 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7110 && expr
->symtree
->n
.sym
->attr
.dummy
)
7111 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7113 gfc_add_modify (&block
, dest
,
7114 fold_convert (TREE_TYPE (dest
), se
.expr
));
7115 gfc_add_block_to_block (&block
, &se
.post
);
7118 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
7120 /* NULL initialization for CLASS components. */
7121 tmp
= gfc_trans_structure_assign (dest
,
7122 gfc_class_initializer (&cm
->ts
, expr
),
7124 gfc_add_expr_to_block (&block
, tmp
);
7126 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
7127 && !cm
->attr
.proc_pointer
)
7129 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
7130 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
7131 else if (cm
->attr
.allocatable
)
7133 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
7134 gfc_add_expr_to_block (&block
, tmp
);
7138 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
7139 gfc_add_expr_to_block (&block
, tmp
);
7142 else if (cm
->ts
.type
== BT_CLASS
7143 && CLASS_DATA (cm
)->attr
.dimension
7144 && CLASS_DATA (cm
)->attr
.allocatable
7145 && expr
->ts
.type
== BT_DERIVED
)
7147 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7148 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7149 tmp
= gfc_class_vptr_get (dest
);
7150 gfc_add_modify (&block
, tmp
,
7151 fold_convert (TREE_TYPE (tmp
), vtab
));
7152 tmp
= gfc_class_data_get (dest
);
7153 tmp
= gfc_trans_alloc_subarray_assign (tmp
, cm
, expr
);
7154 gfc_add_expr_to_block (&block
, tmp
);
7156 else if (init
&& (cm
->attr
.allocatable
7157 || (cm
->ts
.type
== BT_CLASS
&& CLASS_DATA (cm
)->attr
.allocatable
7158 && expr
->ts
.type
!= BT_CLASS
)))
7160 /* Take care about non-array allocatable components here. The alloc_*
7161 routine below is motivated by the alloc_scalar_allocatable_for_
7162 assignment() routine, but with the realloc portions removed and
7164 alloc_scalar_allocatable_for_subcomponent_assignment (&block
,
7169 /* The remainder of these instructions follow the if (cm->attr.pointer)
7170 if (!cm->attr.dimension) part above. */
7171 gfc_init_se (&se
, NULL
);
7172 gfc_conv_expr (&se
, expr
);
7173 gfc_add_block_to_block (&block
, &se
.pre
);
7175 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
7176 && expr
->symtree
->n
.sym
->attr
.dummy
)
7177 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
7179 if (cm
->ts
.type
== BT_CLASS
&& expr
->ts
.type
== BT_DERIVED
)
7181 tmp
= gfc_class_data_get (dest
);
7182 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
7183 vtab
= gfc_get_symbol_decl (gfc_find_vtab (&expr
->ts
));
7184 vtab
= gfc_build_addr_expr (NULL_TREE
, vtab
);
7185 gfc_add_modify (&block
, gfc_class_vptr_get (dest
),
7186 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest
)), vtab
));
7189 tmp
= build_fold_indirect_ref_loc (input_location
, dest
);
7191 /* For deferred strings insert a memcpy. */
7192 if (cm
->ts
.type
== BT_CHARACTER
&& cm
->ts
.deferred
)
7195 gcc_assert (se
.string_length
|| expr
->ts
.u
.cl
->backend_decl
);
7196 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
7198 : expr
->ts
.u
.cl
->backend_decl
);
7199 tmp
= gfc_build_memcpy_call (tmp
, se
.expr
, size
);
7200 gfc_add_expr_to_block (&block
, tmp
);
7203 gfc_add_modify (&block
, tmp
,
7204 fold_convert (TREE_TYPE (tmp
), se
.expr
));
7205 gfc_add_block_to_block (&block
, &se
.post
);
7207 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
7209 if (expr
->expr_type
!= EXPR_STRUCTURE
)
7211 tree dealloc
= NULL_TREE
;
7212 gfc_init_se (&se
, NULL
);
7213 gfc_conv_expr (&se
, expr
);
7214 gfc_add_block_to_block (&block
, &se
.pre
);
7215 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7216 expression in a temporary variable and deallocate the allocatable
7217 components. Then we can the copy the expression to the result. */
7218 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7219 && expr
->expr_type
!= EXPR_VARIABLE
)
7221 se
.expr
= gfc_evaluate_now (se
.expr
, &block
);
7222 dealloc
= gfc_deallocate_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7225 gfc_add_modify (&block
, dest
,
7226 fold_convert (TREE_TYPE (dest
), se
.expr
));
7227 if (cm
->ts
.u
.derived
->attr
.alloc_comp
7228 && expr
->expr_type
!= EXPR_NULL
)
7230 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
,
7232 gfc_add_expr_to_block (&block
, tmp
);
7233 if (dealloc
!= NULL_TREE
)
7234 gfc_add_expr_to_block (&block
, dealloc
);
7236 gfc_add_block_to_block (&block
, &se
.post
);
7240 /* Nested constructors. */
7241 tmp
= gfc_trans_structure_assign (dest
, expr
, expr
->symtree
!= NULL
);
7242 gfc_add_expr_to_block (&block
, tmp
);
7245 else if (gfc_deferred_strlen (cm
, &tmp
))
7249 gcc_assert (strlen
);
7250 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
7252 TREE_OPERAND (dest
, 0),
7255 if (expr
->expr_type
== EXPR_NULL
)
7257 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
7258 gfc_add_modify (&block
, dest
, tmp
);
7259 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
7260 gfc_add_modify (&block
, strlen
, tmp
);
7265 gfc_init_se (&se
, NULL
);
7266 gfc_conv_expr (&se
, expr
);
7267 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
7268 tmp
= build_call_expr_loc (input_location
,
7269 builtin_decl_explicit (BUILT_IN_MALLOC
),
7271 gfc_add_modify (&block
, dest
,
7272 fold_convert (TREE_TYPE (dest
), tmp
));
7273 gfc_add_modify (&block
, strlen
, se
.string_length
);
7274 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
7275 gfc_add_expr_to_block (&block
, tmp
);
7278 else if (!cm
->attr
.artificial
)
7280 /* Scalar component (excluding deferred parameters). */
7281 gfc_init_se (&se
, NULL
);
7282 gfc_init_se (&lse
, NULL
);
7284 gfc_conv_expr (&se
, expr
);
7285 if (cm
->ts
.type
== BT_CHARACTER
)
7286 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
7288 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, false, false);
7289 gfc_add_expr_to_block (&block
, tmp
);
7291 return gfc_finish_block (&block
);
7294 /* Assign a derived type constructor to a variable. */
7297 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
, bool init
)
7305 gfc_start_block (&block
);
7306 cm
= expr
->ts
.u
.derived
->components
;
7308 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
7309 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
7310 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
7314 gcc_assert (cm
->backend_decl
== NULL
);
7315 gfc_init_se (&se
, NULL
);
7316 gfc_init_se (&lse
, NULL
);
7317 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
7319 gfc_add_modify (&block
, lse
.expr
,
7320 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
7322 return gfc_finish_block (&block
);
7325 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7326 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7328 /* Skip absent members in default initializers. */
7329 if (!c
->expr
&& !cm
->attr
.allocatable
)
7332 field
= cm
->backend_decl
;
7333 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
7334 dest
, field
, NULL_TREE
);
7337 gfc_expr
*e
= gfc_get_null_expr (NULL
);
7338 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, e
, expr
->ts
.u
.derived
,
7343 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
,
7344 expr
->ts
.u
.derived
, init
);
7345 gfc_add_expr_to_block (&block
, tmp
);
7347 return gfc_finish_block (&block
);
7350 /* Build an expression for a constructor. If init is nonzero then
7351 this is part of a static variable initializer. */
7354 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
7361 vec
<constructor_elt
, va_gc
> *v
= NULL
;
7363 gcc_assert (se
->ss
== NULL
);
7364 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
7365 type
= gfc_typenode_for_spec (&expr
->ts
);
7369 /* Create a temporary variable and fill it in. */
7370 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
7371 /* The symtree in expr is NULL, if the code to generate is for
7372 initializing the static members only. */
7373 tmp
= gfc_trans_structure_assign (se
->expr
, expr
, expr
->symtree
!= NULL
);
7374 gfc_add_expr_to_block (&se
->pre
, tmp
);
7378 cm
= expr
->ts
.u
.derived
->components
;
7380 for (c
= gfc_constructor_first (expr
->value
.constructor
);
7381 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
7383 /* Skip absent members in default initializers and allocatable
7384 components. Although the latter have a default initializer
7385 of EXPR_NULL,... by default, the static nullify is not needed
7386 since this is done every time we come into scope. */
7387 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
7390 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
7391 && strcmp (cm
->name
, "_extends") == 0
7392 && cm
->initializer
->symtree
)
7396 vtabs
= cm
->initializer
->symtree
->n
.sym
;
7397 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
7398 vtab
= unshare_expr_without_location (vtab
);
7399 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
7401 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
7403 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
7404 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7405 fold_convert (TREE_TYPE (cm
->backend_decl
),
7408 else if (cm
->ts
.type
== BT_INTEGER
&& strcmp (cm
->name
, "_len") == 0)
7409 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
7410 fold_convert (TREE_TYPE (cm
->backend_decl
),
7411 integer_zero_node
));
7414 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
7415 TREE_TYPE (cm
->backend_decl
),
7416 cm
->attr
.dimension
, cm
->attr
.pointer
,
7417 cm
->attr
.proc_pointer
);
7418 val
= unshare_expr_without_location (val
);
7420 /* Append it to the constructor list. */
7421 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
7424 se
->expr
= build_constructor (type
, v
);
7426 TREE_CONSTANT (se
->expr
) = 1;
7430 /* Translate a substring expression. */
7433 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
7439 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
7441 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
7442 expr
->value
.character
.length
,
7443 expr
->value
.character
.string
);
7445 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
7446 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
7449 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
7453 /* Entry point for expression translation. Evaluates a scalar quantity.
7454 EXPR is the expression to be translated, and SE is the state structure if
7455 called from within the scalarized. */
7458 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
7463 if (ss
&& ss
->info
->expr
== expr
7464 && (ss
->info
->type
== GFC_SS_SCALAR
7465 || ss
->info
->type
== GFC_SS_REFERENCE
))
7467 gfc_ss_info
*ss_info
;
7470 /* Substitute a scalar expression evaluated outside the scalarization
7472 se
->expr
= ss_info
->data
.scalar
.value
;
7473 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info
))
7474 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7476 se
->string_length
= ss_info
->string_length
;
7477 gfc_advance_se_ss_chain (se
);
7481 /* We need to convert the expressions for the iso_c_binding derived types.
7482 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7483 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7484 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7485 updated to be an integer with a kind equal to the size of a (void *). */
7486 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
7487 && expr
->ts
.u
.derived
->attr
.is_bind_c
)
7489 if (expr
->expr_type
== EXPR_VARIABLE
7490 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
7491 || expr
->symtree
->n
.sym
->intmod_sym_id
7492 == ISOCBINDING_NULL_FUNPTR
))
7494 /* Set expr_type to EXPR_NULL, which will result in
7495 null_pointer_node being used below. */
7496 expr
->expr_type
= EXPR_NULL
;
7500 /* Update the type/kind of the expression to be what the new
7501 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7502 expr
->ts
.type
= BT_INTEGER
;
7503 expr
->ts
.f90_type
= BT_VOID
;
7504 expr
->ts
.kind
= gfc_index_integer_kind
;
7508 gfc_fix_class_refs (expr
);
7510 switch (expr
->expr_type
)
7513 gfc_conv_expr_op (se
, expr
);
7517 gfc_conv_function_expr (se
, expr
);
7521 gfc_conv_constant (se
, expr
);
7525 gfc_conv_variable (se
, expr
);
7529 se
->expr
= null_pointer_node
;
7532 case EXPR_SUBSTRING
:
7533 gfc_conv_substring_expr (se
, expr
);
7536 case EXPR_STRUCTURE
:
7537 gfc_conv_structure (se
, expr
, 0);
7541 gfc_conv_array_constructor_expr (se
, expr
);
7550 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
7551 of an assignment. */
7553 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
7555 gfc_conv_expr (se
, expr
);
7556 /* All numeric lvalues should have empty post chains. If not we need to
7557 figure out a way of rewriting an lvalue so that it has no post chain. */
7558 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
7561 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
7562 numeric expressions. Used for scalar values where inserting cleanup code
7565 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
7569 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
7570 gfc_conv_expr (se
, expr
);
7573 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7574 gfc_add_modify (&se
->pre
, val
, se
->expr
);
7576 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7580 /* Helper to translate an expression and convert it to a particular type. */
7582 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
7584 gfc_conv_expr_val (se
, expr
);
7585 se
->expr
= convert (type
, se
->expr
);
7589 /* Converts an expression so that it can be passed by reference. Scalar
7593 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
7599 if (ss
&& ss
->info
->expr
== expr
7600 && ss
->info
->type
== GFC_SS_REFERENCE
)
7602 /* Returns a reference to the scalar evaluated outside the loop
7604 gfc_conv_expr (se
, expr
);
7606 if (expr
->ts
.type
== BT_CHARACTER
7607 && expr
->expr_type
!= EXPR_FUNCTION
)
7608 gfc_conv_string_parameter (se
);
7610 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
7615 if (expr
->ts
.type
== BT_CHARACTER
)
7617 gfc_conv_expr (se
, expr
);
7618 gfc_conv_string_parameter (se
);
7622 if (expr
->expr_type
== EXPR_VARIABLE
)
7624 se
->want_pointer
= 1;
7625 gfc_conv_expr (se
, expr
);
7628 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7629 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7630 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7636 if (expr
->expr_type
== EXPR_FUNCTION
7637 && ((expr
->value
.function
.esym
7638 && expr
->value
.function
.esym
->result
->attr
.pointer
7639 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
7640 || (!expr
->value
.function
.esym
&& !expr
->ref
7641 && expr
->symtree
->n
.sym
->attr
.pointer
7642 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
7644 se
->want_pointer
= 1;
7645 gfc_conv_expr (se
, expr
);
7646 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7647 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7652 gfc_conv_expr (se
, expr
);
7654 /* Create a temporary var to hold the value. */
7655 if (TREE_CONSTANT (se
->expr
))
7657 tree tmp
= se
->expr
;
7658 STRIP_TYPE_NOPS (tmp
);
7659 var
= build_decl (input_location
,
7660 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
7661 DECL_INITIAL (var
) = tmp
;
7662 TREE_STATIC (var
) = 1;
7667 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
7668 gfc_add_modify (&se
->pre
, var
, se
->expr
);
7670 gfc_add_block_to_block (&se
->pre
, &se
->post
);
7672 /* Take the address of that value. */
7673 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
7678 gfc_trans_pointer_assign (gfc_code
* code
)
7680 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
7684 /* Generate code for a pointer assignment. */
7687 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
7689 gfc_expr
*expr1_vptr
= NULL
;
7699 gfc_start_block (&block
);
7701 gfc_init_se (&lse
, NULL
);
7703 /* Check whether the expression is a scalar or not; we cannot use
7704 expr1->rank as it can be nonzero for proc pointers. */
7705 ss
= gfc_walk_expr (expr1
);
7706 scalar
= ss
== gfc_ss_terminator
;
7708 gfc_free_ss_chain (ss
);
7710 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
7711 && expr2
->expr_type
!= EXPR_FUNCTION
)
7713 gfc_add_data_component (expr2
);
7714 /* The following is required as gfc_add_data_component doesn't
7715 update ts.type if there is a tailing REF_ARRAY. */
7716 expr2
->ts
.type
= BT_DERIVED
;
7721 /* Scalar pointers. */
7722 lse
.want_pointer
= 1;
7723 gfc_conv_expr (&lse
, expr1
);
7724 gfc_init_se (&rse
, NULL
);
7725 rse
.want_pointer
= 1;
7726 gfc_conv_expr (&rse
, expr2
);
7728 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
7729 && expr1
->symtree
->n
.sym
->attr
.dummy
)
7730 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
7733 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
7734 && expr2
->symtree
->n
.sym
->attr
.dummy
)
7735 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
7738 gfc_add_block_to_block (&block
, &lse
.pre
);
7739 gfc_add_block_to_block (&block
, &rse
.pre
);
7741 /* For string assignments to unlimited polymorphic pointers add an
7742 assignment of the string_length to the _len component of the
7744 if ((expr1
->ts
.type
== BT_CLASS
|| expr1
->ts
.type
== BT_DERIVED
)
7745 && expr1
->ts
.u
.derived
->attr
.unlimited_polymorphic
7746 && (expr2
->ts
.type
== BT_CHARACTER
||
7747 ((expr2
->ts
.type
== BT_DERIVED
|| expr2
->ts
.type
== BT_CLASS
)
7748 && expr2
->ts
.u
.derived
->attr
.unlimited_polymorphic
)))
7752 len_comp
= gfc_get_len_component (expr1
);
7753 gfc_init_se (&se
, NULL
);
7754 gfc_conv_expr (&se
, len_comp
);
7756 /* ptr % _len = len (str) */
7757 gfc_add_modify (&block
, se
.expr
, rse
.string_length
);
7758 lse
.string_length
= se
.expr
;
7759 gfc_free_expr (len_comp
);
7762 /* Check character lengths if character expression. The test is only
7763 really added if -fbounds-check is enabled. Exclude deferred
7764 character length lefthand sides. */
7765 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
7766 && !expr1
->ts
.deferred
7767 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
7768 && !gfc_is_proc_ptr_comp (expr1
))
7770 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7771 gcc_assert (lse
.string_length
&& rse
.string_length
);
7772 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7773 lse
.string_length
, rse
.string_length
,
7777 /* The assignment to an deferred character length sets the string
7778 length to that of the rhs. */
7779 if (expr1
->ts
.deferred
)
7781 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
7782 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
7783 else if (lse
.string_length
!= NULL
)
7784 gfc_add_modify (&block
, lse
.string_length
,
7785 build_int_cst (gfc_charlen_type_node
, 0));
7788 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
7789 rse
.expr
= gfc_class_data_get (rse
.expr
);
7791 gfc_add_modify (&block
, lse
.expr
,
7792 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
7794 gfc_add_block_to_block (&block
, &rse
.post
);
7795 gfc_add_block_to_block (&block
, &lse
.post
);
7802 tree strlen_rhs
= NULL_TREE
;
7804 /* Array pointer. Find the last reference on the LHS and if it is an
7805 array section ref, we're dealing with bounds remapping. In this case,
7806 set it to AR_FULL so that gfc_conv_expr_descriptor does
7807 not see it and process the bounds remapping afterwards explicitly. */
7808 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
7809 if (!remap
->next
&& remap
->type
== REF_ARRAY
7810 && remap
->u
.ar
.type
== AR_SECTION
)
7812 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
7814 gfc_init_se (&lse
, NULL
);
7816 lse
.descriptor_only
= 1;
7817 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
7818 && expr1
->ts
.type
== BT_CLASS
)
7819 expr1_vptr
= gfc_copy_expr (expr1
);
7820 gfc_conv_expr_descriptor (&lse
, expr1
);
7821 strlen_lhs
= lse
.string_length
;
7824 if (expr2
->expr_type
== EXPR_NULL
)
7826 /* Just set the data pointer to null. */
7827 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
7829 else if (rank_remap
)
7831 /* If we are rank-remapping, just get the RHS's descriptor and
7832 process this later on. */
7833 gfc_init_se (&rse
, NULL
);
7834 rse
.direct_byref
= 1;
7835 rse
.byref_noassign
= 1;
7837 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7839 gfc_conv_function_expr (&rse
, expr2
);
7841 if (expr1
->ts
.type
!= BT_CLASS
)
7842 rse
.expr
= gfc_class_data_get (rse
.expr
);
7845 gfc_add_block_to_block (&block
, &rse
.pre
);
7846 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7847 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7849 gfc_add_vptr_component (expr1_vptr
);
7850 gfc_init_se (&rse
, NULL
);
7851 rse
.want_pointer
= 1;
7852 gfc_conv_expr (&rse
, expr1_vptr
);
7853 gfc_add_modify (&lse
.pre
, rse
.expr
,
7854 fold_convert (TREE_TYPE (rse
.expr
),
7855 gfc_class_vptr_get (tmp
)));
7856 rse
.expr
= gfc_class_data_get (tmp
);
7859 else if (expr2
->expr_type
== EXPR_FUNCTION
)
7861 tree bound
[GFC_MAX_DIMENSIONS
];
7864 for (i
= 0; i
< expr2
->rank
; i
++)
7865 bound
[i
] = NULL_TREE
;
7866 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
7867 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
7869 GFC_ARRAY_POINTER_CONT
, false);
7870 tmp
= gfc_create_var (tmp
, "ptrtemp");
7871 lse
.descriptor_only
= 0;
7873 lse
.direct_byref
= 1;
7874 gfc_conv_expr_descriptor (&lse
, expr2
);
7875 strlen_rhs
= lse
.string_length
;
7880 gfc_conv_expr_descriptor (&rse
, expr2
);
7881 strlen_rhs
= rse
.string_length
;
7884 else if (expr2
->expr_type
== EXPR_VARIABLE
)
7886 /* Assign directly to the LHS's descriptor. */
7887 lse
.descriptor_only
= 0;
7888 lse
.direct_byref
= 1;
7889 gfc_conv_expr_descriptor (&lse
, expr2
);
7890 strlen_rhs
= lse
.string_length
;
7892 /* If this is a subreference array pointer assignment, use the rhs
7893 descriptor element size for the lhs span. */
7894 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
7896 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
7897 gfc_init_se (&rse
, NULL
);
7898 rse
.descriptor_only
= 1;
7899 gfc_conv_expr (&rse
, expr2
);
7900 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
7901 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
7902 if (!INTEGER_CST_P (tmp
))
7903 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
7904 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
7907 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
7909 gfc_init_se (&rse
, NULL
);
7910 rse
.want_pointer
= 1;
7911 gfc_conv_function_expr (&rse
, expr2
);
7912 if (expr1
->ts
.type
!= BT_CLASS
)
7914 rse
.expr
= gfc_class_data_get (rse
.expr
);
7915 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7919 gfc_add_block_to_block (&block
, &rse
.pre
);
7920 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7921 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7923 gfc_add_vptr_component (expr1_vptr
);
7924 gfc_init_se (&rse
, NULL
);
7925 rse
.want_pointer
= 1;
7926 gfc_conv_expr (&rse
, expr1_vptr
);
7927 gfc_add_modify (&lse
.pre
, rse
.expr
,
7928 fold_convert (TREE_TYPE (rse
.expr
),
7929 gfc_class_vptr_get (tmp
)));
7930 rse
.expr
= gfc_class_data_get (tmp
);
7931 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7936 /* Assign to a temporary descriptor and then copy that
7937 temporary to the pointer. */
7938 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7939 lse
.descriptor_only
= 0;
7941 lse
.direct_byref
= 1;
7942 gfc_conv_expr_descriptor (&lse
, expr2
);
7943 strlen_rhs
= lse
.string_length
;
7944 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7948 gfc_free_expr (expr1_vptr
);
7950 gfc_add_block_to_block (&block
, &lse
.pre
);
7952 gfc_add_block_to_block (&block
, &rse
.pre
);
7954 /* If we do bounds remapping, update LHS descriptor accordingly. */
7958 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7962 /* Do rank remapping. We already have the RHS's descriptor
7963 converted in rse and now have to build the correct LHS
7964 descriptor for it. */
7968 tree lbound
, ubound
;
7971 dtype
= gfc_conv_descriptor_dtype (desc
);
7972 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7973 gfc_add_modify (&block
, dtype
, tmp
);
7975 /* Copy data pointer. */
7976 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7977 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7979 /* Copy offset but adjust it such that it would correspond
7980 to a lbound of zero. */
7981 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7982 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7984 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7986 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7988 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7989 gfc_array_index_type
, stride
, lbound
);
7990 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7991 gfc_array_index_type
, offs
, tmp
);
7993 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7995 /* Set the bounds as declared for the LHS and calculate strides as
7996 well as another offset update accordingly. */
7997 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7999 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
8004 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
8006 /* Convert declared bounds. */
8007 gfc_init_se (&lower_se
, NULL
);
8008 gfc_init_se (&upper_se
, NULL
);
8009 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
8010 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
8012 gfc_add_block_to_block (&block
, &lower_se
.pre
);
8013 gfc_add_block_to_block (&block
, &upper_se
.pre
);
8015 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
8016 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
8018 lbound
= gfc_evaluate_now (lbound
, &block
);
8019 ubound
= gfc_evaluate_now (ubound
, &block
);
8021 gfc_add_block_to_block (&block
, &lower_se
.post
);
8022 gfc_add_block_to_block (&block
, &upper_se
.post
);
8024 /* Set bounds in descriptor. */
8025 gfc_conv_descriptor_lbound_set (&block
, desc
,
8026 gfc_rank_cst
[dim
], lbound
);
8027 gfc_conv_descriptor_ubound_set (&block
, desc
,
8028 gfc_rank_cst
[dim
], ubound
);
8031 stride
= gfc_evaluate_now (stride
, &block
);
8032 gfc_conv_descriptor_stride_set (&block
, desc
,
8033 gfc_rank_cst
[dim
], stride
);
8035 /* Update offset. */
8036 offs
= gfc_conv_descriptor_offset_get (desc
);
8037 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8038 gfc_array_index_type
, lbound
, stride
);
8039 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
8040 gfc_array_index_type
, offs
, tmp
);
8041 offs
= gfc_evaluate_now (offs
, &block
);
8042 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
8044 /* Update stride. */
8045 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
8046 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
8047 gfc_array_index_type
, stride
, tmp
);
8052 /* Bounds remapping. Just shift the lower bounds. */
8054 gcc_assert (expr1
->rank
== expr2
->rank
);
8056 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
8060 gcc_assert (remap
->u
.ar
.start
[dim
]);
8061 gcc_assert (!remap
->u
.ar
.end
[dim
]);
8062 gfc_init_se (&lbound_se
, NULL
);
8063 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
8065 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
8066 gfc_conv_shift_descriptor_lbound (&block
, desc
,
8067 dim
, lbound_se
.expr
);
8068 gfc_add_block_to_block (&block
, &lbound_se
.post
);
8073 /* Check string lengths if applicable. The check is only really added
8074 to the output code if -fbounds-check is enabled. */
8075 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
8077 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
8078 gcc_assert (strlen_lhs
&& strlen_rhs
);
8079 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
8080 strlen_lhs
, strlen_rhs
, &block
);
8083 /* If rank remapping was done, check with -fcheck=bounds that
8084 the target is at least as large as the pointer. */
8085 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
8091 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
8092 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
8094 lsize
= gfc_evaluate_now (lsize
, &block
);
8095 rsize
= gfc_evaluate_now (rsize
, &block
);
8096 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
8099 msg
= _("Target of rank remapping is too small (%ld < %ld)");
8100 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
8104 gfc_add_block_to_block (&block
, &lse
.post
);
8106 gfc_add_block_to_block (&block
, &rse
.post
);
8109 return gfc_finish_block (&block
);
8113 /* Makes sure se is suitable for passing as a function string parameter. */
8114 /* TODO: Need to check all callers of this function. It may be abused. */
8117 gfc_conv_string_parameter (gfc_se
* se
)
8121 if (TREE_CODE (se
->expr
) == STRING_CST
)
8123 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
8124 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8128 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
8130 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
8132 type
= TREE_TYPE (se
->expr
);
8133 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
8137 type
= gfc_get_character_type_len (gfc_default_character_kind
,
8139 type
= build_pointer_type (type
);
8140 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
8144 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
8148 /* Generate code for assignment of scalar variables. Includes character
8149 strings and derived types with allocatable components.
8150 If you know that the LHS has no allocations, set dealloc to false.
8152 DEEP_COPY has no effect if the typespec TS is not a derived type with
8153 allocatable components. Otherwise, if it is set, an explicit copy of each
8154 allocatable component is made. This is necessary as a simple copy of the
8155 whole object would copy array descriptors as is, so that the lhs's
8156 allocatable components would point to the rhs's after the assignment.
8157 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8158 necessary if the rhs is a non-pointer function, as the allocatable components
8159 are not accessible by other means than the function's result after the
8160 function has returned. It is even more subtle when temporaries are involved,
8161 as the two following examples show:
8162 1. When we evaluate an array constructor, a temporary is created. Thus
8163 there is theoretically no alias possible. However, no deep copy is
8164 made for this temporary, so that if the constructor is made of one or
8165 more variable with allocatable components, those components still point
8166 to the variable's: DEEP_COPY should be set for the assignment from the
8167 temporary to the lhs in that case.
8168 2. When assigning a scalar to an array, we evaluate the scalar value out
8169 of the loop, store it into a temporary variable, and assign from that.
8170 In that case, deep copying when assigning to the temporary would be a
8171 waste of resources; however deep copies should happen when assigning from
8172 the temporary to each array element: again DEEP_COPY should be set for
8173 the assignment from the temporary to the lhs. */
8176 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
8177 bool deep_copy
, bool dealloc
)
8183 gfc_init_block (&block
);
8185 if (ts
.type
== BT_CHARACTER
)
8190 if (lse
->string_length
!= NULL_TREE
)
8192 gfc_conv_string_parameter (lse
);
8193 gfc_add_block_to_block (&block
, &lse
->pre
);
8194 llen
= lse
->string_length
;
8197 if (rse
->string_length
!= NULL_TREE
)
8199 gcc_assert (rse
->string_length
!= NULL_TREE
);
8200 gfc_conv_string_parameter (rse
);
8201 gfc_add_block_to_block (&block
, &rse
->pre
);
8202 rlen
= rse
->string_length
;
8205 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
8206 rse
->expr
, ts
.kind
);
8208 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
8210 tree tmp_var
= NULL_TREE
;
8213 /* Are the rhs and the lhs the same? */
8216 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8217 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
8218 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
8219 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
8222 /* Deallocate the lhs allocated components as long as it is not
8223 the same as the rhs. This must be done following the assignment
8224 to prevent deallocating data that could be used in the rhs
8228 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
8229 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
8231 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8233 gfc_add_expr_to_block (&lse
->post
, tmp
);
8236 gfc_add_block_to_block (&block
, &rse
->pre
);
8237 gfc_add_block_to_block (&block
, &lse
->pre
);
8239 gfc_add_modify (&block
, lse
->expr
,
8240 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8242 /* Restore pointer address of coarray components. */
8243 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
8245 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
8246 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8248 gfc_add_expr_to_block (&block
, tmp
);
8251 /* Do a deep copy if the rhs is a variable, if it is not the
8255 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
8256 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
8258 gfc_add_expr_to_block (&block
, tmp
);
8261 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
8263 gfc_add_block_to_block (&block
, &lse
->pre
);
8264 gfc_add_block_to_block (&block
, &rse
->pre
);
8265 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
8266 TREE_TYPE (lse
->expr
), rse
->expr
);
8267 gfc_add_modify (&block
, lse
->expr
, tmp
);
8271 gfc_add_block_to_block (&block
, &lse
->pre
);
8272 gfc_add_block_to_block (&block
, &rse
->pre
);
8274 gfc_add_modify (&block
, lse
->expr
,
8275 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
8278 gfc_add_block_to_block (&block
, &lse
->post
);
8279 gfc_add_block_to_block (&block
, &rse
->post
);
8281 return gfc_finish_block (&block
);
8285 /* There are quite a lot of restrictions on the optimisation in using an
8286 array function assign without a temporary. */
8289 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
8292 bool seen_array_ref
;
8294 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
8296 /* Play it safe with class functions assigned to a derived type. */
8297 if (gfc_is_alloc_class_array_function (expr2
)
8298 && expr1
->ts
.type
== BT_DERIVED
)
8301 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
8302 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
8305 /* Elemental functions are scalarized so that they don't need a
8306 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
8307 they would need special treatment in gfc_trans_arrayfunc_assign. */
8308 if (expr2
->value
.function
.esym
!= NULL
8309 && expr2
->value
.function
.esym
->attr
.elemental
)
8312 /* Need a temporary if rhs is not FULL or a contiguous section. */
8313 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
8316 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
8317 if (gfc_ref_needs_temporary_p (expr1
->ref
))
8320 /* Functions returning pointers or allocatables need temporaries. */
8321 c
= expr2
->value
.function
.esym
8322 ? (expr2
->value
.function
.esym
->attr
.pointer
8323 || expr2
->value
.function
.esym
->attr
.allocatable
)
8324 : (expr2
->symtree
->n
.sym
->attr
.pointer
8325 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
8329 /* Character array functions need temporaries unless the
8330 character lengths are the same. */
8331 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
8333 if (expr1
->ts
.u
.cl
->length
== NULL
8334 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8337 if (expr2
->ts
.u
.cl
->length
== NULL
8338 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
8341 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
8342 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
8346 /* Check that no LHS component references appear during an array
8347 reference. This is needed because we do not have the means to
8348 span any arbitrary stride with an array descriptor. This check
8349 is not needed for the rhs because the function result has to be
8351 seen_array_ref
= false;
8352 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8354 if (ref
->type
== REF_ARRAY
)
8355 seen_array_ref
= true;
8356 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
8360 /* Check for a dependency. */
8361 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
8362 expr2
->value
.function
.esym
,
8363 expr2
->value
.function
.actual
,
8367 /* If we have reached here with an intrinsic function, we do not
8368 need a temporary except in the particular case that reallocation
8369 on assignment is active and the lhs is allocatable and a target. */
8370 if (expr2
->value
.function
.isym
)
8371 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
8373 /* If the LHS is a dummy, we need a temporary if it is not
8375 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
8378 /* If the lhs has been host_associated, is in common, a pointer or is
8379 a target and the function is not using a RESULT variable, aliasing
8380 can occur and a temporary is needed. */
8381 if ((sym
->attr
.host_assoc
8382 || sym
->attr
.in_common
8383 || sym
->attr
.pointer
8384 || sym
->attr
.cray_pointee
8385 || sym
->attr
.target
)
8386 && expr2
->symtree
!= NULL
8387 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
8390 /* A PURE function can unconditionally be called without a temporary. */
8391 if (expr2
->value
.function
.esym
!= NULL
8392 && expr2
->value
.function
.esym
->attr
.pure
)
8395 /* Implicit_pure functions are those which could legally be declared
8397 if (expr2
->value
.function
.esym
!= NULL
8398 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
8401 if (!sym
->attr
.use_assoc
8402 && !sym
->attr
.in_common
8403 && !sym
->attr
.pointer
8404 && !sym
->attr
.target
8405 && !sym
->attr
.cray_pointee
8406 && expr2
->value
.function
.esym
)
8408 /* A temporary is not needed if the function is not contained and
8409 the variable is local or host associated and not a pointer or
8411 if (!expr2
->value
.function
.esym
->attr
.contained
)
8414 /* A temporary is not needed if the lhs has never been host
8415 associated and the procedure is contained. */
8416 else if (!sym
->attr
.host_assoc
)
8419 /* A temporary is not needed if the variable is local and not
8420 a pointer, a target or a result. */
8422 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
8426 /* Default to temporary use. */
8431 /* Provide the loop info so that the lhs descriptor can be built for
8432 reallocatable assignments from extrinsic function calls. */
8435 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
8438 /* Signal that the function call should not be made by
8439 gfc_conv_loop_setup. */
8440 se
->ss
->is_alloc_lhs
= 1;
8441 gfc_init_loopinfo (loop
);
8442 gfc_add_ss_to_loop (loop
, *ss
);
8443 gfc_add_ss_to_loop (loop
, se
->ss
);
8444 gfc_conv_ss_startstride (loop
);
8445 gfc_conv_loop_setup (loop
, where
);
8446 gfc_copy_loopinfo_to_se (se
, loop
);
8447 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
8448 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
8449 se
->ss
->is_alloc_lhs
= 0;
8453 /* For assignment to a reallocatable lhs from intrinsic functions,
8454 replace the se.expr (ie. the result) with a temporary descriptor.
8455 Null the data field so that the library allocates space for the
8456 result. Free the data of the original descriptor after the function,
8457 in case it appears in an argument expression and transfer the
8458 result to the original descriptor. */
8461 fcncall_realloc_result (gfc_se
*se
, int rank
)
8470 /* Use the allocation done by the library. Substitute the lhs
8471 descriptor with a copy, whose data field is nulled.*/
8472 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
8473 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
8474 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
8476 /* Unallocated, the descriptor does not have a dtype. */
8477 tmp
= gfc_conv_descriptor_dtype (desc
);
8478 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
8480 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
8481 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
8482 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
8484 /* Free the lhs after the function call and copy the result data to
8485 the lhs descriptor. */
8486 tmp
= gfc_conv_descriptor_data_get (desc
);
8487 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
8488 boolean_type_node
, tmp
,
8489 build_int_cst (TREE_TYPE (tmp
), 0));
8490 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8491 tmp
= gfc_call_free (tmp
);
8492 gfc_add_expr_to_block (&se
->post
, tmp
);
8494 tmp
= gfc_conv_descriptor_data_get (res_desc
);
8495 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
8497 /* Check that the shapes are the same between lhs and expression. */
8498 for (n
= 0 ; n
< rank
; n
++)
8501 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8502 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
8503 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8504 gfc_array_index_type
, tmp
, tmp1
);
8505 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
8506 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
8507 gfc_array_index_type
, tmp
, tmp1
);
8508 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8509 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8510 gfc_array_index_type
, tmp
, tmp1
);
8511 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
8512 boolean_type_node
, tmp
,
8513 gfc_index_zero_node
);
8514 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
8515 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
8516 boolean_type_node
, tmp
,
8520 /* 'zero_cond' being true is equal to lhs not being allocated or the
8521 shapes being different. */
8522 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
8524 /* Now reset the bounds returned from the function call to bounds based
8525 on the lhs lbounds, except where the lhs is not allocated or the shapes
8526 of 'variable and 'expr' are different. Set the offset accordingly. */
8527 offset
= gfc_index_zero_node
;
8528 for (n
= 0 ; n
< rank
; n
++)
8532 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
8533 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
8534 gfc_array_index_type
, zero_cond
,
8535 gfc_index_one_node
, lbound
);
8536 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
8538 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
8539 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
8540 gfc_array_index_type
, tmp
, lbound
);
8541 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
8542 gfc_rank_cst
[n
], lbound
);
8543 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
8544 gfc_rank_cst
[n
], tmp
);
8546 /* Set stride and accumulate the offset. */
8547 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
8548 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
8549 gfc_rank_cst
[n
], tmp
);
8550 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
8551 gfc_array_index_type
, lbound
, tmp
);
8552 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
8553 gfc_array_index_type
, offset
, tmp
);
8554 offset
= gfc_evaluate_now (offset
, &se
->post
);
8557 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
8562 /* Try to translate array(:) = func (...), where func is a transformational
8563 array function, without using a temporary. Returns NULL if this isn't the
8567 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
8571 gfc_component
*comp
= NULL
;
8574 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
8577 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
8579 comp
= gfc_get_proc_ptr_comp (expr2
);
8580 gcc_assert (expr2
->value
.function
.isym
8581 || (comp
&& comp
->attr
.dimension
)
8582 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
8583 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
8585 gfc_init_se (&se
, NULL
);
8586 gfc_start_block (&se
.pre
);
8587 se
.want_pointer
= 1;
8589 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
8591 if (expr1
->ts
.type
== BT_DERIVED
8592 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8595 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
8597 gfc_add_expr_to_block (&se
.pre
, tmp
);
8600 se
.direct_byref
= 1;
8601 se
.ss
= gfc_walk_expr (expr2
);
8602 gcc_assert (se
.ss
!= gfc_ss_terminator
);
8604 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
8605 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
8606 Clearly, this cannot be done for an allocatable function result, since
8607 the shape of the result is unknown and, in any case, the function must
8608 correctly take care of the reallocation internally. For intrinsic
8609 calls, the array data is freed and the library takes care of allocation.
8610 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
8612 if (flag_realloc_lhs
8613 && gfc_is_reallocatable_lhs (expr1
)
8614 && !gfc_expr_attr (expr1
).codimension
8615 && !gfc_is_coindexed (expr1
)
8616 && !(expr2
->value
.function
.esym
8617 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
8619 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8621 if (!expr2
->value
.function
.isym
)
8623 ss
= gfc_walk_expr (expr1
);
8624 gcc_assert (ss
!= gfc_ss_terminator
);
8626 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
8627 ss
->is_alloc_lhs
= 1;
8630 fcncall_realloc_result (&se
, expr1
->rank
);
8633 gfc_conv_function_expr (&se
, expr2
);
8634 gfc_add_block_to_block (&se
.pre
, &se
.post
);
8637 gfc_cleanup_loop (&loop
);
8639 gfc_free_ss_chain (se
.ss
);
8641 return gfc_finish_block (&se
.pre
);
8645 /* Try to efficiently translate array(:) = 0. Return NULL if this
8649 gfc_trans_zero_assign (gfc_expr
* expr
)
8651 tree dest
, len
, type
;
8655 sym
= expr
->symtree
->n
.sym
;
8656 dest
= gfc_get_symbol_decl (sym
);
8658 type
= TREE_TYPE (dest
);
8659 if (POINTER_TYPE_P (type
))
8660 type
= TREE_TYPE (type
);
8661 if (!GFC_ARRAY_TYPE_P (type
))
8664 /* Determine the length of the array. */
8665 len
= GFC_TYPE_ARRAY_SIZE (type
);
8666 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8669 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
8670 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8671 fold_convert (gfc_array_index_type
, tmp
));
8673 /* If we are zeroing a local array avoid taking its address by emitting
8675 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
8676 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
8677 dest
, build_constructor (TREE_TYPE (dest
),
8680 /* Convert arguments to the correct types. */
8681 dest
= fold_convert (pvoid_type_node
, dest
);
8682 len
= fold_convert (size_type_node
, len
);
8684 /* Construct call to __builtin_memset. */
8685 tmp
= build_call_expr_loc (input_location
,
8686 builtin_decl_explicit (BUILT_IN_MEMSET
),
8687 3, dest
, integer_zero_node
, len
);
8688 return fold_convert (void_type_node
, tmp
);
8692 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
8693 that constructs the call to __builtin_memcpy. */
8696 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
8700 /* Convert arguments to the correct types. */
8701 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
8702 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
8704 dst
= fold_convert (pvoid_type_node
, dst
);
8706 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
8707 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
8709 src
= fold_convert (pvoid_type_node
, src
);
8711 len
= fold_convert (size_type_node
, len
);
8713 /* Construct call to __builtin_memcpy. */
8714 tmp
= build_call_expr_loc (input_location
,
8715 builtin_decl_explicit (BUILT_IN_MEMCPY
),
8717 return fold_convert (void_type_node
, tmp
);
8721 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
8722 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
8723 source/rhs, both are gfc_full_array_ref_p which have been checked for
8727 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8729 tree dst
, dlen
, dtype
;
8730 tree src
, slen
, stype
;
8733 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8734 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
8736 dtype
= TREE_TYPE (dst
);
8737 if (POINTER_TYPE_P (dtype
))
8738 dtype
= TREE_TYPE (dtype
);
8739 stype
= TREE_TYPE (src
);
8740 if (POINTER_TYPE_P (stype
))
8741 stype
= TREE_TYPE (stype
);
8743 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
8746 /* Determine the lengths of the arrays. */
8747 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
8748 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
8750 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8751 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8752 dlen
, fold_convert (gfc_array_index_type
, tmp
));
8754 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
8755 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
8757 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
8758 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
8759 slen
, fold_convert (gfc_array_index_type
, tmp
));
8761 /* Sanity check that they are the same. This should always be
8762 the case, as we should already have checked for conformance. */
8763 if (!tree_int_cst_equal (slen
, dlen
))
8766 return gfc_build_memcpy_call (dst
, src
, dlen
);
8770 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
8771 this can't be done. EXPR1 is the destination/lhs for which
8772 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
8775 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
8777 unsigned HOST_WIDE_INT nelem
;
8783 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
8787 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
8788 dtype
= TREE_TYPE (dst
);
8789 if (POINTER_TYPE_P (dtype
))
8790 dtype
= TREE_TYPE (dtype
);
8791 if (!GFC_ARRAY_TYPE_P (dtype
))
8794 /* Determine the lengths of the array. */
8795 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
8796 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
8799 /* Confirm that the constructor is the same size. */
8800 if (compare_tree_int (len
, nelem
) != 0)
8803 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
8804 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
8805 fold_convert (gfc_array_index_type
, tmp
));
8807 stype
= gfc_typenode_for_spec (&expr2
->ts
);
8808 src
= gfc_build_constant_array_constructor (expr2
, stype
);
8810 stype
= TREE_TYPE (src
);
8811 if (POINTER_TYPE_P (stype
))
8812 stype
= TREE_TYPE (stype
);
8814 return gfc_build_memcpy_call (dst
, src
, len
);
8818 /* Tells whether the expression is to be treated as a variable reference. */
8821 expr_is_variable (gfc_expr
*expr
)
8824 gfc_component
*comp
;
8825 gfc_symbol
*func_ifc
;
8827 if (expr
->expr_type
== EXPR_VARIABLE
)
8830 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
8833 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
8834 return expr_is_variable (arg
);
8837 /* A data-pointer-returning function should be considered as a variable
8839 if (expr
->expr_type
== EXPR_FUNCTION
8840 && expr
->ref
== NULL
)
8842 if (expr
->value
.function
.isym
!= NULL
)
8845 if (expr
->value
.function
.esym
!= NULL
)
8847 func_ifc
= expr
->value
.function
.esym
;
8852 gcc_assert (expr
->symtree
);
8853 func_ifc
= expr
->symtree
->n
.sym
;
8860 comp
= gfc_get_proc_ptr_comp (expr
);
8861 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
8864 func_ifc
= comp
->ts
.interface
;
8868 if (expr
->expr_type
== EXPR_COMPCALL
)
8870 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
8871 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
8878 gcc_assert (func_ifc
->attr
.function
8879 && func_ifc
->result
!= NULL
);
8880 return func_ifc
->result
->attr
.pointer
;
8884 /* Is the lhs OK for automatic reallocation? */
8887 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
8891 /* An allocatable variable with no reference. */
8892 if (expr
->symtree
->n
.sym
->attr
.allocatable
8896 /* All that can be left are allocatable components. */
8897 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
8898 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
8899 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
8902 /* Find an allocatable component ref last. */
8903 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
8904 if (ref
->type
== REF_COMPONENT
8906 && ref
->u
.c
.component
->attr
.allocatable
)
8913 /* Allocate or reallocate scalar lhs, as necessary. */
8916 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8931 if (!expr1
|| expr1
->rank
)
8934 if (!expr2
|| expr2
->rank
)
8937 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
8938 if (ref
->type
== REF_SUBSTRING
)
8941 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8943 /* Since this is a scalar lhs, we can afford to do this. That is,
8944 there is no risk of side effects being repeated. */
8945 gfc_init_se (&lse
, NULL
);
8946 lse
.want_pointer
= 1;
8947 gfc_conv_expr (&lse
, expr1
);
8949 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8950 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8952 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8953 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8954 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8956 tmp
= build3_v (COND_EXPR
, cond
,
8957 build1_v (GOTO_EXPR
, jump_label1
),
8958 build_empty_stmt (input_location
));
8959 gfc_add_expr_to_block (block
, tmp
);
8961 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8963 /* Use the rhs string length and the lhs element size. */
8964 size
= string_length
;
8965 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8966 tmp
= TYPE_SIZE_UNIT (tmp
);
8967 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8968 TREE_TYPE (tmp
), tmp
,
8969 fold_convert (TREE_TYPE (tmp
), size
));
8973 /* Otherwise use the length in bytes of the rhs. */
8974 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8975 size_in_bytes
= size
;
8978 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8979 size_in_bytes
, size_one_node
);
8981 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8983 tmp
= build_call_expr_loc (input_location
,
8984 builtin_decl_explicit (BUILT_IN_CALLOC
),
8985 2, build_one_cst (size_type_node
),
8987 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8988 gfc_add_modify (block
, lse
.expr
, tmp
);
8992 tmp
= build_call_expr_loc (input_location
,
8993 builtin_decl_explicit (BUILT_IN_MALLOC
),
8995 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8996 gfc_add_modify (block
, lse
.expr
, tmp
);
8999 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9001 /* Deferred characters need checking for lhs and rhs string
9002 length. Other deferred parameter variables will have to
9004 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
9005 gfc_add_expr_to_block (block
, tmp
);
9007 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
9008 gfc_add_expr_to_block (block
, tmp
);
9010 /* For a deferred length character, reallocate if lengths of lhs and
9011 rhs are different. */
9012 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9014 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
9015 lse
.string_length
, size
);
9016 /* Jump past the realloc if the lengths are the same. */
9017 tmp
= build3_v (COND_EXPR
, cond
,
9018 build1_v (GOTO_EXPR
, jump_label2
),
9019 build_empty_stmt (input_location
));
9020 gfc_add_expr_to_block (block
, tmp
);
9021 tmp
= build_call_expr_loc (input_location
,
9022 builtin_decl_explicit (BUILT_IN_REALLOC
),
9023 2, fold_convert (pvoid_type_node
, lse
.expr
),
9025 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
9026 gfc_add_modify (block
, lse
.expr
, tmp
);
9027 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
9028 gfc_add_expr_to_block (block
, tmp
);
9030 /* Update the lhs character length. */
9031 size
= string_length
;
9032 gfc_add_modify (block
, lse
.string_length
, size
);
9036 /* Check for assignments of the type
9040 to make sure we do not check for reallocation unneccessarily. */
9044 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
9046 gfc_actual_arglist
*a
;
9049 switch (expr2
->expr_type
)
9052 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
9055 if (expr2
->value
.function
.esym
9056 && expr2
->value
.function
.esym
->attr
.elemental
)
9058 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9061 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9066 else if (expr2
->value
.function
.isym
9067 && expr2
->value
.function
.isym
->elemental
)
9069 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
9072 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
9081 switch (expr2
->value
.op
.op
)
9084 case INTRINSIC_UPLUS
:
9085 case INTRINSIC_UMINUS
:
9086 case INTRINSIC_PARENTHESES
:
9087 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
9089 case INTRINSIC_PLUS
:
9090 case INTRINSIC_MINUS
:
9091 case INTRINSIC_TIMES
:
9092 case INTRINSIC_DIVIDE
:
9093 case INTRINSIC_POWER
:
9097 case INTRINSIC_NEQV
:
9104 case INTRINSIC_EQ_OS
:
9105 case INTRINSIC_NE_OS
:
9106 case INTRINSIC_GT_OS
:
9107 case INTRINSIC_GE_OS
:
9108 case INTRINSIC_LT_OS
:
9109 case INTRINSIC_LE_OS
:
9111 e1
= expr2
->value
.op
.op1
;
9112 e2
= expr2
->value
.op
.op2
;
9114 if (e1
->rank
== 0 && e2
->rank
> 0)
9115 return is_runtime_conformable (expr1
, e2
);
9116 else if (e1
->rank
> 0 && e2
->rank
== 0)
9117 return is_runtime_conformable (expr1
, e1
);
9118 else if (e1
->rank
> 0 && e2
->rank
> 0)
9119 return is_runtime_conformable (expr1
, e1
)
9120 && is_runtime_conformable (expr1
, e2
);
9136 /* Subroutine of gfc_trans_assignment that actually scalarizes the
9137 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
9138 init_flag indicates initialization expressions and dealloc that no
9139 deallocate prior assignment is needed (if in doubt, set true). */
9142 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9148 gfc_ss
*lss_section
;
9155 bool scalar_to_array
;
9159 /* Assignment of the form lhs = rhs. */
9160 gfc_start_block (&block
);
9162 gfc_init_se (&lse
, NULL
);
9163 gfc_init_se (&rse
, NULL
);
9166 lss
= gfc_walk_expr (expr1
);
9167 if (gfc_is_reallocatable_lhs (expr1
)
9168 && !(expr2
->expr_type
== EXPR_FUNCTION
9169 && expr2
->value
.function
.isym
!= NULL
))
9170 lss
->is_alloc_lhs
= 1;
9173 if ((expr1
->ts
.type
== BT_DERIVED
)
9174 && (gfc_is_alloc_class_array_function (expr2
)
9175 || gfc_is_alloc_class_scalar_function (expr2
)))
9176 expr2
->must_finalize
= 1;
9178 if (lss
!= gfc_ss_terminator
)
9180 /* The assignment needs scalarization. */
9183 /* Find a non-scalar SS from the lhs. */
9184 while (lss_section
!= gfc_ss_terminator
9185 && lss_section
->info
->type
!= GFC_SS_SECTION
)
9186 lss_section
= lss_section
->next
;
9188 gcc_assert (lss_section
!= gfc_ss_terminator
);
9190 /* Initialize the scalarizer. */
9191 gfc_init_loopinfo (&loop
);
9194 rss
= gfc_walk_expr (expr2
);
9195 if (rss
== gfc_ss_terminator
)
9196 /* The rhs is scalar. Add a ss for the expression. */
9197 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
9199 /* Associate the SS with the loop. */
9200 gfc_add_ss_to_loop (&loop
, lss
);
9201 gfc_add_ss_to_loop (&loop
, rss
);
9203 /* Calculate the bounds of the scalarization. */
9204 gfc_conv_ss_startstride (&loop
);
9205 /* Enable loop reversal. */
9206 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
9207 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
9208 /* Resolve any data dependencies in the statement. */
9209 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
9210 /* Setup the scalarizing loops. */
9211 gfc_conv_loop_setup (&loop
, &expr2
->where
);
9213 /* Setup the gfc_se structures. */
9214 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9215 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9218 gfc_mark_ss_chain_used (rss
, 1);
9219 if (loop
.temp_ss
== NULL
)
9222 gfc_mark_ss_chain_used (lss
, 1);
9226 lse
.ss
= loop
.temp_ss
;
9227 gfc_mark_ss_chain_used (lss
, 3);
9228 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
9231 /* Allow the scalarizer to workshare array assignments. */
9232 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
9233 ompws_flags
|= OMPWS_SCALARIZER_WS
;
9235 /* Start the scalarized loop body. */
9236 gfc_start_scalarized_body (&loop
, &body
);
9239 gfc_init_block (&body
);
9241 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
9243 /* Translate the expression. */
9244 gfc_conv_expr (&rse
, expr2
);
9246 /* Deal with the case of a scalar class function assigned to a derived type. */
9247 if (gfc_is_alloc_class_scalar_function (expr2
)
9248 && expr1
->ts
.type
== BT_DERIVED
)
9250 rse
.expr
= gfc_class_data_get (rse
.expr
);
9251 rse
.expr
= build_fold_indirect_ref_loc (input_location
, rse
.expr
);
9254 /* Stabilize a string length for temporaries. */
9255 if (expr2
->ts
.type
== BT_CHARACTER
)
9256 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
9258 string_length
= NULL_TREE
;
9262 gfc_conv_tmp_array_ref (&lse
);
9263 if (expr2
->ts
.type
== BT_CHARACTER
)
9264 lse
.string_length
= string_length
;
9267 gfc_conv_expr (&lse
, expr1
);
9269 /* Assignments of scalar derived types with allocatable components
9270 to arrays must be done with a deep copy and the rhs temporary
9271 must have its components deallocated afterwards. */
9272 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
9273 && expr2
->ts
.u
.derived
->attr
.alloc_comp
9274 && !expr_is_variable (expr2
)
9275 && expr1
->rank
&& !expr2
->rank
);
9276 scalar_to_array
|= (expr1
->ts
.type
== BT_DERIVED
9278 && expr1
->ts
.u
.derived
->attr
.alloc_comp
9279 && gfc_is_alloc_class_scalar_function (expr2
));
9280 if (scalar_to_array
&& dealloc
)
9282 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
9283 gfc_prepend_expr_to_block (&loop
.post
, tmp
);
9286 /* When assigning a character function result to a deferred-length variable,
9287 the function call must happen before the (re)allocation of the lhs -
9288 otherwise the character length of the result is not known.
9289 NOTE: This relies on having the exact dependence of the length type
9290 parameter available to the caller; gfortran saves it in the .mod files. */
9291 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
9292 gfc_add_block_to_block (&block
, &rse
.pre
);
9294 /* Nullify the allocatable components corresponding to those of the lhs
9295 derived type, so that the finalization of the function result does not
9296 affect the lhs of the assignment. Prepend is used to ensure that the
9297 nullification occurs before the call to the finalizer. In the case of
9298 a scalar to array assignment, this is done in gfc_trans_scalar_assign
9299 as part of the deep copy. */
9300 if (!scalar_to_array
&& (expr1
->ts
.type
== BT_DERIVED
)
9301 && (gfc_is_alloc_class_array_function (expr2
)
9302 || gfc_is_alloc_class_scalar_function (expr2
)))
9305 tmp
= gfc_nullify_alloc_comp (expr1
->ts
.u
.derived
, rse
.expr
, 0);
9306 gfc_prepend_expr_to_block (&rse
.post
, tmp
);
9307 if (lss
!= gfc_ss_terminator
&& rss
== gfc_ss_terminator
)
9308 gfc_add_block_to_block (&loop
.post
, &rse
.post
);
9311 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9312 expr_is_variable (expr2
) || scalar_to_array
9313 || expr2
->expr_type
== EXPR_ARRAY
,
9314 !(l_is_temp
|| init_flag
) && dealloc
);
9315 gfc_add_expr_to_block (&body
, tmp
);
9317 if (lss
== gfc_ss_terminator
)
9319 /* F2003: Add the code for reallocation on assignment. */
9320 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
9321 alloc_scalar_allocatable_for_assignment (&block
, string_length
,
9324 /* Use the scalar assignment as is. */
9325 gfc_add_block_to_block (&block
, &body
);
9329 gcc_assert (lse
.ss
== gfc_ss_terminator
9330 && rse
.ss
== gfc_ss_terminator
);
9334 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
9336 /* We need to copy the temporary to the actual lhs. */
9337 gfc_init_se (&lse
, NULL
);
9338 gfc_init_se (&rse
, NULL
);
9339 gfc_copy_loopinfo_to_se (&lse
, &loop
);
9340 gfc_copy_loopinfo_to_se (&rse
, &loop
);
9342 rse
.ss
= loop
.temp_ss
;
9345 gfc_conv_tmp_array_ref (&rse
);
9346 gfc_conv_expr (&lse
, expr1
);
9348 gcc_assert (lse
.ss
== gfc_ss_terminator
9349 && rse
.ss
== gfc_ss_terminator
);
9351 if (expr2
->ts
.type
== BT_CHARACTER
)
9352 rse
.string_length
= string_length
;
9354 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
9356 gfc_add_expr_to_block (&body
, tmp
);
9359 /* F2003: Allocate or reallocate lhs of allocatable array. */
9360 if (flag_realloc_lhs
9361 && gfc_is_reallocatable_lhs (expr1
)
9362 && !gfc_expr_attr (expr1
).codimension
9363 && !gfc_is_coindexed (expr1
)
9365 && !is_runtime_conformable (expr1
, expr2
))
9367 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
9368 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
9369 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
9370 if (tmp
!= NULL_TREE
)
9371 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
9374 /* Generate the copying loops. */
9375 gfc_trans_scalarizing_loops (&loop
, &body
);
9377 /* Wrap the whole thing up. */
9378 gfc_add_block_to_block (&block
, &loop
.pre
);
9379 gfc_add_block_to_block (&block
, &loop
.post
);
9381 gfc_cleanup_loop (&loop
);
9384 return gfc_finish_block (&block
);
9388 /* Check whether EXPR is a copyable array. */
9391 copyable_array_p (gfc_expr
* expr
)
9393 if (expr
->expr_type
!= EXPR_VARIABLE
)
9396 /* First check it's an array. */
9397 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
9400 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
9403 /* Next check that it's of a simple enough type. */
9404 switch (expr
->ts
.type
)
9416 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
9425 /* Translate an assignment. */
9428 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
9433 /* Special case a single function returning an array. */
9434 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
9436 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
9441 /* Special case assigning an array to zero. */
9442 if (copyable_array_p (expr1
)
9443 && is_zero_initializer_p (expr2
))
9445 tmp
= gfc_trans_zero_assign (expr1
);
9450 /* Special case copying one array to another. */
9451 if (copyable_array_p (expr1
)
9452 && copyable_array_p (expr2
)
9453 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
9454 && !gfc_check_dependency (expr1
, expr2
, 0))
9456 tmp
= gfc_trans_array_copy (expr1
, expr2
);
9461 /* Special case initializing an array from a constant array constructor. */
9462 if (copyable_array_p (expr1
)
9463 && expr2
->expr_type
== EXPR_ARRAY
9464 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
9466 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
9471 /* Fallback to the scalarizer to generate explicit loops. */
9472 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
9476 gfc_trans_init_assign (gfc_code
* code
)
9478 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
9482 gfc_trans_assign (gfc_code
* code
)
9484 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);