1 /* Expression translation
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
28 #include "stringpool.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
61 akind
, !(attr
.pointer
|| attr
.target
));
65 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 type
= get_scalar_to_descriptor_type (scalar
, attr
);
70 desc
= gfc_create_var (type
, "desc");
71 DECL_ARTIFICIAL (desc
) = 1;
73 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
74 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
75 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
76 gfc_get_dtype (type
));
77 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
79 /* Copy pointer address back - but only if it could have changed and
80 if the actual argument is a pointer and not, e.g., NULL(). */
81 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
82 gfc_add_modify (&se
->post
, scalar
,
83 fold_convert (TREE_TYPE (scalar
),
84 gfc_conv_descriptor_data_get (desc
)));
89 /* This is the seed for an eventual trans-class.c
91 The following parameters should not be used directly since they might
92 in future implementations. Use the corresponding APIs. */
93 #define CLASS_DATA_FIELD 0
94 #define CLASS_VPTR_FIELD 1
95 #define VTABLE_HASH_FIELD 0
96 #define VTABLE_SIZE_FIELD 1
97 #define VTABLE_EXTENDS_FIELD 2
98 #define VTABLE_DEF_INIT_FIELD 3
99 #define VTABLE_COPY_FIELD 4
100 #define VTABLE_FINAL_FIELD 5
104 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
108 vec
<constructor_elt
, va_gc
> *init
= NULL
;
110 field
= TYPE_FIELDS (TREE_TYPE (decl
));
111 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
112 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
114 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
115 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
117 return build_constructor (TREE_TYPE (decl
), init
);
122 gfc_class_data_get (tree decl
)
125 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
126 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
127 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
129 return fold_build3_loc (input_location
, COMPONENT_REF
,
130 TREE_TYPE (data
), decl
, data
,
136 gfc_class_vptr_get (tree decl
)
139 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
140 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
141 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
143 return fold_build3_loc (input_location
, COMPONENT_REF
,
144 TREE_TYPE (vptr
), decl
, vptr
,
150 gfc_vtable_field_get (tree decl
, int field
)
154 vptr
= gfc_class_vptr_get (decl
);
155 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
156 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
158 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
159 TREE_TYPE (size
), vptr
, size
,
161 /* Always return size as an array index type. */
162 if (field
== VTABLE_SIZE_FIELD
)
163 size
= fold_convert (gfc_array_index_type
, size
);
170 gfc_vtable_hash_get (tree decl
)
172 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
177 gfc_vtable_size_get (tree decl
)
179 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
184 gfc_vtable_extends_get (tree decl
)
186 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
191 gfc_vtable_def_init_get (tree decl
)
193 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
198 gfc_vtable_copy_get (tree decl
)
200 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
205 gfc_vtable_final_get (tree decl
)
207 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
211 #undef CLASS_DATA_FIELD
212 #undef CLASS_VPTR_FIELD
213 #undef VTABLE_HASH_FIELD
214 #undef VTABLE_SIZE_FIELD
215 #undef VTABLE_EXTENDS_FIELD
216 #undef VTABLE_DEF_INIT_FIELD
217 #undef VTABLE_COPY_FIELD
218 #undef VTABLE_FINAL_FIELD
221 /* Reset the vptr to the declared type, e.g. after deallocation. */
224 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
226 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
231 /* If we have a class array, we need go back to the class
233 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
234 && lhs
->ref
->next
->type
== REF_ARRAY
235 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
236 && lhs
->ref
->type
== REF_COMPONENT
237 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
239 gfc_free_ref_list (lhs
->ref
);
243 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
244 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
245 && ref
->next
->next
->type
== REF_ARRAY
246 && ref
->next
->next
->u
.ar
.type
== AR_FULL
247 && ref
->next
->type
== REF_COMPONENT
248 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
250 gfc_free_ref_list (ref
->next
);
254 gfc_add_vptr_component (lhs
);
256 if (UNLIMITED_POLY (e
))
257 rhs
= gfc_get_null_expr (NULL
);
260 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
261 rhs
= gfc_lval_expr_from_sym (vtab
);
263 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
264 gfc_add_expr_to_block (block
, tmp
);
270 /* Obtain the vptr of the last class reference in an expression.
271 Return NULL_TREE if no class reference is found. */
274 gfc_get_vptr_from_expr (tree expr
)
279 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
281 type
= TREE_TYPE (tmp
);
284 if (GFC_CLASS_TYPE_P (type
))
285 return gfc_class_vptr_get (tmp
);
286 if (type
!= TYPE_CANONICAL (type
))
287 type
= TYPE_CANONICAL (type
);
291 if (TREE_CODE (tmp
) == VAR_DECL
)
299 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
302 tree tmp
, tmp2
, type
;
304 gfc_conv_descriptor_data_set (block
, lhs_desc
,
305 gfc_conv_descriptor_data_get (rhs_desc
));
306 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
307 gfc_conv_descriptor_offset_get (rhs_desc
));
309 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
310 gfc_conv_descriptor_dtype (rhs_desc
));
312 /* Assign the dimension as range-ref. */
313 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
314 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
316 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
317 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
318 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
319 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
320 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
321 gfc_add_modify (block
, tmp
, tmp2
);
325 /* Takes a derived type expression and returns the address of a temporary
326 class object of the 'declared' type. If vptr is not NULL, this is
327 used for the temporary class object.
328 optional_alloc_ptr is false when the dummy is neither allocatable
329 nor a pointer; that's only relevant for the optional handling. */
331 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
332 gfc_typespec class_ts
, tree vptr
, bool optional
,
333 bool optional_alloc_ptr
)
336 tree cond_optional
= NULL_TREE
;
342 /* The derived type needs to be converted to a temporary
344 tmp
= gfc_typenode_for_spec (&class_ts
);
345 var
= gfc_create_var (tmp
, "class");
348 ctree
= gfc_class_vptr_get (var
);
350 if (vptr
!= NULL_TREE
)
352 /* Use the dynamic vptr. */
357 /* In this case the vtab corresponds to the derived type and the
358 vptr must point to it. */
359 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
361 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
363 gfc_add_modify (&parmse
->pre
, ctree
,
364 fold_convert (TREE_TYPE (ctree
), tmp
));
366 /* Now set the data field. */
367 ctree
= gfc_class_data_get (var
);
370 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
372 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
374 /* For an array reference in an elemental procedure call we need
375 to retain the ss to provide the scalarized array reference. */
376 gfc_conv_expr_reference (parmse
, e
);
377 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
379 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
381 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
382 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
387 ss
= gfc_walk_expr (e
);
388 if (ss
== gfc_ss_terminator
)
391 gfc_conv_expr_reference (parmse
, e
);
393 /* Scalar to an assumed-rank array. */
394 if (class_ts
.u
.derived
->components
->as
)
397 type
= get_scalar_to_descriptor_type (parmse
->expr
,
399 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
400 gfc_get_dtype (type
));
402 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
403 TREE_TYPE (parmse
->expr
),
404 cond_optional
, parmse
->expr
,
405 fold_convert (TREE_TYPE (parmse
->expr
),
407 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
411 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
413 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
415 fold_convert (TREE_TYPE (tmp
),
417 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
423 gfc_init_block (&block
);
426 gfc_conv_expr_descriptor (parmse
, e
);
428 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
430 gcc_assert (class_ts
.u
.derived
->components
->as
->type
432 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
436 if (gfc_expr_attr (e
).codimension
)
437 parmse
->expr
= fold_build1_loc (input_location
,
441 gfc_add_modify (&block
, ctree
, parmse
->expr
);
446 tmp
= gfc_finish_block (&block
);
448 gfc_init_block (&block
);
449 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
451 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
452 gfc_finish_block (&block
));
453 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
456 gfc_add_block_to_block (&parmse
->pre
, &block
);
460 /* Pass the address of the class object. */
461 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
463 if (optional
&& optional_alloc_ptr
)
464 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
465 TREE_TYPE (parmse
->expr
),
466 cond_optional
, parmse
->expr
,
467 fold_convert (TREE_TYPE (parmse
->expr
),
472 /* Create a new class container, which is required as scalar coarrays
473 have an array descriptor while normal scalars haven't. Optionally,
474 NULL pointer checks are added if the argument is OPTIONAL. */
477 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
478 gfc_typespec class_ts
, bool optional
)
480 tree var
, ctree
, tmp
;
485 gfc_init_block (&block
);
488 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
490 if (ref
->type
== REF_COMPONENT
491 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
495 if (class_ref
== NULL
496 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
497 tmp
= e
->symtree
->n
.sym
->backend_decl
;
500 /* Remove everything after the last class reference, convert the
501 expression and then recover its tailend once more. */
503 ref
= class_ref
->next
;
504 class_ref
->next
= NULL
;
505 gfc_init_se (&tmpse
, NULL
);
506 gfc_conv_expr (&tmpse
, e
);
507 class_ref
->next
= ref
;
511 var
= gfc_typenode_for_spec (&class_ts
);
512 var
= gfc_create_var (var
, "class");
514 ctree
= gfc_class_vptr_get (var
);
515 gfc_add_modify (&block
, ctree
,
516 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
518 ctree
= gfc_class_data_get (var
);
519 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
520 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
522 /* Pass the address of the class object. */
523 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
527 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
530 tmp
= gfc_finish_block (&block
);
532 gfc_init_block (&block
);
533 tmp2
= gfc_class_data_get (var
);
534 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
536 tmp2
= gfc_finish_block (&block
);
538 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
540 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
543 gfc_add_block_to_block (&parmse
->pre
, &block
);
547 /* Takes an intrinsic type expression and returns the address of a temporary
548 class object of the 'declared' type. */
550 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
551 gfc_typespec class_ts
)
559 /* The intrinsic type needs to be converted to a temporary
561 tmp
= gfc_typenode_for_spec (&class_ts
);
562 var
= gfc_create_var (tmp
, "class");
565 ctree
= gfc_class_vptr_get (var
);
567 vtab
= gfc_find_vtab (&e
->ts
);
569 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
570 gfc_add_modify (&parmse
->pre
, ctree
,
571 fold_convert (TREE_TYPE (ctree
), tmp
));
573 /* Now set the data field. */
574 ctree
= gfc_class_data_get (var
);
575 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
577 /* For an array reference in an elemental procedure call we need
578 to retain the ss to provide the scalarized array reference. */
579 gfc_conv_expr_reference (parmse
, e
);
580 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
581 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
585 ss
= gfc_walk_expr (e
);
586 if (ss
== gfc_ss_terminator
)
589 gfc_conv_expr_reference (parmse
, e
);
590 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
591 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
596 parmse
->use_offset
= 1;
597 gfc_conv_expr_descriptor (parmse
, e
);
598 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
602 /* Pass the address of the class object. */
603 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
607 /* Takes a scalarized class array expression and returns the
608 address of a temporary scalar class object of the 'declared'
610 OOP-TODO: This could be improved by adding code that branched on
611 the dynamic type being the same as the declared type. In this case
612 the original class expression can be passed directly.
613 optional_alloc_ptr is false when the dummy is neither allocatable
614 nor a pointer; that's relevant for the optional handling.
615 Set copyback to true if class container's _data and _vtab pointers
616 might get modified. */
619 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
620 bool elemental
, bool copyback
, bool optional
,
621 bool optional_alloc_ptr
)
627 tree cond
= NULL_TREE
;
631 bool full_array
= false;
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
)
642 if (ref
->next
== NULL
)
646 if ((ref
== NULL
|| class_ref
== ref
)
647 && (!class_ts
.u
.derived
->components
->as
648 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
651 /* Test for FULL_ARRAY. */
652 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
653 && gfc_expr_attr (e
).dimension
)
656 gfc_is_class_array_ref (e
, &full_array
);
658 /* The derived type needs to be converted to a temporary
660 tmp
= gfc_typenode_for_spec (&class_ts
);
661 var
= gfc_create_var (tmp
, "class");
664 ctree
= gfc_class_data_get (var
);
665 if (class_ts
.u
.derived
->components
->as
666 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
670 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
672 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
673 gfc_get_dtype (type
));
675 tmp
= gfc_class_data_get (parmse
->expr
);
676 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
677 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
679 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
682 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
686 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
687 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
688 TREE_TYPE (ctree
), parmse
->expr
);
689 gfc_add_modify (&block
, ctree
, parmse
->expr
);
692 /* Return the data component, except in the case of scalarized array
693 references, where nullification of the cannot occur and so there
695 if (!elemental
&& full_array
&& copyback
)
697 if (class_ts
.u
.derived
->components
->as
698 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
701 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
702 gfc_conv_descriptor_data_get (ctree
));
704 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
707 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
711 ctree
= gfc_class_vptr_get (var
);
713 /* The vptr is the second field of the actual argument.
714 First we have to find the corresponding class reference. */
717 if (class_ref
== NULL
718 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
719 tmp
= e
->symtree
->n
.sym
->backend_decl
;
722 /* Remove everything after the last class reference, convert the
723 expression and then recover its tailend once more. */
725 ref
= class_ref
->next
;
726 class_ref
->next
= NULL
;
727 gfc_init_se (&tmpse
, NULL
);
728 gfc_conv_expr (&tmpse
, e
);
729 class_ref
->next
= ref
;
733 gcc_assert (tmp
!= NULL_TREE
);
735 /* Dereference if needs be. */
736 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
737 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
739 vptr
= gfc_class_vptr_get (tmp
);
740 gfc_add_modify (&block
, ctree
,
741 fold_convert (TREE_TYPE (ctree
), vptr
));
743 /* Return the vptr component, except in the case of scalarized array
744 references, where the dynamic type cannot change. */
745 if (!elemental
&& full_array
&& copyback
)
746 gfc_add_modify (&parmse
->post
, vptr
,
747 fold_convert (TREE_TYPE (vptr
), ctree
));
753 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
754 tmp
= gfc_finish_block (&block
);
756 if (optional_alloc_ptr
)
757 tmp2
= build_empty_stmt (input_location
);
760 gfc_init_block (&block
);
762 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
763 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
765 tmp2
= gfc_finish_block (&block
);
768 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
770 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
773 gfc_add_block_to_block (&parmse
->pre
, &block
);
775 /* Pass the address of the class object. */
776 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
778 if (optional
&& optional_alloc_ptr
)
779 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
780 TREE_TYPE (parmse
->expr
),
782 fold_convert (TREE_TYPE (parmse
->expr
),
787 /* Given a class array declaration and an index, returns the address
788 of the referenced element. */
791 gfc_get_class_array_ref (tree index
, tree class_decl
)
793 tree data
= gfc_class_data_get (class_decl
);
794 tree size
= gfc_vtable_size_get (class_decl
);
795 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
796 gfc_array_index_type
,
799 data
= gfc_conv_descriptor_data_get (data
);
800 ptr
= fold_convert (pvoid_type_node
, data
);
801 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
802 return fold_convert (TREE_TYPE (data
), ptr
);
806 /* Copies one class expression to another, assuming that if either
807 'to' or 'from' are arrays they are packed. Should 'from' be
808 NULL_TREE, the initialization expression for 'to' is used, assuming
809 that the _vptr is set. */
812 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
820 vec
<tree
, va_gc
> *args
;
823 stmtblock_t loopbody
;
829 if (from
!= NULL_TREE
)
830 fcn
= gfc_vtable_copy_get (from
);
832 fcn
= gfc_vtable_copy_get (to
);
834 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
836 if (from
!= NULL_TREE
)
837 from_data
= gfc_class_data_get (from
);
839 from_data
= gfc_vtable_def_init_get (to
);
841 to_data
= gfc_class_data_get (to
);
843 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
845 gfc_init_block (&body
);
846 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
847 gfc_array_index_type
, nelems
,
849 nelems
= gfc_evaluate_now (tmp
, &body
);
850 index
= gfc_create_var (gfc_array_index_type
, "S");
852 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
854 from_ref
= gfc_get_class_array_ref (index
, from
);
855 vec_safe_push (args
, from_ref
);
858 vec_safe_push (args
, from_data
);
860 to_ref
= gfc_get_class_array_ref (index
, to
);
861 vec_safe_push (args
, to_ref
);
863 tmp
= build_call_vec (fcn_type
, fcn
, args
);
865 /* Build the body of the loop. */
866 gfc_init_block (&loopbody
);
867 gfc_add_expr_to_block (&loopbody
, tmp
);
869 /* Build the loop and return. */
870 gfc_init_loopinfo (&loop
);
872 loop
.from
[0] = gfc_index_zero_node
;
873 loop
.loopvar
[0] = index
;
875 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
876 gfc_add_block_to_block (&body
, &loop
.pre
);
877 tmp
= gfc_finish_block (&body
);
878 gfc_cleanup_loop (&loop
);
882 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
883 vec_safe_push (args
, from_data
);
884 vec_safe_push (args
, to_data
);
885 tmp
= build_call_vec (fcn_type
, fcn
, args
);
892 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
894 gfc_actual_arglist
*actual
;
899 actual
= gfc_get_actual_arglist ();
900 actual
->expr
= gfc_copy_expr (rhs
);
901 actual
->next
= gfc_get_actual_arglist ();
902 actual
->next
->expr
= gfc_copy_expr (lhs
);
903 ppc
= gfc_copy_expr (obj
);
904 gfc_add_vptr_component (ppc
);
905 gfc_add_component_ref (ppc
, "_copy");
906 ppc_code
= gfc_get_code (EXEC_CALL
);
907 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
908 /* Although '_copy' is set to be elemental in class.c, it is
909 not staying that way. Find out why, sometime.... */
910 ppc_code
->resolved_sym
->attr
.elemental
= 1;
911 ppc_code
->ext
.actual
= actual
;
912 ppc_code
->expr1
= ppc
;
913 /* Since '_copy' is elemental, the scalarizer will take care
914 of arrays in gfc_trans_call. */
915 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
916 gfc_free_statements (ppc_code
);
920 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
921 A MEMCPY is needed to copy the full data from the default initializer
922 of the dynamic type. */
925 gfc_trans_class_init_assign (gfc_code
*code
)
929 gfc_se dst
,src
,memsz
;
930 gfc_expr
*lhs
, *rhs
, *sz
;
932 gfc_start_block (&block
);
934 lhs
= gfc_copy_expr (code
->expr1
);
935 gfc_add_data_component (lhs
);
937 rhs
= gfc_copy_expr (code
->expr1
);
938 gfc_add_vptr_component (rhs
);
940 /* Make sure that the component backend_decls have been built, which
941 will not have happened if the derived types concerned have not
943 gfc_get_derived_type (rhs
->ts
.u
.derived
);
944 gfc_add_def_init_component (rhs
);
946 if (code
->expr1
->ts
.type
== BT_CLASS
947 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
948 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
951 sz
= gfc_copy_expr (code
->expr1
);
952 gfc_add_vptr_component (sz
);
953 gfc_add_size_component (sz
);
955 gfc_init_se (&dst
, NULL
);
956 gfc_init_se (&src
, NULL
);
957 gfc_init_se (&memsz
, NULL
);
958 gfc_conv_expr (&dst
, lhs
);
959 gfc_conv_expr (&src
, rhs
);
960 gfc_conv_expr (&memsz
, sz
);
961 gfc_add_block_to_block (&block
, &src
.pre
);
962 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
964 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
967 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
968 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
970 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
971 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
973 build_empty_stmt (input_location
));
976 gfc_add_expr_to_block (&block
, tmp
);
978 return gfc_finish_block (&block
);
982 /* Translate an assignment to a CLASS object
983 (pointer or ordinary assignment). */
986 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
994 gfc_start_block (&block
);
997 while (ref
&& ref
->next
)
1000 /* Class valued proc_pointer assignments do not need any further
1002 if (ref
&& ref
->type
== REF_COMPONENT
1003 && ref
->u
.c
.component
->attr
.proc_pointer
1004 && expr2
->expr_type
== EXPR_VARIABLE
1005 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1006 && op
== EXEC_POINTER_ASSIGN
)
1009 if (expr2
->ts
.type
!= BT_CLASS
)
1011 /* Insert an additional assignment which sets the '_vptr' field. */
1012 gfc_symbol
*vtab
= NULL
;
1015 lhs
= gfc_copy_expr (expr1
);
1016 gfc_add_vptr_component (lhs
);
1018 if (UNLIMITED_POLY (expr1
)
1019 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1021 rhs
= gfc_get_null_expr (&expr2
->where
);
1025 if (expr2
->expr_type
== EXPR_NULL
)
1026 vtab
= gfc_find_vtab (&expr1
->ts
);
1028 vtab
= gfc_find_vtab (&expr2
->ts
);
1031 rhs
= gfc_get_expr ();
1032 rhs
->expr_type
= EXPR_VARIABLE
;
1033 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1037 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1038 gfc_add_expr_to_block (&block
, tmp
);
1040 gfc_free_expr (lhs
);
1041 gfc_free_expr (rhs
);
1043 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1045 /* F2003:C717 only sequence and bind-C types can come here. */
1046 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1047 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1048 gfc_add_data_component (expr2
);
1051 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1053 /* Insert an additional assignment which sets the '_vptr' field. */
1054 lhs
= gfc_copy_expr (expr1
);
1055 gfc_add_vptr_component (lhs
);
1057 rhs
= gfc_copy_expr (expr2
);
1058 gfc_add_vptr_component (rhs
);
1060 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1061 gfc_add_expr_to_block (&block
, tmp
);
1063 gfc_free_expr (lhs
);
1064 gfc_free_expr (rhs
);
1067 /* Do the actual CLASS assignment. */
1068 if (expr2
->ts
.type
== BT_CLASS
1069 && !CLASS_DATA (expr2
)->attr
.dimension
)
1071 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1072 || !CLASS_DATA (expr2
)->attr
.dimension
)
1073 gfc_add_data_component (expr1
);
1077 if (op
== EXEC_ASSIGN
)
1078 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1079 else if (op
== EXEC_POINTER_ASSIGN
)
1080 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1084 gfc_add_expr_to_block (&block
, tmp
);
1086 return gfc_finish_block (&block
);
1090 /* End of prototype trans-class.c */
1094 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1096 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1097 && gfc_option
.warn_realloc_lhs
)
1098 gfc_warning ("Code for reallocating the allocatable array at %L will "
1100 else if (gfc_option
.warn_realloc_lhs_all
)
1101 gfc_warning ("Code for reallocating the allocatable variable at %L "
1102 "will be added", where
);
1106 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1107 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1110 /* Copy the scalarization loop variables. */
1113 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1116 dest
->loop
= src
->loop
;
1120 /* Initialize a simple expression holder.
1122 Care must be taken when multiple se are created with the same parent.
1123 The child se must be kept in sync. The easiest way is to delay creation
1124 of a child se until after after the previous se has been translated. */
1127 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1129 memset (se
, 0, sizeof (gfc_se
));
1130 gfc_init_block (&se
->pre
);
1131 gfc_init_block (&se
->post
);
1133 se
->parent
= parent
;
1136 gfc_copy_se_loopvars (se
, parent
);
1140 /* Advances to the next SS in the chain. Use this rather than setting
1141 se->ss = se->ss->next because all the parents needs to be kept in sync.
1145 gfc_advance_se_ss_chain (gfc_se
* se
)
1150 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1153 /* Walk down the parent chain. */
1156 /* Simple consistency check. */
1157 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1158 || p
->parent
->ss
->nested_ss
== p
->ss
);
1160 /* If we were in a nested loop, the next scalarized expression can be
1161 on the parent ss' next pointer. Thus we should not take the next
1162 pointer blindly, but rather go up one nest level as long as next
1163 is the end of chain. */
1165 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1175 /* Ensures the result of the expression as either a temporary variable
1176 or a constant so that it can be used repeatedly. */
1179 gfc_make_safe_expr (gfc_se
* se
)
1183 if (CONSTANT_CLASS_P (se
->expr
))
1186 /* We need a temporary for this result. */
1187 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1188 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1193 /* Return an expression which determines if a dummy parameter is present.
1194 Also used for arguments to procedures with multiple entry points. */
1197 gfc_conv_expr_present (gfc_symbol
* sym
)
1201 gcc_assert (sym
->attr
.dummy
);
1202 decl
= gfc_get_symbol_decl (sym
);
1204 /* Intrinsic scalars with VALUE attribute which are passed by value
1205 use a hidden argument to denote the present status. */
1206 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1207 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1208 && !sym
->attr
.dimension
)
1210 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1213 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1215 strcpy (&name
[1], sym
->name
);
1216 tree_name
= get_identifier (name
);
1218 /* Walk function argument list to find hidden arg. */
1219 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1220 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1221 if (DECL_NAME (cond
) == tree_name
)
1228 if (TREE_CODE (decl
) != PARM_DECL
)
1230 /* Array parameters use a temporary descriptor, we want the real
1232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1233 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1234 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1237 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1238 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1240 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1241 as actual argument to denote absent dummies. For array descriptors,
1242 we thus also need to check the array descriptor. For BT_CLASS, it
1243 can also occur for scalars and F2003 due to type->class wrapping and
1244 class->class wrapping. Note further that BT_CLASS always uses an
1245 array descriptor for arrays, also for explicit-shape/assumed-size. */
1247 if (!sym
->attr
.allocatable
1248 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1249 || (sym
->ts
.type
== BT_CLASS
1250 && !CLASS_DATA (sym
)->attr
.allocatable
1251 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1252 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1253 || sym
->ts
.type
== BT_CLASS
))
1257 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1258 || sym
->as
->type
== AS_ASSUMED_RANK
1259 || sym
->attr
.codimension
))
1260 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1262 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1263 if (sym
->ts
.type
== BT_CLASS
)
1264 tmp
= gfc_class_data_get (tmp
);
1265 tmp
= gfc_conv_array_data (tmp
);
1267 else if (sym
->ts
.type
== BT_CLASS
)
1268 tmp
= gfc_class_data_get (decl
);
1272 if (tmp
!= NULL_TREE
)
1274 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1275 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1276 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1277 boolean_type_node
, cond
, tmp
);
1285 /* Converts a missing, dummy argument into a null or zero. */
1288 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1293 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1297 /* Create a temporary and convert it to the correct type. */
1298 tmp
= gfc_get_int_type (kind
);
1299 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1302 /* Test for a NULL value. */
1303 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1304 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1305 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1306 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1310 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1312 build_zero_cst (TREE_TYPE (se
->expr
)));
1313 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1317 if (ts
.type
== BT_CHARACTER
)
1319 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1320 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1321 present
, se
->string_length
, tmp
);
1322 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1323 se
->string_length
= tmp
;
1329 /* Get the character length of an expression, looking through gfc_refs
1333 gfc_get_expr_charlen (gfc_expr
*e
)
1338 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1339 && e
->ts
.type
== BT_CHARACTER
);
1341 length
= NULL
; /* To silence compiler warning. */
1343 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1346 gfc_init_se (&tmpse
, NULL
);
1347 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1348 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1352 /* First candidate: if the variable is of type CHARACTER, the
1353 expression's length could be the length of the character
1355 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1356 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1358 /* Look through the reference chain for component references. */
1359 for (r
= e
->ref
; r
; r
= r
->next
)
1364 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1365 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1373 /* We should never got substring references here. These will be
1374 broken down by the scalarizer. */
1380 gcc_assert (length
!= NULL
);
1385 /* Return for an expression the backend decl of the coarray. */
1388 get_tree_for_caf_expr (gfc_expr
*expr
)
1394 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1396 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1397 gcc_assert (caf_decl
);
1398 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1399 caf_decl
= gfc_class_data_get (caf_decl
);
1400 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1403 /* The following code assumes that the coarray is a component reachable via
1404 only scalar components/variables; the Fortran standard guarantees this. */
1406 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1407 if (ref
->type
== REF_COMPONENT
)
1409 gfc_component
*comp
= ref
->u
.c
.component
;
1411 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1412 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1413 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1414 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1415 comp
->backend_decl
, NULL_TREE
);
1416 if (comp
->ts
.type
== BT_CLASS
)
1417 caf_decl
= gfc_class_data_get (caf_decl
);
1418 if (comp
->attr
.codimension
)
1424 gcc_assert (found
&& caf_decl
);
1429 /* For each character array constructor subexpression without a ts.u.cl->length,
1430 replace it by its first element (if there aren't any elements, the length
1431 should already be set to zero). */
1434 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1436 gfc_actual_arglist
* arg
;
1442 switch (e
->expr_type
)
1446 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1447 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1451 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1455 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1456 flatten_array_ctors_without_strlen (arg
->expr
);
1461 /* We've found what we're looking for. */
1462 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1467 gcc_assert (e
->value
.constructor
);
1469 c
= gfc_constructor_first (e
->value
.constructor
);
1473 flatten_array_ctors_without_strlen (new_expr
);
1474 gfc_replace_expr (e
, new_expr
);
1478 /* Otherwise, fall through to handle constructor elements. */
1479 case EXPR_STRUCTURE
:
1480 for (c
= gfc_constructor_first (e
->value
.constructor
);
1481 c
; c
= gfc_constructor_next (c
))
1482 flatten_array_ctors_without_strlen (c
->expr
);
1492 /* Generate code to initialize a string length variable. Returns the
1493 value. For array constructors, cl->length might be NULL and in this case,
1494 the first element of the constructor is needed. expr is the original
1495 expression so we can access it but can be NULL if this is not needed. */
1498 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1502 gfc_init_se (&se
, NULL
);
1506 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1509 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1510 "flatten" array constructors by taking their first element; all elements
1511 should be the same length or a cl->length should be present. */
1514 gfc_expr
* expr_flat
;
1516 expr_flat
= gfc_copy_expr (expr
);
1517 flatten_array_ctors_without_strlen (expr_flat
);
1518 gfc_resolve_expr (expr_flat
);
1520 gfc_conv_expr (&se
, expr_flat
);
1521 gfc_add_block_to_block (pblock
, &se
.pre
);
1522 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1524 gfc_free_expr (expr_flat
);
1528 /* Convert cl->length. */
1530 gcc_assert (cl
->length
);
1532 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1533 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1534 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1535 gfc_add_block_to_block (pblock
, &se
.pre
);
1537 if (cl
->backend_decl
)
1538 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1540 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1545 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1546 const char *name
, locus
*where
)
1556 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1557 type
= build_pointer_type (type
);
1559 gfc_init_se (&start
, se
);
1560 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1561 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1563 if (integer_onep (start
.expr
))
1564 gfc_conv_string_parameter (se
);
1569 /* Avoid multiple evaluation of substring start. */
1570 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1571 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1573 /* Change the start of the string. */
1574 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1577 tmp
= build_fold_indirect_ref_loc (input_location
,
1579 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1580 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1583 /* Length = end + 1 - start. */
1584 gfc_init_se (&end
, se
);
1585 if (ref
->u
.ss
.end
== NULL
)
1586 end
.expr
= se
->string_length
;
1589 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1590 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1594 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1595 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1597 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1599 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1600 boolean_type_node
, start
.expr
,
1603 /* Check lower bound. */
1604 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1606 build_int_cst (gfc_charlen_type_node
, 1));
1607 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1608 boolean_type_node
, nonempty
, fault
);
1610 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1611 "is less than one", name
);
1613 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1614 "is less than one");
1615 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1616 fold_convert (long_integer_type_node
,
1620 /* Check upper bound. */
1621 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1622 end
.expr
, se
->string_length
);
1623 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1624 boolean_type_node
, nonempty
, fault
);
1626 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1627 "exceeds string length (%%ld)", name
);
1629 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1630 "exceeds string length (%%ld)");
1631 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1632 fold_convert (long_integer_type_node
, end
.expr
),
1633 fold_convert (long_integer_type_node
,
1634 se
->string_length
));
1638 /* Try to calculate the length from the start and end expressions. */
1640 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1644 i_len
= mpz_get_si (length
) + 1;
1648 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1649 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1653 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1654 end
.expr
, start
.expr
);
1655 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1656 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1657 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1658 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1661 se
->string_length
= tmp
;
1665 /* Convert a derived type component reference. */
1668 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1675 c
= ref
->u
.c
.component
;
1677 gcc_assert (c
->backend_decl
);
1679 field
= c
->backend_decl
;
1680 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1683 /* Components can correspond to fields of different containing
1684 types, as components are created without context, whereas
1685 a concrete use of a component has the type of decl as context.
1686 So, if the type doesn't match, we search the corresponding
1687 FIELD_DECL in the parent type. To not waste too much time
1688 we cache this result in norestrict_decl. */
1690 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1692 tree f2
= c
->norestrict_decl
;
1693 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1694 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1695 if (TREE_CODE (f2
) == FIELD_DECL
1696 && DECL_NAME (f2
) == DECL_NAME (field
))
1699 c
->norestrict_decl
= f2
;
1703 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1704 decl
, field
, NULL_TREE
);
1708 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1710 tmp
= c
->ts
.u
.cl
->backend_decl
;
1711 /* Components must always be constant length. */
1712 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1713 se
->string_length
= tmp
;
1716 if (gfc_deferred_strlen (c
, &field
))
1718 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1720 decl
, field
, NULL_TREE
);
1721 se
->string_length
= tmp
;
1724 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1725 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1726 && c
->ts
.type
!= BT_CHARACTER
)
1727 || c
->attr
.proc_pointer
)
1728 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1733 /* This function deals with component references to components of the
1734 parent type for derived type extensions. */
1736 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1744 c
= ref
->u
.c
.component
;
1746 /* Return if the component is in the parent type. */
1747 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1748 if (strcmp (c
->name
, cmp
->name
) == 0)
1751 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1752 parent
.type
= REF_COMPONENT
;
1754 parent
.u
.c
.sym
= dt
;
1755 parent
.u
.c
.component
= dt
->components
;
1757 if (dt
->backend_decl
== NULL
)
1758 gfc_get_derived_type (dt
);
1760 /* Build the reference and call self. */
1761 gfc_conv_component_ref (se
, &parent
);
1762 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1763 parent
.u
.c
.component
= c
;
1764 conv_parent_component_references (se
, &parent
);
1767 /* Return the contents of a variable. Also handles reference/pointer
1768 variables (all Fortran pointer references are implicit). */
1771 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1776 tree parent_decl
= NULL_TREE
;
1779 bool alternate_entry
;
1782 sym
= expr
->symtree
->n
.sym
;
1786 gfc_ss_info
*ss_info
= ss
->info
;
1788 /* Check that something hasn't gone horribly wrong. */
1789 gcc_assert (ss
!= gfc_ss_terminator
);
1790 gcc_assert (ss_info
->expr
== expr
);
1792 /* A scalarized term. We already know the descriptor. */
1793 se
->expr
= ss_info
->data
.array
.descriptor
;
1794 se
->string_length
= ss_info
->string_length
;
1795 ref
= ss_info
->data
.array
.ref
;
1797 gcc_assert (ref
->type
== REF_ARRAY
1798 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1800 gfc_conv_tmp_array_ref (se
);
1804 tree se_expr
= NULL_TREE
;
1806 se
->expr
= gfc_get_symbol_decl (sym
);
1808 /* Deal with references to a parent results or entries by storing
1809 the current_function_decl and moving to the parent_decl. */
1810 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1811 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1812 && sym
->result
== sym
;
1813 entry_master
= sym
->attr
.result
1814 && sym
->ns
->proc_name
->attr
.entry_master
1815 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1816 if (current_function_decl
)
1817 parent_decl
= DECL_CONTEXT (current_function_decl
);
1819 if ((se
->expr
== parent_decl
&& return_value
)
1820 || (sym
->ns
&& sym
->ns
->proc_name
1822 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1823 && (alternate_entry
|| entry_master
)))
1828 /* Special case for assigning the return value of a function.
1829 Self recursive functions must have an explicit return value. */
1830 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1831 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1833 /* Similarly for alternate entry points. */
1834 else if (alternate_entry
1835 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1838 gfc_entry_list
*el
= NULL
;
1840 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1843 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1848 else if (entry_master
1849 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1851 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1856 /* Procedure actual arguments. */
1857 else if (sym
->attr
.flavor
== FL_PROCEDURE
1858 && se
->expr
!= current_function_decl
)
1860 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1862 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1863 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1869 /* Dereference the expression, where needed. Since characters
1870 are entirely different from other types, they are treated
1872 if (sym
->ts
.type
== BT_CHARACTER
)
1874 /* Dereference character pointer dummy arguments
1876 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1878 || sym
->attr
.function
1879 || sym
->attr
.result
))
1880 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1884 else if (!sym
->attr
.value
)
1886 /* Dereference non-character scalar dummy arguments. */
1887 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1888 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1889 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1892 /* Dereference scalar hidden result. */
1893 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1894 && (sym
->attr
.function
|| sym
->attr
.result
)
1895 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1896 && !sym
->attr
.always_explicit
)
1897 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1900 /* Dereference non-character pointer variables.
1901 These must be dummies, results, or scalars. */
1902 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1903 || gfc_is_associate_pointer (sym
)
1904 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1906 || sym
->attr
.function
1908 || (!sym
->attr
.dimension
1909 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1910 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1917 /* For character variables, also get the length. */
1918 if (sym
->ts
.type
== BT_CHARACTER
)
1920 /* If the character length of an entry isn't set, get the length from
1921 the master function instead. */
1922 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1923 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1925 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1926 gcc_assert (se
->string_length
);
1934 /* Return the descriptor if that's what we want and this is an array
1935 section reference. */
1936 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1938 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1939 /* Return the descriptor for array pointers and allocations. */
1940 if (se
->want_pointer
1941 && ref
->next
== NULL
&& (se
->descriptor_only
))
1944 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1945 /* Return a pointer to an element. */
1949 if (ref
->u
.c
.sym
->attr
.extension
)
1950 conv_parent_component_references (se
, ref
);
1952 gfc_conv_component_ref (se
, ref
);
1953 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1954 && se
->want_pointer
&& se
->descriptor_only
)
1960 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1961 expr
->symtree
->name
, &expr
->where
);
1970 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1972 if (se
->want_pointer
)
1974 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1975 gfc_conv_string_parameter (se
);
1977 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1982 /* Unary ops are easy... Or they would be if ! was a valid op. */
1985 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1990 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1991 /* Initialize the operand. */
1992 gfc_init_se (&operand
, se
);
1993 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1994 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1996 type
= gfc_typenode_for_spec (&expr
->ts
);
1998 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1999 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2000 All other unary operators have an equivalent GIMPLE unary operator. */
2001 if (code
== TRUTH_NOT_EXPR
)
2002 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2003 build_int_cst (type
, 0));
2005 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2009 /* Expand power operator to optimal multiplications when a value is raised
2010 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2011 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2012 Programming", 3rd Edition, 1998. */
2014 /* This code is mostly duplicated from expand_powi in the backend.
2015 We establish the "optimal power tree" lookup table with the defined size.
2016 The items in the table are the exponents used to calculate the index
2017 exponents. Any integer n less than the value can get an "addition chain",
2018 with the first node being one. */
2019 #define POWI_TABLE_SIZE 256
2021 /* The table is from builtins.c. */
2022 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2024 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2025 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2026 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2027 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2028 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2029 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2030 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2031 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2032 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2033 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2034 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2035 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2036 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2037 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2038 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2039 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2040 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2041 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2042 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2043 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2044 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2045 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2046 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2047 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2048 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2049 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2050 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2051 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2052 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2053 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2054 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2055 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2058 /* If n is larger than lookup table's max index, we use the "window
2060 #define POWI_WINDOW_SIZE 3
2062 /* Recursive function to expand the power operator. The temporary
2063 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2065 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2072 if (n
< POWI_TABLE_SIZE
)
2077 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2078 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2082 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2083 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2084 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2088 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2092 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2093 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2095 if (n
< POWI_TABLE_SIZE
)
2102 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2103 return 1. Else return 0 and a call to runtime library functions
2104 will have to be built. */
2106 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2111 tree vartmp
[POWI_TABLE_SIZE
];
2113 unsigned HOST_WIDE_INT n
;
2115 wide_int wrhs
= rhs
;
2117 /* If exponent is too large, we won't expand it anyway, so don't bother
2118 with large integer values. */
2119 if (!wi::fits_shwi_p (wrhs
))
2122 m
= wrhs
.to_shwi ();
2123 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2124 of the asymmetric range of the integer type. */
2125 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2127 type
= TREE_TYPE (lhs
);
2128 sgn
= tree_int_cst_sgn (rhs
);
2130 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2131 || optimize_size
) && (m
> 2 || m
< -1))
2137 se
->expr
= gfc_build_const (type
, integer_one_node
);
2141 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2142 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2144 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2145 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2146 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2147 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2150 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2153 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2154 boolean_type_node
, tmp
, cond
);
2155 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2156 tmp
, build_int_cst (type
, 1),
2157 build_int_cst (type
, 0));
2161 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2162 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2163 build_int_cst (type
, -1),
2164 build_int_cst (type
, 0));
2165 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2166 cond
, build_int_cst (type
, 1), tmp
);
2170 memset (vartmp
, 0, sizeof (vartmp
));
2174 tmp
= gfc_build_const (type
, integer_one_node
);
2175 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2179 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2185 /* Power op (**). Constant integer exponent has special handling. */
2188 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2190 tree gfc_int4_type_node
;
2193 int res_ikind_1
, res_ikind_2
;
2198 gfc_init_se (&lse
, se
);
2199 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2200 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2201 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2203 gfc_init_se (&rse
, se
);
2204 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2205 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2207 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2208 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2209 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2212 gfc_int4_type_node
= gfc_get_int_type (4);
2214 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2215 library routine. But in the end, we have to convert the result back
2216 if this case applies -- with res_ikind_K, we keep track whether operand K
2217 falls into this case. */
2221 kind
= expr
->value
.op
.op1
->ts
.kind
;
2222 switch (expr
->value
.op
.op2
->ts
.type
)
2225 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2230 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2231 res_ikind_2
= ikind
;
2253 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2255 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2282 switch (expr
->value
.op
.op1
->ts
.type
)
2285 if (kind
== 3) /* Case 16 was not handled properly above. */
2287 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2291 /* Use builtins for real ** int4. */
2297 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2301 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2305 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2309 /* Use the __builtin_powil() only if real(kind=16) is
2310 actually the C long double type. */
2311 if (!gfc_real16_is_float128
)
2312 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2320 /* If we don't have a good builtin for this, go for the
2321 library function. */
2323 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2327 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2336 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2340 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2348 se
->expr
= build_call_expr_loc (input_location
,
2349 fndecl
, 2, lse
.expr
, rse
.expr
);
2351 /* Convert the result back if it is of wrong integer kind. */
2352 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2354 /* We want the maximum of both operand kinds as result. */
2355 if (res_ikind_1
< res_ikind_2
)
2356 res_ikind_1
= res_ikind_2
;
2357 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2362 /* Generate code to allocate a string temporary. */
2365 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2370 if (gfc_can_put_var_on_stack (len
))
2372 /* Create a temporary variable to hold the result. */
2373 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2374 gfc_charlen_type_node
, len
,
2375 build_int_cst (gfc_charlen_type_node
, 1));
2376 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2378 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2379 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2381 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2383 var
= gfc_create_var (tmp
, "str");
2384 var
= gfc_build_addr_expr (type
, var
);
2388 /* Allocate a temporary to hold the result. */
2389 var
= gfc_create_var (type
, "pstr");
2390 gcc_assert (POINTER_TYPE_P (type
));
2391 tmp
= TREE_TYPE (type
);
2392 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2393 tmp
= TREE_TYPE (tmp
);
2394 tmp
= TYPE_SIZE_UNIT (tmp
);
2395 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2396 fold_convert (size_type_node
, len
),
2397 fold_convert (size_type_node
, tmp
));
2398 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2399 gfc_add_modify (&se
->pre
, var
, tmp
);
2401 /* Free the temporary afterwards. */
2402 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2403 gfc_add_expr_to_block (&se
->post
, tmp
);
2410 /* Handle a string concatenation operation. A temporary will be allocated to
2414 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2417 tree len
, type
, var
, tmp
, fndecl
;
2419 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2420 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2421 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2423 gfc_init_se (&lse
, se
);
2424 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2425 gfc_conv_string_parameter (&lse
);
2426 gfc_init_se (&rse
, se
);
2427 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2428 gfc_conv_string_parameter (&rse
);
2430 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2431 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2433 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2434 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2435 if (len
== NULL_TREE
)
2437 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2438 TREE_TYPE (lse
.string_length
),
2439 lse
.string_length
, rse
.string_length
);
2442 type
= build_pointer_type (type
);
2444 var
= gfc_conv_string_tmp (se
, type
, len
);
2446 /* Do the actual concatenation. */
2447 if (expr
->ts
.kind
== 1)
2448 fndecl
= gfor_fndecl_concat_string
;
2449 else if (expr
->ts
.kind
== 4)
2450 fndecl
= gfor_fndecl_concat_string_char4
;
2454 tmp
= build_call_expr_loc (input_location
,
2455 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2456 rse
.string_length
, rse
.expr
);
2457 gfc_add_expr_to_block (&se
->pre
, tmp
);
2459 /* Add the cleanup for the operands. */
2460 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2461 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2464 se
->string_length
= len
;
2467 /* Translates an op expression. Common (binary) cases are handled by this
2468 function, others are passed on. Recursion is used in either case.
2469 We use the fact that (op1.ts == op2.ts) (except for the power
2471 Operators need no special handling for scalarized expressions as long as
2472 they call gfc_conv_simple_val to get their operands.
2473 Character strings get special handling. */
2476 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2478 enum tree_code code
;
2487 switch (expr
->value
.op
.op
)
2489 case INTRINSIC_PARENTHESES
:
2490 if ((expr
->ts
.type
== BT_REAL
2491 || expr
->ts
.type
== BT_COMPLEX
)
2492 && gfc_option
.flag_protect_parens
)
2494 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2495 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2500 case INTRINSIC_UPLUS
:
2501 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2504 case INTRINSIC_UMINUS
:
2505 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2509 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2512 case INTRINSIC_PLUS
:
2516 case INTRINSIC_MINUS
:
2520 case INTRINSIC_TIMES
:
2524 case INTRINSIC_DIVIDE
:
2525 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2526 an integer, we must round towards zero, so we use a
2528 if (expr
->ts
.type
== BT_INTEGER
)
2529 code
= TRUNC_DIV_EXPR
;
2534 case INTRINSIC_POWER
:
2535 gfc_conv_power_op (se
, expr
);
2538 case INTRINSIC_CONCAT
:
2539 gfc_conv_concat_op (se
, expr
);
2543 code
= TRUTH_ANDIF_EXPR
;
2548 code
= TRUTH_ORIF_EXPR
;
2552 /* EQV and NEQV only work on logicals, but since we represent them
2553 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2555 case INTRINSIC_EQ_OS
:
2563 case INTRINSIC_NE_OS
:
2564 case INTRINSIC_NEQV
:
2571 case INTRINSIC_GT_OS
:
2578 case INTRINSIC_GE_OS
:
2585 case INTRINSIC_LT_OS
:
2592 case INTRINSIC_LE_OS
:
2598 case INTRINSIC_USER
:
2599 case INTRINSIC_ASSIGN
:
2600 /* These should be converted into function calls by the frontend. */
2604 fatal_error ("Unknown intrinsic op");
2608 /* The only exception to this is **, which is handled separately anyway. */
2609 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2611 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2615 gfc_init_se (&lse
, se
);
2616 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2617 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2620 gfc_init_se (&rse
, se
);
2621 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2622 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2626 gfc_conv_string_parameter (&lse
);
2627 gfc_conv_string_parameter (&rse
);
2629 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2630 rse
.string_length
, rse
.expr
,
2631 expr
->value
.op
.op1
->ts
.kind
,
2633 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2634 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2637 type
= gfc_typenode_for_spec (&expr
->ts
);
2641 /* The result of logical ops is always boolean_type_node. */
2642 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2643 lse
.expr
, rse
.expr
);
2644 se
->expr
= convert (type
, tmp
);
2647 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2649 /* Add the post blocks. */
2650 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2651 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2654 /* If a string's length is one, we convert it to a single character. */
2657 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2661 || !tree_fits_uhwi_p (len
)
2662 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2665 if (TREE_INT_CST_LOW (len
) == 1)
2667 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2668 return build_fold_indirect_ref_loc (input_location
, str
);
2672 && TREE_CODE (str
) == ADDR_EXPR
2673 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2674 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2675 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2676 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2677 && TREE_INT_CST_LOW (len
) > 1
2678 && TREE_INT_CST_LOW (len
)
2679 == (unsigned HOST_WIDE_INT
)
2680 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2682 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2683 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2684 if (TREE_CODE (ret
) == INTEGER_CST
)
2686 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2687 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2688 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2690 for (i
= 1; i
< length
; i
++)
2703 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2706 if (sym
->backend_decl
)
2708 /* This becomes the nominal_type in
2709 function.c:assign_parm_find_data_types. */
2710 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2711 /* This becomes the passed_type in
2712 function.c:assign_parm_find_data_types. C promotes char to
2713 integer for argument passing. */
2714 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2716 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2721 /* If we have a constant character expression, make it into an
2723 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2728 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2729 (int)(*expr
)->value
.character
.string
[0]);
2730 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2732 /* The expr needs to be compatible with a C int. If the
2733 conversion fails, then the 2 causes an ICE. */
2734 ts
.type
= BT_INTEGER
;
2735 ts
.kind
= gfc_c_int_kind
;
2736 gfc_convert_type (*expr
, &ts
, 2);
2739 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2741 if ((*expr
)->ref
== NULL
)
2743 se
->expr
= gfc_string_to_single_character
2744 (build_int_cst (integer_type_node
, 1),
2745 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2747 ((*expr
)->symtree
->n
.sym
)),
2752 gfc_conv_variable (se
, *expr
);
2753 se
->expr
= gfc_string_to_single_character
2754 (build_int_cst (integer_type_node
, 1),
2755 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2763 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2764 if STR is a string literal, otherwise return -1. */
2767 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2770 && TREE_CODE (str
) == ADDR_EXPR
2771 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2772 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2773 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2774 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2775 && tree_fits_uhwi_p (len
)
2776 && tree_to_uhwi (len
) >= 1
2777 && tree_to_uhwi (len
)
2778 == (unsigned HOST_WIDE_INT
)
2779 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2781 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2782 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2783 if (TREE_CODE (folded
) == INTEGER_CST
)
2785 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2786 int length
= TREE_STRING_LENGTH (string_cst
);
2787 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2789 for (; length
> 0; length
--)
2790 if (ptr
[length
- 1] != ' ')
2799 /* Helper to build a call to memcmp. */
2802 build_memcmp_call (tree s1
, tree s2
, tree n
)
2806 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2807 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2809 s1
= fold_convert (pvoid_type_node
, s1
);
2811 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2812 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2814 s2
= fold_convert (pvoid_type_node
, s2
);
2816 n
= fold_convert (size_type_node
, n
);
2818 tmp
= build_call_expr_loc (input_location
,
2819 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2822 return fold_convert (integer_type_node
, tmp
);
2825 /* Compare two strings. If they are all single characters, the result is the
2826 subtraction of them. Otherwise, we build a library call. */
2829 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2830 enum tree_code code
)
2836 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2837 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2839 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2840 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2842 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2844 /* Deal with single character specially. */
2845 sc1
= fold_convert (integer_type_node
, sc1
);
2846 sc2
= fold_convert (integer_type_node
, sc2
);
2847 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2851 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2853 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2855 /* If one string is a string literal with LEN_TRIM longer
2856 than the length of the second string, the strings
2858 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2859 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2860 return integer_one_node
;
2861 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2862 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2863 return integer_one_node
;
2866 /* We can compare via memcpy if the strings are known to be equal
2867 in length and they are
2869 - kind=4 and the comparison is for (in)equality. */
2871 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2872 && tree_int_cst_equal (len1
, len2
)
2873 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2878 chartype
= gfc_get_char_type (kind
);
2879 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2880 fold_convert (TREE_TYPE(len1
),
2881 TYPE_SIZE_UNIT(chartype
)),
2883 return build_memcmp_call (str1
, str2
, tmp
);
2886 /* Build a call for the comparison. */
2888 fndecl
= gfor_fndecl_compare_string
;
2890 fndecl
= gfor_fndecl_compare_string_char4
;
2894 return build_call_expr_loc (input_location
, fndecl
, 4,
2895 len1
, str1
, len2
, str2
);
2899 /* Return the backend_decl for a procedure pointer component. */
2902 get_proc_ptr_comp (gfc_expr
*e
)
2908 gfc_init_se (&comp_se
, NULL
);
2909 e2
= gfc_copy_expr (e
);
2910 /* We have to restore the expr type later so that gfc_free_expr frees
2911 the exact same thing that was allocated.
2912 TODO: This is ugly. */
2913 old_type
= e2
->expr_type
;
2914 e2
->expr_type
= EXPR_VARIABLE
;
2915 gfc_conv_expr (&comp_se
, e2
);
2916 e2
->expr_type
= old_type
;
2918 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2922 /* Convert a typebound function reference from a class object. */
2924 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2929 if (TREE_CODE (base_object
) != VAR_DECL
)
2931 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2932 gfc_add_modify (&se
->pre
, var
, base_object
);
2934 se
->expr
= gfc_class_vptr_get (base_object
);
2935 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2937 while (ref
&& ref
->next
)
2939 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2940 if (ref
->u
.c
.sym
->attr
.extension
)
2941 conv_parent_component_references (se
, ref
);
2942 gfc_conv_component_ref (se
, ref
);
2943 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2948 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2952 if (gfc_is_proc_ptr_comp (expr
))
2953 tmp
= get_proc_ptr_comp (expr
);
2954 else if (sym
->attr
.dummy
)
2956 tmp
= gfc_get_symbol_decl (sym
);
2957 if (sym
->attr
.proc_pointer
)
2958 tmp
= build_fold_indirect_ref_loc (input_location
,
2960 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2961 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2965 if (!sym
->backend_decl
)
2966 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2968 TREE_USED (sym
->backend_decl
) = 1;
2970 tmp
= sym
->backend_decl
;
2972 if (sym
->attr
.cray_pointee
)
2974 /* TODO - make the cray pointee a pointer to a procedure,
2975 assign the pointer to it and use it for the call. This
2977 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2978 gfc_get_symbol_decl (sym
->cp_pointer
));
2979 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2982 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2984 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2985 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2992 /* Initialize MAPPING. */
2995 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2997 mapping
->syms
= NULL
;
2998 mapping
->charlens
= NULL
;
3002 /* Free all memory held by MAPPING (but not MAPPING itself). */
3005 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3007 gfc_interface_sym_mapping
*sym
;
3008 gfc_interface_sym_mapping
*nextsym
;
3010 gfc_charlen
*nextcl
;
3012 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3014 nextsym
= sym
->next
;
3015 sym
->new_sym
->n
.sym
->formal
= NULL
;
3016 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3017 gfc_free_expr (sym
->expr
);
3018 free (sym
->new_sym
);
3021 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3024 gfc_free_expr (cl
->length
);
3030 /* Return a copy of gfc_charlen CL. Add the returned structure to
3031 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3033 static gfc_charlen
*
3034 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3037 gfc_charlen
*new_charlen
;
3039 new_charlen
= gfc_get_charlen ();
3040 new_charlen
->next
= mapping
->charlens
;
3041 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3043 mapping
->charlens
= new_charlen
;
3048 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3049 array variable that can be used as the actual argument for dummy
3050 argument SYM. Add any initialization code to BLOCK. PACKED is as
3051 for gfc_get_nodesc_array_type and DATA points to the first element
3052 in the passed array. */
3055 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3056 gfc_packed packed
, tree data
)
3061 type
= gfc_typenode_for_spec (&sym
->ts
);
3062 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3063 !sym
->attr
.target
&& !sym
->attr
.pointer
3064 && !sym
->attr
.proc_pointer
);
3066 var
= gfc_create_var (type
, "ifm");
3067 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3073 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3074 and offset of descriptorless array type TYPE given that it has the same
3075 size as DESC. Add any set-up code to BLOCK. */
3078 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3085 offset
= gfc_index_zero_node
;
3086 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3088 dim
= gfc_rank_cst
[n
];
3089 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3090 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3092 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3093 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3094 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3095 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3097 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3099 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3100 gfc_array_index_type
,
3101 gfc_conv_descriptor_ubound_get (desc
, dim
),
3102 gfc_conv_descriptor_lbound_get (desc
, dim
));
3103 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3104 gfc_array_index_type
,
3105 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3106 tmp
= gfc_evaluate_now (tmp
, block
);
3107 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3109 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3110 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3111 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3112 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3113 gfc_array_index_type
, offset
, tmp
);
3115 offset
= gfc_evaluate_now (offset
, block
);
3116 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3120 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3121 in SE. The caller may still use se->expr and se->string_length after
3122 calling this function. */
3125 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3126 gfc_symbol
* sym
, gfc_se
* se
,
3129 gfc_interface_sym_mapping
*sm
;
3133 gfc_symbol
*new_sym
;
3135 gfc_symtree
*new_symtree
;
3137 /* Create a new symbol to represent the actual argument. */
3138 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3139 new_sym
->ts
= sym
->ts
;
3140 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3141 new_sym
->attr
.referenced
= 1;
3142 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3143 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3144 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3145 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3146 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3147 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3148 new_sym
->attr
.function
= sym
->attr
.function
;
3150 /* Ensure that the interface is available and that
3151 descriptors are passed for array actual arguments. */
3152 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3154 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3155 new_sym
->attr
.always_explicit
3156 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3159 /* Create a fake symtree for it. */
3161 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3162 new_symtree
->n
.sym
= new_sym
;
3163 gcc_assert (new_symtree
== root
);
3165 /* Create a dummy->actual mapping. */
3166 sm
= XCNEW (gfc_interface_sym_mapping
);
3167 sm
->next
= mapping
->syms
;
3169 sm
->new_sym
= new_symtree
;
3170 sm
->expr
= gfc_copy_expr (expr
);
3173 /* Stabilize the argument's value. */
3174 if (!sym
->attr
.function
&& se
)
3175 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3177 if (sym
->ts
.type
== BT_CHARACTER
)
3179 /* Create a copy of the dummy argument's length. */
3180 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3181 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3183 /* If the length is specified as "*", record the length that
3184 the caller is passing. We should use the callee's length
3185 in all other cases. */
3186 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3188 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3189 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3196 /* Use the passed value as-is if the argument is a function. */
3197 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3200 /* If the argument is either a string or a pointer to a string,
3201 convert it to a boundless character type. */
3202 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3204 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3205 tmp
= build_pointer_type (tmp
);
3206 if (sym
->attr
.pointer
)
3207 value
= build_fold_indirect_ref_loc (input_location
,
3211 value
= fold_convert (tmp
, value
);
3214 /* If the argument is a scalar, a pointer to an array or an allocatable,
3216 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3217 value
= build_fold_indirect_ref_loc (input_location
,
3220 /* For character(*), use the actual argument's descriptor. */
3221 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3222 value
= build_fold_indirect_ref_loc (input_location
,
3225 /* If the argument is an array descriptor, use it to determine
3226 information about the actual argument's shape. */
3227 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3228 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3230 /* Get the actual argument's descriptor. */
3231 desc
= build_fold_indirect_ref_loc (input_location
,
3234 /* Create the replacement variable. */
3235 tmp
= gfc_conv_descriptor_data_get (desc
);
3236 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3239 /* Use DESC to work out the upper bounds, strides and offset. */
3240 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3243 /* Otherwise we have a packed array. */
3244 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3245 PACKED_FULL
, se
->expr
);
3247 new_sym
->backend_decl
= value
;
3251 /* Called once all dummy argument mappings have been added to MAPPING,
3252 but before the mapping is used to evaluate expressions. Pre-evaluate
3253 the length of each argument, adding any initialization code to PRE and
3254 any finalization code to POST. */
3257 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3258 stmtblock_t
* pre
, stmtblock_t
* post
)
3260 gfc_interface_sym_mapping
*sym
;
3264 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3265 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3266 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3268 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3269 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3270 gfc_init_se (&se
, NULL
);
3271 gfc_conv_expr (&se
, expr
);
3272 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3273 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3274 gfc_add_block_to_block (pre
, &se
.pre
);
3275 gfc_add_block_to_block (post
, &se
.post
);
3277 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3282 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3286 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3287 gfc_constructor_base base
)
3290 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3292 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3295 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3296 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3297 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3303 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3307 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3312 for (; ref
; ref
= ref
->next
)
3316 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3318 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3319 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3320 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3328 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3329 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3335 /* Convert intrinsic function calls into result expressions. */
3338 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3346 arg1
= expr
->value
.function
.actual
->expr
;
3347 if (expr
->value
.function
.actual
->next
)
3348 arg2
= expr
->value
.function
.actual
->next
->expr
;
3352 sym
= arg1
->symtree
->n
.sym
;
3354 if (sym
->attr
.dummy
)
3359 switch (expr
->value
.function
.isym
->id
)
3362 /* TODO figure out why this condition is necessary. */
3363 if (sym
->attr
.function
3364 && (arg1
->ts
.u
.cl
->length
== NULL
3365 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3366 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3369 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3373 if (!sym
->as
|| sym
->as
->rank
== 0)
3376 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3378 dup
= mpz_get_si (arg2
->value
.integer
);
3383 dup
= sym
->as
->rank
;
3387 for (; d
< dup
; d
++)
3391 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3393 gfc_free_expr (new_expr
);
3397 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3398 gfc_get_int_expr (gfc_default_integer_kind
,
3400 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3402 new_expr
= gfc_multiply (new_expr
, tmp
);
3408 case GFC_ISYM_LBOUND
:
3409 case GFC_ISYM_UBOUND
:
3410 /* TODO These implementations of lbound and ubound do not limit if
3411 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3413 if (!sym
->as
|| sym
->as
->rank
== 0)
3416 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3417 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3419 /* TODO: If the need arises, this could produce an array of
3423 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3425 if (sym
->as
->lower
[d
])
3426 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3430 if (sym
->as
->upper
[d
])
3431 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3439 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3443 gfc_replace_expr (expr
, new_expr
);
3449 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3450 gfc_interface_mapping
* mapping
)
3452 gfc_formal_arglist
*f
;
3453 gfc_actual_arglist
*actual
;
3455 actual
= expr
->value
.function
.actual
;
3456 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3458 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3463 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3466 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3471 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3473 for (d
= 0; d
< as
->rank
; d
++)
3475 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3476 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3479 expr
->value
.function
.esym
->as
= as
;
3482 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3484 expr
->value
.function
.esym
->ts
.u
.cl
->length
3485 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3487 gfc_apply_interface_mapping_to_expr (mapping
,
3488 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3493 /* EXPR is a copy of an expression that appeared in the interface
3494 associated with MAPPING. Walk it recursively looking for references to
3495 dummy arguments that MAPPING maps to actual arguments. Replace each such
3496 reference with a reference to the associated actual argument. */
3499 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3502 gfc_interface_sym_mapping
*sym
;
3503 gfc_actual_arglist
*actual
;
3508 /* Copying an expression does not copy its length, so do that here. */
3509 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3511 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3512 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3515 /* Apply the mapping to any references. */
3516 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3518 /* ...and to the expression's symbol, if it has one. */
3519 /* TODO Find out why the condition on expr->symtree had to be moved into
3520 the loop rather than being outside it, as originally. */
3521 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3522 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3524 if (sym
->new_sym
->n
.sym
->backend_decl
)
3525 expr
->symtree
= sym
->new_sym
;
3527 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3528 /* Replace base type for polymorphic arguments. */
3529 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3530 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3531 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3534 /* ...and to subexpressions in expr->value. */
3535 switch (expr
->expr_type
)
3540 case EXPR_SUBSTRING
:
3544 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3545 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3549 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3550 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3552 if (expr
->value
.function
.esym
== NULL
3553 && expr
->value
.function
.isym
!= NULL
3554 && expr
->value
.function
.actual
->expr
->symtree
3555 && gfc_map_intrinsic_function (expr
, mapping
))
3558 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3559 if (sym
->old
== expr
->value
.function
.esym
)
3561 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3562 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3563 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3568 case EXPR_STRUCTURE
:
3569 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3582 /* Evaluate interface expression EXPR using MAPPING. Store the result
3586 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3587 gfc_se
* se
, gfc_expr
* expr
)
3589 expr
= gfc_copy_expr (expr
);
3590 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3591 gfc_conv_expr (se
, expr
);
3592 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3593 gfc_free_expr (expr
);
3597 /* Returns a reference to a temporary array into which a component of
3598 an actual argument derived type array is copied and then returned
3599 after the function call. */
3601 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3602 sym_intent intent
, bool formal_ptr
)
3610 gfc_array_info
*info
;
3620 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3622 gfc_init_se (&lse
, NULL
);
3623 gfc_init_se (&rse
, NULL
);
3625 /* Walk the argument expression. */
3626 rss
= gfc_walk_expr (expr
);
3628 gcc_assert (rss
!= gfc_ss_terminator
);
3630 /* Initialize the scalarizer. */
3631 gfc_init_loopinfo (&loop
);
3632 gfc_add_ss_to_loop (&loop
, rss
);
3634 /* Calculate the bounds of the scalarization. */
3635 gfc_conv_ss_startstride (&loop
);
3637 /* Build an ss for the temporary. */
3638 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3639 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3641 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3642 if (GFC_ARRAY_TYPE_P (base_type
)
3643 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3644 base_type
= gfc_get_element_type (base_type
);
3646 if (expr
->ts
.type
== BT_CLASS
)
3647 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3649 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3650 ? expr
->ts
.u
.cl
->backend_decl
3654 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3656 /* Associate the SS with the loop. */
3657 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3659 /* Setup the scalarizing loops. */
3660 gfc_conv_loop_setup (&loop
, &expr
->where
);
3662 /* Pass the temporary descriptor back to the caller. */
3663 info
= &loop
.temp_ss
->info
->data
.array
;
3664 parmse
->expr
= info
->descriptor
;
3666 /* Setup the gfc_se structures. */
3667 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3668 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3671 lse
.ss
= loop
.temp_ss
;
3672 gfc_mark_ss_chain_used (rss
, 1);
3673 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3675 /* Start the scalarized loop body. */
3676 gfc_start_scalarized_body (&loop
, &body
);
3678 /* Translate the expression. */
3679 gfc_conv_expr (&rse
, expr
);
3681 gfc_conv_tmp_array_ref (&lse
);
3683 if (intent
!= INTENT_OUT
)
3685 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3686 gfc_add_expr_to_block (&body
, tmp
);
3687 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3688 gfc_trans_scalarizing_loops (&loop
, &body
);
3692 /* Make sure that the temporary declaration survives by merging
3693 all the loop declarations into the current context. */
3694 for (n
= 0; n
< loop
.dimen
; n
++)
3696 gfc_merge_block_scope (&body
);
3697 body
= loop
.code
[loop
.order
[n
]];
3699 gfc_merge_block_scope (&body
);
3702 /* Add the post block after the second loop, so that any
3703 freeing of allocated memory is done at the right time. */
3704 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3706 /**********Copy the temporary back again.*********/
3708 gfc_init_se (&lse
, NULL
);
3709 gfc_init_se (&rse
, NULL
);
3711 /* Walk the argument expression. */
3712 lss
= gfc_walk_expr (expr
);
3713 rse
.ss
= loop
.temp_ss
;
3716 /* Initialize the scalarizer. */
3717 gfc_init_loopinfo (&loop2
);
3718 gfc_add_ss_to_loop (&loop2
, lss
);
3720 /* Calculate the bounds of the scalarization. */
3721 gfc_conv_ss_startstride (&loop2
);
3723 /* Setup the scalarizing loops. */
3724 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3726 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3727 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3729 gfc_mark_ss_chain_used (lss
, 1);
3730 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3732 /* Declare the variable to hold the temporary offset and start the
3733 scalarized loop body. */
3734 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3735 gfc_start_scalarized_body (&loop2
, &body
);
3737 /* Build the offsets for the temporary from the loop variables. The
3738 temporary array has lbounds of zero and strides of one in all
3739 dimensions, so this is very simple. The offset is only computed
3740 outside the innermost loop, so the overall transfer could be
3741 optimized further. */
3742 info
= &rse
.ss
->info
->data
.array
;
3743 dimen
= rse
.ss
->dimen
;
3745 tmp_index
= gfc_index_zero_node
;
3746 for (n
= dimen
- 1; n
> 0; n
--)
3749 tmp
= rse
.loop
->loopvar
[n
];
3750 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3751 tmp
, rse
.loop
->from
[n
]);
3752 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3755 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3756 gfc_array_index_type
,
3757 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3758 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3759 gfc_array_index_type
,
3760 tmp_str
, gfc_index_one_node
);
3762 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3763 gfc_array_index_type
, tmp
, tmp_str
);
3766 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3767 gfc_array_index_type
,
3768 tmp_index
, rse
.loop
->from
[0]);
3769 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3771 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3772 gfc_array_index_type
,
3773 rse
.loop
->loopvar
[0], offset
);
3775 /* Now use the offset for the reference. */
3776 tmp
= build_fold_indirect_ref_loc (input_location
,
3778 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3780 if (expr
->ts
.type
== BT_CHARACTER
)
3781 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3783 gfc_conv_expr (&lse
, expr
);
3785 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3787 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3788 gfc_add_expr_to_block (&body
, tmp
);
3790 /* Generate the copying loops. */
3791 gfc_trans_scalarizing_loops (&loop2
, &body
);
3793 /* Wrap the whole thing up by adding the second loop to the post-block
3794 and following it by the post-block of the first loop. In this way,
3795 if the temporary needs freeing, it is done after use! */
3796 if (intent
!= INTENT_IN
)
3798 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3799 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3802 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3804 gfc_cleanup_loop (&loop
);
3805 gfc_cleanup_loop (&loop2
);
3807 /* Pass the string length to the argument expression. */
3808 if (expr
->ts
.type
== BT_CHARACTER
)
3809 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3811 /* Determine the offset for pointer formal arguments and set the
3815 size
= gfc_index_one_node
;
3816 offset
= gfc_index_zero_node
;
3817 for (n
= 0; n
< dimen
; n
++)
3819 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3821 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3822 gfc_array_index_type
, tmp
,
3823 gfc_index_one_node
);
3824 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3828 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3831 gfc_index_one_node
);
3832 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3833 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3834 gfc_array_index_type
,
3836 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3837 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3838 gfc_array_index_type
,
3839 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3840 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3841 gfc_array_index_type
,
3842 tmp
, gfc_index_one_node
);
3843 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3844 gfc_array_index_type
, size
, tmp
);
3847 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3851 /* We want either the address for the data or the address of the descriptor,
3852 depending on the mode of passing array arguments. */
3854 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3856 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3862 /* Generate the code for argument list functions. */
3865 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3867 /* Pass by value for g77 %VAL(arg), pass the address
3868 indirectly for %LOC, else by reference. Thus %REF
3869 is a "do-nothing" and %LOC is the same as an F95
3871 if (strncmp (name
, "%VAL", 4) == 0)
3872 gfc_conv_expr (se
, expr
);
3873 else if (strncmp (name
, "%LOC", 4) == 0)
3875 gfc_conv_expr_reference (se
, expr
);
3876 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3878 else if (strncmp (name
, "%REF", 4) == 0)
3879 gfc_conv_expr_reference (se
, expr
);
3881 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3885 /* Generate code for a procedure call. Note can return se->post != NULL.
3886 If se->direct_byref is set then se->expr contains the return parameter.
3887 Return nonzero, if the call has alternate specifiers.
3888 'expr' is only needed for procedure pointer components. */
3891 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3892 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3893 vec
<tree
, va_gc
> *append_args
)
3895 gfc_interface_mapping mapping
;
3896 vec
<tree
, va_gc
> *arglist
;
3897 vec
<tree
, va_gc
> *retargs
;
3901 gfc_array_info
*info
;
3908 vec
<tree
, va_gc
> *stringargs
;
3909 vec
<tree
, va_gc
> *optionalargs
;
3911 gfc_formal_arglist
*formal
;
3912 gfc_actual_arglist
*arg
;
3913 int has_alternate_specifier
= 0;
3914 bool need_interface_mapping
;
3921 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3922 gfc_component
*comp
= NULL
;
3928 optionalargs
= NULL
;
3933 comp
= gfc_get_proc_ptr_comp (expr
);
3937 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3939 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3940 if (se
->ss
->info
->useflags
)
3942 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3943 && sym
->result
->attr
.dimension
)
3944 || (comp
&& comp
->attr
.dimension
));
3945 gcc_assert (se
->loop
!= NULL
);
3947 /* Access the previously obtained result. */
3948 gfc_conv_tmp_array_ref (se
);
3952 info
= &se
->ss
->info
->data
.array
;
3957 gfc_init_block (&post
);
3958 gfc_init_interface_mapping (&mapping
);
3961 formal
= gfc_sym_get_dummy_args (sym
);
3962 need_interface_mapping
= sym
->attr
.dimension
||
3963 (sym
->ts
.type
== BT_CHARACTER
3964 && sym
->ts
.u
.cl
->length
3965 && sym
->ts
.u
.cl
->length
->expr_type
3970 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3971 need_interface_mapping
= comp
->attr
.dimension
||
3972 (comp
->ts
.type
== BT_CHARACTER
3973 && comp
->ts
.u
.cl
->length
3974 && comp
->ts
.u
.cl
->length
->expr_type
3978 base_object
= NULL_TREE
;
3980 /* Evaluate the arguments. */
3981 for (arg
= args
; arg
!= NULL
;
3982 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3985 fsym
= formal
? formal
->sym
: NULL
;
3986 parm_kind
= MISSING
;
3988 /* Class array expressions are sometimes coming completely unadorned
3989 with either arrayspec or _data component. Correct that here.
3990 OOP-TODO: Move this to the frontend. */
3991 if (e
&& e
->expr_type
== EXPR_VARIABLE
3993 && e
->ts
.type
== BT_CLASS
3994 && (CLASS_DATA (e
)->attr
.codimension
3995 || CLASS_DATA (e
)->attr
.dimension
))
3997 gfc_typespec temp_ts
= e
->ts
;
3998 gfc_add_class_array_ref (e
);
4004 if (se
->ignore_optional
)
4006 /* Some intrinsics have already been resolved to the correct
4010 else if (arg
->label
)
4012 has_alternate_specifier
= 1;
4017 gfc_init_se (&parmse
, NULL
);
4019 /* For scalar arguments with VALUE attribute which are passed by
4020 value, pass "0" and a hidden argument gives the optional
4022 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4023 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4024 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4026 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4028 vec_safe_push (optionalargs
, boolean_false_node
);
4032 /* Pass a NULL pointer for an absent arg. */
4033 parmse
.expr
= null_pointer_node
;
4034 if (arg
->missing_arg_type
== BT_CHARACTER
)
4035 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4040 else if (arg
->expr
->expr_type
== EXPR_NULL
4041 && fsym
&& !fsym
->attr
.pointer
4042 && (fsym
->ts
.type
!= BT_CLASS
4043 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4045 /* Pass a NULL pointer to denote an absent arg. */
4046 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4047 && (fsym
->ts
.type
!= BT_CLASS
4048 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4049 gfc_init_se (&parmse
, NULL
);
4050 parmse
.expr
= null_pointer_node
;
4051 if (arg
->missing_arg_type
== BT_CHARACTER
)
4052 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4054 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4055 && e
->ts
.type
== BT_DERIVED
)
4057 /* The derived type needs to be converted to a temporary
4059 gfc_init_se (&parmse
, se
);
4060 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4062 && e
->expr_type
== EXPR_VARIABLE
4063 && e
->symtree
->n
.sym
->attr
.optional
,
4064 CLASS_DATA (fsym
)->attr
.class_pointer
4065 || CLASS_DATA (fsym
)->attr
.allocatable
);
4067 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4069 /* The intrinsic type needs to be converted to a temporary
4070 CLASS object for the unlimited polymorphic formal. */
4071 gfc_init_se (&parmse
, se
);
4072 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4074 else if (se
->ss
&& se
->ss
->info
->useflags
)
4080 /* An elemental function inside a scalarized loop. */
4081 gfc_init_se (&parmse
, se
);
4082 parm_kind
= ELEMENTAL
;
4084 if (fsym
&& fsym
->attr
.value
)
4085 gfc_conv_expr (&parmse
, e
);
4087 gfc_conv_expr_reference (&parmse
, e
);
4089 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4090 && e
->expr_type
== EXPR_FUNCTION
)
4091 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4094 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4095 && gfc_is_class_container_ref (e
))
4097 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4099 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4100 && e
->symtree
->n
.sym
->attr
.optional
)
4102 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4103 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4104 TREE_TYPE (parmse
.expr
),
4106 fold_convert (TREE_TYPE (parmse
.expr
),
4107 null_pointer_node
));
4111 /* If we are passing an absent array as optional dummy to an
4112 elemental procedure, make sure that we pass NULL when the data
4113 pointer is NULL. We need this extra conditional because of
4114 scalarization which passes arrays elements to the procedure,
4115 ignoring the fact that the array can be absent/unallocated/... */
4116 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4118 tree descriptor_data
;
4120 descriptor_data
= ss
->info
->data
.array
.data
;
4121 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4123 fold_convert (TREE_TYPE (descriptor_data
),
4124 null_pointer_node
));
4126 = fold_build3_loc (input_location
, COND_EXPR
,
4127 TREE_TYPE (parmse
.expr
),
4128 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4129 fold_convert (TREE_TYPE (parmse
.expr
),
4134 /* The scalarizer does not repackage the reference to a class
4135 array - instead it returns a pointer to the data element. */
4136 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4137 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4138 fsym
->attr
.intent
!= INTENT_IN
4139 && (CLASS_DATA (fsym
)->attr
.class_pointer
4140 || CLASS_DATA (fsym
)->attr
.allocatable
),
4142 && e
->expr_type
== EXPR_VARIABLE
4143 && e
->symtree
->n
.sym
->attr
.optional
,
4144 CLASS_DATA (fsym
)->attr
.class_pointer
4145 || CLASS_DATA (fsym
)->attr
.allocatable
);
4152 gfc_init_se (&parmse
, NULL
);
4154 /* Check whether the expression is a scalar or not; we cannot use
4155 e->rank as it can be nonzero for functions arguments. */
4156 argss
= gfc_walk_expr (e
);
4157 scalar
= argss
== gfc_ss_terminator
;
4159 gfc_free_ss_chain (argss
);
4161 /* Special handling for passing scalar polymorphic coarrays;
4162 otherwise one passes "class->_data.data" instead of "&class". */
4163 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4164 && fsym
&& fsym
->ts
.type
== BT_CLASS
4165 && CLASS_DATA (fsym
)->attr
.codimension
4166 && !CLASS_DATA (fsym
)->attr
.dimension
)
4168 gfc_add_class_array_ref (e
);
4169 parmse
.want_coarray
= 1;
4173 /* A scalar or transformational function. */
4176 if (e
->expr_type
== EXPR_VARIABLE
4177 && e
->symtree
->n
.sym
->attr
.cray_pointee
4178 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4180 /* The Cray pointer needs to be converted to a pointer to
4181 a type given by the expression. */
4182 gfc_conv_expr (&parmse
, e
);
4183 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4184 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4185 parmse
.expr
= convert (type
, tmp
);
4187 else if (fsym
&& fsym
->attr
.value
)
4189 if (fsym
->ts
.type
== BT_CHARACTER
4190 && fsym
->ts
.is_c_interop
4191 && fsym
->ns
->proc_name
!= NULL
4192 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4195 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4196 if (parmse
.expr
== NULL
)
4197 gfc_conv_expr (&parmse
, e
);
4201 gfc_conv_expr (&parmse
, e
);
4202 if (fsym
->attr
.optional
4203 && fsym
->ts
.type
!= BT_CLASS
4204 && fsym
->ts
.type
!= BT_DERIVED
)
4206 if (e
->expr_type
!= EXPR_VARIABLE
4207 || !e
->symtree
->n
.sym
->attr
.optional
4209 vec_safe_push (optionalargs
, boolean_true_node
);
4212 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4213 if (!e
->symtree
->n
.sym
->attr
.value
)
4215 = fold_build3_loc (input_location
, COND_EXPR
,
4216 TREE_TYPE (parmse
.expr
),
4218 fold_convert (TREE_TYPE (parmse
.expr
),
4219 integer_zero_node
));
4221 vec_safe_push (optionalargs
, tmp
);
4226 else if (arg
->name
&& arg
->name
[0] == '%')
4227 /* Argument list functions %VAL, %LOC and %REF are signalled
4228 through arg->name. */
4229 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4230 else if ((e
->expr_type
== EXPR_FUNCTION
)
4231 && ((e
->value
.function
.esym
4232 && e
->value
.function
.esym
->result
->attr
.pointer
)
4233 || (!e
->value
.function
.esym
4234 && e
->symtree
->n
.sym
->attr
.pointer
))
4235 && fsym
&& fsym
->attr
.target
)
4237 gfc_conv_expr (&parmse
, e
);
4238 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4240 else if (e
->expr_type
== EXPR_FUNCTION
4241 && e
->symtree
->n
.sym
->result
4242 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4243 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4245 /* Functions returning procedure pointers. */
4246 gfc_conv_expr (&parmse
, e
);
4247 if (fsym
&& fsym
->attr
.proc_pointer
)
4248 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4252 if (e
->ts
.type
== BT_CLASS
&& fsym
4253 && fsym
->ts
.type
== BT_CLASS
4254 && (!CLASS_DATA (fsym
)->as
4255 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4256 && CLASS_DATA (e
)->attr
.codimension
)
4258 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4259 gcc_assert (!CLASS_DATA (fsym
)->as
);
4260 gfc_add_class_array_ref (e
);
4261 parmse
.want_coarray
= 1;
4262 gfc_conv_expr_reference (&parmse
, e
);
4263 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4265 && e
->expr_type
== EXPR_VARIABLE
);
4268 gfc_conv_expr_reference (&parmse
, e
);
4270 /* Catch base objects that are not variables. */
4271 if (e
->ts
.type
== BT_CLASS
4272 && e
->expr_type
!= EXPR_VARIABLE
4273 && expr
&& e
== expr
->base_expr
)
4274 base_object
= build_fold_indirect_ref_loc (input_location
,
4277 /* A class array element needs converting back to be a
4278 class object, if the formal argument is a class object. */
4279 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4280 && e
->ts
.type
== BT_CLASS
4281 && ((CLASS_DATA (fsym
)->as
4282 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4283 || CLASS_DATA (e
)->attr
.dimension
))
4284 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4285 fsym
->attr
.intent
!= INTENT_IN
4286 && (CLASS_DATA (fsym
)->attr
.class_pointer
4287 || CLASS_DATA (fsym
)->attr
.allocatable
),
4289 && e
->expr_type
== EXPR_VARIABLE
4290 && e
->symtree
->n
.sym
->attr
.optional
,
4291 CLASS_DATA (fsym
)->attr
.class_pointer
4292 || CLASS_DATA (fsym
)->attr
.allocatable
);
4294 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4295 allocated on entry, it must be deallocated. */
4296 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4297 && (fsym
->attr
.allocatable
4298 || (fsym
->ts
.type
== BT_CLASS
4299 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4304 gfc_init_block (&block
);
4306 if (e
->ts
.type
== BT_CLASS
)
4307 ptr
= gfc_class_data_get (ptr
);
4309 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4311 gfc_add_expr_to_block (&block
, tmp
);
4312 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4313 void_type_node
, ptr
,
4315 gfc_add_expr_to_block (&block
, tmp
);
4317 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4319 gfc_add_modify (&block
, ptr
,
4320 fold_convert (TREE_TYPE (ptr
),
4321 null_pointer_node
));
4322 gfc_add_expr_to_block (&block
, tmp
);
4324 else if (fsym
->ts
.type
== BT_CLASS
)
4327 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4328 tmp
= gfc_get_symbol_decl (vtab
);
4329 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4330 ptr
= gfc_class_vptr_get (parmse
.expr
);
4331 gfc_add_modify (&block
, ptr
,
4332 fold_convert (TREE_TYPE (ptr
), tmp
));
4333 gfc_add_expr_to_block (&block
, tmp
);
4336 if (fsym
->attr
.optional
4337 && e
->expr_type
== EXPR_VARIABLE
4338 && e
->symtree
->n
.sym
->attr
.optional
)
4340 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4342 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4343 gfc_finish_block (&block
),
4344 build_empty_stmt (input_location
));
4347 tmp
= gfc_finish_block (&block
);
4349 gfc_add_expr_to_block (&se
->pre
, tmp
);
4352 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4353 || fsym
->ts
.type
== BT_ASSUMED
)
4354 && e
->ts
.type
== BT_CLASS
4355 && !CLASS_DATA (e
)->attr
.dimension
4356 && !CLASS_DATA (e
)->attr
.codimension
)
4357 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4359 /* Wrap scalar variable in a descriptor. We need to convert
4360 the address of a pointer back to the pointer itself before,
4361 we can assign it to the data field. */
4363 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4364 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4367 if (TREE_CODE (tmp
) == ADDR_EXPR
4368 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4369 tmp
= TREE_OPERAND (tmp
, 0);
4370 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4372 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4375 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4376 && ((fsym
->attr
.pointer
4377 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4378 || (fsym
->attr
.proc_pointer
4379 && !(e
->expr_type
== EXPR_VARIABLE
4380 && e
->symtree
->n
.sym
->attr
.dummy
))
4381 || (fsym
->attr
.proc_pointer
4382 && e
->expr_type
== EXPR_VARIABLE
4383 && gfc_is_proc_ptr_comp (e
))
4384 || (fsym
->attr
.allocatable
4385 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4387 /* Scalar pointer dummy args require an extra level of
4388 indirection. The null pointer already contains
4389 this level of indirection. */
4390 parm_kind
= SCALAR_POINTER
;
4391 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4395 else if (e
->ts
.type
== BT_CLASS
4396 && fsym
&& fsym
->ts
.type
== BT_CLASS
4397 && (CLASS_DATA (fsym
)->attr
.dimension
4398 || CLASS_DATA (fsym
)->attr
.codimension
))
4400 /* Pass a class array. */
4401 parmse
.use_offset
= 1;
4402 gfc_conv_expr_descriptor (&parmse
, e
);
4404 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4405 allocated on entry, it must be deallocated. */
4406 if (fsym
->attr
.intent
== INTENT_OUT
4407 && CLASS_DATA (fsym
)->attr
.allocatable
)
4412 gfc_init_block (&block
);
4414 ptr
= gfc_class_data_get (ptr
);
4416 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4417 NULL_TREE
, NULL_TREE
,
4420 gfc_add_expr_to_block (&block
, tmp
);
4421 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4422 void_type_node
, ptr
,
4424 gfc_add_expr_to_block (&block
, tmp
);
4425 gfc_reset_vptr (&block
, e
);
4427 if (fsym
->attr
.optional
4428 && e
->expr_type
== EXPR_VARIABLE
4430 || (e
->ref
->type
== REF_ARRAY
4431 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4432 && e
->symtree
->n
.sym
->attr
.optional
)
4434 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4436 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4437 gfc_finish_block (&block
),
4438 build_empty_stmt (input_location
));
4441 tmp
= gfc_finish_block (&block
);
4443 gfc_add_expr_to_block (&se
->pre
, tmp
);
4446 /* The conversion does not repackage the reference to a class
4447 array - _data descriptor. */
4448 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4449 fsym
->attr
.intent
!= INTENT_IN
4450 && (CLASS_DATA (fsym
)->attr
.class_pointer
4451 || CLASS_DATA (fsym
)->attr
.allocatable
),
4453 && e
->expr_type
== EXPR_VARIABLE
4454 && e
->symtree
->n
.sym
->attr
.optional
,
4455 CLASS_DATA (fsym
)->attr
.class_pointer
4456 || CLASS_DATA (fsym
)->attr
.allocatable
);
4460 /* If the procedure requires an explicit interface, the actual
4461 argument is passed according to the corresponding formal
4462 argument. If the corresponding formal argument is a POINTER,
4463 ALLOCATABLE or assumed shape, we do not use g77's calling
4464 convention, and pass the address of the array descriptor
4465 instead. Otherwise we use g77's calling convention. */
4468 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4469 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4470 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4472 f
= f
|| !comp
->attr
.always_explicit
;
4474 f
= f
|| !sym
->attr
.always_explicit
;
4476 /* If the argument is a function call that may not create
4477 a temporary for the result, we have to check that we
4478 can do it, i.e. that there is no alias between this
4479 argument and another one. */
4480 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4486 intent
= fsym
->attr
.intent
;
4488 intent
= INTENT_UNKNOWN
;
4490 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4492 parmse
.force_tmp
= 1;
4494 iarg
= e
->value
.function
.actual
->expr
;
4496 /* Temporary needed if aliasing due to host association. */
4497 if (sym
->attr
.contained
4499 && !sym
->attr
.implicit_pure
4500 && !sym
->attr
.use_assoc
4501 && iarg
->expr_type
== EXPR_VARIABLE
4502 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4503 parmse
.force_tmp
= 1;
4505 /* Ditto within module. */
4506 if (sym
->attr
.use_assoc
4508 && !sym
->attr
.implicit_pure
4509 && iarg
->expr_type
== EXPR_VARIABLE
4510 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4511 parmse
.force_tmp
= 1;
4514 if (e
->expr_type
== EXPR_VARIABLE
4515 && is_subref_array (e
))
4516 /* The actual argument is a component reference to an
4517 array of derived types. In this case, the argument
4518 is converted to a temporary, which is passed and then
4519 written back after the procedure call. */
4520 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4521 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4522 fsym
&& fsym
->attr
.pointer
);
4523 else if (gfc_is_class_array_ref (e
, NULL
)
4524 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4525 /* The actual argument is a component reference to an
4526 array of derived types. In this case, the argument
4527 is converted to a temporary, which is passed and then
4528 written back after the procedure call.
4529 OOP-TODO: Insert code so that if the dynamic type is
4530 the same as the declared type, copy-in/copy-out does
4532 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4533 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4534 fsym
&& fsym
->attr
.pointer
);
4536 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4538 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4539 allocated on entry, it must be deallocated. */
4540 if (fsym
&& fsym
->attr
.allocatable
4541 && fsym
->attr
.intent
== INTENT_OUT
)
4543 tmp
= build_fold_indirect_ref_loc (input_location
,
4545 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4546 if (fsym
->attr
.optional
4547 && e
->expr_type
== EXPR_VARIABLE
4548 && e
->symtree
->n
.sym
->attr
.optional
)
4549 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4551 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4552 tmp
, build_empty_stmt (input_location
));
4553 gfc_add_expr_to_block (&se
->pre
, tmp
);
4558 /* The case with fsym->attr.optional is that of a user subroutine
4559 with an interface indicating an optional argument. When we call
4560 an intrinsic subroutine, however, fsym is NULL, but we might still
4561 have an optional argument, so we proceed to the substitution
4563 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4565 /* If an optional argument is itself an optional dummy argument,
4566 check its presence and substitute a null if absent. This is
4567 only needed when passing an array to an elemental procedure
4568 as then array elements are accessed - or no NULL pointer is
4569 allowed and a "1" or "0" should be passed if not present.
4570 When passing a non-array-descriptor full array to a
4571 non-array-descriptor dummy, no check is needed. For
4572 array-descriptor actual to array-descriptor dummy, see
4573 PR 41911 for why a check has to be inserted.
4574 fsym == NULL is checked as intrinsics required the descriptor
4575 but do not always set fsym. */
4576 if (e
->expr_type
== EXPR_VARIABLE
4577 && e
->symtree
->n
.sym
->attr
.optional
4578 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4579 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4583 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4584 || fsym
->as
->type
== AS_ASSUMED_RANK
4585 || fsym
->as
->type
== AS_DEFERRED
))))))
4586 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4587 e
->representation
.length
);
4592 /* Obtain the character length of an assumed character length
4593 length procedure from the typespec. */
4594 if (fsym
->ts
.type
== BT_CHARACTER
4595 && parmse
.string_length
== NULL_TREE
4596 && e
->ts
.type
== BT_PROCEDURE
4597 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4598 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4599 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4601 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4602 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4606 if (fsym
&& need_interface_mapping
&& e
)
4607 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4609 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4610 gfc_add_block_to_block (&post
, &parmse
.post
);
4612 /* Allocated allocatable components of derived types must be
4613 deallocated for non-variable scalars. Non-variable arrays are
4614 dealt with in trans-array.c(gfc_conv_array_parameter). */
4615 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4616 && e
->ts
.u
.derived
->attr
.alloc_comp
4617 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4618 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4621 tmp
= build_fold_indirect_ref_loc (input_location
,
4623 parm_rank
= e
->rank
;
4631 case (SCALAR_POINTER
):
4632 tmp
= build_fold_indirect_ref_loc (input_location
,
4637 if (e
->expr_type
== EXPR_OP
4638 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4639 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4642 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4643 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4644 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4647 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4649 /* The derived type is passed to gfc_deallocate_alloc_comp.
4650 Therefore, class actuals can handled correctly but derived
4651 types passed to class formals need the _data component. */
4652 tmp
= gfc_class_data_get (tmp
);
4653 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4654 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4657 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4659 gfc_add_expr_to_block (&se
->post
, tmp
);
4662 /* Add argument checking of passing an unallocated/NULL actual to
4663 a nonallocatable/nonpointer dummy. */
4665 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4667 symbol_attribute attr
;
4671 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4672 attr
= gfc_expr_attr (e
);
4674 goto end_pointer_check
;
4676 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4677 allocatable to an optional dummy, cf. 12.5.2.12. */
4678 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4679 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4680 goto end_pointer_check
;
4684 /* If the actual argument is an optional pointer/allocatable and
4685 the formal argument takes an nonpointer optional value,
4686 it is invalid to pass a non-present argument on, even
4687 though there is no technical reason for this in gfortran.
4688 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4689 tree present
, null_ptr
, type
;
4691 if (attr
.allocatable
4692 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4693 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4694 "allocated or not present", e
->symtree
->n
.sym
->name
);
4695 else if (attr
.pointer
4696 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4697 asprintf (&msg
, "Pointer actual argument '%s' is not "
4698 "associated or not present",
4699 e
->symtree
->n
.sym
->name
);
4700 else if (attr
.proc_pointer
4701 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4702 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4703 "associated or not present",
4704 e
->symtree
->n
.sym
->name
);
4706 goto end_pointer_check
;
4708 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4709 type
= TREE_TYPE (present
);
4710 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4711 boolean_type_node
, present
,
4713 null_pointer_node
));
4714 type
= TREE_TYPE (parmse
.expr
);
4715 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4716 boolean_type_node
, parmse
.expr
,
4718 null_pointer_node
));
4719 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4720 boolean_type_node
, present
, null_ptr
);
4724 if (attr
.allocatable
4725 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4726 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4727 "allocated", e
->symtree
->n
.sym
->name
);
4728 else if (attr
.pointer
4729 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4730 asprintf (&msg
, "Pointer actual argument '%s' is not "
4731 "associated", e
->symtree
->n
.sym
->name
);
4732 else if (attr
.proc_pointer
4733 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4734 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4735 "associated", e
->symtree
->n
.sym
->name
);
4737 goto end_pointer_check
;
4741 /* If the argument is passed by value, we need to strip the
4743 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4744 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4746 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4747 boolean_type_node
, tmp
,
4748 fold_convert (TREE_TYPE (tmp
),
4749 null_pointer_node
));
4752 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4758 /* Deferred length dummies pass the character length by reference
4759 so that the value can be returned. */
4760 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4762 tmp
= parmse
.string_length
;
4763 if (TREE_CODE (tmp
) != VAR_DECL
)
4764 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4765 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4768 /* Character strings are passed as two parameters, a length and a
4769 pointer - except for Bind(c) which only passes the pointer.
4770 An unlimited polymorphic formal argument likewise does not
4772 if (parmse
.string_length
!= NULL_TREE
4773 && !sym
->attr
.is_bind_c
4774 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4775 vec_safe_push (stringargs
, parmse
.string_length
);
4777 /* When calling __copy for character expressions to unlimited
4778 polymorphic entities, the dst argument needs a string length. */
4779 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4780 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4781 && arg
->next
&& arg
->next
->expr
4782 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4783 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4784 vec_safe_push (stringargs
, parmse
.string_length
);
4786 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4787 pass the token and the offset as additional arguments. */
4788 if (fsym
&& e
== NULL
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4789 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4790 && !fsym
->attr
.allocatable
)
4791 || (fsym
->ts
.type
== BT_CLASS
4792 && CLASS_DATA (fsym
)->attr
.codimension
4793 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4795 /* Token and offset. */
4796 vec_safe_push (stringargs
, null_pointer_node
);
4797 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4798 gcc_assert (fsym
->attr
.optional
);
4800 else if (fsym
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4801 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4802 && !fsym
->attr
.allocatable
)
4803 || (fsym
->ts
.type
== BT_CLASS
4804 && CLASS_DATA (fsym
)->attr
.codimension
4805 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4807 tree caf_decl
, caf_type
;
4810 caf_decl
= get_tree_for_caf_expr (e
);
4811 caf_type
= TREE_TYPE (caf_decl
);
4813 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4814 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4815 tmp
= gfc_conv_descriptor_token (caf_decl
);
4816 else if (DECL_LANG_SPECIFIC (caf_decl
)
4817 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4818 tmp
= GFC_DECL_TOKEN (caf_decl
);
4821 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4822 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4823 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4826 vec_safe_push (stringargs
, tmp
);
4828 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4829 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4830 offset
= build_int_cst (gfc_array_index_type
, 0);
4831 else if (DECL_LANG_SPECIFIC (caf_decl
)
4832 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4833 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4834 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4835 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4837 offset
= build_int_cst (gfc_array_index_type
, 0);
4839 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4840 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4843 gcc_assert (POINTER_TYPE_P (caf_type
));
4847 tmp2
= fsym
->ts
.type
== BT_CLASS
4848 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
4849 if ((fsym
->ts
.type
!= BT_CLASS
4850 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4851 || fsym
->as
->type
== AS_ASSUMED_RANK
))
4852 || (fsym
->ts
.type
== BT_CLASS
4853 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
4854 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
4856 if (fsym
->ts
.type
== BT_CLASS
)
4857 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4860 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4861 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
4863 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
4864 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4866 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
4867 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4870 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4873 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4874 gfc_array_index_type
,
4875 fold_convert (gfc_array_index_type
, tmp2
),
4876 fold_convert (gfc_array_index_type
, tmp
));
4877 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4878 gfc_array_index_type
, offset
, tmp
);
4880 vec_safe_push (stringargs
, offset
);
4883 vec_safe_push (arglist
, parmse
.expr
);
4885 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4892 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4893 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4894 else if (ts
.type
== BT_CHARACTER
)
4896 if (ts
.u
.cl
->length
== NULL
)
4898 /* Assumed character length results are not allowed by 5.1.1.5 of the
4899 standard and are trapped in resolve.c; except in the case of SPREAD
4900 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4901 we take the character length of the first argument for the result.
4902 For dummies, we have to look through the formal argument list for
4903 this function and use the character length found there.*/
4905 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4906 else if (!sym
->attr
.dummy
)
4907 cl
.backend_decl
= (*stringargs
)[0];
4910 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4911 for (; formal
; formal
= formal
->next
)
4912 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4913 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4915 len
= cl
.backend_decl
;
4921 /* Calculate the length of the returned string. */
4922 gfc_init_se (&parmse
, NULL
);
4923 if (need_interface_mapping
)
4924 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4926 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4927 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4928 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4930 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4931 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4932 gfc_charlen_type_node
, tmp
,
4933 build_int_cst (gfc_charlen_type_node
, 0));
4934 cl
.backend_decl
= tmp
;
4937 /* Set up a charlen structure for it. */
4942 len
= cl
.backend_decl
;
4945 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4946 || (!comp
&& gfc_return_by_reference (sym
));
4949 if (se
->direct_byref
)
4951 /* Sometimes, too much indirection can be applied; e.g. for
4952 function_result = array_valued_recursive_function. */
4953 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4954 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4955 && GFC_DESCRIPTOR_TYPE_P
4956 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4957 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4960 /* If the lhs of an assignment x = f(..) is allocatable and
4961 f2003 is allowed, we must do the automatic reallocation.
4962 TODO - deal with intrinsics, without using a temporary. */
4963 if (gfc_option
.flag_realloc_lhs
4964 && se
->ss
&& se
->ss
->loop_chain
4965 && se
->ss
->loop_chain
->is_alloc_lhs
4966 && !expr
->value
.function
.isym
4967 && sym
->result
->as
!= NULL
)
4969 /* Evaluate the bounds of the result, if known. */
4970 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4973 /* Perform the automatic reallocation. */
4974 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4976 gfc_add_expr_to_block (&se
->pre
, tmp
);
4978 /* Pass the temporary as the first argument. */
4979 result
= info
->descriptor
;
4982 result
= build_fold_indirect_ref_loc (input_location
,
4984 vec_safe_push (retargs
, se
->expr
);
4986 else if (comp
&& comp
->attr
.dimension
)
4988 gcc_assert (se
->loop
&& info
);
4990 /* Set the type of the array. */
4991 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4992 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4994 /* Evaluate the bounds of the result, if known. */
4995 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4997 /* If the lhs of an assignment x = f(..) is allocatable and
4998 f2003 is allowed, we must not generate the function call
4999 here but should just send back the results of the mapping.
5000 This is signalled by the function ss being flagged. */
5001 if (gfc_option
.flag_realloc_lhs
5002 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5004 gfc_free_interface_mapping (&mapping
);
5005 return has_alternate_specifier
;
5008 /* Create a temporary to store the result. In case the function
5009 returns a pointer, the temporary will be a shallow copy and
5010 mustn't be deallocated. */
5011 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5012 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5013 tmp
, NULL_TREE
, false,
5014 !comp
->attr
.pointer
, callee_alloc
,
5015 &se
->ss
->info
->expr
->where
);
5017 /* Pass the temporary as the first argument. */
5018 result
= info
->descriptor
;
5019 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5020 vec_safe_push (retargs
, tmp
);
5022 else if (!comp
&& sym
->result
->attr
.dimension
)
5024 gcc_assert (se
->loop
&& info
);
5026 /* Set the type of the array. */
5027 tmp
= gfc_typenode_for_spec (&ts
);
5028 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5030 /* Evaluate the bounds of the result, if known. */
5031 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5033 /* If the lhs of an assignment x = f(..) is allocatable and
5034 f2003 is allowed, we must not generate the function call
5035 here but should just send back the results of the mapping.
5036 This is signalled by the function ss being flagged. */
5037 if (gfc_option
.flag_realloc_lhs
5038 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5040 gfc_free_interface_mapping (&mapping
);
5041 return has_alternate_specifier
;
5044 /* Create a temporary to store the result. In case the function
5045 returns a pointer, the temporary will be a shallow copy and
5046 mustn't be deallocated. */
5047 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5048 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5049 tmp
, NULL_TREE
, false,
5050 !sym
->attr
.pointer
, callee_alloc
,
5051 &se
->ss
->info
->expr
->where
);
5053 /* Pass the temporary as the first argument. */
5054 result
= info
->descriptor
;
5055 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5056 vec_safe_push (retargs
, tmp
);
5058 else if (ts
.type
== BT_CHARACTER
)
5060 /* Pass the string length. */
5061 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5062 type
= build_pointer_type (type
);
5064 /* Return an address to a char[0:len-1]* temporary for
5065 character pointers. */
5066 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5067 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5069 var
= gfc_create_var (type
, "pstr");
5071 if ((!comp
&& sym
->attr
.allocatable
)
5072 || (comp
&& comp
->attr
.allocatable
))
5074 gfc_add_modify (&se
->pre
, var
,
5075 fold_convert (TREE_TYPE (var
),
5076 null_pointer_node
));
5077 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5078 gfc_add_expr_to_block (&se
->post
, tmp
);
5081 /* Provide an address expression for the function arguments. */
5082 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5085 var
= gfc_conv_string_tmp (se
, type
, len
);
5087 vec_safe_push (retargs
, var
);
5091 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5093 type
= gfc_get_complex_type (ts
.kind
);
5094 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5095 vec_safe_push (retargs
, var
);
5098 /* Add the string length to the argument list. */
5099 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5102 if (TREE_CODE (tmp
) != VAR_DECL
)
5103 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5104 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5105 vec_safe_push (retargs
, tmp
);
5107 else if (ts
.type
== BT_CHARACTER
)
5108 vec_safe_push (retargs
, len
);
5110 gfc_free_interface_mapping (&mapping
);
5112 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5113 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5114 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5115 vec_safe_reserve (retargs
, arglen
);
5117 /* Add the return arguments. */
5118 retargs
->splice (arglist
);
5120 /* Add the hidden present status for optional+value to the arguments. */
5121 retargs
->splice (optionalargs
);
5123 /* Add the hidden string length parameters to the arguments. */
5124 retargs
->splice (stringargs
);
5126 /* We may want to append extra arguments here. This is used e.g. for
5127 calls to libgfortran_matmul_??, which need extra information. */
5128 if (!vec_safe_is_empty (append_args
))
5129 retargs
->splice (append_args
);
5132 /* Generate the actual call. */
5133 if (base_object
== NULL_TREE
)
5134 conv_function_val (se
, sym
, expr
);
5136 conv_base_obj_fcn_val (se
, base_object
, expr
);
5138 /* If there are alternate return labels, function type should be
5139 integer. Can't modify the type in place though, since it can be shared
5140 with other functions. For dummy arguments, the typing is done to
5141 this result, even if it has to be repeated for each call. */
5142 if (has_alternate_specifier
5143 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5145 if (!sym
->attr
.dummy
)
5147 TREE_TYPE (sym
->backend_decl
)
5148 = build_function_type (integer_type_node
,
5149 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5150 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5153 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5156 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5157 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5159 /* If we have a pointer function, but we don't want a pointer, e.g.
5162 where f is pointer valued, we have to dereference the result. */
5163 if (!se
->want_pointer
&& !byref
5164 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5165 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5166 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5168 /* f2c calling conventions require a scalar default real function to
5169 return a double precision result. Convert this back to default
5170 real. We only care about the cases that can happen in Fortran 77.
5172 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5173 && sym
->ts
.kind
== gfc_default_real_kind
5174 && !sym
->attr
.always_explicit
)
5175 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5177 /* A pure function may still have side-effects - it may modify its
5179 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5181 if (!sym
->attr
.pure
)
5182 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5187 /* Add the function call to the pre chain. There is no expression. */
5188 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5189 se
->expr
= NULL_TREE
;
5191 if (!se
->direct_byref
)
5193 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5195 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5197 /* Check the data pointer hasn't been modified. This would
5198 happen in a function returning a pointer. */
5199 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5200 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5203 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5206 se
->expr
= info
->descriptor
;
5207 /* Bundle in the string length. */
5208 se
->string_length
= len
;
5210 else if (ts
.type
== BT_CHARACTER
)
5212 /* Dereference for character pointer results. */
5213 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5214 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5215 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5219 se
->string_length
= len
;
5223 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5224 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5229 /* Follow the function call with the argument post block. */
5232 gfc_add_block_to_block (&se
->pre
, &post
);
5234 /* Transformational functions of derived types with allocatable
5235 components must have the result allocatable components copied. */
5236 arg
= expr
->value
.function
.actual
;
5237 if (result
&& arg
&& expr
->rank
5238 && expr
->value
.function
.isym
5239 && expr
->value
.function
.isym
->transformational
5240 && arg
->expr
->ts
.type
== BT_DERIVED
5241 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5244 /* Copy the allocatable components. We have to use a
5245 temporary here to prevent source allocatable components
5246 from being corrupted. */
5247 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5248 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5249 result
, tmp2
, expr
->rank
);
5250 gfc_add_expr_to_block (&se
->pre
, tmp
);
5251 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5253 gfc_add_expr_to_block (&se
->pre
, tmp
);
5255 /* Finally free the temporary's data field. */
5256 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5257 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5258 NULL_TREE
, NULL_TREE
, true,
5260 gfc_add_expr_to_block (&se
->pre
, tmp
);
5264 gfc_add_block_to_block (&se
->post
, &post
);
5266 return has_alternate_specifier
;
5270 /* Fill a character string with spaces. */
5273 fill_with_spaces (tree start
, tree type
, tree size
)
5275 stmtblock_t block
, loop
;
5276 tree i
, el
, exit_label
, cond
, tmp
;
5278 /* For a simple char type, we can call memset(). */
5279 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5280 return build_call_expr_loc (input_location
,
5281 builtin_decl_explicit (BUILT_IN_MEMSET
),
5283 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5284 lang_hooks
.to_target_charset (' ')),
5287 /* Otherwise, we use a loop:
5288 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5292 /* Initialize variables. */
5293 gfc_init_block (&block
);
5294 i
= gfc_create_var (sizetype
, "i");
5295 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5296 el
= gfc_create_var (build_pointer_type (type
), "el");
5297 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5298 exit_label
= gfc_build_label_decl (NULL_TREE
);
5299 TREE_USED (exit_label
) = 1;
5303 gfc_init_block (&loop
);
5305 /* Exit condition. */
5306 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5307 build_zero_cst (sizetype
));
5308 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5309 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5310 build_empty_stmt (input_location
));
5311 gfc_add_expr_to_block (&loop
, tmp
);
5314 gfc_add_modify (&loop
,
5315 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5316 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5318 /* Increment loop variables. */
5319 gfc_add_modify (&loop
, i
,
5320 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5321 TYPE_SIZE_UNIT (type
)));
5322 gfc_add_modify (&loop
, el
,
5323 fold_build_pointer_plus_loc (input_location
,
5324 el
, TYPE_SIZE_UNIT (type
)));
5326 /* Making the loop... actually loop! */
5327 tmp
= gfc_finish_block (&loop
);
5328 tmp
= build1_v (LOOP_EXPR
, tmp
);
5329 gfc_add_expr_to_block (&block
, tmp
);
5331 /* The exit label. */
5332 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5333 gfc_add_expr_to_block (&block
, tmp
);
5336 return gfc_finish_block (&block
);
5340 /* Generate code to copy a string. */
5343 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5344 int dkind
, tree slength
, tree src
, int skind
)
5346 tree tmp
, dlen
, slen
;
5355 stmtblock_t tempblock
;
5357 gcc_assert (dkind
== skind
);
5359 if (slength
!= NULL_TREE
)
5361 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5362 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5366 slen
= build_int_cst (size_type_node
, 1);
5370 if (dlength
!= NULL_TREE
)
5372 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5373 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5377 dlen
= build_int_cst (size_type_node
, 1);
5381 /* Assign directly if the types are compatible. */
5382 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5383 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5385 gfc_add_modify (block
, dsc
, ssc
);
5389 /* Do nothing if the destination length is zero. */
5390 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5391 build_int_cst (size_type_node
, 0));
5393 /* The following code was previously in _gfortran_copy_string:
5395 // The two strings may overlap so we use memmove.
5397 copy_string (GFC_INTEGER_4 destlen, char * dest,
5398 GFC_INTEGER_4 srclen, const char * src)
5400 if (srclen >= destlen)
5402 // This will truncate if too long.
5403 memmove (dest, src, destlen);
5407 memmove (dest, src, srclen);
5409 memset (&dest[srclen], ' ', destlen - srclen);
5413 We're now doing it here for better optimization, but the logic
5416 /* For non-default character kinds, we have to multiply the string
5417 length by the base type size. */
5418 chartype
= gfc_get_char_type (dkind
);
5419 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5420 fold_convert (size_type_node
, slen
),
5421 fold_convert (size_type_node
,
5422 TYPE_SIZE_UNIT (chartype
)));
5423 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5424 fold_convert (size_type_node
, dlen
),
5425 fold_convert (size_type_node
,
5426 TYPE_SIZE_UNIT (chartype
)));
5428 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5429 dest
= fold_convert (pvoid_type_node
, dest
);
5431 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5433 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5434 src
= fold_convert (pvoid_type_node
, src
);
5436 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5438 /* Truncate string if source is too long. */
5439 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5441 tmp2
= build_call_expr_loc (input_location
,
5442 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5443 3, dest
, src
, dlen
);
5445 /* Else copy and pad with spaces. */
5446 tmp3
= build_call_expr_loc (input_location
,
5447 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5448 3, dest
, src
, slen
);
5450 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5451 tmp4
= fill_with_spaces (tmp4
, chartype
,
5452 fold_build2_loc (input_location
, MINUS_EXPR
,
5453 TREE_TYPE(dlen
), dlen
, slen
));
5455 gfc_init_block (&tempblock
);
5456 gfc_add_expr_to_block (&tempblock
, tmp3
);
5457 gfc_add_expr_to_block (&tempblock
, tmp4
);
5458 tmp3
= gfc_finish_block (&tempblock
);
5460 /* The whole copy_string function is there. */
5461 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5463 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5464 build_empty_stmt (input_location
));
5465 gfc_add_expr_to_block (block
, tmp
);
5469 /* Translate a statement function.
5470 The value of a statement function reference is obtained by evaluating the
5471 expression using the values of the actual arguments for the values of the
5472 corresponding dummy arguments. */
5475 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5479 gfc_formal_arglist
*fargs
;
5480 gfc_actual_arglist
*args
;
5483 gfc_saved_var
*saved_vars
;
5489 sym
= expr
->symtree
->n
.sym
;
5490 args
= expr
->value
.function
.actual
;
5491 gfc_init_se (&lse
, NULL
);
5492 gfc_init_se (&rse
, NULL
);
5495 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5497 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5498 temp_vars
= XCNEWVEC (tree
, n
);
5500 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5501 fargs
= fargs
->next
, n
++)
5503 /* Each dummy shall be specified, explicitly or implicitly, to be
5505 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5508 if (fsym
->ts
.type
== BT_CHARACTER
)
5510 /* Copy string arguments. */
5513 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5514 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5516 /* Create a temporary to hold the value. */
5517 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5518 fsym
->ts
.u
.cl
->backend_decl
5519 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5521 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5522 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5524 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5526 gfc_conv_expr (&rse
, args
->expr
);
5527 gfc_conv_string_parameter (&rse
);
5528 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5529 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5531 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5532 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5533 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5534 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5538 /* For everything else, just evaluate the expression. */
5540 /* Create a temporary to hold the value. */
5541 type
= gfc_typenode_for_spec (&fsym
->ts
);
5542 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5544 gfc_conv_expr (&lse
, args
->expr
);
5546 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5547 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5548 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5554 /* Use the temporary variables in place of the real ones. */
5555 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5556 fargs
= fargs
->next
, n
++)
5557 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5559 gfc_conv_expr (se
, sym
->value
);
5561 if (sym
->ts
.type
== BT_CHARACTER
)
5563 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5565 /* Force the expression to the correct length. */
5566 if (!INTEGER_CST_P (se
->string_length
)
5567 || tree_int_cst_lt (se
->string_length
,
5568 sym
->ts
.u
.cl
->backend_decl
))
5570 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5571 tmp
= gfc_create_var (type
, sym
->name
);
5572 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5573 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5574 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5578 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5581 /* Restore the original variables. */
5582 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5583 fargs
= fargs
->next
, n
++)
5584 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5590 /* Translate a function expression. */
5593 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5597 if (expr
->value
.function
.isym
)
5599 gfc_conv_intrinsic_function (se
, expr
);
5603 /* expr.value.function.esym is the resolved (specific) function symbol for
5604 most functions. However this isn't set for dummy procedures. */
5605 sym
= expr
->value
.function
.esym
;
5607 sym
= expr
->symtree
->n
.sym
;
5609 /* We distinguish statement functions from general functions to improve
5610 runtime performance. */
5611 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5613 gfc_conv_statement_function (se
, expr
);
5617 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5622 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5625 is_zero_initializer_p (gfc_expr
* expr
)
5627 if (expr
->expr_type
!= EXPR_CONSTANT
)
5630 /* We ignore constants with prescribed memory representations for now. */
5631 if (expr
->representation
.string
)
5634 switch (expr
->ts
.type
)
5637 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5640 return mpfr_zero_p (expr
->value
.real
)
5641 && MPFR_SIGN (expr
->value
.real
) >= 0;
5644 return expr
->value
.logical
== 0;
5647 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5648 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5649 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5650 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5660 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5665 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5666 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5668 gfc_conv_tmp_array_ref (se
);
5672 /* Build a static initializer. EXPR is the expression for the initial value.
5673 The other parameters describe the variable of the component being
5674 initialized. EXPR may be null. */
5677 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5678 bool array
, bool pointer
, bool procptr
)
5682 if (!(expr
|| pointer
|| procptr
))
5685 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5686 (these are the only two iso_c_binding derived types that can be
5687 used as initialization expressions). If so, we need to modify
5688 the 'expr' to be that for a (void *). */
5689 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5690 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5692 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5694 /* The derived symbol has already been converted to a (void *). Use
5696 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5697 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5699 gfc_init_se (&se
, NULL
);
5700 gfc_conv_constant (&se
, expr
);
5701 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5705 if (array
&& !procptr
)
5708 /* Arrays need special handling. */
5710 ctor
= gfc_build_null_descriptor (type
);
5711 /* Special case assigning an array to zero. */
5712 else if (is_zero_initializer_p (expr
))
5713 ctor
= build_constructor (type
, NULL
);
5715 ctor
= gfc_conv_array_initializer (type
, expr
);
5716 TREE_STATIC (ctor
) = 1;
5719 else if (pointer
|| procptr
)
5721 if (ts
->type
== BT_CLASS
&& !procptr
)
5723 gfc_init_se (&se
, NULL
);
5724 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5725 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5726 TREE_STATIC (se
.expr
) = 1;
5729 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5730 return fold_convert (type
, null_pointer_node
);
5733 gfc_init_se (&se
, NULL
);
5734 se
.want_pointer
= 1;
5735 gfc_conv_expr (&se
, expr
);
5736 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5746 gfc_init_se (&se
, NULL
);
5747 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5748 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5750 gfc_conv_structure (&se
, expr
, 1);
5751 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5752 TREE_STATIC (se
.expr
) = 1;
5757 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5758 TREE_STATIC (ctor
) = 1;
5763 gfc_init_se (&se
, NULL
);
5764 gfc_conv_constant (&se
, expr
);
5765 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5772 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5778 gfc_array_info
*lss_array
;
5785 gfc_start_block (&block
);
5787 /* Initialize the scalarizer. */
5788 gfc_init_loopinfo (&loop
);
5790 gfc_init_se (&lse
, NULL
);
5791 gfc_init_se (&rse
, NULL
);
5794 rss
= gfc_walk_expr (expr
);
5795 if (rss
== gfc_ss_terminator
)
5796 /* The rhs is scalar. Add a ss for the expression. */
5797 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5799 /* Create a SS for the destination. */
5800 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5802 lss_array
= &lss
->info
->data
.array
;
5803 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5804 lss_array
->descriptor
= dest
;
5805 lss_array
->data
= gfc_conv_array_data (dest
);
5806 lss_array
->offset
= gfc_conv_array_offset (dest
);
5807 for (n
= 0; n
< cm
->as
->rank
; n
++)
5809 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5810 lss_array
->stride
[n
] = gfc_index_one_node
;
5812 mpz_init (lss_array
->shape
[n
]);
5813 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5814 cm
->as
->lower
[n
]->value
.integer
);
5815 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5818 /* Associate the SS with the loop. */
5819 gfc_add_ss_to_loop (&loop
, lss
);
5820 gfc_add_ss_to_loop (&loop
, rss
);
5822 /* Calculate the bounds of the scalarization. */
5823 gfc_conv_ss_startstride (&loop
);
5825 /* Setup the scalarizing loops. */
5826 gfc_conv_loop_setup (&loop
, &expr
->where
);
5828 /* Setup the gfc_se structures. */
5829 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5830 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5833 gfc_mark_ss_chain_used (rss
, 1);
5835 gfc_mark_ss_chain_used (lss
, 1);
5837 /* Start the scalarized loop body. */
5838 gfc_start_scalarized_body (&loop
, &body
);
5840 gfc_conv_tmp_array_ref (&lse
);
5841 if (cm
->ts
.type
== BT_CHARACTER
)
5842 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5844 gfc_conv_expr (&rse
, expr
);
5846 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5847 gfc_add_expr_to_block (&body
, tmp
);
5849 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5851 /* Generate the copying loops. */
5852 gfc_trans_scalarizing_loops (&loop
, &body
);
5854 /* Wrap the whole thing up. */
5855 gfc_add_block_to_block (&block
, &loop
.pre
);
5856 gfc_add_block_to_block (&block
, &loop
.post
);
5858 gcc_assert (lss_array
->shape
!= NULL
);
5859 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5860 gfc_cleanup_loop (&loop
);
5862 return gfc_finish_block (&block
);
5867 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5877 gfc_expr
*arg
= NULL
;
5879 gfc_start_block (&block
);
5880 gfc_init_se (&se
, NULL
);
5882 /* Get the descriptor for the expressions. */
5883 se
.want_pointer
= 0;
5884 gfc_conv_expr_descriptor (&se
, expr
);
5885 gfc_add_block_to_block (&block
, &se
.pre
);
5886 gfc_add_modify (&block
, dest
, se
.expr
);
5888 /* Deal with arrays of derived types with allocatable components. */
5889 if (cm
->ts
.type
== BT_DERIVED
5890 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5891 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5895 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5896 TREE_TYPE(cm
->backend_decl
),
5899 gfc_add_expr_to_block (&block
, tmp
);
5900 gfc_add_block_to_block (&block
, &se
.post
);
5902 if (expr
->expr_type
!= EXPR_VARIABLE
)
5903 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5906 /* We need to know if the argument of a conversion function is a
5907 variable, so that the correct lower bound can be used. */
5908 if (expr
->expr_type
== EXPR_FUNCTION
5909 && expr
->value
.function
.isym
5910 && expr
->value
.function
.isym
->conversion
5911 && expr
->value
.function
.actual
->expr
5912 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5913 arg
= expr
->value
.function
.actual
->expr
;
5915 /* Obtain the array spec of full array references. */
5917 as
= gfc_get_full_arrayspec_from_expr (arg
);
5919 as
= gfc_get_full_arrayspec_from_expr (expr
);
5921 /* Shift the lbound and ubound of temporaries to being unity,
5922 rather than zero, based. Always calculate the offset. */
5923 offset
= gfc_conv_descriptor_offset_get (dest
);
5924 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5925 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5927 for (n
= 0; n
< expr
->rank
; n
++)
5932 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5933 TODO It looks as if gfc_conv_expr_descriptor should return
5934 the correct bounds and that the following should not be
5935 necessary. This would simplify gfc_conv_intrinsic_bound
5937 if (as
&& as
->lower
[n
])
5940 gfc_init_se (&lbse
, NULL
);
5941 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5942 gfc_add_block_to_block (&block
, &lbse
.pre
);
5943 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5947 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5948 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5952 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5955 lbound
= gfc_index_one_node
;
5957 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5959 /* Shift the bounds and set the offset accordingly. */
5960 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5961 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5962 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5963 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5965 gfc_conv_descriptor_ubound_set (&block
, dest
,
5966 gfc_rank_cst
[n
], tmp
);
5967 gfc_conv_descriptor_lbound_set (&block
, dest
,
5968 gfc_rank_cst
[n
], lbound
);
5970 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5971 gfc_conv_descriptor_lbound_get (dest
,
5973 gfc_conv_descriptor_stride_get (dest
,
5975 gfc_add_modify (&block
, tmp2
, tmp
);
5976 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5978 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5983 /* If a conversion expression has a null data pointer
5984 argument, nullify the allocatable component. */
5988 if (arg
->symtree
->n
.sym
->attr
.allocatable
5989 || arg
->symtree
->n
.sym
->attr
.pointer
)
5991 non_null_expr
= gfc_finish_block (&block
);
5992 gfc_start_block (&block
);
5993 gfc_conv_descriptor_data_set (&block
, dest
,
5995 null_expr
= gfc_finish_block (&block
);
5996 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5997 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5998 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5999 return build3_v (COND_EXPR
, tmp
,
6000 null_expr
, non_null_expr
);
6004 return gfc_finish_block (&block
);
6008 /* Assign a single component of a derived type constructor. */
6011 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6018 gfc_start_block (&block
);
6020 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6022 gfc_init_se (&se
, NULL
);
6023 /* Pointer component. */
6024 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6025 && !cm
->attr
.proc_pointer
)
6027 /* Array pointer. */
6028 if (expr
->expr_type
== EXPR_NULL
)
6029 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6032 se
.direct_byref
= 1;
6034 gfc_conv_expr_descriptor (&se
, expr
);
6035 gfc_add_block_to_block (&block
, &se
.pre
);
6036 gfc_add_block_to_block (&block
, &se
.post
);
6041 /* Scalar pointers. */
6042 se
.want_pointer
= 1;
6043 gfc_conv_expr (&se
, expr
);
6044 gfc_add_block_to_block (&block
, &se
.pre
);
6046 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6047 && expr
->symtree
->n
.sym
->attr
.dummy
)
6048 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6050 gfc_add_modify (&block
, dest
,
6051 fold_convert (TREE_TYPE (dest
), se
.expr
));
6052 gfc_add_block_to_block (&block
, &se
.post
);
6055 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6057 /* NULL initialization for CLASS components. */
6058 tmp
= gfc_trans_structure_assign (dest
,
6059 gfc_class_initializer (&cm
->ts
, expr
));
6060 gfc_add_expr_to_block (&block
, tmp
);
6062 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6063 && !cm
->attr
.proc_pointer
)
6065 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6066 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6067 else if (cm
->attr
.allocatable
)
6069 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6070 gfc_add_expr_to_block (&block
, tmp
);
6074 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6075 gfc_add_expr_to_block (&block
, tmp
);
6078 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6080 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6082 gfc_init_se (&se
, NULL
);
6083 gfc_conv_expr (&se
, expr
);
6084 gfc_add_block_to_block (&block
, &se
.pre
);
6085 gfc_add_modify (&block
, dest
,
6086 fold_convert (TREE_TYPE (dest
), se
.expr
));
6087 gfc_add_block_to_block (&block
, &se
.post
);
6091 /* Nested constructors. */
6092 tmp
= gfc_trans_structure_assign (dest
, expr
);
6093 gfc_add_expr_to_block (&block
, tmp
);
6096 else if (gfc_deferred_strlen (cm
, &tmp
))
6100 gcc_assert (strlen
);
6101 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6103 TREE_OPERAND (dest
, 0),
6106 if (expr
->expr_type
== EXPR_NULL
)
6108 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6109 gfc_add_modify (&block
, dest
, tmp
);
6110 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6111 gfc_add_modify (&block
, strlen
, tmp
);
6116 gfc_init_se (&se
, NULL
);
6117 gfc_conv_expr (&se
, expr
);
6118 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6119 tmp
= build_call_expr_loc (input_location
,
6120 builtin_decl_explicit (BUILT_IN_MALLOC
),
6122 gfc_add_modify (&block
, dest
,
6123 fold_convert (TREE_TYPE (dest
), tmp
));
6124 gfc_add_modify (&block
, strlen
, se
.string_length
);
6125 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6126 gfc_add_expr_to_block (&block
, tmp
);
6129 else if (!cm
->attr
.deferred_parameter
)
6131 /* Scalar component (excluding deferred parameters). */
6132 gfc_init_se (&se
, NULL
);
6133 gfc_init_se (&lse
, NULL
);
6135 gfc_conv_expr (&se
, expr
);
6136 if (cm
->ts
.type
== BT_CHARACTER
)
6137 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6139 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6140 gfc_add_expr_to_block (&block
, tmp
);
6142 return gfc_finish_block (&block
);
6145 /* Assign a derived type constructor to a variable. */
6148 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6156 gfc_start_block (&block
);
6157 cm
= expr
->ts
.u
.derived
->components
;
6159 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6160 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6161 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6165 gcc_assert (cm
->backend_decl
== NULL
);
6166 gfc_init_se (&se
, NULL
);
6167 gfc_init_se (&lse
, NULL
);
6168 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6170 gfc_add_modify (&block
, lse
.expr
,
6171 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6173 return gfc_finish_block (&block
);
6176 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6177 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6179 /* Skip absent members in default initializers. */
6183 field
= cm
->backend_decl
;
6184 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6185 dest
, field
, NULL_TREE
);
6186 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6187 gfc_add_expr_to_block (&block
, tmp
);
6189 return gfc_finish_block (&block
);
6192 /* Build an expression for a constructor. If init is nonzero then
6193 this is part of a static variable initializer. */
6196 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6203 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6205 gcc_assert (se
->ss
== NULL
);
6206 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6207 type
= gfc_typenode_for_spec (&expr
->ts
);
6211 /* Create a temporary variable and fill it in. */
6212 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6213 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6214 gfc_add_expr_to_block (&se
->pre
, tmp
);
6218 cm
= expr
->ts
.u
.derived
->components
;
6220 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6221 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6223 /* Skip absent members in default initializers and allocatable
6224 components. Although the latter have a default initializer
6225 of EXPR_NULL,... by default, the static nullify is not needed
6226 since this is done every time we come into scope. */
6227 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6230 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6231 && strcmp (cm
->name
, "_extends") == 0
6232 && cm
->initializer
->symtree
)
6236 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6237 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6238 vtab
= unshare_expr_without_location (vtab
);
6239 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6241 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6243 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6244 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6248 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6249 TREE_TYPE (cm
->backend_decl
),
6250 cm
->attr
.dimension
, cm
->attr
.pointer
,
6251 cm
->attr
.proc_pointer
);
6252 val
= unshare_expr_without_location (val
);
6254 /* Append it to the constructor list. */
6255 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6258 se
->expr
= build_constructor (type
, v
);
6260 TREE_CONSTANT (se
->expr
) = 1;
6264 /* Translate a substring expression. */
6267 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6273 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6275 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6276 expr
->value
.character
.length
,
6277 expr
->value
.character
.string
);
6279 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6280 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6283 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6287 /* Entry point for expression translation. Evaluates a scalar quantity.
6288 EXPR is the expression to be translated, and SE is the state structure if
6289 called from within the scalarized. */
6292 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6297 if (ss
&& ss
->info
->expr
== expr
6298 && (ss
->info
->type
== GFC_SS_SCALAR
6299 || ss
->info
->type
== GFC_SS_REFERENCE
))
6301 gfc_ss_info
*ss_info
;
6304 /* Substitute a scalar expression evaluated outside the scalarization
6306 se
->expr
= ss_info
->data
.scalar
.value
;
6307 /* If the reference can be NULL, the value field contains the reference,
6308 not the value the reference points to (see gfc_add_loop_ss_code). */
6309 if (ss_info
->can_be_null_ref
)
6310 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6312 se
->string_length
= ss_info
->string_length
;
6313 gfc_advance_se_ss_chain (se
);
6317 /* We need to convert the expressions for the iso_c_binding derived types.
6318 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6319 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6320 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6321 updated to be an integer with a kind equal to the size of a (void *). */
6322 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6324 if (expr
->expr_type
== EXPR_VARIABLE
6325 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6326 || expr
->symtree
->n
.sym
->intmod_sym_id
6327 == ISOCBINDING_NULL_FUNPTR
))
6329 /* Set expr_type to EXPR_NULL, which will result in
6330 null_pointer_node being used below. */
6331 expr
->expr_type
= EXPR_NULL
;
6335 /* Update the type/kind of the expression to be what the new
6336 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6337 expr
->ts
.type
= BT_INTEGER
;
6338 expr
->ts
.f90_type
= BT_VOID
;
6339 expr
->ts
.kind
= gfc_index_integer_kind
;
6343 gfc_fix_class_refs (expr
);
6345 switch (expr
->expr_type
)
6348 gfc_conv_expr_op (se
, expr
);
6352 gfc_conv_function_expr (se
, expr
);
6356 gfc_conv_constant (se
, expr
);
6360 gfc_conv_variable (se
, expr
);
6364 se
->expr
= null_pointer_node
;
6367 case EXPR_SUBSTRING
:
6368 gfc_conv_substring_expr (se
, expr
);
6371 case EXPR_STRUCTURE
:
6372 gfc_conv_structure (se
, expr
, 0);
6376 gfc_conv_array_constructor_expr (se
, expr
);
6385 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6386 of an assignment. */
6388 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6390 gfc_conv_expr (se
, expr
);
6391 /* All numeric lvalues should have empty post chains. If not we need to
6392 figure out a way of rewriting an lvalue so that it has no post chain. */
6393 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6396 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6397 numeric expressions. Used for scalar values where inserting cleanup code
6400 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6404 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6405 gfc_conv_expr (se
, expr
);
6408 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6409 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6411 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6415 /* Helper to translate an expression and convert it to a particular type. */
6417 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6419 gfc_conv_expr_val (se
, expr
);
6420 se
->expr
= convert (type
, se
->expr
);
6424 /* Converts an expression so that it can be passed by reference. Scalar
6428 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6434 if (ss
&& ss
->info
->expr
== expr
6435 && ss
->info
->type
== GFC_SS_REFERENCE
)
6437 /* Returns a reference to the scalar evaluated outside the loop
6439 gfc_conv_expr (se
, expr
);
6441 if (expr
->ts
.type
== BT_CHARACTER
6442 && expr
->expr_type
!= EXPR_FUNCTION
)
6443 gfc_conv_string_parameter (se
);
6445 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6450 if (expr
->ts
.type
== BT_CHARACTER
)
6452 gfc_conv_expr (se
, expr
);
6453 gfc_conv_string_parameter (se
);
6457 if (expr
->expr_type
== EXPR_VARIABLE
)
6459 se
->want_pointer
= 1;
6460 gfc_conv_expr (se
, expr
);
6463 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6464 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6465 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6471 if (expr
->expr_type
== EXPR_FUNCTION
6472 && ((expr
->value
.function
.esym
6473 && expr
->value
.function
.esym
->result
->attr
.pointer
6474 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6475 || (!expr
->value
.function
.esym
&& !expr
->ref
6476 && expr
->symtree
->n
.sym
->attr
.pointer
6477 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6479 se
->want_pointer
= 1;
6480 gfc_conv_expr (se
, expr
);
6481 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6482 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6487 gfc_conv_expr (se
, expr
);
6489 /* Create a temporary var to hold the value. */
6490 if (TREE_CONSTANT (se
->expr
))
6492 tree tmp
= se
->expr
;
6493 STRIP_TYPE_NOPS (tmp
);
6494 var
= build_decl (input_location
,
6495 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6496 DECL_INITIAL (var
) = tmp
;
6497 TREE_STATIC (var
) = 1;
6502 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6503 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6505 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6507 /* Take the address of that value. */
6508 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6513 gfc_trans_pointer_assign (gfc_code
* code
)
6515 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6519 /* Generate code for a pointer assignment. */
6522 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6524 gfc_expr
*expr1_vptr
= NULL
;
6534 gfc_start_block (&block
);
6536 gfc_init_se (&lse
, NULL
);
6538 /* Check whether the expression is a scalar or not; we cannot use
6539 expr1->rank as it can be nonzero for proc pointers. */
6540 ss
= gfc_walk_expr (expr1
);
6541 scalar
= ss
== gfc_ss_terminator
;
6543 gfc_free_ss_chain (ss
);
6545 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6546 && expr2
->expr_type
!= EXPR_FUNCTION
)
6548 gfc_add_data_component (expr2
);
6549 /* The following is required as gfc_add_data_component doesn't
6550 update ts.type if there is a tailing REF_ARRAY. */
6551 expr2
->ts
.type
= BT_DERIVED
;
6556 /* Scalar pointers. */
6557 lse
.want_pointer
= 1;
6558 gfc_conv_expr (&lse
, expr1
);
6559 gfc_init_se (&rse
, NULL
);
6560 rse
.want_pointer
= 1;
6561 gfc_conv_expr (&rse
, expr2
);
6563 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6564 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6565 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6568 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6569 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6570 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6573 gfc_add_block_to_block (&block
, &lse
.pre
);
6574 gfc_add_block_to_block (&block
, &rse
.pre
);
6576 /* Check character lengths if character expression. The test is only
6577 really added if -fbounds-check is enabled. Exclude deferred
6578 character length lefthand sides. */
6579 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6580 && !expr1
->ts
.deferred
6581 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6582 && !gfc_is_proc_ptr_comp (expr1
))
6584 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6585 gcc_assert (lse
.string_length
&& rse
.string_length
);
6586 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6587 lse
.string_length
, rse
.string_length
,
6591 /* The assignment to an deferred character length sets the string
6592 length to that of the rhs. */
6593 if (expr1
->ts
.deferred
)
6595 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6596 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6597 else if (lse
.string_length
!= NULL
)
6598 gfc_add_modify (&block
, lse
.string_length
,
6599 build_int_cst (gfc_charlen_type_node
, 0));
6602 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6603 rse
.expr
= gfc_class_data_get (rse
.expr
);
6605 gfc_add_modify (&block
, lse
.expr
,
6606 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6608 gfc_add_block_to_block (&block
, &rse
.post
);
6609 gfc_add_block_to_block (&block
, &lse
.post
);
6616 tree strlen_rhs
= NULL_TREE
;
6618 /* Array pointer. Find the last reference on the LHS and if it is an
6619 array section ref, we're dealing with bounds remapping. In this case,
6620 set it to AR_FULL so that gfc_conv_expr_descriptor does
6621 not see it and process the bounds remapping afterwards explicitly. */
6622 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6623 if (!remap
->next
&& remap
->type
== REF_ARRAY
6624 && remap
->u
.ar
.type
== AR_SECTION
)
6626 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6628 gfc_init_se (&lse
, NULL
);
6630 lse
.descriptor_only
= 1;
6631 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6632 && expr1
->ts
.type
== BT_CLASS
)
6633 expr1_vptr
= gfc_copy_expr (expr1
);
6634 gfc_conv_expr_descriptor (&lse
, expr1
);
6635 strlen_lhs
= lse
.string_length
;
6638 if (expr2
->expr_type
== EXPR_NULL
)
6640 /* Just set the data pointer to null. */
6641 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6643 else if (rank_remap
)
6645 /* If we are rank-remapping, just get the RHS's descriptor and
6646 process this later on. */
6647 gfc_init_se (&rse
, NULL
);
6648 rse
.direct_byref
= 1;
6649 rse
.byref_noassign
= 1;
6651 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6653 gfc_conv_function_expr (&rse
, expr2
);
6655 if (expr1
->ts
.type
!= BT_CLASS
)
6656 rse
.expr
= gfc_class_data_get (rse
.expr
);
6659 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6660 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6662 gfc_add_vptr_component (expr1_vptr
);
6663 gfc_init_se (&rse
, NULL
);
6664 rse
.want_pointer
= 1;
6665 gfc_conv_expr (&rse
, expr1_vptr
);
6666 gfc_add_modify (&lse
.pre
, rse
.expr
,
6667 fold_convert (TREE_TYPE (rse
.expr
),
6668 gfc_class_vptr_get (tmp
)));
6669 rse
.expr
= gfc_class_data_get (tmp
);
6672 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6674 tree bound
[GFC_MAX_DIMENSIONS
];
6677 for (i
= 0; i
< expr2
->rank
; i
++)
6678 bound
[i
] = NULL_TREE
;
6679 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6680 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6682 GFC_ARRAY_POINTER_CONT
, false);
6683 tmp
= gfc_create_var (tmp
, "ptrtemp");
6685 lse
.direct_byref
= 1;
6686 gfc_conv_expr_descriptor (&lse
, expr2
);
6687 strlen_rhs
= lse
.string_length
;
6692 gfc_conv_expr_descriptor (&rse
, expr2
);
6693 strlen_rhs
= rse
.string_length
;
6696 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6698 /* Assign directly to the LHS's descriptor. */
6699 lse
.direct_byref
= 1;
6700 gfc_conv_expr_descriptor (&lse
, expr2
);
6701 strlen_rhs
= lse
.string_length
;
6703 /* If this is a subreference array pointer assignment, use the rhs
6704 descriptor element size for the lhs span. */
6705 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6707 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6708 gfc_init_se (&rse
, NULL
);
6709 rse
.descriptor_only
= 1;
6710 gfc_conv_expr (&rse
, expr2
);
6711 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6712 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6713 if (!INTEGER_CST_P (tmp
))
6714 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6715 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6718 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6720 gfc_init_se (&rse
, NULL
);
6721 rse
.want_pointer
= 1;
6722 gfc_conv_function_expr (&rse
, expr2
);
6723 if (expr1
->ts
.type
!= BT_CLASS
)
6725 rse
.expr
= gfc_class_data_get (rse
.expr
);
6726 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6730 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6731 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6733 gfc_add_vptr_component (expr1_vptr
);
6734 gfc_init_se (&rse
, NULL
);
6735 rse
.want_pointer
= 1;
6736 gfc_conv_expr (&rse
, expr1_vptr
);
6737 gfc_add_modify (&lse
.pre
, rse
.expr
,
6738 fold_convert (TREE_TYPE (rse
.expr
),
6739 gfc_class_vptr_get (tmp
)));
6740 rse
.expr
= gfc_class_data_get (tmp
);
6741 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6746 /* Assign to a temporary descriptor and then copy that
6747 temporary to the pointer. */
6748 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6750 lse
.direct_byref
= 1;
6751 gfc_conv_expr_descriptor (&lse
, expr2
);
6752 strlen_rhs
= lse
.string_length
;
6753 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6757 gfc_free_expr (expr1_vptr
);
6759 gfc_add_block_to_block (&block
, &lse
.pre
);
6761 gfc_add_block_to_block (&block
, &rse
.pre
);
6763 /* If we do bounds remapping, update LHS descriptor accordingly. */
6767 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6771 /* Do rank remapping. We already have the RHS's descriptor
6772 converted in rse and now have to build the correct LHS
6773 descriptor for it. */
6777 tree lbound
, ubound
;
6780 dtype
= gfc_conv_descriptor_dtype (desc
);
6781 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6782 gfc_add_modify (&block
, dtype
, tmp
);
6784 /* Copy data pointer. */
6785 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6786 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6788 /* Copy offset but adjust it such that it would correspond
6789 to a lbound of zero. */
6790 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6791 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6793 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6795 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6797 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6798 gfc_array_index_type
, stride
, lbound
);
6799 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6800 gfc_array_index_type
, offs
, tmp
);
6802 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6804 /* Set the bounds as declared for the LHS and calculate strides as
6805 well as another offset update accordingly. */
6806 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6808 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6813 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6815 /* Convert declared bounds. */
6816 gfc_init_se (&lower_se
, NULL
);
6817 gfc_init_se (&upper_se
, NULL
);
6818 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6819 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6821 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6822 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6824 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6825 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6827 lbound
= gfc_evaluate_now (lbound
, &block
);
6828 ubound
= gfc_evaluate_now (ubound
, &block
);
6830 gfc_add_block_to_block (&block
, &lower_se
.post
);
6831 gfc_add_block_to_block (&block
, &upper_se
.post
);
6833 /* Set bounds in descriptor. */
6834 gfc_conv_descriptor_lbound_set (&block
, desc
,
6835 gfc_rank_cst
[dim
], lbound
);
6836 gfc_conv_descriptor_ubound_set (&block
, desc
,
6837 gfc_rank_cst
[dim
], ubound
);
6840 stride
= gfc_evaluate_now (stride
, &block
);
6841 gfc_conv_descriptor_stride_set (&block
, desc
,
6842 gfc_rank_cst
[dim
], stride
);
6844 /* Update offset. */
6845 offs
= gfc_conv_descriptor_offset_get (desc
);
6846 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6847 gfc_array_index_type
, lbound
, stride
);
6848 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6849 gfc_array_index_type
, offs
, tmp
);
6850 offs
= gfc_evaluate_now (offs
, &block
);
6851 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6853 /* Update stride. */
6854 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6855 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6856 gfc_array_index_type
, stride
, tmp
);
6861 /* Bounds remapping. Just shift the lower bounds. */
6863 gcc_assert (expr1
->rank
== expr2
->rank
);
6865 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6869 gcc_assert (remap
->u
.ar
.start
[dim
]);
6870 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6871 gfc_init_se (&lbound_se
, NULL
);
6872 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6874 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6875 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6876 dim
, lbound_se
.expr
);
6877 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6882 /* Check string lengths if applicable. The check is only really added
6883 to the output code if -fbounds-check is enabled. */
6884 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6886 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6887 gcc_assert (strlen_lhs
&& strlen_rhs
);
6888 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6889 strlen_lhs
, strlen_rhs
, &block
);
6892 /* If rank remapping was done, check with -fcheck=bounds that
6893 the target is at least as large as the pointer. */
6894 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6900 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6901 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6903 lsize
= gfc_evaluate_now (lsize
, &block
);
6904 rsize
= gfc_evaluate_now (rsize
, &block
);
6905 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6908 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6909 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6913 gfc_add_block_to_block (&block
, &lse
.post
);
6915 gfc_add_block_to_block (&block
, &rse
.post
);
6918 return gfc_finish_block (&block
);
6922 /* Makes sure se is suitable for passing as a function string parameter. */
6923 /* TODO: Need to check all callers of this function. It may be abused. */
6926 gfc_conv_string_parameter (gfc_se
* se
)
6930 if (TREE_CODE (se
->expr
) == STRING_CST
)
6932 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6933 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6937 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6939 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6941 type
= TREE_TYPE (se
->expr
);
6942 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6946 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6948 type
= build_pointer_type (type
);
6949 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6953 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6957 /* Generate code for assignment of scalar variables. Includes character
6958 strings and derived types with allocatable components.
6959 If you know that the LHS has no allocations, set dealloc to false.
6961 DEEP_COPY has no effect if the typespec TS is not a derived type with
6962 allocatable components. Otherwise, if it is set, an explicit copy of each
6963 allocatable component is made. This is necessary as a simple copy of the
6964 whole object would copy array descriptors as is, so that the lhs's
6965 allocatable components would point to the rhs's after the assignment.
6966 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6967 necessary if the rhs is a non-pointer function, as the allocatable components
6968 are not accessible by other means than the function's result after the
6969 function has returned. It is even more subtle when temporaries are involved,
6970 as the two following examples show:
6971 1. When we evaluate an array constructor, a temporary is created. Thus
6972 there is theoretically no alias possible. However, no deep copy is
6973 made for this temporary, so that if the constructor is made of one or
6974 more variable with allocatable components, those components still point
6975 to the variable's: DEEP_COPY should be set for the assignment from the
6976 temporary to the lhs in that case.
6977 2. When assigning a scalar to an array, we evaluate the scalar value out
6978 of the loop, store it into a temporary variable, and assign from that.
6979 In that case, deep copying when assigning to the temporary would be a
6980 waste of resources; however deep copies should happen when assigning from
6981 the temporary to each array element: again DEEP_COPY should be set for
6982 the assignment from the temporary to the lhs. */
6985 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6986 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6992 gfc_init_block (&block
);
6994 if (ts
.type
== BT_CHARACTER
)
6999 if (lse
->string_length
!= NULL_TREE
)
7001 gfc_conv_string_parameter (lse
);
7002 gfc_add_block_to_block (&block
, &lse
->pre
);
7003 llen
= lse
->string_length
;
7006 if (rse
->string_length
!= NULL_TREE
)
7008 gcc_assert (rse
->string_length
!= NULL_TREE
);
7009 gfc_conv_string_parameter (rse
);
7010 gfc_add_block_to_block (&block
, &rse
->pre
);
7011 rlen
= rse
->string_length
;
7014 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7015 rse
->expr
, ts
.kind
);
7017 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7019 tree tmp_var
= NULL_TREE
;
7022 /* Are the rhs and the lhs the same? */
7025 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7026 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7027 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7028 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7031 /* Deallocate the lhs allocated components as long as it is not
7032 the same as the rhs. This must be done following the assignment
7033 to prevent deallocating data that could be used in the rhs
7035 if (!l_is_temp
&& dealloc
)
7037 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7038 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7040 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7042 gfc_add_expr_to_block (&lse
->post
, tmp
);
7045 gfc_add_block_to_block (&block
, &rse
->pre
);
7046 gfc_add_block_to_block (&block
, &lse
->pre
);
7048 gfc_add_modify (&block
, lse
->expr
,
7049 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7051 /* Restore pointer address of coarray components. */
7052 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7054 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7055 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7057 gfc_add_expr_to_block (&block
, tmp
);
7060 /* Do a deep copy if the rhs is a variable, if it is not the
7064 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7065 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7067 gfc_add_expr_to_block (&block
, tmp
);
7070 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7072 gfc_add_block_to_block (&block
, &lse
->pre
);
7073 gfc_add_block_to_block (&block
, &rse
->pre
);
7074 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7075 TREE_TYPE (lse
->expr
), rse
->expr
);
7076 gfc_add_modify (&block
, lse
->expr
, tmp
);
7080 gfc_add_block_to_block (&block
, &lse
->pre
);
7081 gfc_add_block_to_block (&block
, &rse
->pre
);
7083 gfc_add_modify (&block
, lse
->expr
,
7084 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7087 gfc_add_block_to_block (&block
, &lse
->post
);
7088 gfc_add_block_to_block (&block
, &rse
->post
);
7090 return gfc_finish_block (&block
);
7094 /* There are quite a lot of restrictions on the optimisation in using an
7095 array function assign without a temporary. */
7098 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7101 bool seen_array_ref
;
7103 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7105 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7106 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7109 /* Elemental functions are scalarized so that they don't need a
7110 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7111 they would need special treatment in gfc_trans_arrayfunc_assign. */
7112 if (expr2
->value
.function
.esym
!= NULL
7113 && expr2
->value
.function
.esym
->attr
.elemental
)
7116 /* Need a temporary if rhs is not FULL or a contiguous section. */
7117 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7120 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7121 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7124 /* Functions returning pointers or allocatables need temporaries. */
7125 c
= expr2
->value
.function
.esym
7126 ? (expr2
->value
.function
.esym
->attr
.pointer
7127 || expr2
->value
.function
.esym
->attr
.allocatable
)
7128 : (expr2
->symtree
->n
.sym
->attr
.pointer
7129 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7133 /* Character array functions need temporaries unless the
7134 character lengths are the same. */
7135 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7137 if (expr1
->ts
.u
.cl
->length
== NULL
7138 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7141 if (expr2
->ts
.u
.cl
->length
== NULL
7142 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7145 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7146 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7150 /* Check that no LHS component references appear during an array
7151 reference. This is needed because we do not have the means to
7152 span any arbitrary stride with an array descriptor. This check
7153 is not needed for the rhs because the function result has to be
7155 seen_array_ref
= false;
7156 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7158 if (ref
->type
== REF_ARRAY
)
7159 seen_array_ref
= true;
7160 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7164 /* Check for a dependency. */
7165 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7166 expr2
->value
.function
.esym
,
7167 expr2
->value
.function
.actual
,
7171 /* If we have reached here with an intrinsic function, we do not
7172 need a temporary except in the particular case that reallocation
7173 on assignment is active and the lhs is allocatable and a target. */
7174 if (expr2
->value
.function
.isym
)
7175 return (gfc_option
.flag_realloc_lhs
7176 && sym
->attr
.allocatable
7177 && sym
->attr
.target
);
7179 /* If the LHS is a dummy, we need a temporary if it is not
7181 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7184 /* If the lhs has been host_associated, is in common, a pointer or is
7185 a target and the function is not using a RESULT variable, aliasing
7186 can occur and a temporary is needed. */
7187 if ((sym
->attr
.host_assoc
7188 || sym
->attr
.in_common
7189 || sym
->attr
.pointer
7190 || sym
->attr
.cray_pointee
7191 || sym
->attr
.target
)
7192 && expr2
->symtree
!= NULL
7193 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7196 /* A PURE function can unconditionally be called without a temporary. */
7197 if (expr2
->value
.function
.esym
!= NULL
7198 && expr2
->value
.function
.esym
->attr
.pure
)
7201 /* Implicit_pure functions are those which could legally be declared
7203 if (expr2
->value
.function
.esym
!= NULL
7204 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7207 if (!sym
->attr
.use_assoc
7208 && !sym
->attr
.in_common
7209 && !sym
->attr
.pointer
7210 && !sym
->attr
.target
7211 && !sym
->attr
.cray_pointee
7212 && expr2
->value
.function
.esym
)
7214 /* A temporary is not needed if the function is not contained and
7215 the variable is local or host associated and not a pointer or
7217 if (!expr2
->value
.function
.esym
->attr
.contained
)
7220 /* A temporary is not needed if the lhs has never been host
7221 associated and the procedure is contained. */
7222 else if (!sym
->attr
.host_assoc
)
7225 /* A temporary is not needed if the variable is local and not
7226 a pointer, a target or a result. */
7228 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7232 /* Default to temporary use. */
7237 /* Provide the loop info so that the lhs descriptor can be built for
7238 reallocatable assignments from extrinsic function calls. */
7241 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7244 /* Signal that the function call should not be made by
7245 gfc_conv_loop_setup. */
7246 se
->ss
->is_alloc_lhs
= 1;
7247 gfc_init_loopinfo (loop
);
7248 gfc_add_ss_to_loop (loop
, *ss
);
7249 gfc_add_ss_to_loop (loop
, se
->ss
);
7250 gfc_conv_ss_startstride (loop
);
7251 gfc_conv_loop_setup (loop
, where
);
7252 gfc_copy_loopinfo_to_se (se
, loop
);
7253 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7254 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7255 se
->ss
->is_alloc_lhs
= 0;
7259 /* For assignment to a reallocatable lhs from intrinsic functions,
7260 replace the se.expr (ie. the result) with a temporary descriptor.
7261 Null the data field so that the library allocates space for the
7262 result. Free the data of the original descriptor after the function,
7263 in case it appears in an argument expression and transfer the
7264 result to the original descriptor. */
7267 fcncall_realloc_result (gfc_se
*se
, int rank
)
7276 /* Use the allocation done by the library. Substitute the lhs
7277 descriptor with a copy, whose data field is nulled.*/
7278 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7279 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7280 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7282 /* Unallocated, the descriptor does not have a dtype. */
7283 tmp
= gfc_conv_descriptor_dtype (desc
);
7284 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7286 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7287 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7288 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
7290 /* Free the lhs after the function call and copy the result data to
7291 the lhs descriptor. */
7292 tmp
= gfc_conv_descriptor_data_get (desc
);
7293 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7294 boolean_type_node
, tmp
,
7295 build_int_cst (TREE_TYPE (tmp
), 0));
7296 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7297 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7298 gfc_add_expr_to_block (&se
->post
, tmp
);
7300 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7301 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7303 /* Check that the shapes are the same between lhs and expression. */
7304 for (n
= 0 ; n
< rank
; n
++)
7307 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7308 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7309 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7310 gfc_array_index_type
, tmp
, tmp1
);
7311 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7312 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7313 gfc_array_index_type
, tmp
, tmp1
);
7314 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7315 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7316 gfc_array_index_type
, tmp
, tmp1
);
7317 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7318 boolean_type_node
, tmp
,
7319 gfc_index_zero_node
);
7320 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7321 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7322 boolean_type_node
, tmp
,
7326 /* 'zero_cond' being true is equal to lhs not being allocated or the
7327 shapes being different. */
7328 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7330 /* Now reset the bounds returned from the function call to bounds based
7331 on the lhs lbounds, except where the lhs is not allocated or the shapes
7332 of 'variable and 'expr' are different. Set the offset accordingly. */
7333 offset
= gfc_index_zero_node
;
7334 for (n
= 0 ; n
< rank
; n
++)
7338 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7339 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7340 gfc_array_index_type
, zero_cond
,
7341 gfc_index_one_node
, lbound
);
7342 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7344 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7345 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7346 gfc_array_index_type
, tmp
, lbound
);
7347 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7348 gfc_rank_cst
[n
], lbound
);
7349 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7350 gfc_rank_cst
[n
], tmp
);
7352 /* Set stride and accumulate the offset. */
7353 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7354 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7355 gfc_rank_cst
[n
], tmp
);
7356 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7357 gfc_array_index_type
, lbound
, tmp
);
7358 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7359 gfc_array_index_type
, offset
, tmp
);
7360 offset
= gfc_evaluate_now (offset
, &se
->post
);
7363 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7368 /* Try to translate array(:) = func (...), where func is a transformational
7369 array function, without using a temporary. Returns NULL if this isn't the
7373 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7377 gfc_component
*comp
= NULL
;
7380 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7383 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7385 comp
= gfc_get_proc_ptr_comp (expr2
);
7386 gcc_assert (expr2
->value
.function
.isym
7387 || (comp
&& comp
->attr
.dimension
)
7388 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7389 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7391 gfc_init_se (&se
, NULL
);
7392 gfc_start_block (&se
.pre
);
7393 se
.want_pointer
= 1;
7395 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7397 if (expr1
->ts
.type
== BT_DERIVED
7398 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7401 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7403 gfc_add_expr_to_block (&se
.pre
, tmp
);
7406 se
.direct_byref
= 1;
7407 se
.ss
= gfc_walk_expr (expr2
);
7408 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7410 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7411 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7412 Clearly, this cannot be done for an allocatable function result, since
7413 the shape of the result is unknown and, in any case, the function must
7414 correctly take care of the reallocation internally. For intrinsic
7415 calls, the array data is freed and the library takes care of allocation.
7416 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7418 if (gfc_option
.flag_realloc_lhs
7419 && gfc_is_reallocatable_lhs (expr1
)
7420 && !gfc_expr_attr (expr1
).codimension
7421 && !gfc_is_coindexed (expr1
)
7422 && !(expr2
->value
.function
.esym
7423 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7425 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7427 if (!expr2
->value
.function
.isym
)
7429 ss
= gfc_walk_expr (expr1
);
7430 gcc_assert (ss
!= gfc_ss_terminator
);
7432 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7433 ss
->is_alloc_lhs
= 1;
7436 fcncall_realloc_result (&se
, expr1
->rank
);
7439 gfc_conv_function_expr (&se
, expr2
);
7440 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7443 gfc_cleanup_loop (&loop
);
7445 gfc_free_ss_chain (se
.ss
);
7447 return gfc_finish_block (&se
.pre
);
7451 /* Try to efficiently translate array(:) = 0. Return NULL if this
7455 gfc_trans_zero_assign (gfc_expr
* expr
)
7457 tree dest
, len
, type
;
7461 sym
= expr
->symtree
->n
.sym
;
7462 dest
= gfc_get_symbol_decl (sym
);
7464 type
= TREE_TYPE (dest
);
7465 if (POINTER_TYPE_P (type
))
7466 type
= TREE_TYPE (type
);
7467 if (!GFC_ARRAY_TYPE_P (type
))
7470 /* Determine the length of the array. */
7471 len
= GFC_TYPE_ARRAY_SIZE (type
);
7472 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7475 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7476 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7477 fold_convert (gfc_array_index_type
, tmp
));
7479 /* If we are zeroing a local array avoid taking its address by emitting
7481 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7482 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7483 dest
, build_constructor (TREE_TYPE (dest
),
7486 /* Convert arguments to the correct types. */
7487 dest
= fold_convert (pvoid_type_node
, dest
);
7488 len
= fold_convert (size_type_node
, len
);
7490 /* Construct call to __builtin_memset. */
7491 tmp
= build_call_expr_loc (input_location
,
7492 builtin_decl_explicit (BUILT_IN_MEMSET
),
7493 3, dest
, integer_zero_node
, len
);
7494 return fold_convert (void_type_node
, tmp
);
7498 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7499 that constructs the call to __builtin_memcpy. */
7502 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7506 /* Convert arguments to the correct types. */
7507 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7508 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7510 dst
= fold_convert (pvoid_type_node
, dst
);
7512 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7513 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7515 src
= fold_convert (pvoid_type_node
, src
);
7517 len
= fold_convert (size_type_node
, len
);
7519 /* Construct call to __builtin_memcpy. */
7520 tmp
= build_call_expr_loc (input_location
,
7521 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7523 return fold_convert (void_type_node
, tmp
);
7527 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7528 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7529 source/rhs, both are gfc_full_array_ref_p which have been checked for
7533 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7535 tree dst
, dlen
, dtype
;
7536 tree src
, slen
, stype
;
7539 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7540 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7542 dtype
= TREE_TYPE (dst
);
7543 if (POINTER_TYPE_P (dtype
))
7544 dtype
= TREE_TYPE (dtype
);
7545 stype
= TREE_TYPE (src
);
7546 if (POINTER_TYPE_P (stype
))
7547 stype
= TREE_TYPE (stype
);
7549 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7552 /* Determine the lengths of the arrays. */
7553 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7554 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7556 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7557 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7558 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7560 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7561 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7563 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7564 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7565 slen
, fold_convert (gfc_array_index_type
, tmp
));
7567 /* Sanity check that they are the same. This should always be
7568 the case, as we should already have checked for conformance. */
7569 if (!tree_int_cst_equal (slen
, dlen
))
7572 return gfc_build_memcpy_call (dst
, src
, dlen
);
7576 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7577 this can't be done. EXPR1 is the destination/lhs for which
7578 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7581 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7583 unsigned HOST_WIDE_INT nelem
;
7589 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7593 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7594 dtype
= TREE_TYPE (dst
);
7595 if (POINTER_TYPE_P (dtype
))
7596 dtype
= TREE_TYPE (dtype
);
7597 if (!GFC_ARRAY_TYPE_P (dtype
))
7600 /* Determine the lengths of the array. */
7601 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7602 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7605 /* Confirm that the constructor is the same size. */
7606 if (compare_tree_int (len
, nelem
) != 0)
7609 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7610 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7611 fold_convert (gfc_array_index_type
, tmp
));
7613 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7614 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7616 stype
= TREE_TYPE (src
);
7617 if (POINTER_TYPE_P (stype
))
7618 stype
= TREE_TYPE (stype
);
7620 return gfc_build_memcpy_call (dst
, src
, len
);
7624 /* Tells whether the expression is to be treated as a variable reference. */
7627 expr_is_variable (gfc_expr
*expr
)
7630 gfc_component
*comp
;
7631 gfc_symbol
*func_ifc
;
7633 if (expr
->expr_type
== EXPR_VARIABLE
)
7636 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7639 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7640 return expr_is_variable (arg
);
7643 /* A data-pointer-returning function should be considered as a variable
7645 if (expr
->expr_type
== EXPR_FUNCTION
7646 && expr
->ref
== NULL
)
7648 if (expr
->value
.function
.isym
!= NULL
)
7651 if (expr
->value
.function
.esym
!= NULL
)
7653 func_ifc
= expr
->value
.function
.esym
;
7658 gcc_assert (expr
->symtree
);
7659 func_ifc
= expr
->symtree
->n
.sym
;
7666 comp
= gfc_get_proc_ptr_comp (expr
);
7667 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7670 func_ifc
= comp
->ts
.interface
;
7674 if (expr
->expr_type
== EXPR_COMPCALL
)
7676 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7677 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7684 gcc_assert (func_ifc
->attr
.function
7685 && func_ifc
->result
!= NULL
);
7686 return func_ifc
->result
->attr
.pointer
;
7690 /* Is the lhs OK for automatic reallocation? */
7693 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7697 /* An allocatable variable with no reference. */
7698 if (expr
->symtree
->n
.sym
->attr
.allocatable
7702 /* All that can be left are allocatable components. */
7703 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7704 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7705 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7708 /* Find an allocatable component ref last. */
7709 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7710 if (ref
->type
== REF_COMPONENT
7712 && ref
->u
.c
.component
->attr
.allocatable
)
7719 /* Allocate or reallocate scalar lhs, as necessary. */
7722 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7736 if (!expr1
|| expr1
->rank
)
7739 if (!expr2
|| expr2
->rank
)
7742 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7744 /* Since this is a scalar lhs, we can afford to do this. That is,
7745 there is no risk of side effects being repeated. */
7746 gfc_init_se (&lse
, NULL
);
7747 lse
.want_pointer
= 1;
7748 gfc_conv_expr (&lse
, expr1
);
7750 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7751 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7753 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7754 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7755 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7757 tmp
= build3_v (COND_EXPR
, cond
,
7758 build1_v (GOTO_EXPR
, jump_label1
),
7759 build_empty_stmt (input_location
));
7760 gfc_add_expr_to_block (block
, tmp
);
7762 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7764 /* Use the rhs string length and the lhs element size. */
7765 size
= string_length
;
7766 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7767 tmp
= TYPE_SIZE_UNIT (tmp
);
7768 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7769 TREE_TYPE (tmp
), tmp
,
7770 fold_convert (TREE_TYPE (tmp
), size
));
7774 /* Otherwise use the length in bytes of the rhs. */
7775 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7776 size_in_bytes
= size
;
7779 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7780 size_in_bytes
, size_one_node
);
7782 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7784 tmp
= build_call_expr_loc (input_location
,
7785 builtin_decl_explicit (BUILT_IN_CALLOC
),
7786 2, build_one_cst (size_type_node
),
7788 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7789 gfc_add_modify (block
, lse
.expr
, tmp
);
7793 tmp
= build_call_expr_loc (input_location
,
7794 builtin_decl_explicit (BUILT_IN_MALLOC
),
7796 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7797 gfc_add_modify (block
, lse
.expr
, tmp
);
7800 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7802 /* Deferred characters need checking for lhs and rhs string
7803 length. Other deferred parameter variables will have to
7805 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7806 gfc_add_expr_to_block (block
, tmp
);
7808 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7809 gfc_add_expr_to_block (block
, tmp
);
7811 /* For a deferred length character, reallocate if lengths of lhs and
7812 rhs are different. */
7813 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7815 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7816 expr1
->ts
.u
.cl
->backend_decl
, size
);
7817 /* Jump past the realloc if the lengths are the same. */
7818 tmp
= build3_v (COND_EXPR
, cond
,
7819 build1_v (GOTO_EXPR
, jump_label2
),
7820 build_empty_stmt (input_location
));
7821 gfc_add_expr_to_block (block
, tmp
);
7822 tmp
= build_call_expr_loc (input_location
,
7823 builtin_decl_explicit (BUILT_IN_REALLOC
),
7824 2, fold_convert (pvoid_type_node
, lse
.expr
),
7826 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7827 gfc_add_modify (block
, lse
.expr
, tmp
);
7828 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7829 gfc_add_expr_to_block (block
, tmp
);
7831 /* Update the lhs character length. */
7832 size
= string_length
;
7833 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
7834 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7836 gfc_add_modify (block
, lse
.string_length
, size
);
7840 /* Check for assignments of the type
7844 to make sure we do not check for reallocation unneccessarily. */
7848 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7850 gfc_actual_arglist
*a
;
7853 switch (expr2
->expr_type
)
7856 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7859 if (expr2
->value
.function
.esym
7860 && expr2
->value
.function
.esym
->attr
.elemental
)
7862 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7865 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7870 else if (expr2
->value
.function
.isym
7871 && expr2
->value
.function
.isym
->elemental
)
7873 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7876 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7885 switch (expr2
->value
.op
.op
)
7888 case INTRINSIC_UPLUS
:
7889 case INTRINSIC_UMINUS
:
7890 case INTRINSIC_PARENTHESES
:
7891 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7893 case INTRINSIC_PLUS
:
7894 case INTRINSIC_MINUS
:
7895 case INTRINSIC_TIMES
:
7896 case INTRINSIC_DIVIDE
:
7897 case INTRINSIC_POWER
:
7901 case INTRINSIC_NEQV
:
7908 case INTRINSIC_EQ_OS
:
7909 case INTRINSIC_NE_OS
:
7910 case INTRINSIC_GT_OS
:
7911 case INTRINSIC_GE_OS
:
7912 case INTRINSIC_LT_OS
:
7913 case INTRINSIC_LE_OS
:
7915 e1
= expr2
->value
.op
.op1
;
7916 e2
= expr2
->value
.op
.op2
;
7918 if (e1
->rank
== 0 && e2
->rank
> 0)
7919 return is_runtime_conformable (expr1
, e2
);
7920 else if (e1
->rank
> 0 && e2
->rank
== 0)
7921 return is_runtime_conformable (expr1
, e1
);
7922 else if (e1
->rank
> 0 && e2
->rank
> 0)
7923 return is_runtime_conformable (expr1
, e1
)
7924 && is_runtime_conformable (expr1
, e2
);
7940 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7941 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7942 init_flag indicates initialization expressions and dealloc that no
7943 deallocate prior assignment is needed (if in doubt, set true). */
7946 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7952 gfc_ss
*lss_section
;
7959 bool scalar_to_array
;
7963 /* Assignment of the form lhs = rhs. */
7964 gfc_start_block (&block
);
7966 gfc_init_se (&lse
, NULL
);
7967 gfc_init_se (&rse
, NULL
);
7970 lss
= gfc_walk_expr (expr1
);
7971 if (gfc_is_reallocatable_lhs (expr1
)
7972 && !(expr2
->expr_type
== EXPR_FUNCTION
7973 && expr2
->value
.function
.isym
!= NULL
))
7974 lss
->is_alloc_lhs
= 1;
7976 if (lss
!= gfc_ss_terminator
)
7978 /* The assignment needs scalarization. */
7981 /* Find a non-scalar SS from the lhs. */
7982 while (lss_section
!= gfc_ss_terminator
7983 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7984 lss_section
= lss_section
->next
;
7986 gcc_assert (lss_section
!= gfc_ss_terminator
);
7988 /* Initialize the scalarizer. */
7989 gfc_init_loopinfo (&loop
);
7992 rss
= gfc_walk_expr (expr2
);
7993 if (rss
== gfc_ss_terminator
)
7994 /* The rhs is scalar. Add a ss for the expression. */
7995 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7997 /* Associate the SS with the loop. */
7998 gfc_add_ss_to_loop (&loop
, lss
);
7999 gfc_add_ss_to_loop (&loop
, rss
);
8001 /* Calculate the bounds of the scalarization. */
8002 gfc_conv_ss_startstride (&loop
);
8003 /* Enable loop reversal. */
8004 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8005 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8006 /* Resolve any data dependencies in the statement. */
8007 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8008 /* Setup the scalarizing loops. */
8009 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8011 /* Setup the gfc_se structures. */
8012 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8013 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8016 gfc_mark_ss_chain_used (rss
, 1);
8017 if (loop
.temp_ss
== NULL
)
8020 gfc_mark_ss_chain_used (lss
, 1);
8024 lse
.ss
= loop
.temp_ss
;
8025 gfc_mark_ss_chain_used (lss
, 3);
8026 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8029 /* Allow the scalarizer to workshare array assignments. */
8030 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8031 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8033 /* Start the scalarized loop body. */
8034 gfc_start_scalarized_body (&loop
, &body
);
8037 gfc_init_block (&body
);
8039 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8041 /* Translate the expression. */
8042 gfc_conv_expr (&rse
, expr2
);
8044 /* Stabilize a string length for temporaries. */
8045 if (expr2
->ts
.type
== BT_CHARACTER
)
8046 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8048 string_length
= NULL_TREE
;
8052 gfc_conv_tmp_array_ref (&lse
);
8053 if (expr2
->ts
.type
== BT_CHARACTER
)
8054 lse
.string_length
= string_length
;
8057 gfc_conv_expr (&lse
, expr1
);
8059 /* Assignments of scalar derived types with allocatable components
8060 to arrays must be done with a deep copy and the rhs temporary
8061 must have its components deallocated afterwards. */
8062 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8063 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8064 && !expr_is_variable (expr2
)
8065 && !gfc_is_constant_expr (expr2
)
8066 && expr1
->rank
&& !expr2
->rank
);
8067 if (scalar_to_array
&& dealloc
)
8069 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8070 gfc_add_expr_to_block (&loop
.post
, tmp
);
8073 /* When assigning a character function result to a deferred-length variable,
8074 the function call must happen before the (re)allocation of the lhs -
8075 otherwise the character length of the result is not known.
8076 NOTE: This relies on having the exact dependence of the length type
8077 parameter available to the caller; gfortran saves it in the .mod files. */
8078 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
8079 && expr1
->ts
.deferred
)
8080 gfc_add_block_to_block (&block
, &rse
.pre
);
8082 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8083 l_is_temp
|| init_flag
,
8084 expr_is_variable (expr2
) || scalar_to_array
8085 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8086 gfc_add_expr_to_block (&body
, tmp
);
8088 if (lss
== gfc_ss_terminator
)
8090 /* F2003: Add the code for reallocation on assignment. */
8091 if (gfc_option
.flag_realloc_lhs
8092 && is_scalar_reallocatable_lhs (expr1
))
8093 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8096 /* Use the scalar assignment as is. */
8097 gfc_add_block_to_block (&block
, &body
);
8101 gcc_assert (lse
.ss
== gfc_ss_terminator
8102 && rse
.ss
== gfc_ss_terminator
);
8106 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8108 /* We need to copy the temporary to the actual lhs. */
8109 gfc_init_se (&lse
, NULL
);
8110 gfc_init_se (&rse
, NULL
);
8111 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8112 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8114 rse
.ss
= loop
.temp_ss
;
8117 gfc_conv_tmp_array_ref (&rse
);
8118 gfc_conv_expr (&lse
, expr1
);
8120 gcc_assert (lse
.ss
== gfc_ss_terminator
8121 && rse
.ss
== gfc_ss_terminator
);
8123 if (expr2
->ts
.type
== BT_CHARACTER
)
8124 rse
.string_length
= string_length
;
8126 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8127 false, false, dealloc
);
8128 gfc_add_expr_to_block (&body
, tmp
);
8131 /* F2003: Allocate or reallocate lhs of allocatable array. */
8132 if (gfc_option
.flag_realloc_lhs
8133 && gfc_is_reallocatable_lhs (expr1
)
8134 && !gfc_expr_attr (expr1
).codimension
8135 && !gfc_is_coindexed (expr1
)
8137 && !is_runtime_conformable (expr1
, expr2
))
8139 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8140 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8141 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8142 if (tmp
!= NULL_TREE
)
8143 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8146 /* Generate the copying loops. */
8147 gfc_trans_scalarizing_loops (&loop
, &body
);
8149 /* Wrap the whole thing up. */
8150 gfc_add_block_to_block (&block
, &loop
.pre
);
8151 gfc_add_block_to_block (&block
, &loop
.post
);
8153 gfc_cleanup_loop (&loop
);
8156 return gfc_finish_block (&block
);
8160 /* Check whether EXPR is a copyable array. */
8163 copyable_array_p (gfc_expr
* expr
)
8165 if (expr
->expr_type
!= EXPR_VARIABLE
)
8168 /* First check it's an array. */
8169 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8172 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8175 /* Next check that it's of a simple enough type. */
8176 switch (expr
->ts
.type
)
8188 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8197 /* Translate an assignment. */
8200 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8205 /* Special case a single function returning an array. */
8206 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8208 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8213 /* Special case assigning an array to zero. */
8214 if (copyable_array_p (expr1
)
8215 && is_zero_initializer_p (expr2
))
8217 tmp
= gfc_trans_zero_assign (expr1
);
8222 /* Special case copying one array to another. */
8223 if (copyable_array_p (expr1
)
8224 && copyable_array_p (expr2
)
8225 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8226 && !gfc_check_dependency (expr1
, expr2
, 0))
8228 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8233 /* Special case initializing an array from a constant array constructor. */
8234 if (copyable_array_p (expr1
)
8235 && expr2
->expr_type
== EXPR_ARRAY
8236 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8238 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8243 /* Fallback to the scalarizer to generate explicit loops. */
8244 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8248 gfc_trans_init_assign (gfc_code
* code
)
8250 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8254 gfc_trans_assign (gfc_code
* code
)
8256 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);