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
)
1390 tree caf_decl
= NULL_TREE
;
1393 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1394 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1395 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1397 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1398 if (ref
->type
== REF_COMPONENT
)
1400 gfc_component
*comp
= ref
->u
.c
.component
;
1401 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
1402 caf_decl
= NULL_TREE
;
1403 if (comp
->attr
.codimension
)
1404 caf_decl
= comp
->backend_decl
;
1407 gcc_assert (caf_decl
!= NULL_TREE
);
1412 /* For each character array constructor subexpression without a ts.u.cl->length,
1413 replace it by its first element (if there aren't any elements, the length
1414 should already be set to zero). */
1417 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1419 gfc_actual_arglist
* arg
;
1425 switch (e
->expr_type
)
1429 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1430 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1434 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1438 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1439 flatten_array_ctors_without_strlen (arg
->expr
);
1444 /* We've found what we're looking for. */
1445 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1450 gcc_assert (e
->value
.constructor
);
1452 c
= gfc_constructor_first (e
->value
.constructor
);
1456 flatten_array_ctors_without_strlen (new_expr
);
1457 gfc_replace_expr (e
, new_expr
);
1461 /* Otherwise, fall through to handle constructor elements. */
1462 case EXPR_STRUCTURE
:
1463 for (c
= gfc_constructor_first (e
->value
.constructor
);
1464 c
; c
= gfc_constructor_next (c
))
1465 flatten_array_ctors_without_strlen (c
->expr
);
1475 /* Generate code to initialize a string length variable. Returns the
1476 value. For array constructors, cl->length might be NULL and in this case,
1477 the first element of the constructor is needed. expr is the original
1478 expression so we can access it but can be NULL if this is not needed. */
1481 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1485 gfc_init_se (&se
, NULL
);
1489 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1492 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1493 "flatten" array constructors by taking their first element; all elements
1494 should be the same length or a cl->length should be present. */
1497 gfc_expr
* expr_flat
;
1499 expr_flat
= gfc_copy_expr (expr
);
1500 flatten_array_ctors_without_strlen (expr_flat
);
1501 gfc_resolve_expr (expr_flat
);
1503 gfc_conv_expr (&se
, expr_flat
);
1504 gfc_add_block_to_block (pblock
, &se
.pre
);
1505 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1507 gfc_free_expr (expr_flat
);
1511 /* Convert cl->length. */
1513 gcc_assert (cl
->length
);
1515 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1516 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1517 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1518 gfc_add_block_to_block (pblock
, &se
.pre
);
1520 if (cl
->backend_decl
)
1521 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1523 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1528 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1529 const char *name
, locus
*where
)
1539 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1540 type
= build_pointer_type (type
);
1542 gfc_init_se (&start
, se
);
1543 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1544 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1546 if (integer_onep (start
.expr
))
1547 gfc_conv_string_parameter (se
);
1552 /* Avoid multiple evaluation of substring start. */
1553 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1554 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1556 /* Change the start of the string. */
1557 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1560 tmp
= build_fold_indirect_ref_loc (input_location
,
1562 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1563 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1566 /* Length = end + 1 - start. */
1567 gfc_init_se (&end
, se
);
1568 if (ref
->u
.ss
.end
== NULL
)
1569 end
.expr
= se
->string_length
;
1572 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1573 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1577 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1578 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1580 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1582 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1583 boolean_type_node
, start
.expr
,
1586 /* Check lower bound. */
1587 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1589 build_int_cst (gfc_charlen_type_node
, 1));
1590 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1591 boolean_type_node
, nonempty
, fault
);
1593 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1594 "is less than one", name
);
1596 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1597 "is less than one");
1598 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1599 fold_convert (long_integer_type_node
,
1603 /* Check upper bound. */
1604 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1605 end
.expr
, se
->string_length
);
1606 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1607 boolean_type_node
, nonempty
, fault
);
1609 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1610 "exceeds string length (%%ld)", name
);
1612 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1613 "exceeds string length (%%ld)");
1614 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1615 fold_convert (long_integer_type_node
, end
.expr
),
1616 fold_convert (long_integer_type_node
,
1617 se
->string_length
));
1621 /* Try to calculate the length from the start and end expressions. */
1623 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1627 i_len
= mpz_get_si (length
) + 1;
1631 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1632 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1636 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1637 end
.expr
, start
.expr
);
1638 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1639 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1640 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1641 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1644 se
->string_length
= tmp
;
1648 /* Convert a derived type component reference. */
1651 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1658 c
= ref
->u
.c
.component
;
1660 if (c
->backend_decl
== NULL_TREE
1661 && ref
->u
.c
.sym
!= NULL
)
1662 gfc_get_derived_type (ref
->u
.c
.sym
);
1664 field
= c
->backend_decl
;
1665 gcc_assert (field
&& TREE_CODE (field
) == FIELD_DECL
);
1668 /* Components can correspond to fields of different containing
1669 types, as components are created without context, whereas
1670 a concrete use of a component has the type of decl as context.
1671 So, if the type doesn't match, we search the corresponding
1672 FIELD_DECL in the parent type. To not waste too much time
1673 we cache this result in norestrict_decl. */
1675 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1677 tree f2
= c
->norestrict_decl
;
1678 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1679 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1680 if (TREE_CODE (f2
) == FIELD_DECL
1681 && DECL_NAME (f2
) == DECL_NAME (field
))
1684 c
->norestrict_decl
= f2
;
1688 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1689 decl
, field
, NULL_TREE
);
1693 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1695 tmp
= c
->ts
.u
.cl
->backend_decl
;
1696 /* Components must always be constant length. */
1697 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1698 se
->string_length
= tmp
;
1701 if (gfc_deferred_strlen (c
, &field
))
1703 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1705 decl
, field
, NULL_TREE
);
1706 se
->string_length
= tmp
;
1709 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1710 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1711 && c
->ts
.type
!= BT_CHARACTER
)
1712 || c
->attr
.proc_pointer
)
1713 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1718 /* This function deals with component references to components of the
1719 parent type for derived type extensions. */
1721 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1729 c
= ref
->u
.c
.component
;
1731 /* Return if the component is in the parent type. */
1732 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1733 if (strcmp (c
->name
, cmp
->name
) == 0)
1736 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1737 parent
.type
= REF_COMPONENT
;
1739 parent
.u
.c
.sym
= dt
;
1740 parent
.u
.c
.component
= dt
->components
;
1742 if (dt
->backend_decl
== NULL
)
1743 gfc_get_derived_type (dt
);
1745 /* Build the reference and call self. */
1746 gfc_conv_component_ref (se
, &parent
);
1747 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1748 parent
.u
.c
.component
= c
;
1749 conv_parent_component_references (se
, &parent
);
1752 /* Return the contents of a variable. Also handles reference/pointer
1753 variables (all Fortran pointer references are implicit). */
1756 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1761 tree parent_decl
= NULL_TREE
;
1764 bool alternate_entry
;
1767 sym
= expr
->symtree
->n
.sym
;
1771 gfc_ss_info
*ss_info
= ss
->info
;
1773 /* Check that something hasn't gone horribly wrong. */
1774 gcc_assert (ss
!= gfc_ss_terminator
);
1775 gcc_assert (ss_info
->expr
== expr
);
1777 /* A scalarized term. We already know the descriptor. */
1778 se
->expr
= ss_info
->data
.array
.descriptor
;
1779 se
->string_length
= ss_info
->string_length
;
1780 ref
= ss_info
->data
.array
.ref
;
1782 gcc_assert (ref
->type
== REF_ARRAY
1783 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1785 gfc_conv_tmp_array_ref (se
);
1789 tree se_expr
= NULL_TREE
;
1791 se
->expr
= gfc_get_symbol_decl (sym
);
1793 /* Deal with references to a parent results or entries by storing
1794 the current_function_decl and moving to the parent_decl. */
1795 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1796 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1797 && sym
->result
== sym
;
1798 entry_master
= sym
->attr
.result
1799 && sym
->ns
->proc_name
->attr
.entry_master
1800 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1801 if (current_function_decl
)
1802 parent_decl
= DECL_CONTEXT (current_function_decl
);
1804 if ((se
->expr
== parent_decl
&& return_value
)
1805 || (sym
->ns
&& sym
->ns
->proc_name
1807 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1808 && (alternate_entry
|| entry_master
)))
1813 /* Special case for assigning the return value of a function.
1814 Self recursive functions must have an explicit return value. */
1815 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1816 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1818 /* Similarly for alternate entry points. */
1819 else if (alternate_entry
1820 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1823 gfc_entry_list
*el
= NULL
;
1825 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1828 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1833 else if (entry_master
1834 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1836 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1841 /* Procedure actual arguments. */
1842 else if (sym
->attr
.flavor
== FL_PROCEDURE
1843 && se
->expr
!= current_function_decl
)
1845 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1847 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1848 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1854 /* Dereference the expression, where needed. Since characters
1855 are entirely different from other types, they are treated
1857 if (sym
->ts
.type
== BT_CHARACTER
)
1859 /* Dereference character pointer dummy arguments
1861 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1863 || sym
->attr
.function
1864 || sym
->attr
.result
))
1865 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1869 else if (!sym
->attr
.value
)
1871 /* Dereference non-character scalar dummy arguments. */
1872 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1873 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1874 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1877 /* Dereference scalar hidden result. */
1878 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1879 && (sym
->attr
.function
|| sym
->attr
.result
)
1880 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1881 && !sym
->attr
.always_explicit
)
1882 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1885 /* Dereference non-character pointer variables.
1886 These must be dummies, results, or scalars. */
1887 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1888 || gfc_is_associate_pointer (sym
)
1889 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1891 || sym
->attr
.function
1893 || (!sym
->attr
.dimension
1894 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1895 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1902 /* For character variables, also get the length. */
1903 if (sym
->ts
.type
== BT_CHARACTER
)
1905 /* If the character length of an entry isn't set, get the length from
1906 the master function instead. */
1907 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1908 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1910 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1911 gcc_assert (se
->string_length
);
1919 /* Return the descriptor if that's what we want and this is an array
1920 section reference. */
1921 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1923 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1924 /* Return the descriptor for array pointers and allocations. */
1925 if (se
->want_pointer
1926 && ref
->next
== NULL
&& (se
->descriptor_only
))
1929 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1930 /* Return a pointer to an element. */
1934 if (ref
->u
.c
.sym
->attr
.extension
)
1935 conv_parent_component_references (se
, ref
);
1937 gfc_conv_component_ref (se
, ref
);
1938 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1939 && se
->want_pointer
&& se
->descriptor_only
)
1945 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1946 expr
->symtree
->name
, &expr
->where
);
1955 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1957 if (se
->want_pointer
)
1959 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1960 gfc_conv_string_parameter (se
);
1962 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1967 /* Unary ops are easy... Or they would be if ! was a valid op. */
1970 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1975 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1976 /* Initialize the operand. */
1977 gfc_init_se (&operand
, se
);
1978 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1979 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1981 type
= gfc_typenode_for_spec (&expr
->ts
);
1983 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1984 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1985 All other unary operators have an equivalent GIMPLE unary operator. */
1986 if (code
== TRUTH_NOT_EXPR
)
1987 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1988 build_int_cst (type
, 0));
1990 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1994 /* Expand power operator to optimal multiplications when a value is raised
1995 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1996 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1997 Programming", 3rd Edition, 1998. */
1999 /* This code is mostly duplicated from expand_powi in the backend.
2000 We establish the "optimal power tree" lookup table with the defined size.
2001 The items in the table are the exponents used to calculate the index
2002 exponents. Any integer n less than the value can get an "addition chain",
2003 with the first node being one. */
2004 #define POWI_TABLE_SIZE 256
2006 /* The table is from builtins.c. */
2007 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2009 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2010 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2011 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2012 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2013 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2014 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2015 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2016 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2017 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2018 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2019 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2020 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2021 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2022 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2023 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2024 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2025 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2026 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2027 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2028 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2029 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2030 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2031 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2032 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2033 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2034 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2035 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2036 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2037 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2038 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2039 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2040 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2043 /* If n is larger than lookup table's max index, we use the "window
2045 #define POWI_WINDOW_SIZE 3
2047 /* Recursive function to expand the power operator. The temporary
2048 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2050 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2057 if (n
< POWI_TABLE_SIZE
)
2062 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2063 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2067 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2068 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2069 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2073 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2077 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2078 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2080 if (n
< POWI_TABLE_SIZE
)
2087 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2088 return 1. Else return 0 and a call to runtime library functions
2089 will have to be built. */
2091 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2096 tree vartmp
[POWI_TABLE_SIZE
];
2098 unsigned HOST_WIDE_INT n
;
2101 /* If exponent is too large, we won't expand it anyway, so don't bother
2102 with large integer values. */
2103 if (!TREE_INT_CST (rhs
).fits_shwi ())
2106 m
= TREE_INT_CST (rhs
).to_shwi ();
2107 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2108 of the asymmetric range of the integer type. */
2109 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2111 type
= TREE_TYPE (lhs
);
2112 sgn
= tree_int_cst_sgn (rhs
);
2114 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2115 || optimize_size
) && (m
> 2 || m
< -1))
2121 se
->expr
= gfc_build_const (type
, integer_one_node
);
2125 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2126 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2128 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2129 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2130 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2131 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2134 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2137 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2138 boolean_type_node
, tmp
, cond
);
2139 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2140 tmp
, build_int_cst (type
, 1),
2141 build_int_cst (type
, 0));
2145 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2146 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2147 build_int_cst (type
, -1),
2148 build_int_cst (type
, 0));
2149 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2150 cond
, build_int_cst (type
, 1), tmp
);
2154 memset (vartmp
, 0, sizeof (vartmp
));
2158 tmp
= gfc_build_const (type
, integer_one_node
);
2159 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2163 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2169 /* Power op (**). Constant integer exponent has special handling. */
2172 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2174 tree gfc_int4_type_node
;
2177 int res_ikind_1
, res_ikind_2
;
2182 gfc_init_se (&lse
, se
);
2183 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2184 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2185 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2187 gfc_init_se (&rse
, se
);
2188 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2189 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2191 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2192 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2193 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2196 gfc_int4_type_node
= gfc_get_int_type (4);
2198 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2199 library routine. But in the end, we have to convert the result back
2200 if this case applies -- with res_ikind_K, we keep track whether operand K
2201 falls into this case. */
2205 kind
= expr
->value
.op
.op1
->ts
.kind
;
2206 switch (expr
->value
.op
.op2
->ts
.type
)
2209 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2214 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2215 res_ikind_2
= ikind
;
2237 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2239 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2266 switch (expr
->value
.op
.op1
->ts
.type
)
2269 if (kind
== 3) /* Case 16 was not handled properly above. */
2271 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2275 /* Use builtins for real ** int4. */
2281 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2285 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2289 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2293 /* Use the __builtin_powil() only if real(kind=16) is
2294 actually the C long double type. */
2295 if (!gfc_real16_is_float128
)
2296 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2304 /* If we don't have a good builtin for this, go for the
2305 library function. */
2307 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2311 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2320 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2324 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2332 se
->expr
= build_call_expr_loc (input_location
,
2333 fndecl
, 2, lse
.expr
, rse
.expr
);
2335 /* Convert the result back if it is of wrong integer kind. */
2336 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2338 /* We want the maximum of both operand kinds as result. */
2339 if (res_ikind_1
< res_ikind_2
)
2340 res_ikind_1
= res_ikind_2
;
2341 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2346 /* Generate code to allocate a string temporary. */
2349 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2354 if (gfc_can_put_var_on_stack (len
))
2356 /* Create a temporary variable to hold the result. */
2357 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2358 gfc_charlen_type_node
, len
,
2359 build_int_cst (gfc_charlen_type_node
, 1));
2360 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2362 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2363 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2365 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2367 var
= gfc_create_var (tmp
, "str");
2368 var
= gfc_build_addr_expr (type
, var
);
2372 /* Allocate a temporary to hold the result. */
2373 var
= gfc_create_var (type
, "pstr");
2374 gcc_assert (POINTER_TYPE_P (type
));
2375 tmp
= TREE_TYPE (type
);
2376 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2377 tmp
= TREE_TYPE (tmp
);
2378 tmp
= TYPE_SIZE_UNIT (tmp
);
2379 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2380 fold_convert (size_type_node
, len
),
2381 fold_convert (size_type_node
, tmp
));
2382 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2383 gfc_add_modify (&se
->pre
, var
, tmp
);
2385 /* Free the temporary afterwards. */
2386 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2387 gfc_add_expr_to_block (&se
->post
, tmp
);
2394 /* Handle a string concatenation operation. A temporary will be allocated to
2398 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2401 tree len
, type
, var
, tmp
, fndecl
;
2403 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2404 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2405 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2407 gfc_init_se (&lse
, se
);
2408 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2409 gfc_conv_string_parameter (&lse
);
2410 gfc_init_se (&rse
, se
);
2411 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2412 gfc_conv_string_parameter (&rse
);
2414 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2415 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2417 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2418 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2419 if (len
== NULL_TREE
)
2421 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2422 TREE_TYPE (lse
.string_length
),
2423 lse
.string_length
, rse
.string_length
);
2426 type
= build_pointer_type (type
);
2428 var
= gfc_conv_string_tmp (se
, type
, len
);
2430 /* Do the actual concatenation. */
2431 if (expr
->ts
.kind
== 1)
2432 fndecl
= gfor_fndecl_concat_string
;
2433 else if (expr
->ts
.kind
== 4)
2434 fndecl
= gfor_fndecl_concat_string_char4
;
2438 tmp
= build_call_expr_loc (input_location
,
2439 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2440 rse
.string_length
, rse
.expr
);
2441 gfc_add_expr_to_block (&se
->pre
, tmp
);
2443 /* Add the cleanup for the operands. */
2444 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2445 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2448 se
->string_length
= len
;
2451 /* Translates an op expression. Common (binary) cases are handled by this
2452 function, others are passed on. Recursion is used in either case.
2453 We use the fact that (op1.ts == op2.ts) (except for the power
2455 Operators need no special handling for scalarized expressions as long as
2456 they call gfc_conv_simple_val to get their operands.
2457 Character strings get special handling. */
2460 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2462 enum tree_code code
;
2471 switch (expr
->value
.op
.op
)
2473 case INTRINSIC_PARENTHESES
:
2474 if ((expr
->ts
.type
== BT_REAL
2475 || expr
->ts
.type
== BT_COMPLEX
)
2476 && gfc_option
.flag_protect_parens
)
2478 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2479 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2484 case INTRINSIC_UPLUS
:
2485 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2488 case INTRINSIC_UMINUS
:
2489 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2493 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2496 case INTRINSIC_PLUS
:
2500 case INTRINSIC_MINUS
:
2504 case INTRINSIC_TIMES
:
2508 case INTRINSIC_DIVIDE
:
2509 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2510 an integer, we must round towards zero, so we use a
2512 if (expr
->ts
.type
== BT_INTEGER
)
2513 code
= TRUNC_DIV_EXPR
;
2518 case INTRINSIC_POWER
:
2519 gfc_conv_power_op (se
, expr
);
2522 case INTRINSIC_CONCAT
:
2523 gfc_conv_concat_op (se
, expr
);
2527 code
= TRUTH_ANDIF_EXPR
;
2532 code
= TRUTH_ORIF_EXPR
;
2536 /* EQV and NEQV only work on logicals, but since we represent them
2537 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2539 case INTRINSIC_EQ_OS
:
2547 case INTRINSIC_NE_OS
:
2548 case INTRINSIC_NEQV
:
2555 case INTRINSIC_GT_OS
:
2562 case INTRINSIC_GE_OS
:
2569 case INTRINSIC_LT_OS
:
2576 case INTRINSIC_LE_OS
:
2582 case INTRINSIC_USER
:
2583 case INTRINSIC_ASSIGN
:
2584 /* These should be converted into function calls by the frontend. */
2588 fatal_error ("Unknown intrinsic op");
2592 /* The only exception to this is **, which is handled separately anyway. */
2593 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2595 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2599 gfc_init_se (&lse
, se
);
2600 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2601 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2604 gfc_init_se (&rse
, se
);
2605 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2606 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2610 gfc_conv_string_parameter (&lse
);
2611 gfc_conv_string_parameter (&rse
);
2613 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2614 rse
.string_length
, rse
.expr
,
2615 expr
->value
.op
.op1
->ts
.kind
,
2617 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2618 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2621 type
= gfc_typenode_for_spec (&expr
->ts
);
2625 /* The result of logical ops is always boolean_type_node. */
2626 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2627 lse
.expr
, rse
.expr
);
2628 se
->expr
= convert (type
, tmp
);
2631 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2633 /* Add the post blocks. */
2634 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2635 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2638 /* If a string's length is one, we convert it to a single character. */
2641 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2645 || !INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2646 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2649 if (TREE_INT_CST_LOW (len
) == 1)
2651 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2652 return build_fold_indirect_ref_loc (input_location
, str
);
2656 && TREE_CODE (str
) == ADDR_EXPR
2657 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2658 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2659 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2660 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2661 && TREE_INT_CST_LOW (len
) > 1
2662 && TREE_INT_CST_LOW (len
)
2663 == (unsigned HOST_WIDE_INT
)
2664 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2666 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2667 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2668 if (TREE_CODE (ret
) == INTEGER_CST
)
2670 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2671 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2672 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2674 for (i
= 1; i
< length
; i
++)
2687 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2690 if (sym
->backend_decl
)
2692 /* This becomes the nominal_type in
2693 function.c:assign_parm_find_data_types. */
2694 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2695 /* This becomes the passed_type in
2696 function.c:assign_parm_find_data_types. C promotes char to
2697 integer for argument passing. */
2698 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2700 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2705 /* If we have a constant character expression, make it into an
2707 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2712 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2713 (int)(*expr
)->value
.character
.string
[0]);
2714 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2716 /* The expr needs to be compatible with a C int. If the
2717 conversion fails, then the 2 causes an ICE. */
2718 ts
.type
= BT_INTEGER
;
2719 ts
.kind
= gfc_c_int_kind
;
2720 gfc_convert_type (*expr
, &ts
, 2);
2723 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2725 if ((*expr
)->ref
== NULL
)
2727 se
->expr
= gfc_string_to_single_character
2728 (build_int_cst (integer_type_node
, 1),
2729 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2731 ((*expr
)->symtree
->n
.sym
)),
2736 gfc_conv_variable (se
, *expr
);
2737 se
->expr
= gfc_string_to_single_character
2738 (build_int_cst (integer_type_node
, 1),
2739 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2747 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2748 if STR is a string literal, otherwise return -1. */
2751 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2754 && TREE_CODE (str
) == ADDR_EXPR
2755 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2756 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2757 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2758 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2759 && TREE_INT_CST_LOW (len
) >= 1
2760 && TREE_INT_CST_LOW (len
)
2761 == (unsigned HOST_WIDE_INT
)
2762 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2764 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2765 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2766 if (TREE_CODE (folded
) == INTEGER_CST
)
2768 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2769 int length
= TREE_STRING_LENGTH (string_cst
);
2770 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2772 for (; length
> 0; length
--)
2773 if (ptr
[length
- 1] != ' ')
2782 /* Helper to build a call to memcmp. */
2785 build_memcmp_call (tree s1
, tree s2
, tree n
)
2789 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2790 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2792 s1
= fold_convert (pvoid_type_node
, s1
);
2794 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2795 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2797 s2
= fold_convert (pvoid_type_node
, s2
);
2799 n
= fold_convert (size_type_node
, n
);
2801 tmp
= build_call_expr_loc (input_location
,
2802 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2805 return fold_convert (integer_type_node
, tmp
);
2808 /* Compare two strings. If they are all single characters, the result is the
2809 subtraction of them. Otherwise, we build a library call. */
2812 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2813 enum tree_code code
)
2819 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2820 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2822 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2823 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2825 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2827 /* Deal with single character specially. */
2828 sc1
= fold_convert (integer_type_node
, sc1
);
2829 sc2
= fold_convert (integer_type_node
, sc2
);
2830 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2834 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2836 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2838 /* If one string is a string literal with LEN_TRIM longer
2839 than the length of the second string, the strings
2841 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2842 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2843 return integer_one_node
;
2844 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2845 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2846 return integer_one_node
;
2849 /* We can compare via memcpy if the strings are known to be equal
2850 in length and they are
2852 - kind=4 and the comparison is for (in)equality. */
2854 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2855 && tree_int_cst_equal (len1
, len2
)
2856 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2861 chartype
= gfc_get_char_type (kind
);
2862 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2863 fold_convert (TREE_TYPE(len1
),
2864 TYPE_SIZE_UNIT(chartype
)),
2866 return build_memcmp_call (str1
, str2
, tmp
);
2869 /* Build a call for the comparison. */
2871 fndecl
= gfor_fndecl_compare_string
;
2873 fndecl
= gfor_fndecl_compare_string_char4
;
2877 return build_call_expr_loc (input_location
, fndecl
, 4,
2878 len1
, str1
, len2
, str2
);
2882 /* Return the backend_decl for a procedure pointer component. */
2885 get_proc_ptr_comp (gfc_expr
*e
)
2891 gfc_init_se (&comp_se
, NULL
);
2892 e2
= gfc_copy_expr (e
);
2893 /* We have to restore the expr type later so that gfc_free_expr frees
2894 the exact same thing that was allocated.
2895 TODO: This is ugly. */
2896 old_type
= e2
->expr_type
;
2897 e2
->expr_type
= EXPR_VARIABLE
;
2898 gfc_conv_expr (&comp_se
, e2
);
2899 e2
->expr_type
= old_type
;
2901 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2905 /* Convert a typebound function reference from a class object. */
2907 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2912 if (TREE_CODE (base_object
) != VAR_DECL
)
2914 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2915 gfc_add_modify (&se
->pre
, var
, base_object
);
2917 se
->expr
= gfc_class_vptr_get (base_object
);
2918 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2920 while (ref
&& ref
->next
)
2922 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2923 if (ref
->u
.c
.sym
->attr
.extension
)
2924 conv_parent_component_references (se
, ref
);
2925 gfc_conv_component_ref (se
, ref
);
2926 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2931 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2935 if (gfc_is_proc_ptr_comp (expr
))
2936 tmp
= get_proc_ptr_comp (expr
);
2937 else if (sym
->attr
.dummy
)
2939 tmp
= gfc_get_symbol_decl (sym
);
2940 if (sym
->attr
.proc_pointer
)
2941 tmp
= build_fold_indirect_ref_loc (input_location
,
2943 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2944 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2948 if (!sym
->backend_decl
)
2949 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2951 TREE_USED (sym
->backend_decl
) = 1;
2953 tmp
= sym
->backend_decl
;
2955 if (sym
->attr
.cray_pointee
)
2957 /* TODO - make the cray pointee a pointer to a procedure,
2958 assign the pointer to it and use it for the call. This
2960 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2961 gfc_get_symbol_decl (sym
->cp_pointer
));
2962 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2965 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2967 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2968 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2975 /* Initialize MAPPING. */
2978 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2980 mapping
->syms
= NULL
;
2981 mapping
->charlens
= NULL
;
2985 /* Free all memory held by MAPPING (but not MAPPING itself). */
2988 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2990 gfc_interface_sym_mapping
*sym
;
2991 gfc_interface_sym_mapping
*nextsym
;
2993 gfc_charlen
*nextcl
;
2995 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2997 nextsym
= sym
->next
;
2998 sym
->new_sym
->n
.sym
->formal
= NULL
;
2999 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3000 gfc_free_expr (sym
->expr
);
3001 free (sym
->new_sym
);
3004 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3007 gfc_free_expr (cl
->length
);
3013 /* Return a copy of gfc_charlen CL. Add the returned structure to
3014 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3016 static gfc_charlen
*
3017 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3020 gfc_charlen
*new_charlen
;
3022 new_charlen
= gfc_get_charlen ();
3023 new_charlen
->next
= mapping
->charlens
;
3024 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3026 mapping
->charlens
= new_charlen
;
3031 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3032 array variable that can be used as the actual argument for dummy
3033 argument SYM. Add any initialization code to BLOCK. PACKED is as
3034 for gfc_get_nodesc_array_type and DATA points to the first element
3035 in the passed array. */
3038 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3039 gfc_packed packed
, tree data
)
3044 type
= gfc_typenode_for_spec (&sym
->ts
);
3045 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3046 !sym
->attr
.target
&& !sym
->attr
.pointer
3047 && !sym
->attr
.proc_pointer
);
3049 var
= gfc_create_var (type
, "ifm");
3050 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3056 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3057 and offset of descriptorless array type TYPE given that it has the same
3058 size as DESC. Add any set-up code to BLOCK. */
3061 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3068 offset
= gfc_index_zero_node
;
3069 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3071 dim
= gfc_rank_cst
[n
];
3072 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3073 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3075 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3076 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3077 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3078 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3080 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3082 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3083 gfc_array_index_type
,
3084 gfc_conv_descriptor_ubound_get (desc
, dim
),
3085 gfc_conv_descriptor_lbound_get (desc
, dim
));
3086 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3087 gfc_array_index_type
,
3088 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3089 tmp
= gfc_evaluate_now (tmp
, block
);
3090 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3092 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3093 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3094 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3095 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3096 gfc_array_index_type
, offset
, tmp
);
3098 offset
= gfc_evaluate_now (offset
, block
);
3099 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3103 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3104 in SE. The caller may still use se->expr and se->string_length after
3105 calling this function. */
3108 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3109 gfc_symbol
* sym
, gfc_se
* se
,
3112 gfc_interface_sym_mapping
*sm
;
3116 gfc_symbol
*new_sym
;
3118 gfc_symtree
*new_symtree
;
3120 /* Create a new symbol to represent the actual argument. */
3121 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3122 new_sym
->ts
= sym
->ts
;
3123 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3124 new_sym
->attr
.referenced
= 1;
3125 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3126 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3127 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3128 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3129 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3130 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3131 new_sym
->attr
.function
= sym
->attr
.function
;
3133 /* Ensure that the interface is available and that
3134 descriptors are passed for array actual arguments. */
3135 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3137 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3138 new_sym
->attr
.always_explicit
3139 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3142 /* Create a fake symtree for it. */
3144 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3145 new_symtree
->n
.sym
= new_sym
;
3146 gcc_assert (new_symtree
== root
);
3148 /* Create a dummy->actual mapping. */
3149 sm
= XCNEW (gfc_interface_sym_mapping
);
3150 sm
->next
= mapping
->syms
;
3152 sm
->new_sym
= new_symtree
;
3153 sm
->expr
= gfc_copy_expr (expr
);
3156 /* Stabilize the argument's value. */
3157 if (!sym
->attr
.function
&& se
)
3158 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3160 if (sym
->ts
.type
== BT_CHARACTER
)
3162 /* Create a copy of the dummy argument's length. */
3163 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3164 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3166 /* If the length is specified as "*", record the length that
3167 the caller is passing. We should use the callee's length
3168 in all other cases. */
3169 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3171 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3172 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3179 /* Use the passed value as-is if the argument is a function. */
3180 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3183 /* If the argument is either a string or a pointer to a string,
3184 convert it to a boundless character type. */
3185 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3187 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3188 tmp
= build_pointer_type (tmp
);
3189 if (sym
->attr
.pointer
)
3190 value
= build_fold_indirect_ref_loc (input_location
,
3194 value
= fold_convert (tmp
, value
);
3197 /* If the argument is a scalar, a pointer to an array or an allocatable,
3199 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3200 value
= build_fold_indirect_ref_loc (input_location
,
3203 /* For character(*), use the actual argument's descriptor. */
3204 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3205 value
= build_fold_indirect_ref_loc (input_location
,
3208 /* If the argument is an array descriptor, use it to determine
3209 information about the actual argument's shape. */
3210 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3211 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3213 /* Get the actual argument's descriptor. */
3214 desc
= build_fold_indirect_ref_loc (input_location
,
3217 /* Create the replacement variable. */
3218 tmp
= gfc_conv_descriptor_data_get (desc
);
3219 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3222 /* Use DESC to work out the upper bounds, strides and offset. */
3223 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3226 /* Otherwise we have a packed array. */
3227 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3228 PACKED_FULL
, se
->expr
);
3230 new_sym
->backend_decl
= value
;
3234 /* Called once all dummy argument mappings have been added to MAPPING,
3235 but before the mapping is used to evaluate expressions. Pre-evaluate
3236 the length of each argument, adding any initialization code to PRE and
3237 any finalization code to POST. */
3240 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3241 stmtblock_t
* pre
, stmtblock_t
* post
)
3243 gfc_interface_sym_mapping
*sym
;
3247 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3248 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3249 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3251 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3252 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3253 gfc_init_se (&se
, NULL
);
3254 gfc_conv_expr (&se
, expr
);
3255 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3256 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3257 gfc_add_block_to_block (pre
, &se
.pre
);
3258 gfc_add_block_to_block (post
, &se
.post
);
3260 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3265 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3269 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3270 gfc_constructor_base base
)
3273 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3275 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3278 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3279 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3280 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3286 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3290 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3295 for (; ref
; ref
= ref
->next
)
3299 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3301 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3302 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3303 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3311 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3312 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3318 /* Convert intrinsic function calls into result expressions. */
3321 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3329 arg1
= expr
->value
.function
.actual
->expr
;
3330 if (expr
->value
.function
.actual
->next
)
3331 arg2
= expr
->value
.function
.actual
->next
->expr
;
3335 sym
= arg1
->symtree
->n
.sym
;
3337 if (sym
->attr
.dummy
)
3342 switch (expr
->value
.function
.isym
->id
)
3345 /* TODO figure out why this condition is necessary. */
3346 if (sym
->attr
.function
3347 && (arg1
->ts
.u
.cl
->length
== NULL
3348 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3349 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3352 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3356 if (!sym
->as
|| sym
->as
->rank
== 0)
3359 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3361 dup
= mpz_get_si (arg2
->value
.integer
);
3366 dup
= sym
->as
->rank
;
3370 for (; d
< dup
; d
++)
3374 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3376 gfc_free_expr (new_expr
);
3380 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3381 gfc_get_int_expr (gfc_default_integer_kind
,
3383 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3385 new_expr
= gfc_multiply (new_expr
, tmp
);
3391 case GFC_ISYM_LBOUND
:
3392 case GFC_ISYM_UBOUND
:
3393 /* TODO These implementations of lbound and ubound do not limit if
3394 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3396 if (!sym
->as
|| sym
->as
->rank
== 0)
3399 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3400 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3402 /* TODO: If the need arises, this could produce an array of
3406 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3408 if (sym
->as
->lower
[d
])
3409 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3413 if (sym
->as
->upper
[d
])
3414 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3422 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3426 gfc_replace_expr (expr
, new_expr
);
3432 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3433 gfc_interface_mapping
* mapping
)
3435 gfc_formal_arglist
*f
;
3436 gfc_actual_arglist
*actual
;
3438 actual
= expr
->value
.function
.actual
;
3439 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3441 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3446 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3449 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3454 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3456 for (d
= 0; d
< as
->rank
; d
++)
3458 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3459 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3462 expr
->value
.function
.esym
->as
= as
;
3465 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3467 expr
->value
.function
.esym
->ts
.u
.cl
->length
3468 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3470 gfc_apply_interface_mapping_to_expr (mapping
,
3471 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3476 /* EXPR is a copy of an expression that appeared in the interface
3477 associated with MAPPING. Walk it recursively looking for references to
3478 dummy arguments that MAPPING maps to actual arguments. Replace each such
3479 reference with a reference to the associated actual argument. */
3482 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3485 gfc_interface_sym_mapping
*sym
;
3486 gfc_actual_arglist
*actual
;
3491 /* Copying an expression does not copy its length, so do that here. */
3492 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3494 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3495 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3498 /* Apply the mapping to any references. */
3499 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3501 /* ...and to the expression's symbol, if it has one. */
3502 /* TODO Find out why the condition on expr->symtree had to be moved into
3503 the loop rather than being outside it, as originally. */
3504 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3505 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3507 if (sym
->new_sym
->n
.sym
->backend_decl
)
3508 expr
->symtree
= sym
->new_sym
;
3510 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3511 /* Replace base type for polymorphic arguments. */
3512 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3513 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3514 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3517 /* ...and to subexpressions in expr->value. */
3518 switch (expr
->expr_type
)
3523 case EXPR_SUBSTRING
:
3527 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3528 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3532 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3533 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3535 if (expr
->value
.function
.esym
== NULL
3536 && expr
->value
.function
.isym
!= NULL
3537 && expr
->value
.function
.actual
->expr
->symtree
3538 && gfc_map_intrinsic_function (expr
, mapping
))
3541 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3542 if (sym
->old
== expr
->value
.function
.esym
)
3544 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3545 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3546 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3551 case EXPR_STRUCTURE
:
3552 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3565 /* Evaluate interface expression EXPR using MAPPING. Store the result
3569 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3570 gfc_se
* se
, gfc_expr
* expr
)
3572 expr
= gfc_copy_expr (expr
);
3573 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3574 gfc_conv_expr (se
, expr
);
3575 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3576 gfc_free_expr (expr
);
3580 /* Returns a reference to a temporary array into which a component of
3581 an actual argument derived type array is copied and then returned
3582 after the function call. */
3584 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3585 sym_intent intent
, bool formal_ptr
)
3593 gfc_array_info
*info
;
3603 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3605 gfc_init_se (&lse
, NULL
);
3606 gfc_init_se (&rse
, NULL
);
3608 /* Walk the argument expression. */
3609 rss
= gfc_walk_expr (expr
);
3611 gcc_assert (rss
!= gfc_ss_terminator
);
3613 /* Initialize the scalarizer. */
3614 gfc_init_loopinfo (&loop
);
3615 gfc_add_ss_to_loop (&loop
, rss
);
3617 /* Calculate the bounds of the scalarization. */
3618 gfc_conv_ss_startstride (&loop
);
3620 /* Build an ss for the temporary. */
3621 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3622 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3624 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3625 if (GFC_ARRAY_TYPE_P (base_type
)
3626 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3627 base_type
= gfc_get_element_type (base_type
);
3629 if (expr
->ts
.type
== BT_CLASS
)
3630 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3632 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3633 ? expr
->ts
.u
.cl
->backend_decl
3637 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3639 /* Associate the SS with the loop. */
3640 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3642 /* Setup the scalarizing loops. */
3643 gfc_conv_loop_setup (&loop
, &expr
->where
);
3645 /* Pass the temporary descriptor back to the caller. */
3646 info
= &loop
.temp_ss
->info
->data
.array
;
3647 parmse
->expr
= info
->descriptor
;
3649 /* Setup the gfc_se structures. */
3650 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3651 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3654 lse
.ss
= loop
.temp_ss
;
3655 gfc_mark_ss_chain_used (rss
, 1);
3656 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3658 /* Start the scalarized loop body. */
3659 gfc_start_scalarized_body (&loop
, &body
);
3661 /* Translate the expression. */
3662 gfc_conv_expr (&rse
, expr
);
3664 gfc_conv_tmp_array_ref (&lse
);
3666 if (intent
!= INTENT_OUT
)
3668 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3669 gfc_add_expr_to_block (&body
, tmp
);
3670 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3671 gfc_trans_scalarizing_loops (&loop
, &body
);
3675 /* Make sure that the temporary declaration survives by merging
3676 all the loop declarations into the current context. */
3677 for (n
= 0; n
< loop
.dimen
; n
++)
3679 gfc_merge_block_scope (&body
);
3680 body
= loop
.code
[loop
.order
[n
]];
3682 gfc_merge_block_scope (&body
);
3685 /* Add the post block after the second loop, so that any
3686 freeing of allocated memory is done at the right time. */
3687 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3689 /**********Copy the temporary back again.*********/
3691 gfc_init_se (&lse
, NULL
);
3692 gfc_init_se (&rse
, NULL
);
3694 /* Walk the argument expression. */
3695 lss
= gfc_walk_expr (expr
);
3696 rse
.ss
= loop
.temp_ss
;
3699 /* Initialize the scalarizer. */
3700 gfc_init_loopinfo (&loop2
);
3701 gfc_add_ss_to_loop (&loop2
, lss
);
3703 /* Calculate the bounds of the scalarization. */
3704 gfc_conv_ss_startstride (&loop2
);
3706 /* Setup the scalarizing loops. */
3707 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3709 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3710 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3712 gfc_mark_ss_chain_used (lss
, 1);
3713 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3715 /* Declare the variable to hold the temporary offset and start the
3716 scalarized loop body. */
3717 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3718 gfc_start_scalarized_body (&loop2
, &body
);
3720 /* Build the offsets for the temporary from the loop variables. The
3721 temporary array has lbounds of zero and strides of one in all
3722 dimensions, so this is very simple. The offset is only computed
3723 outside the innermost loop, so the overall transfer could be
3724 optimized further. */
3725 info
= &rse
.ss
->info
->data
.array
;
3726 dimen
= rse
.ss
->dimen
;
3728 tmp_index
= gfc_index_zero_node
;
3729 for (n
= dimen
- 1; n
> 0; n
--)
3732 tmp
= rse
.loop
->loopvar
[n
];
3733 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3734 tmp
, rse
.loop
->from
[n
]);
3735 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3738 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3739 gfc_array_index_type
,
3740 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3741 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3742 gfc_array_index_type
,
3743 tmp_str
, gfc_index_one_node
);
3745 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3746 gfc_array_index_type
, tmp
, tmp_str
);
3749 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3750 gfc_array_index_type
,
3751 tmp_index
, rse
.loop
->from
[0]);
3752 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3754 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3755 gfc_array_index_type
,
3756 rse
.loop
->loopvar
[0], offset
);
3758 /* Now use the offset for the reference. */
3759 tmp
= build_fold_indirect_ref_loc (input_location
,
3761 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3763 if (expr
->ts
.type
== BT_CHARACTER
)
3764 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3766 gfc_conv_expr (&lse
, expr
);
3768 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3770 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3771 gfc_add_expr_to_block (&body
, tmp
);
3773 /* Generate the copying loops. */
3774 gfc_trans_scalarizing_loops (&loop2
, &body
);
3776 /* Wrap the whole thing up by adding the second loop to the post-block
3777 and following it by the post-block of the first loop. In this way,
3778 if the temporary needs freeing, it is done after use! */
3779 if (intent
!= INTENT_IN
)
3781 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3782 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3785 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3787 gfc_cleanup_loop (&loop
);
3788 gfc_cleanup_loop (&loop2
);
3790 /* Pass the string length to the argument expression. */
3791 if (expr
->ts
.type
== BT_CHARACTER
)
3792 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3794 /* Determine the offset for pointer formal arguments and set the
3798 size
= gfc_index_one_node
;
3799 offset
= gfc_index_zero_node
;
3800 for (n
= 0; n
< dimen
; n
++)
3802 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3804 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3805 gfc_array_index_type
, tmp
,
3806 gfc_index_one_node
);
3807 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3811 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3814 gfc_index_one_node
);
3815 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3816 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3817 gfc_array_index_type
,
3819 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3820 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3821 gfc_array_index_type
,
3822 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3823 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3824 gfc_array_index_type
,
3825 tmp
, gfc_index_one_node
);
3826 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3827 gfc_array_index_type
, size
, tmp
);
3830 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3834 /* We want either the address for the data or the address of the descriptor,
3835 depending on the mode of passing array arguments. */
3837 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3839 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3845 /* Generate the code for argument list functions. */
3848 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3850 /* Pass by value for g77 %VAL(arg), pass the address
3851 indirectly for %LOC, else by reference. Thus %REF
3852 is a "do-nothing" and %LOC is the same as an F95
3854 if (strncmp (name
, "%VAL", 4) == 0)
3855 gfc_conv_expr (se
, expr
);
3856 else if (strncmp (name
, "%LOC", 4) == 0)
3858 gfc_conv_expr_reference (se
, expr
);
3859 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3861 else if (strncmp (name
, "%REF", 4) == 0)
3862 gfc_conv_expr_reference (se
, expr
);
3864 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3868 /* Generate code for a procedure call. Note can return se->post != NULL.
3869 If se->direct_byref is set then se->expr contains the return parameter.
3870 Return nonzero, if the call has alternate specifiers.
3871 'expr' is only needed for procedure pointer components. */
3874 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3875 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3876 vec
<tree
, va_gc
> *append_args
)
3878 gfc_interface_mapping mapping
;
3879 vec
<tree
, va_gc
> *arglist
;
3880 vec
<tree
, va_gc
> *retargs
;
3884 gfc_array_info
*info
;
3891 vec
<tree
, va_gc
> *stringargs
;
3892 vec
<tree
, va_gc
> *optionalargs
;
3894 gfc_formal_arglist
*formal
;
3895 gfc_actual_arglist
*arg
;
3896 int has_alternate_specifier
= 0;
3897 bool need_interface_mapping
;
3904 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3905 gfc_component
*comp
= NULL
;
3911 optionalargs
= NULL
;
3916 comp
= gfc_get_proc_ptr_comp (expr
);
3920 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3922 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3923 if (se
->ss
->info
->useflags
)
3925 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3926 && sym
->result
->attr
.dimension
)
3927 || (comp
&& comp
->attr
.dimension
));
3928 gcc_assert (se
->loop
!= NULL
);
3930 /* Access the previously obtained result. */
3931 gfc_conv_tmp_array_ref (se
);
3935 info
= &se
->ss
->info
->data
.array
;
3940 gfc_init_block (&post
);
3941 gfc_init_interface_mapping (&mapping
);
3944 formal
= gfc_sym_get_dummy_args (sym
);
3945 need_interface_mapping
= sym
->attr
.dimension
||
3946 (sym
->ts
.type
== BT_CHARACTER
3947 && sym
->ts
.u
.cl
->length
3948 && sym
->ts
.u
.cl
->length
->expr_type
3953 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3954 need_interface_mapping
= comp
->attr
.dimension
||
3955 (comp
->ts
.type
== BT_CHARACTER
3956 && comp
->ts
.u
.cl
->length
3957 && comp
->ts
.u
.cl
->length
->expr_type
3961 base_object
= NULL_TREE
;
3963 /* Evaluate the arguments. */
3964 for (arg
= args
; arg
!= NULL
;
3965 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3968 fsym
= formal
? formal
->sym
: NULL
;
3969 parm_kind
= MISSING
;
3971 /* Class array expressions are sometimes coming completely unadorned
3972 with either arrayspec or _data component. Correct that here.
3973 OOP-TODO: Move this to the frontend. */
3974 if (e
&& e
->expr_type
== EXPR_VARIABLE
3976 && e
->ts
.type
== BT_CLASS
3977 && (CLASS_DATA (e
)->attr
.codimension
3978 || CLASS_DATA (e
)->attr
.dimension
))
3980 gfc_typespec temp_ts
= e
->ts
;
3981 gfc_add_class_array_ref (e
);
3987 if (se
->ignore_optional
)
3989 /* Some intrinsics have already been resolved to the correct
3993 else if (arg
->label
)
3995 has_alternate_specifier
= 1;
4000 gfc_init_se (&parmse
, NULL
);
4002 /* For scalar arguments with VALUE attribute which are passed by
4003 value, pass "0" and a hidden argument gives the optional
4005 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4006 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4007 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4009 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4011 vec_safe_push (optionalargs
, boolean_false_node
);
4015 /* Pass a NULL pointer for an absent arg. */
4016 parmse
.expr
= null_pointer_node
;
4017 if (arg
->missing_arg_type
== BT_CHARACTER
)
4018 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4023 else if (arg
->expr
->expr_type
== EXPR_NULL
4024 && fsym
&& !fsym
->attr
.pointer
4025 && (fsym
->ts
.type
!= BT_CLASS
4026 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4028 /* Pass a NULL pointer to denote an absent arg. */
4029 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4030 && (fsym
->ts
.type
!= BT_CLASS
4031 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4032 gfc_init_se (&parmse
, NULL
);
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
, 0);
4037 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4038 && e
->ts
.type
== BT_DERIVED
)
4040 /* The derived type needs to be converted to a temporary
4042 gfc_init_se (&parmse
, se
);
4043 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4045 && e
->expr_type
== EXPR_VARIABLE
4046 && e
->symtree
->n
.sym
->attr
.optional
,
4047 CLASS_DATA (fsym
)->attr
.class_pointer
4048 || CLASS_DATA (fsym
)->attr
.allocatable
);
4050 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4052 /* The intrinsic type needs to be converted to a temporary
4053 CLASS object for the unlimited polymorphic formal. */
4054 gfc_init_se (&parmse
, se
);
4055 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4057 else if (se
->ss
&& se
->ss
->info
->useflags
)
4063 /* An elemental function inside a scalarized loop. */
4064 gfc_init_se (&parmse
, se
);
4065 parm_kind
= ELEMENTAL
;
4067 if (fsym
&& fsym
->attr
.value
)
4068 gfc_conv_expr (&parmse
, e
);
4070 gfc_conv_expr_reference (&parmse
, e
);
4072 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4073 && e
->expr_type
== EXPR_FUNCTION
)
4074 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4077 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4078 && gfc_is_class_container_ref (e
))
4080 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4082 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4083 && e
->symtree
->n
.sym
->attr
.optional
)
4085 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4086 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4087 TREE_TYPE (parmse
.expr
),
4089 fold_convert (TREE_TYPE (parmse
.expr
),
4090 null_pointer_node
));
4094 /* If we are passing an absent array as optional dummy to an
4095 elemental procedure, make sure that we pass NULL when the data
4096 pointer is NULL. We need this extra conditional because of
4097 scalarization which passes arrays elements to the procedure,
4098 ignoring the fact that the array can be absent/unallocated/... */
4099 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4101 tree descriptor_data
;
4103 descriptor_data
= ss
->info
->data
.array
.data
;
4104 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4106 fold_convert (TREE_TYPE (descriptor_data
),
4107 null_pointer_node
));
4109 = fold_build3_loc (input_location
, COND_EXPR
,
4110 TREE_TYPE (parmse
.expr
),
4111 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4112 fold_convert (TREE_TYPE (parmse
.expr
),
4117 /* The scalarizer does not repackage the reference to a class
4118 array - instead it returns a pointer to the data element. */
4119 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4120 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4121 fsym
->attr
.intent
!= INTENT_IN
4122 && (CLASS_DATA (fsym
)->attr
.class_pointer
4123 || CLASS_DATA (fsym
)->attr
.allocatable
),
4125 && e
->expr_type
== EXPR_VARIABLE
4126 && e
->symtree
->n
.sym
->attr
.optional
,
4127 CLASS_DATA (fsym
)->attr
.class_pointer
4128 || CLASS_DATA (fsym
)->attr
.allocatable
);
4135 gfc_init_se (&parmse
, NULL
);
4137 /* Check whether the expression is a scalar or not; we cannot use
4138 e->rank as it can be nonzero for functions arguments. */
4139 argss
= gfc_walk_expr (e
);
4140 scalar
= argss
== gfc_ss_terminator
;
4142 gfc_free_ss_chain (argss
);
4144 /* Special handling for passing scalar polymorphic coarrays;
4145 otherwise one passes "class->_data.data" instead of "&class". */
4146 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4147 && fsym
&& fsym
->ts
.type
== BT_CLASS
4148 && CLASS_DATA (fsym
)->attr
.codimension
4149 && !CLASS_DATA (fsym
)->attr
.dimension
)
4151 gfc_add_class_array_ref (e
);
4152 parmse
.want_coarray
= 1;
4156 /* A scalar or transformational function. */
4159 if (e
->expr_type
== EXPR_VARIABLE
4160 && e
->symtree
->n
.sym
->attr
.cray_pointee
4161 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4163 /* The Cray pointer needs to be converted to a pointer to
4164 a type given by the expression. */
4165 gfc_conv_expr (&parmse
, e
);
4166 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4167 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4168 parmse
.expr
= convert (type
, tmp
);
4170 else if (fsym
&& fsym
->attr
.value
)
4172 if (fsym
->ts
.type
== BT_CHARACTER
4173 && fsym
->ts
.is_c_interop
4174 && fsym
->ns
->proc_name
!= NULL
4175 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4178 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4179 if (parmse
.expr
== NULL
)
4180 gfc_conv_expr (&parmse
, e
);
4184 gfc_conv_expr (&parmse
, e
);
4185 if (fsym
->attr
.optional
4186 && fsym
->ts
.type
!= BT_CLASS
4187 && fsym
->ts
.type
!= BT_DERIVED
)
4189 if (e
->expr_type
!= EXPR_VARIABLE
4190 || !e
->symtree
->n
.sym
->attr
.optional
4192 vec_safe_push (optionalargs
, boolean_true_node
);
4195 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4196 if (!e
->symtree
->n
.sym
->attr
.value
)
4198 = fold_build3_loc (input_location
, COND_EXPR
,
4199 TREE_TYPE (parmse
.expr
),
4201 fold_convert (TREE_TYPE (parmse
.expr
),
4202 integer_zero_node
));
4204 vec_safe_push (optionalargs
, tmp
);
4209 else if (arg
->name
&& arg
->name
[0] == '%')
4210 /* Argument list functions %VAL, %LOC and %REF are signalled
4211 through arg->name. */
4212 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4213 else if ((e
->expr_type
== EXPR_FUNCTION
)
4214 && ((e
->value
.function
.esym
4215 && e
->value
.function
.esym
->result
->attr
.pointer
)
4216 || (!e
->value
.function
.esym
4217 && e
->symtree
->n
.sym
->attr
.pointer
))
4218 && fsym
&& fsym
->attr
.target
)
4220 gfc_conv_expr (&parmse
, e
);
4221 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4223 else if (e
->expr_type
== EXPR_FUNCTION
4224 && e
->symtree
->n
.sym
->result
4225 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4226 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4228 /* Functions returning procedure pointers. */
4229 gfc_conv_expr (&parmse
, e
);
4230 if (fsym
&& fsym
->attr
.proc_pointer
)
4231 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4235 if (e
->ts
.type
== BT_CLASS
&& fsym
4236 && fsym
->ts
.type
== BT_CLASS
4237 && (!CLASS_DATA (fsym
)->as
4238 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4239 && CLASS_DATA (e
)->attr
.codimension
)
4241 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4242 gcc_assert (!CLASS_DATA (fsym
)->as
);
4243 gfc_add_class_array_ref (e
);
4244 parmse
.want_coarray
= 1;
4245 gfc_conv_expr_reference (&parmse
, e
);
4246 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4248 && e
->expr_type
== EXPR_VARIABLE
);
4251 gfc_conv_expr_reference (&parmse
, e
);
4253 /* Catch base objects that are not variables. */
4254 if (e
->ts
.type
== BT_CLASS
4255 && e
->expr_type
!= EXPR_VARIABLE
4256 && expr
&& e
== expr
->base_expr
)
4257 base_object
= build_fold_indirect_ref_loc (input_location
,
4260 /* A class array element needs converting back to be a
4261 class object, if the formal argument is a class object. */
4262 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4263 && e
->ts
.type
== BT_CLASS
4264 && ((CLASS_DATA (fsym
)->as
4265 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4266 || CLASS_DATA (e
)->attr
.dimension
))
4267 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4268 fsym
->attr
.intent
!= INTENT_IN
4269 && (CLASS_DATA (fsym
)->attr
.class_pointer
4270 || CLASS_DATA (fsym
)->attr
.allocatable
),
4272 && e
->expr_type
== EXPR_VARIABLE
4273 && e
->symtree
->n
.sym
->attr
.optional
,
4274 CLASS_DATA (fsym
)->attr
.class_pointer
4275 || CLASS_DATA (fsym
)->attr
.allocatable
);
4277 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4278 allocated on entry, it must be deallocated. */
4279 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4280 && (fsym
->attr
.allocatable
4281 || (fsym
->ts
.type
== BT_CLASS
4282 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4287 gfc_init_block (&block
);
4289 if (e
->ts
.type
== BT_CLASS
)
4290 ptr
= gfc_class_data_get (ptr
);
4292 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4294 gfc_add_expr_to_block (&block
, tmp
);
4295 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4296 void_type_node
, ptr
,
4298 gfc_add_expr_to_block (&block
, tmp
);
4300 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4302 gfc_add_modify (&block
, ptr
,
4303 fold_convert (TREE_TYPE (ptr
),
4304 null_pointer_node
));
4305 gfc_add_expr_to_block (&block
, tmp
);
4307 else if (fsym
->ts
.type
== BT_CLASS
)
4310 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4311 tmp
= gfc_get_symbol_decl (vtab
);
4312 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4313 ptr
= gfc_class_vptr_get (parmse
.expr
);
4314 gfc_add_modify (&block
, ptr
,
4315 fold_convert (TREE_TYPE (ptr
), tmp
));
4316 gfc_add_expr_to_block (&block
, tmp
);
4319 if (fsym
->attr
.optional
4320 && e
->expr_type
== EXPR_VARIABLE
4321 && e
->symtree
->n
.sym
->attr
.optional
)
4323 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4325 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4326 gfc_finish_block (&block
),
4327 build_empty_stmt (input_location
));
4330 tmp
= gfc_finish_block (&block
);
4332 gfc_add_expr_to_block (&se
->pre
, tmp
);
4335 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4336 || fsym
->ts
.type
== BT_ASSUMED
)
4337 && e
->ts
.type
== BT_CLASS
4338 && !CLASS_DATA (e
)->attr
.dimension
4339 && !CLASS_DATA (e
)->attr
.codimension
)
4340 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4342 /* Wrap scalar variable in a descriptor. We need to convert
4343 the address of a pointer back to the pointer itself before,
4344 we can assign it to the data field. */
4346 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4347 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4350 if (TREE_CODE (tmp
) == ADDR_EXPR
4351 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4352 tmp
= TREE_OPERAND (tmp
, 0);
4353 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4355 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4358 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4359 && ((fsym
->attr
.pointer
4360 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4361 || (fsym
->attr
.proc_pointer
4362 && !(e
->expr_type
== EXPR_VARIABLE
4363 && e
->symtree
->n
.sym
->attr
.dummy
))
4364 || (fsym
->attr
.proc_pointer
4365 && e
->expr_type
== EXPR_VARIABLE
4366 && gfc_is_proc_ptr_comp (e
))
4367 || (fsym
->attr
.allocatable
4368 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4370 /* Scalar pointer dummy args require an extra level of
4371 indirection. The null pointer already contains
4372 this level of indirection. */
4373 parm_kind
= SCALAR_POINTER
;
4374 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4378 else if (e
->ts
.type
== BT_CLASS
4379 && fsym
&& fsym
->ts
.type
== BT_CLASS
4380 && (CLASS_DATA (fsym
)->attr
.dimension
4381 || CLASS_DATA (fsym
)->attr
.codimension
))
4383 /* Pass a class array. */
4384 parmse
.use_offset
= 1;
4385 gfc_conv_expr_descriptor (&parmse
, e
);
4387 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4388 allocated on entry, it must be deallocated. */
4389 if (fsym
->attr
.intent
== INTENT_OUT
4390 && CLASS_DATA (fsym
)->attr
.allocatable
)
4395 gfc_init_block (&block
);
4397 ptr
= gfc_class_data_get (ptr
);
4399 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4400 NULL_TREE
, NULL_TREE
,
4403 gfc_add_expr_to_block (&block
, tmp
);
4404 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4405 void_type_node
, ptr
,
4407 gfc_add_expr_to_block (&block
, tmp
);
4408 gfc_reset_vptr (&block
, e
);
4410 if (fsym
->attr
.optional
4411 && e
->expr_type
== EXPR_VARIABLE
4413 || (e
->ref
->type
== REF_ARRAY
4414 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4415 && e
->symtree
->n
.sym
->attr
.optional
)
4417 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4419 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4420 gfc_finish_block (&block
),
4421 build_empty_stmt (input_location
));
4424 tmp
= gfc_finish_block (&block
);
4426 gfc_add_expr_to_block (&se
->pre
, tmp
);
4429 /* The conversion does not repackage the reference to a class
4430 array - _data descriptor. */
4431 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4432 fsym
->attr
.intent
!= INTENT_IN
4433 && (CLASS_DATA (fsym
)->attr
.class_pointer
4434 || CLASS_DATA (fsym
)->attr
.allocatable
),
4436 && e
->expr_type
== EXPR_VARIABLE
4437 && e
->symtree
->n
.sym
->attr
.optional
,
4438 CLASS_DATA (fsym
)->attr
.class_pointer
4439 || CLASS_DATA (fsym
)->attr
.allocatable
);
4443 /* If the procedure requires an explicit interface, the actual
4444 argument is passed according to the corresponding formal
4445 argument. If the corresponding formal argument is a POINTER,
4446 ALLOCATABLE or assumed shape, we do not use g77's calling
4447 convention, and pass the address of the array descriptor
4448 instead. Otherwise we use g77's calling convention. */
4451 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4452 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4453 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4455 f
= f
|| !comp
->attr
.always_explicit
;
4457 f
= f
|| !sym
->attr
.always_explicit
;
4459 /* If the argument is a function call that may not create
4460 a temporary for the result, we have to check that we
4461 can do it, i.e. that there is no alias between this
4462 argument and another one. */
4463 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4469 intent
= fsym
->attr
.intent
;
4471 intent
= INTENT_UNKNOWN
;
4473 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4475 parmse
.force_tmp
= 1;
4477 iarg
= e
->value
.function
.actual
->expr
;
4479 /* Temporary needed if aliasing due to host association. */
4480 if (sym
->attr
.contained
4482 && !sym
->attr
.implicit_pure
4483 && !sym
->attr
.use_assoc
4484 && iarg
->expr_type
== EXPR_VARIABLE
4485 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4486 parmse
.force_tmp
= 1;
4488 /* Ditto within module. */
4489 if (sym
->attr
.use_assoc
4491 && !sym
->attr
.implicit_pure
4492 && iarg
->expr_type
== EXPR_VARIABLE
4493 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4494 parmse
.force_tmp
= 1;
4497 if (e
->expr_type
== EXPR_VARIABLE
4498 && is_subref_array (e
))
4499 /* The actual argument is a component reference to an
4500 array of derived types. In this case, the argument
4501 is converted to a temporary, which is passed and then
4502 written back after the procedure call. */
4503 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4504 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4505 fsym
&& fsym
->attr
.pointer
);
4506 else if (gfc_is_class_array_ref (e
, NULL
)
4507 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4508 /* The actual argument is a component reference to an
4509 array of derived types. In this case, the argument
4510 is converted to a temporary, which is passed and then
4511 written back after the procedure call.
4512 OOP-TODO: Insert code so that if the dynamic type is
4513 the same as the declared type, copy-in/copy-out does
4515 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4516 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4517 fsym
&& fsym
->attr
.pointer
);
4519 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4521 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4522 allocated on entry, it must be deallocated. */
4523 if (fsym
&& fsym
->attr
.allocatable
4524 && fsym
->attr
.intent
== INTENT_OUT
)
4526 tmp
= build_fold_indirect_ref_loc (input_location
,
4528 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4529 if (fsym
->attr
.optional
4530 && e
->expr_type
== EXPR_VARIABLE
4531 && e
->symtree
->n
.sym
->attr
.optional
)
4532 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4534 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4535 tmp
, build_empty_stmt (input_location
));
4536 gfc_add_expr_to_block (&se
->pre
, tmp
);
4541 /* The case with fsym->attr.optional is that of a user subroutine
4542 with an interface indicating an optional argument. When we call
4543 an intrinsic subroutine, however, fsym is NULL, but we might still
4544 have an optional argument, so we proceed to the substitution
4546 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4548 /* If an optional argument is itself an optional dummy argument,
4549 check its presence and substitute a null if absent. This is
4550 only needed when passing an array to an elemental procedure
4551 as then array elements are accessed - or no NULL pointer is
4552 allowed and a "1" or "0" should be passed if not present.
4553 When passing a non-array-descriptor full array to a
4554 non-array-descriptor dummy, no check is needed. For
4555 array-descriptor actual to array-descriptor dummy, see
4556 PR 41911 for why a check has to be inserted.
4557 fsym == NULL is checked as intrinsics required the descriptor
4558 but do not always set fsym. */
4559 if (e
->expr_type
== EXPR_VARIABLE
4560 && e
->symtree
->n
.sym
->attr
.optional
4561 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4562 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4566 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4567 || fsym
->as
->type
== AS_ASSUMED_RANK
4568 || fsym
->as
->type
== AS_DEFERRED
))))))
4569 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4570 e
->representation
.length
);
4575 /* Obtain the character length of an assumed character length
4576 length procedure from the typespec. */
4577 if (fsym
->ts
.type
== BT_CHARACTER
4578 && parmse
.string_length
== NULL_TREE
4579 && e
->ts
.type
== BT_PROCEDURE
4580 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4581 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4582 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4584 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4585 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4589 if (fsym
&& need_interface_mapping
&& e
)
4590 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4592 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4593 gfc_add_block_to_block (&post
, &parmse
.post
);
4595 /* Allocated allocatable components of derived types must be
4596 deallocated for non-variable scalars. Non-variable arrays are
4597 dealt with in trans-array.c(gfc_conv_array_parameter). */
4598 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4599 && e
->ts
.u
.derived
->attr
.alloc_comp
4600 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4601 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4604 tmp
= build_fold_indirect_ref_loc (input_location
,
4606 parm_rank
= e
->rank
;
4614 case (SCALAR_POINTER
):
4615 tmp
= build_fold_indirect_ref_loc (input_location
,
4620 if (e
->expr_type
== EXPR_OP
4621 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4622 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4625 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4626 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4627 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4630 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4632 /* The derived type is passed to gfc_deallocate_alloc_comp.
4633 Therefore, class actuals can handled correctly but derived
4634 types passed to class formals need the _data component. */
4635 tmp
= gfc_class_data_get (tmp
);
4636 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4637 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4640 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4642 gfc_add_expr_to_block (&se
->post
, tmp
);
4645 /* Add argument checking of passing an unallocated/NULL actual to
4646 a nonallocatable/nonpointer dummy. */
4648 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4650 symbol_attribute attr
;
4654 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4655 attr
= gfc_expr_attr (e
);
4657 goto end_pointer_check
;
4659 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4660 allocatable to an optional dummy, cf. 12.5.2.12. */
4661 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4662 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4663 goto end_pointer_check
;
4667 /* If the actual argument is an optional pointer/allocatable and
4668 the formal argument takes an nonpointer optional value,
4669 it is invalid to pass a non-present argument on, even
4670 though there is no technical reason for this in gfortran.
4671 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4672 tree present
, null_ptr
, type
;
4674 if (attr
.allocatable
4675 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4676 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4677 "allocated or not present", e
->symtree
->n
.sym
->name
);
4678 else if (attr
.pointer
4679 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4680 asprintf (&msg
, "Pointer actual argument '%s' is not "
4681 "associated or not present",
4682 e
->symtree
->n
.sym
->name
);
4683 else if (attr
.proc_pointer
4684 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4685 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4686 "associated or not present",
4687 e
->symtree
->n
.sym
->name
);
4689 goto end_pointer_check
;
4691 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4692 type
= TREE_TYPE (present
);
4693 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4694 boolean_type_node
, present
,
4696 null_pointer_node
));
4697 type
= TREE_TYPE (parmse
.expr
);
4698 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4699 boolean_type_node
, parmse
.expr
,
4701 null_pointer_node
));
4702 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4703 boolean_type_node
, present
, null_ptr
);
4707 if (attr
.allocatable
4708 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4709 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4710 "allocated", e
->symtree
->n
.sym
->name
);
4711 else if (attr
.pointer
4712 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4713 asprintf (&msg
, "Pointer actual argument '%s' is not "
4714 "associated", e
->symtree
->n
.sym
->name
);
4715 else if (attr
.proc_pointer
4716 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4717 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4718 "associated", e
->symtree
->n
.sym
->name
);
4720 goto end_pointer_check
;
4724 /* If the argument is passed by value, we need to strip the
4726 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4727 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4729 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4730 boolean_type_node
, tmp
,
4731 fold_convert (TREE_TYPE (tmp
),
4732 null_pointer_node
));
4735 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4741 /* Deferred length dummies pass the character length by reference
4742 so that the value can be returned. */
4743 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4745 tmp
= parmse
.string_length
;
4746 if (TREE_CODE (tmp
) != VAR_DECL
)
4747 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4748 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4751 /* Character strings are passed as two parameters, a length and a
4752 pointer - except for Bind(c) which only passes the pointer.
4753 An unlimited polymorphic formal argument likewise does not
4755 if (parmse
.string_length
!= NULL_TREE
4756 && !sym
->attr
.is_bind_c
4757 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4758 vec_safe_push (stringargs
, parmse
.string_length
);
4760 /* When calling __copy for character expressions to unlimited
4761 polymorphic entities, the dst argument needs a string length. */
4762 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4763 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4764 && arg
->next
&& arg
->next
->expr
4765 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4766 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4767 vec_safe_push (stringargs
, parmse
.string_length
);
4769 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4770 pass the token and the offset as additional arguments. */
4771 if (fsym
&& fsym
->attr
.codimension
4772 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4773 && !fsym
->attr
.allocatable
4776 /* Token and offset. */
4777 vec_safe_push (stringargs
, null_pointer_node
);
4778 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4779 gcc_assert (fsym
->attr
.optional
);
4781 else if (fsym
&& fsym
->attr
.codimension
4782 && !fsym
->attr
.allocatable
4783 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4785 tree caf_decl
, caf_type
;
4788 caf_decl
= get_tree_for_caf_expr (e
);
4789 caf_type
= TREE_TYPE (caf_decl
);
4791 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4792 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4793 tmp
= gfc_conv_descriptor_token (caf_decl
);
4794 else if (DECL_LANG_SPECIFIC (caf_decl
)
4795 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4796 tmp
= GFC_DECL_TOKEN (caf_decl
);
4799 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4800 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4801 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4804 vec_safe_push (stringargs
, tmp
);
4806 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4807 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4808 offset
= build_int_cst (gfc_array_index_type
, 0);
4809 else if (DECL_LANG_SPECIFIC (caf_decl
)
4810 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4811 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4812 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4813 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4815 offset
= build_int_cst (gfc_array_index_type
, 0);
4817 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4818 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4821 gcc_assert (POINTER_TYPE_P (caf_type
));
4825 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4826 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4827 && !fsym
->attr
.allocatable
))
4829 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4830 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4831 (TREE_TYPE (parmse
.expr
))));
4832 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4833 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4835 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4836 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4839 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4843 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4844 gfc_array_index_type
,
4845 fold_convert (gfc_array_index_type
, tmp2
),
4846 fold_convert (gfc_array_index_type
, tmp
));
4847 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4848 gfc_array_index_type
, offset
, tmp
);
4850 vec_safe_push (stringargs
, offset
);
4853 vec_safe_push (arglist
, parmse
.expr
);
4855 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4862 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4863 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4864 else if (ts
.type
== BT_CHARACTER
)
4866 if (ts
.u
.cl
->length
== NULL
)
4868 /* Assumed character length results are not allowed by 5.1.1.5 of the
4869 standard and are trapped in resolve.c; except in the case of SPREAD
4870 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4871 we take the character length of the first argument for the result.
4872 For dummies, we have to look through the formal argument list for
4873 this function and use the character length found there.*/
4875 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4876 else if (!sym
->attr
.dummy
)
4877 cl
.backend_decl
= (*stringargs
)[0];
4880 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4881 for (; formal
; formal
= formal
->next
)
4882 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4883 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4885 len
= cl
.backend_decl
;
4891 /* Calculate the length of the returned string. */
4892 gfc_init_se (&parmse
, NULL
);
4893 if (need_interface_mapping
)
4894 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4896 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4897 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4898 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4900 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4901 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4902 gfc_charlen_type_node
, tmp
,
4903 build_int_cst (gfc_charlen_type_node
, 0));
4904 cl
.backend_decl
= tmp
;
4907 /* Set up a charlen structure for it. */
4912 len
= cl
.backend_decl
;
4915 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4916 || (!comp
&& gfc_return_by_reference (sym
));
4919 if (se
->direct_byref
)
4921 /* Sometimes, too much indirection can be applied; e.g. for
4922 function_result = array_valued_recursive_function. */
4923 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4924 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4925 && GFC_DESCRIPTOR_TYPE_P
4926 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4927 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4930 /* If the lhs of an assignment x = f(..) is allocatable and
4931 f2003 is allowed, we must do the automatic reallocation.
4932 TODO - deal with intrinsics, without using a temporary. */
4933 if (gfc_option
.flag_realloc_lhs
4934 && se
->ss
&& se
->ss
->loop_chain
4935 && se
->ss
->loop_chain
->is_alloc_lhs
4936 && !expr
->value
.function
.isym
4937 && sym
->result
->as
!= NULL
)
4939 /* Evaluate the bounds of the result, if known. */
4940 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4943 /* Perform the automatic reallocation. */
4944 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4946 gfc_add_expr_to_block (&se
->pre
, tmp
);
4948 /* Pass the temporary as the first argument. */
4949 result
= info
->descriptor
;
4952 result
= build_fold_indirect_ref_loc (input_location
,
4954 vec_safe_push (retargs
, se
->expr
);
4956 else if (comp
&& comp
->attr
.dimension
)
4958 gcc_assert (se
->loop
&& info
);
4960 /* Set the type of the array. */
4961 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4962 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4964 /* Evaluate the bounds of the result, if known. */
4965 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4967 /* If the lhs of an assignment x = f(..) is allocatable and
4968 f2003 is allowed, we must not generate the function call
4969 here but should just send back the results of the mapping.
4970 This is signalled by the function ss being flagged. */
4971 if (gfc_option
.flag_realloc_lhs
4972 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4974 gfc_free_interface_mapping (&mapping
);
4975 return has_alternate_specifier
;
4978 /* Create a temporary to store the result. In case the function
4979 returns a pointer, the temporary will be a shallow copy and
4980 mustn't be deallocated. */
4981 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4982 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4983 tmp
, NULL_TREE
, false,
4984 !comp
->attr
.pointer
, callee_alloc
,
4985 &se
->ss
->info
->expr
->where
);
4987 /* Pass the temporary as the first argument. */
4988 result
= info
->descriptor
;
4989 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4990 vec_safe_push (retargs
, tmp
);
4992 else if (!comp
&& sym
->result
->attr
.dimension
)
4994 gcc_assert (se
->loop
&& info
);
4996 /* Set the type of the array. */
4997 tmp
= gfc_typenode_for_spec (&ts
);
4998 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5000 /* Evaluate the bounds of the result, if known. */
5001 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5003 /* If the lhs of an assignment x = f(..) is allocatable and
5004 f2003 is allowed, we must not generate the function call
5005 here but should just send back the results of the mapping.
5006 This is signalled by the function ss being flagged. */
5007 if (gfc_option
.flag_realloc_lhs
5008 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5010 gfc_free_interface_mapping (&mapping
);
5011 return has_alternate_specifier
;
5014 /* Create a temporary to store the result. In case the function
5015 returns a pointer, the temporary will be a shallow copy and
5016 mustn't be deallocated. */
5017 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5018 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5019 tmp
, NULL_TREE
, false,
5020 !sym
->attr
.pointer
, callee_alloc
,
5021 &se
->ss
->info
->expr
->where
);
5023 /* Pass the temporary as the first argument. */
5024 result
= info
->descriptor
;
5025 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5026 vec_safe_push (retargs
, tmp
);
5028 else if (ts
.type
== BT_CHARACTER
)
5030 /* Pass the string length. */
5031 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5032 type
= build_pointer_type (type
);
5034 /* Return an address to a char[0:len-1]* temporary for
5035 character pointers. */
5036 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5037 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5039 var
= gfc_create_var (type
, "pstr");
5041 if ((!comp
&& sym
->attr
.allocatable
)
5042 || (comp
&& comp
->attr
.allocatable
))
5044 gfc_add_modify (&se
->pre
, var
,
5045 fold_convert (TREE_TYPE (var
),
5046 null_pointer_node
));
5047 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5048 gfc_add_expr_to_block (&se
->post
, tmp
);
5051 /* Provide an address expression for the function arguments. */
5052 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5055 var
= gfc_conv_string_tmp (se
, type
, len
);
5057 vec_safe_push (retargs
, var
);
5061 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5063 type
= gfc_get_complex_type (ts
.kind
);
5064 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5065 vec_safe_push (retargs
, var
);
5068 /* Add the string length to the argument list. */
5069 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5072 if (TREE_CODE (tmp
) != VAR_DECL
)
5073 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5074 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5075 vec_safe_push (retargs
, tmp
);
5077 else if (ts
.type
== BT_CHARACTER
)
5078 vec_safe_push (retargs
, len
);
5080 gfc_free_interface_mapping (&mapping
);
5082 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5083 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5084 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5085 vec_safe_reserve (retargs
, arglen
);
5087 /* Add the return arguments. */
5088 retargs
->splice (arglist
);
5090 /* Add the hidden present status for optional+value to the arguments. */
5091 retargs
->splice (optionalargs
);
5093 /* Add the hidden string length parameters to the arguments. */
5094 retargs
->splice (stringargs
);
5096 /* We may want to append extra arguments here. This is used e.g. for
5097 calls to libgfortran_matmul_??, which need extra information. */
5098 if (!vec_safe_is_empty (append_args
))
5099 retargs
->splice (append_args
);
5102 /* Generate the actual call. */
5103 if (base_object
== NULL_TREE
)
5104 conv_function_val (se
, sym
, expr
);
5106 conv_base_obj_fcn_val (se
, base_object
, expr
);
5108 /* If there are alternate return labels, function type should be
5109 integer. Can't modify the type in place though, since it can be shared
5110 with other functions. For dummy arguments, the typing is done to
5111 this result, even if it has to be repeated for each call. */
5112 if (has_alternate_specifier
5113 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5115 if (!sym
->attr
.dummy
)
5117 TREE_TYPE (sym
->backend_decl
)
5118 = build_function_type (integer_type_node
,
5119 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5120 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5123 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5126 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5127 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5129 /* If we have a pointer function, but we don't want a pointer, e.g.
5132 where f is pointer valued, we have to dereference the result. */
5133 if (!se
->want_pointer
&& !byref
5134 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5135 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5136 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5138 /* f2c calling conventions require a scalar default real function to
5139 return a double precision result. Convert this back to default
5140 real. We only care about the cases that can happen in Fortran 77.
5142 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5143 && sym
->ts
.kind
== gfc_default_real_kind
5144 && !sym
->attr
.always_explicit
)
5145 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5147 /* A pure function may still have side-effects - it may modify its
5149 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5151 if (!sym
->attr
.pure
)
5152 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5157 /* Add the function call to the pre chain. There is no expression. */
5158 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5159 se
->expr
= NULL_TREE
;
5161 if (!se
->direct_byref
)
5163 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5165 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5167 /* Check the data pointer hasn't been modified. This would
5168 happen in a function returning a pointer. */
5169 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5170 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5173 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5176 se
->expr
= info
->descriptor
;
5177 /* Bundle in the string length. */
5178 se
->string_length
= len
;
5180 else if (ts
.type
== BT_CHARACTER
)
5182 /* Dereference for character pointer results. */
5183 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5184 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5185 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5189 se
->string_length
= len
;
5193 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5194 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5199 /* Follow the function call with the argument post block. */
5202 gfc_add_block_to_block (&se
->pre
, &post
);
5204 /* Transformational functions of derived types with allocatable
5205 components must have the result allocatable components copied. */
5206 arg
= expr
->value
.function
.actual
;
5207 if (result
&& arg
&& expr
->rank
5208 && expr
->value
.function
.isym
5209 && expr
->value
.function
.isym
->transformational
5210 && arg
->expr
->ts
.type
== BT_DERIVED
5211 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5214 /* Copy the allocatable components. We have to use a
5215 temporary here to prevent source allocatable components
5216 from being corrupted. */
5217 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5218 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5219 result
, tmp2
, expr
->rank
);
5220 gfc_add_expr_to_block (&se
->pre
, tmp
);
5221 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5223 gfc_add_expr_to_block (&se
->pre
, tmp
);
5225 /* Finally free the temporary's data field. */
5226 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5227 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5228 NULL_TREE
, NULL_TREE
, true,
5230 gfc_add_expr_to_block (&se
->pre
, tmp
);
5234 gfc_add_block_to_block (&se
->post
, &post
);
5236 return has_alternate_specifier
;
5240 /* Fill a character string with spaces. */
5243 fill_with_spaces (tree start
, tree type
, tree size
)
5245 stmtblock_t block
, loop
;
5246 tree i
, el
, exit_label
, cond
, tmp
;
5248 /* For a simple char type, we can call memset(). */
5249 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5250 return build_call_expr_loc (input_location
,
5251 builtin_decl_explicit (BUILT_IN_MEMSET
),
5253 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5254 lang_hooks
.to_target_charset (' ')),
5257 /* Otherwise, we use a loop:
5258 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5262 /* Initialize variables. */
5263 gfc_init_block (&block
);
5264 i
= gfc_create_var (sizetype
, "i");
5265 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5266 el
= gfc_create_var (build_pointer_type (type
), "el");
5267 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5268 exit_label
= gfc_build_label_decl (NULL_TREE
);
5269 TREE_USED (exit_label
) = 1;
5273 gfc_init_block (&loop
);
5275 /* Exit condition. */
5276 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5277 build_zero_cst (sizetype
));
5278 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5279 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5280 build_empty_stmt (input_location
));
5281 gfc_add_expr_to_block (&loop
, tmp
);
5284 gfc_add_modify (&loop
,
5285 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5286 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5288 /* Increment loop variables. */
5289 gfc_add_modify (&loop
, i
,
5290 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5291 TYPE_SIZE_UNIT (type
)));
5292 gfc_add_modify (&loop
, el
,
5293 fold_build_pointer_plus_loc (input_location
,
5294 el
, TYPE_SIZE_UNIT (type
)));
5296 /* Making the loop... actually loop! */
5297 tmp
= gfc_finish_block (&loop
);
5298 tmp
= build1_v (LOOP_EXPR
, tmp
);
5299 gfc_add_expr_to_block (&block
, tmp
);
5301 /* The exit label. */
5302 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5303 gfc_add_expr_to_block (&block
, tmp
);
5306 return gfc_finish_block (&block
);
5310 /* Generate code to copy a string. */
5313 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5314 int dkind
, tree slength
, tree src
, int skind
)
5316 tree tmp
, dlen
, slen
;
5325 stmtblock_t tempblock
;
5327 gcc_assert (dkind
== skind
);
5329 if (slength
!= NULL_TREE
)
5331 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5332 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5336 slen
= build_int_cst (size_type_node
, 1);
5340 if (dlength
!= NULL_TREE
)
5342 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5343 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5347 dlen
= build_int_cst (size_type_node
, 1);
5351 /* Assign directly if the types are compatible. */
5352 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5353 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5355 gfc_add_modify (block
, dsc
, ssc
);
5359 /* Do nothing if the destination length is zero. */
5360 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5361 build_int_cst (size_type_node
, 0));
5363 /* The following code was previously in _gfortran_copy_string:
5365 // The two strings may overlap so we use memmove.
5367 copy_string (GFC_INTEGER_4 destlen, char * dest,
5368 GFC_INTEGER_4 srclen, const char * src)
5370 if (srclen >= destlen)
5372 // This will truncate if too long.
5373 memmove (dest, src, destlen);
5377 memmove (dest, src, srclen);
5379 memset (&dest[srclen], ' ', destlen - srclen);
5383 We're now doing it here for better optimization, but the logic
5386 /* For non-default character kinds, we have to multiply the string
5387 length by the base type size. */
5388 chartype
= gfc_get_char_type (dkind
);
5389 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5390 fold_convert (size_type_node
, slen
),
5391 fold_convert (size_type_node
,
5392 TYPE_SIZE_UNIT (chartype
)));
5393 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5394 fold_convert (size_type_node
, dlen
),
5395 fold_convert (size_type_node
,
5396 TYPE_SIZE_UNIT (chartype
)));
5398 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5399 dest
= fold_convert (pvoid_type_node
, dest
);
5401 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5403 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5404 src
= fold_convert (pvoid_type_node
, src
);
5406 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5408 /* Truncate string if source is too long. */
5409 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5411 tmp2
= build_call_expr_loc (input_location
,
5412 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5413 3, dest
, src
, dlen
);
5415 /* Else copy and pad with spaces. */
5416 tmp3
= build_call_expr_loc (input_location
,
5417 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5418 3, dest
, src
, slen
);
5420 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5421 tmp4
= fill_with_spaces (tmp4
, chartype
,
5422 fold_build2_loc (input_location
, MINUS_EXPR
,
5423 TREE_TYPE(dlen
), dlen
, slen
));
5425 gfc_init_block (&tempblock
);
5426 gfc_add_expr_to_block (&tempblock
, tmp3
);
5427 gfc_add_expr_to_block (&tempblock
, tmp4
);
5428 tmp3
= gfc_finish_block (&tempblock
);
5430 /* The whole copy_string function is there. */
5431 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5433 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5434 build_empty_stmt (input_location
));
5435 gfc_add_expr_to_block (block
, tmp
);
5439 /* Translate a statement function.
5440 The value of a statement function reference is obtained by evaluating the
5441 expression using the values of the actual arguments for the values of the
5442 corresponding dummy arguments. */
5445 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5449 gfc_formal_arglist
*fargs
;
5450 gfc_actual_arglist
*args
;
5453 gfc_saved_var
*saved_vars
;
5459 sym
= expr
->symtree
->n
.sym
;
5460 args
= expr
->value
.function
.actual
;
5461 gfc_init_se (&lse
, NULL
);
5462 gfc_init_se (&rse
, NULL
);
5465 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5467 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5468 temp_vars
= XCNEWVEC (tree
, n
);
5470 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5471 fargs
= fargs
->next
, n
++)
5473 /* Each dummy shall be specified, explicitly or implicitly, to be
5475 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5478 if (fsym
->ts
.type
== BT_CHARACTER
)
5480 /* Copy string arguments. */
5483 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5484 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5486 /* Create a temporary to hold the value. */
5487 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5488 fsym
->ts
.u
.cl
->backend_decl
5489 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5491 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5492 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5494 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5496 gfc_conv_expr (&rse
, args
->expr
);
5497 gfc_conv_string_parameter (&rse
);
5498 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5499 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5501 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5502 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5503 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5504 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5508 /* For everything else, just evaluate the expression. */
5510 /* Create a temporary to hold the value. */
5511 type
= gfc_typenode_for_spec (&fsym
->ts
);
5512 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5514 gfc_conv_expr (&lse
, args
->expr
);
5516 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5517 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5518 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5524 /* Use the temporary variables in place of the real ones. */
5525 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5526 fargs
= fargs
->next
, n
++)
5527 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5529 gfc_conv_expr (se
, sym
->value
);
5531 if (sym
->ts
.type
== BT_CHARACTER
)
5533 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5535 /* Force the expression to the correct length. */
5536 if (!INTEGER_CST_P (se
->string_length
)
5537 || tree_int_cst_lt (se
->string_length
,
5538 sym
->ts
.u
.cl
->backend_decl
))
5540 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5541 tmp
= gfc_create_var (type
, sym
->name
);
5542 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5543 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5544 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5548 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5551 /* Restore the original variables. */
5552 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5553 fargs
= fargs
->next
, n
++)
5554 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5560 /* Translate a function expression. */
5563 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5567 if (expr
->value
.function
.isym
)
5569 gfc_conv_intrinsic_function (se
, expr
);
5573 /* expr.value.function.esym is the resolved (specific) function symbol for
5574 most functions. However this isn't set for dummy procedures. */
5575 sym
= expr
->value
.function
.esym
;
5577 sym
= expr
->symtree
->n
.sym
;
5579 /* We distinguish statement functions from general functions to improve
5580 runtime performance. */
5581 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5583 gfc_conv_statement_function (se
, expr
);
5587 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5592 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5595 is_zero_initializer_p (gfc_expr
* expr
)
5597 if (expr
->expr_type
!= EXPR_CONSTANT
)
5600 /* We ignore constants with prescribed memory representations for now. */
5601 if (expr
->representation
.string
)
5604 switch (expr
->ts
.type
)
5607 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5610 return mpfr_zero_p (expr
->value
.real
)
5611 && MPFR_SIGN (expr
->value
.real
) >= 0;
5614 return expr
->value
.logical
== 0;
5617 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5618 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5619 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5620 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5630 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5635 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5636 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5638 gfc_conv_tmp_array_ref (se
);
5642 /* Build a static initializer. EXPR is the expression for the initial value.
5643 The other parameters describe the variable of the component being
5644 initialized. EXPR may be null. */
5647 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5648 bool array
, bool pointer
, bool procptr
)
5652 if (!(expr
|| pointer
|| procptr
))
5655 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5656 (these are the only two iso_c_binding derived types that can be
5657 used as initialization expressions). If so, we need to modify
5658 the 'expr' to be that for a (void *). */
5659 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5660 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5662 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5664 /* The derived symbol has already been converted to a (void *). Use
5666 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5667 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5669 gfc_init_se (&se
, NULL
);
5670 gfc_conv_constant (&se
, expr
);
5671 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5675 if (array
&& !procptr
)
5678 /* Arrays need special handling. */
5680 ctor
= gfc_build_null_descriptor (type
);
5681 /* Special case assigning an array to zero. */
5682 else if (is_zero_initializer_p (expr
))
5683 ctor
= build_constructor (type
, NULL
);
5685 ctor
= gfc_conv_array_initializer (type
, expr
);
5686 TREE_STATIC (ctor
) = 1;
5689 else if (pointer
|| procptr
)
5691 if (ts
->type
== BT_CLASS
&& !procptr
)
5693 gfc_init_se (&se
, NULL
);
5694 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5695 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5696 TREE_STATIC (se
.expr
) = 1;
5699 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5700 return fold_convert (type
, null_pointer_node
);
5703 gfc_init_se (&se
, NULL
);
5704 se
.want_pointer
= 1;
5705 gfc_conv_expr (&se
, expr
);
5706 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5716 gfc_init_se (&se
, NULL
);
5717 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5718 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5720 gfc_conv_structure (&se
, expr
, 1);
5721 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5722 TREE_STATIC (se
.expr
) = 1;
5727 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5728 TREE_STATIC (ctor
) = 1;
5733 gfc_init_se (&se
, NULL
);
5734 gfc_conv_constant (&se
, expr
);
5735 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5742 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5748 gfc_array_info
*lss_array
;
5755 gfc_start_block (&block
);
5757 /* Initialize the scalarizer. */
5758 gfc_init_loopinfo (&loop
);
5760 gfc_init_se (&lse
, NULL
);
5761 gfc_init_se (&rse
, NULL
);
5764 rss
= gfc_walk_expr (expr
);
5765 if (rss
== gfc_ss_terminator
)
5766 /* The rhs is scalar. Add a ss for the expression. */
5767 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5769 /* Create a SS for the destination. */
5770 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5772 lss_array
= &lss
->info
->data
.array
;
5773 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5774 lss_array
->descriptor
= dest
;
5775 lss_array
->data
= gfc_conv_array_data (dest
);
5776 lss_array
->offset
= gfc_conv_array_offset (dest
);
5777 for (n
= 0; n
< cm
->as
->rank
; n
++)
5779 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5780 lss_array
->stride
[n
] = gfc_index_one_node
;
5782 mpz_init (lss_array
->shape
[n
]);
5783 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5784 cm
->as
->lower
[n
]->value
.integer
);
5785 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5788 /* Associate the SS with the loop. */
5789 gfc_add_ss_to_loop (&loop
, lss
);
5790 gfc_add_ss_to_loop (&loop
, rss
);
5792 /* Calculate the bounds of the scalarization. */
5793 gfc_conv_ss_startstride (&loop
);
5795 /* Setup the scalarizing loops. */
5796 gfc_conv_loop_setup (&loop
, &expr
->where
);
5798 /* Setup the gfc_se structures. */
5799 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5800 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5803 gfc_mark_ss_chain_used (rss
, 1);
5805 gfc_mark_ss_chain_used (lss
, 1);
5807 /* Start the scalarized loop body. */
5808 gfc_start_scalarized_body (&loop
, &body
);
5810 gfc_conv_tmp_array_ref (&lse
);
5811 if (cm
->ts
.type
== BT_CHARACTER
)
5812 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5814 gfc_conv_expr (&rse
, expr
);
5816 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5817 gfc_add_expr_to_block (&body
, tmp
);
5819 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5821 /* Generate the copying loops. */
5822 gfc_trans_scalarizing_loops (&loop
, &body
);
5824 /* Wrap the whole thing up. */
5825 gfc_add_block_to_block (&block
, &loop
.pre
);
5826 gfc_add_block_to_block (&block
, &loop
.post
);
5828 gcc_assert (lss_array
->shape
!= NULL
);
5829 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5830 gfc_cleanup_loop (&loop
);
5832 return gfc_finish_block (&block
);
5837 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5847 gfc_expr
*arg
= NULL
;
5849 gfc_start_block (&block
);
5850 gfc_init_se (&se
, NULL
);
5852 /* Get the descriptor for the expressions. */
5853 se
.want_pointer
= 0;
5854 gfc_conv_expr_descriptor (&se
, expr
);
5855 gfc_add_block_to_block (&block
, &se
.pre
);
5856 gfc_add_modify (&block
, dest
, se
.expr
);
5858 /* Deal with arrays of derived types with allocatable components. */
5859 if (cm
->ts
.type
== BT_DERIVED
5860 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5861 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5865 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5866 TREE_TYPE(cm
->backend_decl
),
5869 gfc_add_expr_to_block (&block
, tmp
);
5870 gfc_add_block_to_block (&block
, &se
.post
);
5872 if (expr
->expr_type
!= EXPR_VARIABLE
)
5873 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5876 /* We need to know if the argument of a conversion function is a
5877 variable, so that the correct lower bound can be used. */
5878 if (expr
->expr_type
== EXPR_FUNCTION
5879 && expr
->value
.function
.isym
5880 && expr
->value
.function
.isym
->conversion
5881 && expr
->value
.function
.actual
->expr
5882 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5883 arg
= expr
->value
.function
.actual
->expr
;
5885 /* Obtain the array spec of full array references. */
5887 as
= gfc_get_full_arrayspec_from_expr (arg
);
5889 as
= gfc_get_full_arrayspec_from_expr (expr
);
5891 /* Shift the lbound and ubound of temporaries to being unity,
5892 rather than zero, based. Always calculate the offset. */
5893 offset
= gfc_conv_descriptor_offset_get (dest
);
5894 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5895 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5897 for (n
= 0; n
< expr
->rank
; n
++)
5902 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5903 TODO It looks as if gfc_conv_expr_descriptor should return
5904 the correct bounds and that the following should not be
5905 necessary. This would simplify gfc_conv_intrinsic_bound
5907 if (as
&& as
->lower
[n
])
5910 gfc_init_se (&lbse
, NULL
);
5911 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5912 gfc_add_block_to_block (&block
, &lbse
.pre
);
5913 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5917 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5918 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5922 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5925 lbound
= gfc_index_one_node
;
5927 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5929 /* Shift the bounds and set the offset accordingly. */
5930 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5931 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5932 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5933 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5935 gfc_conv_descriptor_ubound_set (&block
, dest
,
5936 gfc_rank_cst
[n
], tmp
);
5937 gfc_conv_descriptor_lbound_set (&block
, dest
,
5938 gfc_rank_cst
[n
], lbound
);
5940 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5941 gfc_conv_descriptor_lbound_get (dest
,
5943 gfc_conv_descriptor_stride_get (dest
,
5945 gfc_add_modify (&block
, tmp2
, tmp
);
5946 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5948 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5953 /* If a conversion expression has a null data pointer
5954 argument, nullify the allocatable component. */
5958 if (arg
->symtree
->n
.sym
->attr
.allocatable
5959 || arg
->symtree
->n
.sym
->attr
.pointer
)
5961 non_null_expr
= gfc_finish_block (&block
);
5962 gfc_start_block (&block
);
5963 gfc_conv_descriptor_data_set (&block
, dest
,
5965 null_expr
= gfc_finish_block (&block
);
5966 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5967 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5968 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5969 return build3_v (COND_EXPR
, tmp
,
5970 null_expr
, non_null_expr
);
5974 return gfc_finish_block (&block
);
5978 /* Assign a single component of a derived type constructor. */
5981 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5988 gfc_start_block (&block
);
5990 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5992 gfc_init_se (&se
, NULL
);
5993 /* Pointer component. */
5994 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5996 /* Array pointer. */
5997 if (expr
->expr_type
== EXPR_NULL
)
5998 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6001 se
.direct_byref
= 1;
6003 gfc_conv_expr_descriptor (&se
, expr
);
6004 gfc_add_block_to_block (&block
, &se
.pre
);
6005 gfc_add_block_to_block (&block
, &se
.post
);
6010 /* Scalar pointers. */
6011 se
.want_pointer
= 1;
6012 gfc_conv_expr (&se
, expr
);
6013 gfc_add_block_to_block (&block
, &se
.pre
);
6015 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6016 && expr
->symtree
->n
.sym
->attr
.dummy
)
6017 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6019 gfc_add_modify (&block
, dest
,
6020 fold_convert (TREE_TYPE (dest
), se
.expr
));
6021 gfc_add_block_to_block (&block
, &se
.post
);
6024 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6026 /* NULL initialization for CLASS components. */
6027 tmp
= gfc_trans_structure_assign (dest
,
6028 gfc_class_initializer (&cm
->ts
, expr
));
6029 gfc_add_expr_to_block (&block
, tmp
);
6031 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
6033 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6034 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6035 else if (cm
->attr
.allocatable
)
6037 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6038 gfc_add_expr_to_block (&block
, tmp
);
6042 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6043 gfc_add_expr_to_block (&block
, tmp
);
6046 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6048 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6050 gfc_init_se (&se
, NULL
);
6051 gfc_conv_expr (&se
, expr
);
6052 gfc_add_block_to_block (&block
, &se
.pre
);
6053 gfc_add_modify (&block
, dest
,
6054 fold_convert (TREE_TYPE (dest
), se
.expr
));
6055 gfc_add_block_to_block (&block
, &se
.post
);
6059 /* Nested constructors. */
6060 tmp
= gfc_trans_structure_assign (dest
, expr
);
6061 gfc_add_expr_to_block (&block
, tmp
);
6064 else if (gfc_deferred_strlen (cm
, &tmp
))
6068 gcc_assert (strlen
);
6069 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6071 TREE_OPERAND (dest
, 0),
6074 if (expr
->expr_type
== EXPR_NULL
)
6076 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6077 gfc_add_modify (&block
, dest
, tmp
);
6078 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6079 gfc_add_modify (&block
, strlen
, tmp
);
6084 gfc_init_se (&se
, NULL
);
6085 gfc_conv_expr (&se
, expr
);
6086 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6087 tmp
= build_call_expr_loc (input_location
,
6088 builtin_decl_explicit (BUILT_IN_MALLOC
),
6090 gfc_add_modify (&block
, dest
,
6091 fold_convert (TREE_TYPE (dest
), tmp
));
6092 gfc_add_modify (&block
, strlen
, se
.string_length
);
6093 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6094 gfc_add_expr_to_block (&block
, tmp
);
6097 else if (!cm
->attr
.deferred_parameter
)
6099 /* Scalar component (excluding deferred parameters). */
6100 gfc_init_se (&se
, NULL
);
6101 gfc_init_se (&lse
, NULL
);
6103 gfc_conv_expr (&se
, expr
);
6104 if (cm
->ts
.type
== BT_CHARACTER
)
6105 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6107 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6108 gfc_add_expr_to_block (&block
, tmp
);
6110 return gfc_finish_block (&block
);
6113 /* Assign a derived type constructor to a variable. */
6116 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6124 gfc_start_block (&block
);
6125 cm
= expr
->ts
.u
.derived
->components
;
6127 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6128 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6129 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6133 gcc_assert (cm
->backend_decl
== NULL
);
6134 gfc_init_se (&se
, NULL
);
6135 gfc_init_se (&lse
, NULL
);
6136 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6138 gfc_add_modify (&block
, lse
.expr
,
6139 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6141 return gfc_finish_block (&block
);
6144 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6145 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6147 /* Skip absent members in default initializers. */
6151 field
= cm
->backend_decl
;
6152 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6153 dest
, field
, NULL_TREE
);
6154 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6155 gfc_add_expr_to_block (&block
, tmp
);
6157 return gfc_finish_block (&block
);
6160 /* Build an expression for a constructor. If init is nonzero then
6161 this is part of a static variable initializer. */
6164 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6171 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6173 gcc_assert (se
->ss
== NULL
);
6174 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6175 type
= gfc_typenode_for_spec (&expr
->ts
);
6179 /* Create a temporary variable and fill it in. */
6180 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6181 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6182 gfc_add_expr_to_block (&se
->pre
, tmp
);
6186 cm
= expr
->ts
.u
.derived
->components
;
6188 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6189 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6191 /* Skip absent members in default initializers and allocatable
6192 components. Although the latter have a default initializer
6193 of EXPR_NULL,... by default, the static nullify is not needed
6194 since this is done every time we come into scope. */
6195 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6198 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6199 && strcmp (cm
->name
, "_extends") == 0
6200 && cm
->initializer
->symtree
)
6204 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6205 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6206 vtab
= unshare_expr_without_location (vtab
);
6207 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6209 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6211 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6212 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6216 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6217 TREE_TYPE (cm
->backend_decl
),
6218 cm
->attr
.dimension
, cm
->attr
.pointer
,
6219 cm
->attr
.proc_pointer
);
6220 val
= unshare_expr_without_location (val
);
6222 /* Append it to the constructor list. */
6223 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6226 se
->expr
= build_constructor (type
, v
);
6228 TREE_CONSTANT (se
->expr
) = 1;
6232 /* Translate a substring expression. */
6235 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6241 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6243 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6244 expr
->value
.character
.length
,
6245 expr
->value
.character
.string
);
6247 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6248 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6251 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6255 /* Entry point for expression translation. Evaluates a scalar quantity.
6256 EXPR is the expression to be translated, and SE is the state structure if
6257 called from within the scalarized. */
6260 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6265 if (ss
&& ss
->info
->expr
== expr
6266 && (ss
->info
->type
== GFC_SS_SCALAR
6267 || ss
->info
->type
== GFC_SS_REFERENCE
))
6269 gfc_ss_info
*ss_info
;
6272 /* Substitute a scalar expression evaluated outside the scalarization
6274 se
->expr
= ss_info
->data
.scalar
.value
;
6275 /* If the reference can be NULL, the value field contains the reference,
6276 not the value the reference points to (see gfc_add_loop_ss_code). */
6277 if (ss_info
->can_be_null_ref
)
6278 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6280 se
->string_length
= ss_info
->string_length
;
6281 gfc_advance_se_ss_chain (se
);
6285 /* We need to convert the expressions for the iso_c_binding derived types.
6286 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6287 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6288 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6289 updated to be an integer with a kind equal to the size of a (void *). */
6290 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6292 if (expr
->expr_type
== EXPR_VARIABLE
6293 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6294 || expr
->symtree
->n
.sym
->intmod_sym_id
6295 == ISOCBINDING_NULL_FUNPTR
))
6297 /* Set expr_type to EXPR_NULL, which will result in
6298 null_pointer_node being used below. */
6299 expr
->expr_type
= EXPR_NULL
;
6303 /* Update the type/kind of the expression to be what the new
6304 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6305 expr
->ts
.type
= BT_INTEGER
;
6306 expr
->ts
.f90_type
= BT_VOID
;
6307 expr
->ts
.kind
= gfc_index_integer_kind
;
6311 gfc_fix_class_refs (expr
);
6313 switch (expr
->expr_type
)
6316 gfc_conv_expr_op (se
, expr
);
6320 gfc_conv_function_expr (se
, expr
);
6324 gfc_conv_constant (se
, expr
);
6328 gfc_conv_variable (se
, expr
);
6332 se
->expr
= null_pointer_node
;
6335 case EXPR_SUBSTRING
:
6336 gfc_conv_substring_expr (se
, expr
);
6339 case EXPR_STRUCTURE
:
6340 gfc_conv_structure (se
, expr
, 0);
6344 gfc_conv_array_constructor_expr (se
, expr
);
6353 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6354 of an assignment. */
6356 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6358 gfc_conv_expr (se
, expr
);
6359 /* All numeric lvalues should have empty post chains. If not we need to
6360 figure out a way of rewriting an lvalue so that it has no post chain. */
6361 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6364 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6365 numeric expressions. Used for scalar values where inserting cleanup code
6368 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6372 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6373 gfc_conv_expr (se
, expr
);
6376 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6377 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6379 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6383 /* Helper to translate an expression and convert it to a particular type. */
6385 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6387 gfc_conv_expr_val (se
, expr
);
6388 se
->expr
= convert (type
, se
->expr
);
6392 /* Converts an expression so that it can be passed by reference. Scalar
6396 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6402 if (ss
&& ss
->info
->expr
== expr
6403 && ss
->info
->type
== GFC_SS_REFERENCE
)
6405 /* Returns a reference to the scalar evaluated outside the loop
6407 gfc_conv_expr (se
, expr
);
6409 if (expr
->ts
.type
== BT_CHARACTER
6410 && expr
->expr_type
!= EXPR_FUNCTION
)
6411 gfc_conv_string_parameter (se
);
6413 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6418 if (expr
->ts
.type
== BT_CHARACTER
)
6420 gfc_conv_expr (se
, expr
);
6421 gfc_conv_string_parameter (se
);
6425 if (expr
->expr_type
== EXPR_VARIABLE
)
6427 se
->want_pointer
= 1;
6428 gfc_conv_expr (se
, expr
);
6431 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6432 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6433 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6439 if (expr
->expr_type
== EXPR_FUNCTION
6440 && ((expr
->value
.function
.esym
6441 && expr
->value
.function
.esym
->result
->attr
.pointer
6442 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6443 || (!expr
->value
.function
.esym
&& !expr
->ref
6444 && expr
->symtree
->n
.sym
->attr
.pointer
6445 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6447 se
->want_pointer
= 1;
6448 gfc_conv_expr (se
, expr
);
6449 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6450 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6455 gfc_conv_expr (se
, expr
);
6457 /* Create a temporary var to hold the value. */
6458 if (TREE_CONSTANT (se
->expr
))
6460 tree tmp
= se
->expr
;
6461 STRIP_TYPE_NOPS (tmp
);
6462 var
= build_decl (input_location
,
6463 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6464 DECL_INITIAL (var
) = tmp
;
6465 TREE_STATIC (var
) = 1;
6470 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6471 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6473 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6475 /* Take the address of that value. */
6476 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6477 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6478 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6479 && expr
->ts
.u
.derived
->attr
.alloc_comp
6480 && expr
->expr_type
!= EXPR_VARIABLE
)
6484 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6485 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6487 /* The components shall be deallocated before
6488 their containing entity. */
6489 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6495 gfc_trans_pointer_assign (gfc_code
* code
)
6497 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6501 /* Generate code for a pointer assignment. */
6504 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6506 gfc_expr
*expr1_vptr
= NULL
;
6516 gfc_start_block (&block
);
6518 gfc_init_se (&lse
, NULL
);
6520 /* Check whether the expression is a scalar or not; we cannot use
6521 expr1->rank as it can be nonzero for proc pointers. */
6522 ss
= gfc_walk_expr (expr1
);
6523 scalar
= ss
== gfc_ss_terminator
;
6525 gfc_free_ss_chain (ss
);
6527 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6528 && expr2
->expr_type
!= EXPR_FUNCTION
)
6530 gfc_add_data_component (expr2
);
6531 /* The following is required as gfc_add_data_component doesn't
6532 update ts.type if there is a tailing REF_ARRAY. */
6533 expr2
->ts
.type
= BT_DERIVED
;
6538 /* Scalar pointers. */
6539 lse
.want_pointer
= 1;
6540 gfc_conv_expr (&lse
, expr1
);
6541 gfc_init_se (&rse
, NULL
);
6542 rse
.want_pointer
= 1;
6543 gfc_conv_expr (&rse
, expr2
);
6545 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6546 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6547 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6550 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6551 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6552 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6555 gfc_add_block_to_block (&block
, &lse
.pre
);
6556 gfc_add_block_to_block (&block
, &rse
.pre
);
6558 /* Check character lengths if character expression. The test is only
6559 really added if -fbounds-check is enabled. Exclude deferred
6560 character length lefthand sides. */
6561 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6562 && !expr1
->ts
.deferred
6563 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6564 && !gfc_is_proc_ptr_comp (expr1
))
6566 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6567 gcc_assert (lse
.string_length
&& rse
.string_length
);
6568 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6569 lse
.string_length
, rse
.string_length
,
6573 /* The assignment to an deferred character length sets the string
6574 length to that of the rhs. */
6575 if (expr1
->ts
.deferred
)
6577 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6578 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6579 else if (lse
.string_length
!= NULL
)
6580 gfc_add_modify (&block
, lse
.string_length
,
6581 build_int_cst (gfc_charlen_type_node
, 0));
6584 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6585 rse
.expr
= gfc_class_data_get (rse
.expr
);
6587 gfc_add_modify (&block
, lse
.expr
,
6588 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6590 gfc_add_block_to_block (&block
, &rse
.post
);
6591 gfc_add_block_to_block (&block
, &lse
.post
);
6598 tree strlen_rhs
= NULL_TREE
;
6600 /* Array pointer. Find the last reference on the LHS and if it is an
6601 array section ref, we're dealing with bounds remapping. In this case,
6602 set it to AR_FULL so that gfc_conv_expr_descriptor does
6603 not see it and process the bounds remapping afterwards explicitly. */
6604 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6605 if (!remap
->next
&& remap
->type
== REF_ARRAY
6606 && remap
->u
.ar
.type
== AR_SECTION
)
6608 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6610 gfc_init_se (&lse
, NULL
);
6612 lse
.descriptor_only
= 1;
6613 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6614 && expr1
->ts
.type
== BT_CLASS
)
6615 expr1_vptr
= gfc_copy_expr (expr1
);
6616 gfc_conv_expr_descriptor (&lse
, expr1
);
6617 strlen_lhs
= lse
.string_length
;
6620 if (expr2
->expr_type
== EXPR_NULL
)
6622 /* Just set the data pointer to null. */
6623 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6625 else if (rank_remap
)
6627 /* If we are rank-remapping, just get the RHS's descriptor and
6628 process this later on. */
6629 gfc_init_se (&rse
, NULL
);
6630 rse
.direct_byref
= 1;
6631 rse
.byref_noassign
= 1;
6633 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6635 gfc_conv_function_expr (&rse
, expr2
);
6637 if (expr1
->ts
.type
!= BT_CLASS
)
6638 rse
.expr
= gfc_class_data_get (rse
.expr
);
6641 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6642 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6644 gfc_add_vptr_component (expr1_vptr
);
6645 gfc_init_se (&rse
, NULL
);
6646 rse
.want_pointer
= 1;
6647 gfc_conv_expr (&rse
, expr1_vptr
);
6648 gfc_add_modify (&lse
.pre
, rse
.expr
,
6649 fold_convert (TREE_TYPE (rse
.expr
),
6650 gfc_class_vptr_get (tmp
)));
6651 rse
.expr
= gfc_class_data_get (tmp
);
6654 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6656 tree bound
[GFC_MAX_DIMENSIONS
];
6659 for (i
= 0; i
< expr2
->rank
; i
++)
6660 bound
[i
] = NULL_TREE
;
6661 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6662 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6664 GFC_ARRAY_POINTER_CONT
, false);
6665 tmp
= gfc_create_var (tmp
, "ptrtemp");
6666 lse
.descriptor_only
= 0;
6668 lse
.direct_byref
= 1;
6669 gfc_conv_expr_descriptor (&lse
, expr2
);
6670 strlen_rhs
= lse
.string_length
;
6675 gfc_conv_expr_descriptor (&rse
, expr2
);
6676 strlen_rhs
= rse
.string_length
;
6679 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6681 /* Assign directly to the LHS's descriptor. */
6682 lse
.descriptor_only
= 0;
6683 lse
.direct_byref
= 1;
6684 gfc_conv_expr_descriptor (&lse
, expr2
);
6685 strlen_rhs
= lse
.string_length
;
6687 /* If this is a subreference array pointer assignment, use the rhs
6688 descriptor element size for the lhs span. */
6689 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6691 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6692 gfc_init_se (&rse
, NULL
);
6693 rse
.descriptor_only
= 1;
6694 gfc_conv_expr (&rse
, expr2
);
6695 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6696 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6697 if (!INTEGER_CST_P (tmp
))
6698 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6699 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6702 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6704 gfc_init_se (&rse
, NULL
);
6705 rse
.want_pointer
= 1;
6706 gfc_conv_function_expr (&rse
, expr2
);
6707 if (expr1
->ts
.type
!= BT_CLASS
)
6709 rse
.expr
= gfc_class_data_get (rse
.expr
);
6710 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6714 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6715 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6717 gfc_add_vptr_component (expr1_vptr
);
6718 gfc_init_se (&rse
, NULL
);
6719 rse
.want_pointer
= 1;
6720 gfc_conv_expr (&rse
, expr1_vptr
);
6721 gfc_add_modify (&lse
.pre
, rse
.expr
,
6722 fold_convert (TREE_TYPE (rse
.expr
),
6723 gfc_class_vptr_get (tmp
)));
6724 rse
.expr
= gfc_class_data_get (tmp
);
6725 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6730 /* Assign to a temporary descriptor and then copy that
6731 temporary to the pointer. */
6732 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6733 lse
.descriptor_only
= 0;
6735 lse
.direct_byref
= 1;
6736 gfc_conv_expr_descriptor (&lse
, expr2
);
6737 strlen_rhs
= lse
.string_length
;
6738 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6742 gfc_free_expr (expr1_vptr
);
6744 gfc_add_block_to_block (&block
, &lse
.pre
);
6746 gfc_add_block_to_block (&block
, &rse
.pre
);
6748 /* If we do bounds remapping, update LHS descriptor accordingly. */
6752 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6756 /* Do rank remapping. We already have the RHS's descriptor
6757 converted in rse and now have to build the correct LHS
6758 descriptor for it. */
6762 tree lbound
, ubound
;
6765 dtype
= gfc_conv_descriptor_dtype (desc
);
6766 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6767 gfc_add_modify (&block
, dtype
, tmp
);
6769 /* Copy data pointer. */
6770 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6771 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6773 /* Copy offset but adjust it such that it would correspond
6774 to a lbound of zero. */
6775 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6776 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6778 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6780 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6782 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6783 gfc_array_index_type
, stride
, lbound
);
6784 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6785 gfc_array_index_type
, offs
, tmp
);
6787 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6789 /* Set the bounds as declared for the LHS and calculate strides as
6790 well as another offset update accordingly. */
6791 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6793 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6798 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6800 /* Convert declared bounds. */
6801 gfc_init_se (&lower_se
, NULL
);
6802 gfc_init_se (&upper_se
, NULL
);
6803 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6804 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6806 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6807 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6809 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6810 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6812 lbound
= gfc_evaluate_now (lbound
, &block
);
6813 ubound
= gfc_evaluate_now (ubound
, &block
);
6815 gfc_add_block_to_block (&block
, &lower_se
.post
);
6816 gfc_add_block_to_block (&block
, &upper_se
.post
);
6818 /* Set bounds in descriptor. */
6819 gfc_conv_descriptor_lbound_set (&block
, desc
,
6820 gfc_rank_cst
[dim
], lbound
);
6821 gfc_conv_descriptor_ubound_set (&block
, desc
,
6822 gfc_rank_cst
[dim
], ubound
);
6825 stride
= gfc_evaluate_now (stride
, &block
);
6826 gfc_conv_descriptor_stride_set (&block
, desc
,
6827 gfc_rank_cst
[dim
], stride
);
6829 /* Update offset. */
6830 offs
= gfc_conv_descriptor_offset_get (desc
);
6831 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6832 gfc_array_index_type
, lbound
, stride
);
6833 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6834 gfc_array_index_type
, offs
, tmp
);
6835 offs
= gfc_evaluate_now (offs
, &block
);
6836 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6838 /* Update stride. */
6839 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6840 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6841 gfc_array_index_type
, stride
, tmp
);
6846 /* Bounds remapping. Just shift the lower bounds. */
6848 gcc_assert (expr1
->rank
== expr2
->rank
);
6850 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6854 gcc_assert (remap
->u
.ar
.start
[dim
]);
6855 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6856 gfc_init_se (&lbound_se
, NULL
);
6857 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6859 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6860 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6861 dim
, lbound_se
.expr
);
6862 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6867 /* Check string lengths if applicable. The check is only really added
6868 to the output code if -fbounds-check is enabled. */
6869 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6871 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6872 gcc_assert (strlen_lhs
&& strlen_rhs
);
6873 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6874 strlen_lhs
, strlen_rhs
, &block
);
6877 /* If rank remapping was done, check with -fcheck=bounds that
6878 the target is at least as large as the pointer. */
6879 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6885 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6886 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6888 lsize
= gfc_evaluate_now (lsize
, &block
);
6889 rsize
= gfc_evaluate_now (rsize
, &block
);
6890 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6893 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6894 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6898 gfc_add_block_to_block (&block
, &lse
.post
);
6900 gfc_add_block_to_block (&block
, &rse
.post
);
6903 return gfc_finish_block (&block
);
6907 /* Makes sure se is suitable for passing as a function string parameter. */
6908 /* TODO: Need to check all callers of this function. It may be abused. */
6911 gfc_conv_string_parameter (gfc_se
* se
)
6915 if (TREE_CODE (se
->expr
) == STRING_CST
)
6917 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6918 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6922 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6924 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6926 type
= TREE_TYPE (se
->expr
);
6927 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6931 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6933 type
= build_pointer_type (type
);
6934 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6938 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6942 /* Generate code for assignment of scalar variables. Includes character
6943 strings and derived types with allocatable components.
6944 If you know that the LHS has no allocations, set dealloc to false.
6946 DEEP_COPY has no effect if the typespec TS is not a derived type with
6947 allocatable components. Otherwise, if it is set, an explicit copy of each
6948 allocatable component is made. This is necessary as a simple copy of the
6949 whole object would copy array descriptors as is, so that the lhs's
6950 allocatable components would point to the rhs's after the assignment.
6951 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6952 necessary if the rhs is a non-pointer function, as the allocatable components
6953 are not accessible by other means than the function's result after the
6954 function has returned. It is even more subtle when temporaries are involved,
6955 as the two following examples show:
6956 1. When we evaluate an array constructor, a temporary is created. Thus
6957 there is theoretically no alias possible. However, no deep copy is
6958 made for this temporary, so that if the constructor is made of one or
6959 more variable with allocatable components, those components still point
6960 to the variable's: DEEP_COPY should be set for the assignment from the
6961 temporary to the lhs in that case.
6962 2. When assigning a scalar to an array, we evaluate the scalar value out
6963 of the loop, store it into a temporary variable, and assign from that.
6964 In that case, deep copying when assigning to the temporary would be a
6965 waste of resources; however deep copies should happen when assigning from
6966 the temporary to each array element: again DEEP_COPY should be set for
6967 the assignment from the temporary to the lhs. */
6970 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6971 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6977 gfc_init_block (&block
);
6979 if (ts
.type
== BT_CHARACTER
)
6984 if (lse
->string_length
!= NULL_TREE
)
6986 gfc_conv_string_parameter (lse
);
6987 gfc_add_block_to_block (&block
, &lse
->pre
);
6988 llen
= lse
->string_length
;
6991 if (rse
->string_length
!= NULL_TREE
)
6993 gcc_assert (rse
->string_length
!= NULL_TREE
);
6994 gfc_conv_string_parameter (rse
);
6995 gfc_add_block_to_block (&block
, &rse
->pre
);
6996 rlen
= rse
->string_length
;
6999 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7000 rse
->expr
, ts
.kind
);
7002 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7004 tree tmp_var
= NULL_TREE
;
7007 /* Are the rhs and the lhs the same? */
7010 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7011 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7012 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7013 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7016 /* Deallocate the lhs allocated components as long as it is not
7017 the same as the rhs. This must be done following the assignment
7018 to prevent deallocating data that could be used in the rhs
7020 if (!l_is_temp
&& dealloc
)
7022 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7023 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7025 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7027 gfc_add_expr_to_block (&lse
->post
, tmp
);
7030 gfc_add_block_to_block (&block
, &rse
->pre
);
7031 gfc_add_block_to_block (&block
, &lse
->pre
);
7033 gfc_add_modify (&block
, lse
->expr
,
7034 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7036 /* Restore pointer address of coarray components. */
7037 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7039 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7040 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7042 gfc_add_expr_to_block (&block
, tmp
);
7045 /* Do a deep copy if the rhs is a variable, if it is not the
7049 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7050 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7052 gfc_add_expr_to_block (&block
, tmp
);
7055 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7057 gfc_add_block_to_block (&block
, &lse
->pre
);
7058 gfc_add_block_to_block (&block
, &rse
->pre
);
7059 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7060 TREE_TYPE (lse
->expr
), rse
->expr
);
7061 gfc_add_modify (&block
, lse
->expr
, tmp
);
7065 gfc_add_block_to_block (&block
, &lse
->pre
);
7066 gfc_add_block_to_block (&block
, &rse
->pre
);
7068 gfc_add_modify (&block
, lse
->expr
,
7069 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7072 gfc_add_block_to_block (&block
, &lse
->post
);
7073 gfc_add_block_to_block (&block
, &rse
->post
);
7075 return gfc_finish_block (&block
);
7079 /* There are quite a lot of restrictions on the optimisation in using an
7080 array function assign without a temporary. */
7083 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7086 bool seen_array_ref
;
7088 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7090 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7091 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7094 /* Elemental functions are scalarized so that they don't need a
7095 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7096 they would need special treatment in gfc_trans_arrayfunc_assign. */
7097 if (expr2
->value
.function
.esym
!= NULL
7098 && expr2
->value
.function
.esym
->attr
.elemental
)
7101 /* Need a temporary if rhs is not FULL or a contiguous section. */
7102 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7105 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7106 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7109 /* Functions returning pointers or allocatables need temporaries. */
7110 c
= expr2
->value
.function
.esym
7111 ? (expr2
->value
.function
.esym
->attr
.pointer
7112 || expr2
->value
.function
.esym
->attr
.allocatable
)
7113 : (expr2
->symtree
->n
.sym
->attr
.pointer
7114 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7118 /* Character array functions need temporaries unless the
7119 character lengths are the same. */
7120 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7122 if (expr1
->ts
.u
.cl
->length
== NULL
7123 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7126 if (expr2
->ts
.u
.cl
->length
== NULL
7127 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7130 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7131 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7135 /* Check that no LHS component references appear during an array
7136 reference. This is needed because we do not have the means to
7137 span any arbitrary stride with an array descriptor. This check
7138 is not needed for the rhs because the function result has to be
7140 seen_array_ref
= false;
7141 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7143 if (ref
->type
== REF_ARRAY
)
7144 seen_array_ref
= true;
7145 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7149 /* Check for a dependency. */
7150 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7151 expr2
->value
.function
.esym
,
7152 expr2
->value
.function
.actual
,
7156 /* If we have reached here with an intrinsic function, we do not
7157 need a temporary except in the particular case that reallocation
7158 on assignment is active and the lhs is allocatable and a target. */
7159 if (expr2
->value
.function
.isym
)
7160 return (gfc_option
.flag_realloc_lhs
7161 && sym
->attr
.allocatable
7162 && sym
->attr
.target
);
7164 /* If the LHS is a dummy, we need a temporary if it is not
7166 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7169 /* If the lhs has been host_associated, is in common, a pointer or is
7170 a target and the function is not using a RESULT variable, aliasing
7171 can occur and a temporary is needed. */
7172 if ((sym
->attr
.host_assoc
7173 || sym
->attr
.in_common
7174 || sym
->attr
.pointer
7175 || sym
->attr
.cray_pointee
7176 || sym
->attr
.target
)
7177 && expr2
->symtree
!= NULL
7178 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7181 /* A PURE function can unconditionally be called without a temporary. */
7182 if (expr2
->value
.function
.esym
!= NULL
7183 && expr2
->value
.function
.esym
->attr
.pure
)
7186 /* Implicit_pure functions are those which could legally be declared
7188 if (expr2
->value
.function
.esym
!= NULL
7189 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7192 if (!sym
->attr
.use_assoc
7193 && !sym
->attr
.in_common
7194 && !sym
->attr
.pointer
7195 && !sym
->attr
.target
7196 && !sym
->attr
.cray_pointee
7197 && expr2
->value
.function
.esym
)
7199 /* A temporary is not needed if the function is not contained and
7200 the variable is local or host associated and not a pointer or
7202 if (!expr2
->value
.function
.esym
->attr
.contained
)
7205 /* A temporary is not needed if the lhs has never been host
7206 associated and the procedure is contained. */
7207 else if (!sym
->attr
.host_assoc
)
7210 /* A temporary is not needed if the variable is local and not
7211 a pointer, a target or a result. */
7213 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7217 /* Default to temporary use. */
7222 /* Provide the loop info so that the lhs descriptor can be built for
7223 reallocatable assignments from extrinsic function calls. */
7226 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7229 /* Signal that the function call should not be made by
7230 gfc_conv_loop_setup. */
7231 se
->ss
->is_alloc_lhs
= 1;
7232 gfc_init_loopinfo (loop
);
7233 gfc_add_ss_to_loop (loop
, *ss
);
7234 gfc_add_ss_to_loop (loop
, se
->ss
);
7235 gfc_conv_ss_startstride (loop
);
7236 gfc_conv_loop_setup (loop
, where
);
7237 gfc_copy_loopinfo_to_se (se
, loop
);
7238 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7239 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7240 se
->ss
->is_alloc_lhs
= 0;
7244 /* For assignment to a reallocatable lhs from intrinsic functions,
7245 replace the se.expr (ie. the result) with a temporary descriptor.
7246 Null the data field so that the library allocates space for the
7247 result. Free the data of the original descriptor after the function,
7248 in case it appears in an argument expression and transfer the
7249 result to the original descriptor. */
7252 fcncall_realloc_result (gfc_se
*se
, int rank
)
7261 /* Use the allocation done by the library. Substitute the lhs
7262 descriptor with a copy, whose data field is nulled.*/
7263 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7264 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7265 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7267 /* Unallocated, the descriptor does not have a dtype. */
7268 tmp
= gfc_conv_descriptor_dtype (desc
);
7269 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7271 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7272 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7273 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7275 /* Free the lhs after the function call and copy the result data to
7276 the lhs descriptor. */
7277 tmp
= gfc_conv_descriptor_data_get (desc
);
7278 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7279 boolean_type_node
, tmp
,
7280 build_int_cst (TREE_TYPE (tmp
), 0));
7281 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7282 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7283 gfc_add_expr_to_block (&se
->post
, tmp
);
7285 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7286 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7288 /* Check that the shapes are the same between lhs and expression. */
7289 for (n
= 0 ; n
< rank
; n
++)
7292 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7293 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7294 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7295 gfc_array_index_type
, tmp
, tmp1
);
7296 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7297 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7298 gfc_array_index_type
, tmp
, tmp1
);
7299 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7300 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7301 gfc_array_index_type
, tmp
, tmp1
);
7302 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7303 boolean_type_node
, tmp
,
7304 gfc_index_zero_node
);
7305 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7306 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7307 boolean_type_node
, tmp
,
7311 /* 'zero_cond' being true is equal to lhs not being allocated or the
7312 shapes being different. */
7313 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7315 /* Now reset the bounds returned from the function call to bounds based
7316 on the lhs lbounds, except where the lhs is not allocated or the shapes
7317 of 'variable and 'expr' are different. Set the offset accordingly. */
7318 offset
= gfc_index_zero_node
;
7319 for (n
= 0 ; n
< rank
; n
++)
7323 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7324 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7325 gfc_array_index_type
, zero_cond
,
7326 gfc_index_one_node
, lbound
);
7327 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7329 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7330 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7331 gfc_array_index_type
, tmp
, lbound
);
7332 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7333 gfc_rank_cst
[n
], lbound
);
7334 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7335 gfc_rank_cst
[n
], tmp
);
7337 /* Set stride and accumulate the offset. */
7338 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7339 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7340 gfc_rank_cst
[n
], tmp
);
7341 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7342 gfc_array_index_type
, lbound
, tmp
);
7343 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7344 gfc_array_index_type
, offset
, tmp
);
7345 offset
= gfc_evaluate_now (offset
, &se
->post
);
7348 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7353 /* Try to translate array(:) = func (...), where func is a transformational
7354 array function, without using a temporary. Returns NULL if this isn't the
7358 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7362 gfc_component
*comp
= NULL
;
7365 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7368 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7370 comp
= gfc_get_proc_ptr_comp (expr2
);
7371 gcc_assert (expr2
->value
.function
.isym
7372 || (comp
&& comp
->attr
.dimension
)
7373 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7374 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7376 gfc_init_se (&se
, NULL
);
7377 gfc_start_block (&se
.pre
);
7378 se
.want_pointer
= 1;
7380 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7382 if (expr1
->ts
.type
== BT_DERIVED
7383 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7386 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7388 gfc_add_expr_to_block (&se
.pre
, tmp
);
7391 se
.direct_byref
= 1;
7392 se
.ss
= gfc_walk_expr (expr2
);
7393 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7395 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7396 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7397 Clearly, this cannot be done for an allocatable function result, since
7398 the shape of the result is unknown and, in any case, the function must
7399 correctly take care of the reallocation internally. For intrinsic
7400 calls, the array data is freed and the library takes care of allocation.
7401 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7403 if (gfc_option
.flag_realloc_lhs
7404 && gfc_is_reallocatable_lhs (expr1
)
7405 && !gfc_expr_attr (expr1
).codimension
7406 && !gfc_is_coindexed (expr1
)
7407 && !(expr2
->value
.function
.esym
7408 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7410 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7412 if (!expr2
->value
.function
.isym
)
7414 ss
= gfc_walk_expr (expr1
);
7415 gcc_assert (ss
!= gfc_ss_terminator
);
7417 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7418 ss
->is_alloc_lhs
= 1;
7421 fcncall_realloc_result (&se
, expr1
->rank
);
7424 gfc_conv_function_expr (&se
, expr2
);
7425 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7428 gfc_cleanup_loop (&loop
);
7430 gfc_free_ss_chain (se
.ss
);
7432 return gfc_finish_block (&se
.pre
);
7436 /* Try to efficiently translate array(:) = 0. Return NULL if this
7440 gfc_trans_zero_assign (gfc_expr
* expr
)
7442 tree dest
, len
, type
;
7446 sym
= expr
->symtree
->n
.sym
;
7447 dest
= gfc_get_symbol_decl (sym
);
7449 type
= TREE_TYPE (dest
);
7450 if (POINTER_TYPE_P (type
))
7451 type
= TREE_TYPE (type
);
7452 if (!GFC_ARRAY_TYPE_P (type
))
7455 /* Determine the length of the array. */
7456 len
= GFC_TYPE_ARRAY_SIZE (type
);
7457 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7460 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7461 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7462 fold_convert (gfc_array_index_type
, tmp
));
7464 /* If we are zeroing a local array avoid taking its address by emitting
7466 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7467 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7468 dest
, build_constructor (TREE_TYPE (dest
),
7471 /* Convert arguments to the correct types. */
7472 dest
= fold_convert (pvoid_type_node
, dest
);
7473 len
= fold_convert (size_type_node
, len
);
7475 /* Construct call to __builtin_memset. */
7476 tmp
= build_call_expr_loc (input_location
,
7477 builtin_decl_explicit (BUILT_IN_MEMSET
),
7478 3, dest
, integer_zero_node
, len
);
7479 return fold_convert (void_type_node
, tmp
);
7483 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7484 that constructs the call to __builtin_memcpy. */
7487 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7491 /* Convert arguments to the correct types. */
7492 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7493 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7495 dst
= fold_convert (pvoid_type_node
, dst
);
7497 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7498 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7500 src
= fold_convert (pvoid_type_node
, src
);
7502 len
= fold_convert (size_type_node
, len
);
7504 /* Construct call to __builtin_memcpy. */
7505 tmp
= build_call_expr_loc (input_location
,
7506 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7508 return fold_convert (void_type_node
, tmp
);
7512 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7513 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7514 source/rhs, both are gfc_full_array_ref_p which have been checked for
7518 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7520 tree dst
, dlen
, dtype
;
7521 tree src
, slen
, stype
;
7524 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7525 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7527 dtype
= TREE_TYPE (dst
);
7528 if (POINTER_TYPE_P (dtype
))
7529 dtype
= TREE_TYPE (dtype
);
7530 stype
= TREE_TYPE (src
);
7531 if (POINTER_TYPE_P (stype
))
7532 stype
= TREE_TYPE (stype
);
7534 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7537 /* Determine the lengths of the arrays. */
7538 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7539 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7541 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7542 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7543 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7545 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7546 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7548 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7549 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7550 slen
, fold_convert (gfc_array_index_type
, tmp
));
7552 /* Sanity check that they are the same. This should always be
7553 the case, as we should already have checked for conformance. */
7554 if (!tree_int_cst_equal (slen
, dlen
))
7557 return gfc_build_memcpy_call (dst
, src
, dlen
);
7561 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7562 this can't be done. EXPR1 is the destination/lhs for which
7563 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7566 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7568 unsigned HOST_WIDE_INT nelem
;
7574 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7578 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7579 dtype
= TREE_TYPE (dst
);
7580 if (POINTER_TYPE_P (dtype
))
7581 dtype
= TREE_TYPE (dtype
);
7582 if (!GFC_ARRAY_TYPE_P (dtype
))
7585 /* Determine the lengths of the array. */
7586 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7587 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7590 /* Confirm that the constructor is the same size. */
7591 if (compare_tree_int (len
, nelem
) != 0)
7594 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7595 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7596 fold_convert (gfc_array_index_type
, tmp
));
7598 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7599 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7601 stype
= TREE_TYPE (src
);
7602 if (POINTER_TYPE_P (stype
))
7603 stype
= TREE_TYPE (stype
);
7605 return gfc_build_memcpy_call (dst
, src
, len
);
7609 /* Tells whether the expression is to be treated as a variable reference. */
7612 expr_is_variable (gfc_expr
*expr
)
7615 gfc_component
*comp
;
7616 gfc_symbol
*func_ifc
;
7618 if (expr
->expr_type
== EXPR_VARIABLE
)
7621 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7624 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7625 return expr_is_variable (arg
);
7628 /* A data-pointer-returning function should be considered as a variable
7630 if (expr
->expr_type
== EXPR_FUNCTION
7631 && expr
->ref
== NULL
)
7633 if (expr
->value
.function
.isym
!= NULL
)
7636 if (expr
->value
.function
.esym
!= NULL
)
7638 func_ifc
= expr
->value
.function
.esym
;
7643 gcc_assert (expr
->symtree
);
7644 func_ifc
= expr
->symtree
->n
.sym
;
7651 comp
= gfc_get_proc_ptr_comp (expr
);
7652 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7655 func_ifc
= comp
->ts
.interface
;
7659 if (expr
->expr_type
== EXPR_COMPCALL
)
7661 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7662 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7669 gcc_assert (func_ifc
->attr
.function
7670 && func_ifc
->result
!= NULL
);
7671 return func_ifc
->result
->attr
.pointer
;
7675 /* Is the lhs OK for automatic reallocation? */
7678 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7682 /* An allocatable variable with no reference. */
7683 if (expr
->symtree
->n
.sym
->attr
.allocatable
7687 /* All that can be left are allocatable components. */
7688 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7689 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7690 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7693 /* Find an allocatable component ref last. */
7694 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7695 if (ref
->type
== REF_COMPONENT
7697 && ref
->u
.c
.component
->attr
.allocatable
)
7704 /* Allocate or reallocate scalar lhs, as necessary. */
7707 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7721 if (!expr1
|| expr1
->rank
)
7724 if (!expr2
|| expr2
->rank
)
7727 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7729 /* Since this is a scalar lhs, we can afford to do this. That is,
7730 there is no risk of side effects being repeated. */
7731 gfc_init_se (&lse
, NULL
);
7732 lse
.want_pointer
= 1;
7733 gfc_conv_expr (&lse
, expr1
);
7735 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7736 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7738 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7739 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7740 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7742 tmp
= build3_v (COND_EXPR
, cond
,
7743 build1_v (GOTO_EXPR
, jump_label1
),
7744 build_empty_stmt (input_location
));
7745 gfc_add_expr_to_block (block
, tmp
);
7747 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7749 /* Use the rhs string length and the lhs element size. */
7750 size
= string_length
;
7751 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7752 tmp
= TYPE_SIZE_UNIT (tmp
);
7753 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7754 TREE_TYPE (tmp
), tmp
,
7755 fold_convert (TREE_TYPE (tmp
), size
));
7759 /* Otherwise use the length in bytes of the rhs. */
7760 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7761 size_in_bytes
= size
;
7764 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7765 size_in_bytes
, size_one_node
);
7767 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7769 tmp
= build_call_expr_loc (input_location
,
7770 builtin_decl_explicit (BUILT_IN_CALLOC
),
7771 2, build_one_cst (size_type_node
),
7773 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7774 gfc_add_modify (block
, lse
.expr
, tmp
);
7778 tmp
= build_call_expr_loc (input_location
,
7779 builtin_decl_explicit (BUILT_IN_MALLOC
),
7781 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7782 gfc_add_modify (block
, lse
.expr
, tmp
);
7785 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7787 /* Deferred characters need checking for lhs and rhs string
7788 length. Other deferred parameter variables will have to
7790 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7791 gfc_add_expr_to_block (block
, tmp
);
7793 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7794 gfc_add_expr_to_block (block
, tmp
);
7796 /* For a deferred length character, reallocate if lengths of lhs and
7797 rhs are different. */
7798 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7800 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7801 expr1
->ts
.u
.cl
->backend_decl
, size
);
7802 /* Jump past the realloc if the lengths are the same. */
7803 tmp
= build3_v (COND_EXPR
, cond
,
7804 build1_v (GOTO_EXPR
, jump_label2
),
7805 build_empty_stmt (input_location
));
7806 gfc_add_expr_to_block (block
, tmp
);
7807 tmp
= build_call_expr_loc (input_location
,
7808 builtin_decl_explicit (BUILT_IN_REALLOC
),
7809 2, fold_convert (pvoid_type_node
, lse
.expr
),
7811 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7812 gfc_add_modify (block
, lse
.expr
, tmp
);
7813 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7814 gfc_add_expr_to_block (block
, tmp
);
7816 /* Update the lhs character length. */
7817 size
= string_length
;
7818 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
7819 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7821 gfc_add_modify (block
, lse
.string_length
, size
);
7825 /* Check for assignments of the type
7829 to make sure we do not check for reallocation unneccessarily. */
7833 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7835 gfc_actual_arglist
*a
;
7838 switch (expr2
->expr_type
)
7841 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7844 if (expr2
->value
.function
.esym
7845 && expr2
->value
.function
.esym
->attr
.elemental
)
7847 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7850 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7855 else if (expr2
->value
.function
.isym
7856 && expr2
->value
.function
.isym
->elemental
)
7858 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7861 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7870 switch (expr2
->value
.op
.op
)
7873 case INTRINSIC_UPLUS
:
7874 case INTRINSIC_UMINUS
:
7875 case INTRINSIC_PARENTHESES
:
7876 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7878 case INTRINSIC_PLUS
:
7879 case INTRINSIC_MINUS
:
7880 case INTRINSIC_TIMES
:
7881 case INTRINSIC_DIVIDE
:
7882 case INTRINSIC_POWER
:
7886 case INTRINSIC_NEQV
:
7893 case INTRINSIC_EQ_OS
:
7894 case INTRINSIC_NE_OS
:
7895 case INTRINSIC_GT_OS
:
7896 case INTRINSIC_GE_OS
:
7897 case INTRINSIC_LT_OS
:
7898 case INTRINSIC_LE_OS
:
7900 e1
= expr2
->value
.op
.op1
;
7901 e2
= expr2
->value
.op
.op2
;
7903 if (e1
->rank
== 0 && e2
->rank
> 0)
7904 return is_runtime_conformable (expr1
, e2
);
7905 else if (e1
->rank
> 0 && e2
->rank
== 0)
7906 return is_runtime_conformable (expr1
, e1
);
7907 else if (e1
->rank
> 0 && e2
->rank
> 0)
7908 return is_runtime_conformable (expr1
, e1
)
7909 && is_runtime_conformable (expr1
, e2
);
7925 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7926 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7927 init_flag indicates initialization expressions and dealloc that no
7928 deallocate prior assignment is needed (if in doubt, set true). */
7931 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7937 gfc_ss
*lss_section
;
7944 bool scalar_to_array
;
7948 /* Assignment of the form lhs = rhs. */
7949 gfc_start_block (&block
);
7951 gfc_init_se (&lse
, NULL
);
7952 gfc_init_se (&rse
, NULL
);
7955 lss
= gfc_walk_expr (expr1
);
7956 if (gfc_is_reallocatable_lhs (expr1
)
7957 && !(expr2
->expr_type
== EXPR_FUNCTION
7958 && expr2
->value
.function
.isym
!= NULL
))
7959 lss
->is_alloc_lhs
= 1;
7961 if (lss
!= gfc_ss_terminator
)
7963 /* The assignment needs scalarization. */
7966 /* Find a non-scalar SS from the lhs. */
7967 while (lss_section
!= gfc_ss_terminator
7968 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7969 lss_section
= lss_section
->next
;
7971 gcc_assert (lss_section
!= gfc_ss_terminator
);
7973 /* Initialize the scalarizer. */
7974 gfc_init_loopinfo (&loop
);
7977 rss
= gfc_walk_expr (expr2
);
7978 if (rss
== gfc_ss_terminator
)
7979 /* The rhs is scalar. Add a ss for the expression. */
7980 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7982 /* Associate the SS with the loop. */
7983 gfc_add_ss_to_loop (&loop
, lss
);
7984 gfc_add_ss_to_loop (&loop
, rss
);
7986 /* Calculate the bounds of the scalarization. */
7987 gfc_conv_ss_startstride (&loop
);
7988 /* Enable loop reversal. */
7989 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7990 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7991 /* Resolve any data dependencies in the statement. */
7992 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7993 /* Setup the scalarizing loops. */
7994 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7996 /* Setup the gfc_se structures. */
7997 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7998 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8001 gfc_mark_ss_chain_used (rss
, 1);
8002 if (loop
.temp_ss
== NULL
)
8005 gfc_mark_ss_chain_used (lss
, 1);
8009 lse
.ss
= loop
.temp_ss
;
8010 gfc_mark_ss_chain_used (lss
, 3);
8011 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8014 /* Allow the scalarizer to workshare array assignments. */
8015 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8016 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8018 /* Start the scalarized loop body. */
8019 gfc_start_scalarized_body (&loop
, &body
);
8022 gfc_init_block (&body
);
8024 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8026 /* Translate the expression. */
8027 gfc_conv_expr (&rse
, expr2
);
8029 /* Stabilize a string length for temporaries. */
8030 if (expr2
->ts
.type
== BT_CHARACTER
)
8031 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8033 string_length
= NULL_TREE
;
8037 gfc_conv_tmp_array_ref (&lse
);
8038 if (expr2
->ts
.type
== BT_CHARACTER
)
8039 lse
.string_length
= string_length
;
8042 gfc_conv_expr (&lse
, expr1
);
8044 /* Assignments of scalar derived types with allocatable components
8045 to arrays must be done with a deep copy and the rhs temporary
8046 must have its components deallocated afterwards. */
8047 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8048 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8049 && !expr_is_variable (expr2
)
8050 && !gfc_is_constant_expr (expr2
)
8051 && expr1
->rank
&& !expr2
->rank
);
8052 if (scalar_to_array
&& dealloc
)
8054 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8055 gfc_add_expr_to_block (&loop
.post
, tmp
);
8058 /* When assigning a character function result to a deferred-length variable,
8059 the function call must happen before the (re)allocation of the lhs -
8060 otherwise the character length of the result is not known.
8061 NOTE: This relies on having the exact dependence of the length type
8062 parameter available to the caller; gfortran saves it in the .mod files. */
8063 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
8064 && expr1
->ts
.deferred
)
8065 gfc_add_block_to_block (&block
, &rse
.pre
);
8067 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8068 l_is_temp
|| init_flag
,
8069 expr_is_variable (expr2
) || scalar_to_array
8070 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8071 gfc_add_expr_to_block (&body
, tmp
);
8073 if (lss
== gfc_ss_terminator
)
8075 /* F2003: Add the code for reallocation on assignment. */
8076 if (gfc_option
.flag_realloc_lhs
8077 && is_scalar_reallocatable_lhs (expr1
))
8078 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8081 /* Use the scalar assignment as is. */
8082 gfc_add_block_to_block (&block
, &body
);
8086 gcc_assert (lse
.ss
== gfc_ss_terminator
8087 && rse
.ss
== gfc_ss_terminator
);
8091 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8093 /* We need to copy the temporary to the actual lhs. */
8094 gfc_init_se (&lse
, NULL
);
8095 gfc_init_se (&rse
, NULL
);
8096 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8097 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8099 rse
.ss
= loop
.temp_ss
;
8102 gfc_conv_tmp_array_ref (&rse
);
8103 gfc_conv_expr (&lse
, expr1
);
8105 gcc_assert (lse
.ss
== gfc_ss_terminator
8106 && rse
.ss
== gfc_ss_terminator
);
8108 if (expr2
->ts
.type
== BT_CHARACTER
)
8109 rse
.string_length
= string_length
;
8111 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8112 false, false, dealloc
);
8113 gfc_add_expr_to_block (&body
, tmp
);
8116 /* F2003: Allocate or reallocate lhs of allocatable array. */
8117 if (gfc_option
.flag_realloc_lhs
8118 && gfc_is_reallocatable_lhs (expr1
)
8119 && !gfc_expr_attr (expr1
).codimension
8120 && !gfc_is_coindexed (expr1
)
8122 && !is_runtime_conformable (expr1
, expr2
))
8124 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8125 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8126 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8127 if (tmp
!= NULL_TREE
)
8128 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8131 /* Generate the copying loops. */
8132 gfc_trans_scalarizing_loops (&loop
, &body
);
8134 /* Wrap the whole thing up. */
8135 gfc_add_block_to_block (&block
, &loop
.pre
);
8136 gfc_add_block_to_block (&block
, &loop
.post
);
8138 gfc_cleanup_loop (&loop
);
8141 return gfc_finish_block (&block
);
8145 /* Check whether EXPR is a copyable array. */
8148 copyable_array_p (gfc_expr
* expr
)
8150 if (expr
->expr_type
!= EXPR_VARIABLE
)
8153 /* First check it's an array. */
8154 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8157 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8160 /* Next check that it's of a simple enough type. */
8161 switch (expr
->ts
.type
)
8173 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8182 /* Translate an assignment. */
8185 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8190 /* Special case a single function returning an array. */
8191 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8193 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8198 /* Special case assigning an array to zero. */
8199 if (copyable_array_p (expr1
)
8200 && is_zero_initializer_p (expr2
))
8202 tmp
= gfc_trans_zero_assign (expr1
);
8207 /* Special case copying one array to another. */
8208 if (copyable_array_p (expr1
)
8209 && copyable_array_p (expr2
)
8210 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8211 && !gfc_check_dependency (expr1
, expr2
, 0))
8213 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8218 /* Special case initializing an array from a constant array constructor. */
8219 if (copyable_array_p (expr1
)
8220 && expr2
->expr_type
== EXPR_ARRAY
8221 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8223 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8228 /* Fallback to the scalarizer to generate explicit loops. */
8229 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8233 gfc_trans_init_assign (gfc_code
* code
)
8235 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8239 gfc_trans_assign (gfc_code
* code
)
8241 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);