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 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
76 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
77 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
78 gfc_get_dtype (type
));
79 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
81 /* Copy pointer address back - but only if it could have changed and
82 if the actual argument is a pointer and not, e.g., NULL(). */
83 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
84 gfc_add_modify (&se
->post
, scalar
,
85 fold_convert (TREE_TYPE (scalar
),
86 gfc_conv_descriptor_data_get (desc
)));
91 /* This is the seed for an eventual trans-class.c
93 The following parameters should not be used directly since they might
94 in future implementations. Use the corresponding APIs. */
95 #define CLASS_DATA_FIELD 0
96 #define CLASS_VPTR_FIELD 1
97 #define VTABLE_HASH_FIELD 0
98 #define VTABLE_SIZE_FIELD 1
99 #define VTABLE_EXTENDS_FIELD 2
100 #define VTABLE_DEF_INIT_FIELD 3
101 #define VTABLE_COPY_FIELD 4
102 #define VTABLE_FINAL_FIELD 5
106 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
110 vec
<constructor_elt
, va_gc
> *init
= NULL
;
112 field
= TYPE_FIELDS (TREE_TYPE (decl
));
113 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
114 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
116 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
117 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
119 return build_constructor (TREE_TYPE (decl
), init
);
124 gfc_class_data_get (tree decl
)
127 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
128 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
129 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
131 return fold_build3_loc (input_location
, COMPONENT_REF
,
132 TREE_TYPE (data
), decl
, data
,
138 gfc_class_vptr_get (tree decl
)
141 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
142 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
143 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
145 return fold_build3_loc (input_location
, COMPONENT_REF
,
146 TREE_TYPE (vptr
), decl
, vptr
,
152 gfc_vtable_field_get (tree decl
, int field
)
156 vptr
= gfc_class_vptr_get (decl
);
157 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
158 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
160 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
161 TREE_TYPE (size
), vptr
, size
,
163 /* Always return size as an array index type. */
164 if (field
== VTABLE_SIZE_FIELD
)
165 size
= fold_convert (gfc_array_index_type
, size
);
172 gfc_vtable_hash_get (tree decl
)
174 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
179 gfc_vtable_size_get (tree decl
)
181 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
186 gfc_vtable_extends_get (tree decl
)
188 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
193 gfc_vtable_def_init_get (tree decl
)
195 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
200 gfc_vtable_copy_get (tree decl
)
202 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
207 gfc_vtable_final_get (tree decl
)
209 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
213 #undef CLASS_DATA_FIELD
214 #undef CLASS_VPTR_FIELD
215 #undef VTABLE_HASH_FIELD
216 #undef VTABLE_SIZE_FIELD
217 #undef VTABLE_EXTENDS_FIELD
218 #undef VTABLE_DEF_INIT_FIELD
219 #undef VTABLE_COPY_FIELD
220 #undef VTABLE_FINAL_FIELD
223 /* Reset the vptr to the declared type, e.g. after deallocation. */
226 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
228 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
233 /* If we have a class array, we need go back to the class
235 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
236 && lhs
->ref
->next
->type
== REF_ARRAY
237 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
238 && lhs
->ref
->type
== REF_COMPONENT
239 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
241 gfc_free_ref_list (lhs
->ref
);
245 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
246 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
247 && ref
->next
->next
->type
== REF_ARRAY
248 && ref
->next
->next
->u
.ar
.type
== AR_FULL
249 && ref
->next
->type
== REF_COMPONENT
250 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
252 gfc_free_ref_list (ref
->next
);
256 gfc_add_vptr_component (lhs
);
258 if (UNLIMITED_POLY (e
))
259 rhs
= gfc_get_null_expr (NULL
);
262 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
263 rhs
= gfc_lval_expr_from_sym (vtab
);
265 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
266 gfc_add_expr_to_block (block
, tmp
);
272 /* Obtain the vptr of the last class reference in an expression.
273 Return NULL_TREE if no class reference is found. */
276 gfc_get_vptr_from_expr (tree expr
)
281 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
283 type
= TREE_TYPE (tmp
);
286 if (GFC_CLASS_TYPE_P (type
))
287 return gfc_class_vptr_get (tmp
);
288 if (type
!= TYPE_CANONICAL (type
))
289 type
= TYPE_CANONICAL (type
);
293 if (TREE_CODE (tmp
) == VAR_DECL
)
301 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
304 tree tmp
, tmp2
, type
;
306 gfc_conv_descriptor_data_set (block
, lhs_desc
,
307 gfc_conv_descriptor_data_get (rhs_desc
));
308 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
309 gfc_conv_descriptor_offset_get (rhs_desc
));
311 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
312 gfc_conv_descriptor_dtype (rhs_desc
));
314 /* Assign the dimension as range-ref. */
315 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
316 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
318 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
319 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
320 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
321 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
322 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
323 gfc_add_modify (block
, tmp
, tmp2
);
327 /* Takes a derived type expression and returns the address of a temporary
328 class object of the 'declared' type. If vptr is not NULL, this is
329 used for the temporary class object.
330 optional_alloc_ptr is false when the dummy is neither allocatable
331 nor a pointer; that's only relevant for the optional handling. */
333 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
334 gfc_typespec class_ts
, tree vptr
, bool optional
,
335 bool optional_alloc_ptr
)
338 tree cond_optional
= NULL_TREE
;
344 /* The derived type needs to be converted to a temporary
346 tmp
= gfc_typenode_for_spec (&class_ts
);
347 var
= gfc_create_var (tmp
, "class");
350 ctree
= gfc_class_vptr_get (var
);
352 if (vptr
!= NULL_TREE
)
354 /* Use the dynamic vptr. */
359 /* In this case the vtab corresponds to the derived type and the
360 vptr must point to it. */
361 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
363 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
365 gfc_add_modify (&parmse
->pre
, ctree
,
366 fold_convert (TREE_TYPE (ctree
), tmp
));
368 /* Now set the data field. */
369 ctree
= gfc_class_data_get (var
);
372 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
374 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
376 /* For an array reference in an elemental procedure call we need
377 to retain the ss to provide the scalarized array reference. */
378 gfc_conv_expr_reference (parmse
, e
);
379 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
381 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
383 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
384 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
389 ss
= gfc_walk_expr (e
);
390 if (ss
== gfc_ss_terminator
)
393 gfc_conv_expr_reference (parmse
, e
);
395 /* Scalar to an assumed-rank array. */
396 if (class_ts
.u
.derived
->components
->as
)
399 type
= get_scalar_to_descriptor_type (parmse
->expr
,
401 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
402 gfc_get_dtype (type
));
404 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
405 TREE_TYPE (parmse
->expr
),
406 cond_optional
, parmse
->expr
,
407 fold_convert (TREE_TYPE (parmse
->expr
),
409 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
413 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
415 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
417 fold_convert (TREE_TYPE (tmp
),
419 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
425 gfc_init_block (&block
);
428 gfc_conv_expr_descriptor (parmse
, e
);
430 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
432 gcc_assert (class_ts
.u
.derived
->components
->as
->type
434 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
438 if (gfc_expr_attr (e
).codimension
)
439 parmse
->expr
= fold_build1_loc (input_location
,
443 gfc_add_modify (&block
, ctree
, parmse
->expr
);
448 tmp
= gfc_finish_block (&block
);
450 gfc_init_block (&block
);
451 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
453 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
454 gfc_finish_block (&block
));
455 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
458 gfc_add_block_to_block (&parmse
->pre
, &block
);
462 /* Pass the address of the class object. */
463 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
465 if (optional
&& optional_alloc_ptr
)
466 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
467 TREE_TYPE (parmse
->expr
),
468 cond_optional
, parmse
->expr
,
469 fold_convert (TREE_TYPE (parmse
->expr
),
474 /* Create a new class container, which is required as scalar coarrays
475 have an array descriptor while normal scalars haven't. Optionally,
476 NULL pointer checks are added if the argument is OPTIONAL. */
479 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
480 gfc_typespec class_ts
, bool optional
)
482 tree var
, ctree
, tmp
;
487 gfc_init_block (&block
);
490 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
492 if (ref
->type
== REF_COMPONENT
493 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
497 if (class_ref
== NULL
498 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
499 tmp
= e
->symtree
->n
.sym
->backend_decl
;
502 /* Remove everything after the last class reference, convert the
503 expression and then recover its tailend once more. */
505 ref
= class_ref
->next
;
506 class_ref
->next
= NULL
;
507 gfc_init_se (&tmpse
, NULL
);
508 gfc_conv_expr (&tmpse
, e
);
509 class_ref
->next
= ref
;
513 var
= gfc_typenode_for_spec (&class_ts
);
514 var
= gfc_create_var (var
, "class");
516 ctree
= gfc_class_vptr_get (var
);
517 gfc_add_modify (&block
, ctree
,
518 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
520 ctree
= gfc_class_data_get (var
);
521 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
522 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
524 /* Pass the address of the class object. */
525 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
529 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
532 tmp
= gfc_finish_block (&block
);
534 gfc_init_block (&block
);
535 tmp2
= gfc_class_data_get (var
);
536 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
538 tmp2
= gfc_finish_block (&block
);
540 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
542 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
545 gfc_add_block_to_block (&parmse
->pre
, &block
);
549 /* Takes an intrinsic type expression and returns the address of a temporary
550 class object of the 'declared' type. */
552 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
553 gfc_typespec class_ts
)
561 /* The intrinsic type needs to be converted to a temporary
563 tmp
= gfc_typenode_for_spec (&class_ts
);
564 var
= gfc_create_var (tmp
, "class");
567 ctree
= gfc_class_vptr_get (var
);
569 vtab
= gfc_find_vtab (&e
->ts
);
571 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
572 gfc_add_modify (&parmse
->pre
, ctree
,
573 fold_convert (TREE_TYPE (ctree
), tmp
));
575 /* Now set the data field. */
576 ctree
= gfc_class_data_get (var
);
577 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
579 /* For an array reference in an elemental procedure call we need
580 to retain the ss to provide the scalarized array reference. */
581 gfc_conv_expr_reference (parmse
, e
);
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
587 ss
= gfc_walk_expr (e
);
588 if (ss
== gfc_ss_terminator
)
591 gfc_conv_expr_reference (parmse
, e
);
592 if (class_ts
.u
.derived
->components
->as
593 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
595 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
597 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
598 TREE_TYPE (ctree
), tmp
);
601 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
602 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
607 parmse
->use_offset
= 1;
608 gfc_conv_expr_descriptor (parmse
, e
);
609 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
611 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
612 TREE_TYPE (ctree
), parmse
->expr
);
613 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
616 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
620 /* Pass the address of the class object. */
621 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
625 /* Takes a scalarized class array expression and returns the
626 address of a temporary scalar class object of the 'declared'
628 OOP-TODO: This could be improved by adding code that branched on
629 the dynamic type being the same as the declared type. In this case
630 the original class expression can be passed directly.
631 optional_alloc_ptr is false when the dummy is neither allocatable
632 nor a pointer; that's relevant for the optional handling.
633 Set copyback to true if class container's _data and _vtab pointers
634 might get modified. */
637 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
638 bool elemental
, bool copyback
, bool optional
,
639 bool optional_alloc_ptr
)
645 tree cond
= NULL_TREE
;
649 bool full_array
= false;
651 gfc_init_block (&block
);
654 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
656 if (ref
->type
== REF_COMPONENT
657 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
660 if (ref
->next
== NULL
)
664 if ((ref
== NULL
|| class_ref
== ref
)
665 && (!class_ts
.u
.derived
->components
->as
666 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
669 /* Test for FULL_ARRAY. */
670 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
671 && gfc_expr_attr (e
).dimension
)
674 gfc_is_class_array_ref (e
, &full_array
);
676 /* The derived type needs to be converted to a temporary
678 tmp
= gfc_typenode_for_spec (&class_ts
);
679 var
= gfc_create_var (tmp
, "class");
682 ctree
= gfc_class_data_get (var
);
683 if (class_ts
.u
.derived
->components
->as
684 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
688 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
690 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
691 gfc_get_dtype (type
));
693 tmp
= gfc_class_data_get (parmse
->expr
);
694 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
695 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
697 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
700 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
704 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
705 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
706 TREE_TYPE (ctree
), parmse
->expr
);
707 gfc_add_modify (&block
, ctree
, parmse
->expr
);
710 /* Return the data component, except in the case of scalarized array
711 references, where nullification of the cannot occur and so there
713 if (!elemental
&& full_array
&& copyback
)
715 if (class_ts
.u
.derived
->components
->as
716 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
719 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
720 gfc_conv_descriptor_data_get (ctree
));
722 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
725 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
729 ctree
= gfc_class_vptr_get (var
);
731 /* The vptr is the second field of the actual argument.
732 First we have to find the corresponding class reference. */
735 if (class_ref
== NULL
736 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
737 tmp
= e
->symtree
->n
.sym
->backend_decl
;
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
743 ref
= class_ref
->next
;
744 class_ref
->next
= NULL
;
745 gfc_init_se (&tmpse
, NULL
);
746 gfc_conv_expr (&tmpse
, e
);
747 class_ref
->next
= ref
;
751 gcc_assert (tmp
!= NULL_TREE
);
753 /* Dereference if needs be. */
754 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
755 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
757 vptr
= gfc_class_vptr_get (tmp
);
758 gfc_add_modify (&block
, ctree
,
759 fold_convert (TREE_TYPE (ctree
), vptr
));
761 /* Return the vptr component, except in the case of scalarized array
762 references, where the dynamic type cannot change. */
763 if (!elemental
&& full_array
&& copyback
)
764 gfc_add_modify (&parmse
->post
, vptr
,
765 fold_convert (TREE_TYPE (vptr
), ctree
));
771 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
772 tmp
= gfc_finish_block (&block
);
774 if (optional_alloc_ptr
)
775 tmp2
= build_empty_stmt (input_location
);
778 gfc_init_block (&block
);
780 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
781 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
783 tmp2
= gfc_finish_block (&block
);
786 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
788 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
791 gfc_add_block_to_block (&parmse
->pre
, &block
);
793 /* Pass the address of the class object. */
794 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
796 if (optional
&& optional_alloc_ptr
)
797 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
798 TREE_TYPE (parmse
->expr
),
800 fold_convert (TREE_TYPE (parmse
->expr
),
805 /* Given a class array declaration and an index, returns the address
806 of the referenced element. */
809 gfc_get_class_array_ref (tree index
, tree class_decl
)
811 tree data
= gfc_class_data_get (class_decl
);
812 tree size
= gfc_vtable_size_get (class_decl
);
813 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
814 gfc_array_index_type
,
817 data
= gfc_conv_descriptor_data_get (data
);
818 ptr
= fold_convert (pvoid_type_node
, data
);
819 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
820 return fold_convert (TREE_TYPE (data
), ptr
);
824 /* Copies one class expression to another, assuming that if either
825 'to' or 'from' are arrays they are packed. Should 'from' be
826 NULL_TREE, the initialization expression for 'to' is used, assuming
827 that the _vptr is set. */
830 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
838 vec
<tree
, va_gc
> *args
;
841 stmtblock_t loopbody
;
847 if (from
!= NULL_TREE
)
848 fcn
= gfc_vtable_copy_get (from
);
850 fcn
= gfc_vtable_copy_get (to
);
852 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
854 if (from
!= NULL_TREE
)
855 from_data
= gfc_class_data_get (from
);
857 from_data
= gfc_vtable_def_init_get (to
);
859 to_data
= gfc_class_data_get (to
);
861 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
863 gfc_init_block (&body
);
864 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
865 gfc_array_index_type
, nelems
,
867 nelems
= gfc_evaluate_now (tmp
, &body
);
868 index
= gfc_create_var (gfc_array_index_type
, "S");
870 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
872 from_ref
= gfc_get_class_array_ref (index
, from
);
873 vec_safe_push (args
, from_ref
);
876 vec_safe_push (args
, from_data
);
878 to_ref
= gfc_get_class_array_ref (index
, to
);
879 vec_safe_push (args
, to_ref
);
881 tmp
= build_call_vec (fcn_type
, fcn
, args
);
883 /* Build the body of the loop. */
884 gfc_init_block (&loopbody
);
885 gfc_add_expr_to_block (&loopbody
, tmp
);
887 /* Build the loop and return. */
888 gfc_init_loopinfo (&loop
);
890 loop
.from
[0] = gfc_index_zero_node
;
891 loop
.loopvar
[0] = index
;
893 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
894 gfc_add_block_to_block (&body
, &loop
.pre
);
895 tmp
= gfc_finish_block (&body
);
896 gfc_cleanup_loop (&loop
);
900 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
901 vec_safe_push (args
, from_data
);
902 vec_safe_push (args
, to_data
);
903 tmp
= build_call_vec (fcn_type
, fcn
, args
);
910 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
912 gfc_actual_arglist
*actual
;
917 actual
= gfc_get_actual_arglist ();
918 actual
->expr
= gfc_copy_expr (rhs
);
919 actual
->next
= gfc_get_actual_arglist ();
920 actual
->next
->expr
= gfc_copy_expr (lhs
);
921 ppc
= gfc_copy_expr (obj
);
922 gfc_add_vptr_component (ppc
);
923 gfc_add_component_ref (ppc
, "_copy");
924 ppc_code
= gfc_get_code (EXEC_CALL
);
925 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
926 /* Although '_copy' is set to be elemental in class.c, it is
927 not staying that way. Find out why, sometime.... */
928 ppc_code
->resolved_sym
->attr
.elemental
= 1;
929 ppc_code
->ext
.actual
= actual
;
930 ppc_code
->expr1
= ppc
;
931 /* Since '_copy' is elemental, the scalarizer will take care
932 of arrays in gfc_trans_call. */
933 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
934 gfc_free_statements (ppc_code
);
938 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
939 A MEMCPY is needed to copy the full data from the default initializer
940 of the dynamic type. */
943 gfc_trans_class_init_assign (gfc_code
*code
)
947 gfc_se dst
,src
,memsz
;
948 gfc_expr
*lhs
, *rhs
, *sz
;
950 gfc_start_block (&block
);
952 lhs
= gfc_copy_expr (code
->expr1
);
953 gfc_add_data_component (lhs
);
955 rhs
= gfc_copy_expr (code
->expr1
);
956 gfc_add_vptr_component (rhs
);
958 /* Make sure that the component backend_decls have been built, which
959 will not have happened if the derived types concerned have not
961 gfc_get_derived_type (rhs
->ts
.u
.derived
);
962 gfc_add_def_init_component (rhs
);
964 if (code
->expr1
->ts
.type
== BT_CLASS
965 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
966 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
969 sz
= gfc_copy_expr (code
->expr1
);
970 gfc_add_vptr_component (sz
);
971 gfc_add_size_component (sz
);
973 gfc_init_se (&dst
, NULL
);
974 gfc_init_se (&src
, NULL
);
975 gfc_init_se (&memsz
, NULL
);
976 gfc_conv_expr (&dst
, lhs
);
977 gfc_conv_expr (&src
, rhs
);
978 gfc_conv_expr (&memsz
, sz
);
979 gfc_add_block_to_block (&block
, &src
.pre
);
980 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
982 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
985 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
986 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
988 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
989 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
991 build_empty_stmt (input_location
));
994 gfc_add_expr_to_block (&block
, tmp
);
996 return gfc_finish_block (&block
);
1000 /* Translate an assignment to a CLASS object
1001 (pointer or ordinary assignment). */
1004 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1012 gfc_start_block (&block
);
1015 while (ref
&& ref
->next
)
1018 /* Class valued proc_pointer assignments do not need any further
1020 if (ref
&& ref
->type
== REF_COMPONENT
1021 && ref
->u
.c
.component
->attr
.proc_pointer
1022 && expr2
->expr_type
== EXPR_VARIABLE
1023 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1024 && op
== EXEC_POINTER_ASSIGN
)
1027 if (expr2
->ts
.type
!= BT_CLASS
)
1029 /* Insert an additional assignment which sets the '_vptr' field. */
1030 gfc_symbol
*vtab
= NULL
;
1033 lhs
= gfc_copy_expr (expr1
);
1034 gfc_add_vptr_component (lhs
);
1036 if (UNLIMITED_POLY (expr1
)
1037 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1039 rhs
= gfc_get_null_expr (&expr2
->where
);
1043 if (expr2
->expr_type
== EXPR_NULL
)
1044 vtab
= gfc_find_vtab (&expr1
->ts
);
1046 vtab
= gfc_find_vtab (&expr2
->ts
);
1049 rhs
= gfc_get_expr ();
1050 rhs
->expr_type
= EXPR_VARIABLE
;
1051 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1055 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1056 gfc_add_expr_to_block (&block
, tmp
);
1058 gfc_free_expr (lhs
);
1059 gfc_free_expr (rhs
);
1061 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1063 /* F2003:C717 only sequence and bind-C types can come here. */
1064 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1065 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1066 gfc_add_data_component (expr2
);
1069 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1071 /* Insert an additional assignment which sets the '_vptr' field. */
1072 lhs
= gfc_copy_expr (expr1
);
1073 gfc_add_vptr_component (lhs
);
1075 rhs
= gfc_copy_expr (expr2
);
1076 gfc_add_vptr_component (rhs
);
1078 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1079 gfc_add_expr_to_block (&block
, tmp
);
1081 gfc_free_expr (lhs
);
1082 gfc_free_expr (rhs
);
1085 /* Do the actual CLASS assignment. */
1086 if (expr2
->ts
.type
== BT_CLASS
1087 && !CLASS_DATA (expr2
)->attr
.dimension
)
1089 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1090 || !CLASS_DATA (expr2
)->attr
.dimension
)
1091 gfc_add_data_component (expr1
);
1095 if (op
== EXEC_ASSIGN
)
1096 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1097 else if (op
== EXEC_POINTER_ASSIGN
)
1098 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1102 gfc_add_expr_to_block (&block
, tmp
);
1104 return gfc_finish_block (&block
);
1108 /* End of prototype trans-class.c */
1112 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1114 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1115 && gfc_option
.warn_realloc_lhs
)
1116 gfc_warning ("Code for reallocating the allocatable array at %L will "
1118 else if (gfc_option
.warn_realloc_lhs_all
)
1119 gfc_warning ("Code for reallocating the allocatable variable at %L "
1120 "will be added", where
);
1124 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1125 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1128 /* Copy the scalarization loop variables. */
1131 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1134 dest
->loop
= src
->loop
;
1138 /* Initialize a simple expression holder.
1140 Care must be taken when multiple se are created with the same parent.
1141 The child se must be kept in sync. The easiest way is to delay creation
1142 of a child se until after after the previous se has been translated. */
1145 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1147 memset (se
, 0, sizeof (gfc_se
));
1148 gfc_init_block (&se
->pre
);
1149 gfc_init_block (&se
->post
);
1151 se
->parent
= parent
;
1154 gfc_copy_se_loopvars (se
, parent
);
1158 /* Advances to the next SS in the chain. Use this rather than setting
1159 se->ss = se->ss->next because all the parents needs to be kept in sync.
1163 gfc_advance_se_ss_chain (gfc_se
* se
)
1168 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1171 /* Walk down the parent chain. */
1174 /* Simple consistency check. */
1175 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1176 || p
->parent
->ss
->nested_ss
== p
->ss
);
1178 /* If we were in a nested loop, the next scalarized expression can be
1179 on the parent ss' next pointer. Thus we should not take the next
1180 pointer blindly, but rather go up one nest level as long as next
1181 is the end of chain. */
1183 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1193 /* Ensures the result of the expression as either a temporary variable
1194 or a constant so that it can be used repeatedly. */
1197 gfc_make_safe_expr (gfc_se
* se
)
1201 if (CONSTANT_CLASS_P (se
->expr
))
1204 /* We need a temporary for this result. */
1205 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1206 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1211 /* Return an expression which determines if a dummy parameter is present.
1212 Also used for arguments to procedures with multiple entry points. */
1215 gfc_conv_expr_present (gfc_symbol
* sym
)
1219 gcc_assert (sym
->attr
.dummy
);
1220 decl
= gfc_get_symbol_decl (sym
);
1222 /* Intrinsic scalars with VALUE attribute which are passed by value
1223 use a hidden argument to denote the present status. */
1224 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1225 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1226 && !sym
->attr
.dimension
)
1228 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1231 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1233 strcpy (&name
[1], sym
->name
);
1234 tree_name
= get_identifier (name
);
1236 /* Walk function argument list to find hidden arg. */
1237 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1238 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1239 if (DECL_NAME (cond
) == tree_name
)
1246 if (TREE_CODE (decl
) != PARM_DECL
)
1248 /* Array parameters use a temporary descriptor, we want the real
1250 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1251 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1252 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1255 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1256 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1258 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1259 as actual argument to denote absent dummies. For array descriptors,
1260 we thus also need to check the array descriptor. For BT_CLASS, it
1261 can also occur for scalars and F2003 due to type->class wrapping and
1262 class->class wrapping. Note further that BT_CLASS always uses an
1263 array descriptor for arrays, also for explicit-shape/assumed-size. */
1265 if (!sym
->attr
.allocatable
1266 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1267 || (sym
->ts
.type
== BT_CLASS
1268 && !CLASS_DATA (sym
)->attr
.allocatable
1269 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1270 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1271 || sym
->ts
.type
== BT_CLASS
))
1275 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1276 || sym
->as
->type
== AS_ASSUMED_RANK
1277 || sym
->attr
.codimension
))
1278 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1280 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1281 if (sym
->ts
.type
== BT_CLASS
)
1282 tmp
= gfc_class_data_get (tmp
);
1283 tmp
= gfc_conv_array_data (tmp
);
1285 else if (sym
->ts
.type
== BT_CLASS
)
1286 tmp
= gfc_class_data_get (decl
);
1290 if (tmp
!= NULL_TREE
)
1292 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1293 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1294 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1295 boolean_type_node
, cond
, tmp
);
1303 /* Converts a missing, dummy argument into a null or zero. */
1306 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1311 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1315 /* Create a temporary and convert it to the correct type. */
1316 tmp
= gfc_get_int_type (kind
);
1317 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1320 /* Test for a NULL value. */
1321 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1322 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1323 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1324 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1328 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1330 build_zero_cst (TREE_TYPE (se
->expr
)));
1331 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1335 if (ts
.type
== BT_CHARACTER
)
1337 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1338 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1339 present
, se
->string_length
, tmp
);
1340 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1341 se
->string_length
= tmp
;
1347 /* Get the character length of an expression, looking through gfc_refs
1351 gfc_get_expr_charlen (gfc_expr
*e
)
1356 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1357 && e
->ts
.type
== BT_CHARACTER
);
1359 length
= NULL
; /* To silence compiler warning. */
1361 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1364 gfc_init_se (&tmpse
, NULL
);
1365 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1366 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1370 /* First candidate: if the variable is of type CHARACTER, the
1371 expression's length could be the length of the character
1373 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1374 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1376 /* Look through the reference chain for component references. */
1377 for (r
= e
->ref
; r
; r
= r
->next
)
1382 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1383 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1391 /* We should never got substring references here. These will be
1392 broken down by the scalarizer. */
1398 gcc_assert (length
!= NULL
);
1403 /* Return for an expression the backend decl of the coarray. */
1406 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1412 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1414 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1415 gcc_assert (caf_decl
);
1416 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1417 caf_decl
= gfc_class_data_get (caf_decl
);
1418 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1421 /* The following code assumes that the coarray is a component reachable via
1422 only scalar components/variables; the Fortran standard guarantees this. */
1424 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1425 if (ref
->type
== REF_COMPONENT
)
1427 gfc_component
*comp
= ref
->u
.c
.component
;
1429 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1430 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1431 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1432 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1433 comp
->backend_decl
, NULL_TREE
);
1434 if (comp
->ts
.type
== BT_CLASS
)
1435 caf_decl
= gfc_class_data_get (caf_decl
);
1436 if (comp
->attr
.codimension
)
1442 gcc_assert (found
&& caf_decl
);
1447 /* For each character array constructor subexpression without a ts.u.cl->length,
1448 replace it by its first element (if there aren't any elements, the length
1449 should already be set to zero). */
1452 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1454 gfc_actual_arglist
* arg
;
1460 switch (e
->expr_type
)
1464 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1465 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1469 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1473 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1474 flatten_array_ctors_without_strlen (arg
->expr
);
1479 /* We've found what we're looking for. */
1480 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1485 gcc_assert (e
->value
.constructor
);
1487 c
= gfc_constructor_first (e
->value
.constructor
);
1491 flatten_array_ctors_without_strlen (new_expr
);
1492 gfc_replace_expr (e
, new_expr
);
1496 /* Otherwise, fall through to handle constructor elements. */
1497 case EXPR_STRUCTURE
:
1498 for (c
= gfc_constructor_first (e
->value
.constructor
);
1499 c
; c
= gfc_constructor_next (c
))
1500 flatten_array_ctors_without_strlen (c
->expr
);
1510 /* Generate code to initialize a string length variable. Returns the
1511 value. For array constructors, cl->length might be NULL and in this case,
1512 the first element of the constructor is needed. expr is the original
1513 expression so we can access it but can be NULL if this is not needed. */
1516 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1520 gfc_init_se (&se
, NULL
);
1524 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1527 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1528 "flatten" array constructors by taking their first element; all elements
1529 should be the same length or a cl->length should be present. */
1532 gfc_expr
* expr_flat
;
1534 expr_flat
= gfc_copy_expr (expr
);
1535 flatten_array_ctors_without_strlen (expr_flat
);
1536 gfc_resolve_expr (expr_flat
);
1538 gfc_conv_expr (&se
, expr_flat
);
1539 gfc_add_block_to_block (pblock
, &se
.pre
);
1540 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1542 gfc_free_expr (expr_flat
);
1546 /* Convert cl->length. */
1548 gcc_assert (cl
->length
);
1550 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1551 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1552 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1553 gfc_add_block_to_block (pblock
, &se
.pre
);
1555 if (cl
->backend_decl
)
1556 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1558 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1563 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1564 const char *name
, locus
*where
)
1574 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1575 type
= build_pointer_type (type
);
1577 gfc_init_se (&start
, se
);
1578 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1579 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1581 if (integer_onep (start
.expr
))
1582 gfc_conv_string_parameter (se
);
1587 /* Avoid multiple evaluation of substring start. */
1588 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1589 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1591 /* Change the start of the string. */
1592 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1595 tmp
= build_fold_indirect_ref_loc (input_location
,
1597 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1598 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1601 /* Length = end + 1 - start. */
1602 gfc_init_se (&end
, se
);
1603 if (ref
->u
.ss
.end
== NULL
)
1604 end
.expr
= se
->string_length
;
1607 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1608 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1612 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1613 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1615 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1617 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1618 boolean_type_node
, start
.expr
,
1621 /* Check lower bound. */
1622 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1624 build_int_cst (gfc_charlen_type_node
, 1));
1625 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1626 boolean_type_node
, nonempty
, fault
);
1628 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1629 "is less than one", name
);
1631 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1632 "is less than one");
1633 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1634 fold_convert (long_integer_type_node
,
1638 /* Check upper bound. */
1639 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1640 end
.expr
, se
->string_length
);
1641 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1642 boolean_type_node
, nonempty
, fault
);
1644 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1645 "exceeds string length (%%ld)", name
);
1647 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1648 "exceeds string length (%%ld)");
1649 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1650 fold_convert (long_integer_type_node
, end
.expr
),
1651 fold_convert (long_integer_type_node
,
1652 se
->string_length
));
1656 /* Try to calculate the length from the start and end expressions. */
1658 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1662 i_len
= mpz_get_si (length
) + 1;
1666 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1667 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1671 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1672 end
.expr
, start
.expr
);
1673 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1674 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1675 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1676 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1679 se
->string_length
= tmp
;
1683 /* Convert a derived type component reference. */
1686 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1693 c
= ref
->u
.c
.component
;
1695 gcc_assert (c
->backend_decl
);
1697 field
= c
->backend_decl
;
1698 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1701 /* Components can correspond to fields of different containing
1702 types, as components are created without context, whereas
1703 a concrete use of a component has the type of decl as context.
1704 So, if the type doesn't match, we search the corresponding
1705 FIELD_DECL in the parent type. To not waste too much time
1706 we cache this result in norestrict_decl. */
1708 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1710 tree f2
= c
->norestrict_decl
;
1711 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1712 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1713 if (TREE_CODE (f2
) == FIELD_DECL
1714 && DECL_NAME (f2
) == DECL_NAME (field
))
1717 c
->norestrict_decl
= f2
;
1721 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1722 decl
, field
, NULL_TREE
);
1726 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1728 tmp
= c
->ts
.u
.cl
->backend_decl
;
1729 /* Components must always be constant length. */
1730 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1731 se
->string_length
= tmp
;
1734 if (gfc_deferred_strlen (c
, &field
))
1736 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1738 decl
, field
, NULL_TREE
);
1739 se
->string_length
= tmp
;
1742 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1743 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1744 && c
->ts
.type
!= BT_CHARACTER
)
1745 || c
->attr
.proc_pointer
)
1746 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1751 /* This function deals with component references to components of the
1752 parent type for derived type extensions. */
1754 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1762 c
= ref
->u
.c
.component
;
1764 /* Return if the component is in the parent type. */
1765 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1766 if (strcmp (c
->name
, cmp
->name
) == 0)
1769 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1770 parent
.type
= REF_COMPONENT
;
1772 parent
.u
.c
.sym
= dt
;
1773 parent
.u
.c
.component
= dt
->components
;
1775 if (dt
->backend_decl
== NULL
)
1776 gfc_get_derived_type (dt
);
1778 /* Build the reference and call self. */
1779 gfc_conv_component_ref (se
, &parent
);
1780 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1781 parent
.u
.c
.component
= c
;
1782 conv_parent_component_references (se
, &parent
);
1785 /* Return the contents of a variable. Also handles reference/pointer
1786 variables (all Fortran pointer references are implicit). */
1789 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1794 tree parent_decl
= NULL_TREE
;
1797 bool alternate_entry
;
1800 sym
= expr
->symtree
->n
.sym
;
1804 gfc_ss_info
*ss_info
= ss
->info
;
1806 /* Check that something hasn't gone horribly wrong. */
1807 gcc_assert (ss
!= gfc_ss_terminator
);
1808 gcc_assert (ss_info
->expr
== expr
);
1810 /* A scalarized term. We already know the descriptor. */
1811 se
->expr
= ss_info
->data
.array
.descriptor
;
1812 se
->string_length
= ss_info
->string_length
;
1813 ref
= ss_info
->data
.array
.ref
;
1815 gcc_assert (ref
->type
== REF_ARRAY
1816 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1818 gfc_conv_tmp_array_ref (se
);
1822 tree se_expr
= NULL_TREE
;
1824 se
->expr
= gfc_get_symbol_decl (sym
);
1826 /* Deal with references to a parent results or entries by storing
1827 the current_function_decl and moving to the parent_decl. */
1828 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1829 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1830 && sym
->result
== sym
;
1831 entry_master
= sym
->attr
.result
1832 && sym
->ns
->proc_name
->attr
.entry_master
1833 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1834 if (current_function_decl
)
1835 parent_decl
= DECL_CONTEXT (current_function_decl
);
1837 if ((se
->expr
== parent_decl
&& return_value
)
1838 || (sym
->ns
&& sym
->ns
->proc_name
1840 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1841 && (alternate_entry
|| entry_master
)))
1846 /* Special case for assigning the return value of a function.
1847 Self recursive functions must have an explicit return value. */
1848 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1849 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1851 /* Similarly for alternate entry points. */
1852 else if (alternate_entry
1853 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1856 gfc_entry_list
*el
= NULL
;
1858 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1861 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1866 else if (entry_master
1867 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1869 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1874 /* Procedure actual arguments. */
1875 else if (sym
->attr
.flavor
== FL_PROCEDURE
1876 && se
->expr
!= current_function_decl
)
1878 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1880 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1881 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1887 /* Dereference the expression, where needed. Since characters
1888 are entirely different from other types, they are treated
1890 if (sym
->ts
.type
== BT_CHARACTER
)
1892 /* Dereference character pointer dummy arguments
1894 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1896 || sym
->attr
.function
1897 || sym
->attr
.result
))
1898 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1902 else if (!sym
->attr
.value
)
1904 /* Dereference non-character scalar dummy arguments. */
1905 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1906 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1907 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1910 /* Dereference scalar hidden result. */
1911 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1912 && (sym
->attr
.function
|| sym
->attr
.result
)
1913 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1914 && !sym
->attr
.always_explicit
)
1915 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1918 /* Dereference non-character pointer variables.
1919 These must be dummies, results, or scalars. */
1920 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1921 || gfc_is_associate_pointer (sym
)
1922 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1924 || sym
->attr
.function
1926 || (!sym
->attr
.dimension
1927 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1928 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1935 /* For character variables, also get the length. */
1936 if (sym
->ts
.type
== BT_CHARACTER
)
1938 /* If the character length of an entry isn't set, get the length from
1939 the master function instead. */
1940 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1941 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1943 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1944 gcc_assert (se
->string_length
);
1952 /* Return the descriptor if that's what we want and this is an array
1953 section reference. */
1954 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1956 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1957 /* Return the descriptor for array pointers and allocations. */
1958 if (se
->want_pointer
1959 && ref
->next
== NULL
&& (se
->descriptor_only
))
1962 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1963 /* Return a pointer to an element. */
1967 if (ref
->u
.c
.sym
->attr
.extension
)
1968 conv_parent_component_references (se
, ref
);
1970 gfc_conv_component_ref (se
, ref
);
1971 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1972 && se
->want_pointer
&& se
->descriptor_only
)
1978 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1979 expr
->symtree
->name
, &expr
->where
);
1988 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1990 if (se
->want_pointer
)
1992 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1993 gfc_conv_string_parameter (se
);
1995 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2000 /* Unary ops are easy... Or they would be if ! was a valid op. */
2003 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2008 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2009 /* Initialize the operand. */
2010 gfc_init_se (&operand
, se
);
2011 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2012 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2014 type
= gfc_typenode_for_spec (&expr
->ts
);
2016 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2017 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2018 All other unary operators have an equivalent GIMPLE unary operator. */
2019 if (code
== TRUTH_NOT_EXPR
)
2020 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2021 build_int_cst (type
, 0));
2023 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2027 /* Expand power operator to optimal multiplications when a value is raised
2028 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2029 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2030 Programming", 3rd Edition, 1998. */
2032 /* This code is mostly duplicated from expand_powi in the backend.
2033 We establish the "optimal power tree" lookup table with the defined size.
2034 The items in the table are the exponents used to calculate the index
2035 exponents. Any integer n less than the value can get an "addition chain",
2036 with the first node being one. */
2037 #define POWI_TABLE_SIZE 256
2039 /* The table is from builtins.c. */
2040 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2042 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2043 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2044 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2045 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2046 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2047 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2048 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2049 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2050 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2051 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2052 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2053 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2054 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2055 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2056 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2057 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2058 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2059 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2060 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2061 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2062 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2063 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2064 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2065 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2066 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2067 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2068 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2069 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2070 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2071 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2072 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2073 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2076 /* If n is larger than lookup table's max index, we use the "window
2078 #define POWI_WINDOW_SIZE 3
2080 /* Recursive function to expand the power operator. The temporary
2081 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2083 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2090 if (n
< POWI_TABLE_SIZE
)
2095 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2096 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2100 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2101 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2102 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2106 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2110 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2111 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2113 if (n
< POWI_TABLE_SIZE
)
2120 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2121 return 1. Else return 0 and a call to runtime library functions
2122 will have to be built. */
2124 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2129 tree vartmp
[POWI_TABLE_SIZE
];
2131 unsigned HOST_WIDE_INT n
;
2133 wide_int wrhs
= rhs
;
2135 /* If exponent is too large, we won't expand it anyway, so don't bother
2136 with large integer values. */
2137 if (!wi::fits_shwi_p (wrhs
))
2140 m
= wrhs
.to_shwi ();
2141 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2142 of the asymmetric range of the integer type. */
2143 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2145 type
= TREE_TYPE (lhs
);
2146 sgn
= tree_int_cst_sgn (rhs
);
2148 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2149 || optimize_size
) && (m
> 2 || m
< -1))
2155 se
->expr
= gfc_build_const (type
, integer_one_node
);
2159 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2160 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2162 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2163 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2164 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2165 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2168 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2171 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2172 boolean_type_node
, tmp
, cond
);
2173 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2174 tmp
, build_int_cst (type
, 1),
2175 build_int_cst (type
, 0));
2179 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2180 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2181 build_int_cst (type
, -1),
2182 build_int_cst (type
, 0));
2183 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2184 cond
, build_int_cst (type
, 1), tmp
);
2188 memset (vartmp
, 0, sizeof (vartmp
));
2192 tmp
= gfc_build_const (type
, integer_one_node
);
2193 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2197 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2203 /* Power op (**). Constant integer exponent has special handling. */
2206 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2208 tree gfc_int4_type_node
;
2211 int res_ikind_1
, res_ikind_2
;
2216 gfc_init_se (&lse
, se
);
2217 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2218 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2219 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2221 gfc_init_se (&rse
, se
);
2222 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2223 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2225 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2226 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2227 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2230 gfc_int4_type_node
= gfc_get_int_type (4);
2232 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2233 library routine. But in the end, we have to convert the result back
2234 if this case applies -- with res_ikind_K, we keep track whether operand K
2235 falls into this case. */
2239 kind
= expr
->value
.op
.op1
->ts
.kind
;
2240 switch (expr
->value
.op
.op2
->ts
.type
)
2243 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2248 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2249 res_ikind_2
= ikind
;
2271 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2273 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2300 switch (expr
->value
.op
.op1
->ts
.type
)
2303 if (kind
== 3) /* Case 16 was not handled properly above. */
2305 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2309 /* Use builtins for real ** int4. */
2315 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2319 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2323 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2327 /* Use the __builtin_powil() only if real(kind=16) is
2328 actually the C long double type. */
2329 if (!gfc_real16_is_float128
)
2330 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2338 /* If we don't have a good builtin for this, go for the
2339 library function. */
2341 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2345 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2354 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2358 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2366 se
->expr
= build_call_expr_loc (input_location
,
2367 fndecl
, 2, lse
.expr
, rse
.expr
);
2369 /* Convert the result back if it is of wrong integer kind. */
2370 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2372 /* We want the maximum of both operand kinds as result. */
2373 if (res_ikind_1
< res_ikind_2
)
2374 res_ikind_1
= res_ikind_2
;
2375 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2380 /* Generate code to allocate a string temporary. */
2383 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2388 if (gfc_can_put_var_on_stack (len
))
2390 /* Create a temporary variable to hold the result. */
2391 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2392 gfc_charlen_type_node
, len
,
2393 build_int_cst (gfc_charlen_type_node
, 1));
2394 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2396 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2397 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2399 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2401 var
= gfc_create_var (tmp
, "str");
2402 var
= gfc_build_addr_expr (type
, var
);
2406 /* Allocate a temporary to hold the result. */
2407 var
= gfc_create_var (type
, "pstr");
2408 gcc_assert (POINTER_TYPE_P (type
));
2409 tmp
= TREE_TYPE (type
);
2410 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2411 tmp
= TREE_TYPE (tmp
);
2412 tmp
= TYPE_SIZE_UNIT (tmp
);
2413 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2414 fold_convert (size_type_node
, len
),
2415 fold_convert (size_type_node
, tmp
));
2416 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2417 gfc_add_modify (&se
->pre
, var
, tmp
);
2419 /* Free the temporary afterwards. */
2420 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2421 gfc_add_expr_to_block (&se
->post
, tmp
);
2428 /* Handle a string concatenation operation. A temporary will be allocated to
2432 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2435 tree len
, type
, var
, tmp
, fndecl
;
2437 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2438 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2439 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2441 gfc_init_se (&lse
, se
);
2442 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2443 gfc_conv_string_parameter (&lse
);
2444 gfc_init_se (&rse
, se
);
2445 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2446 gfc_conv_string_parameter (&rse
);
2448 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2449 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2451 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2452 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2453 if (len
== NULL_TREE
)
2455 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2456 TREE_TYPE (lse
.string_length
),
2457 lse
.string_length
, rse
.string_length
);
2460 type
= build_pointer_type (type
);
2462 var
= gfc_conv_string_tmp (se
, type
, len
);
2464 /* Do the actual concatenation. */
2465 if (expr
->ts
.kind
== 1)
2466 fndecl
= gfor_fndecl_concat_string
;
2467 else if (expr
->ts
.kind
== 4)
2468 fndecl
= gfor_fndecl_concat_string_char4
;
2472 tmp
= build_call_expr_loc (input_location
,
2473 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2474 rse
.string_length
, rse
.expr
);
2475 gfc_add_expr_to_block (&se
->pre
, tmp
);
2477 /* Add the cleanup for the operands. */
2478 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2479 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2482 se
->string_length
= len
;
2485 /* Translates an op expression. Common (binary) cases are handled by this
2486 function, others are passed on. Recursion is used in either case.
2487 We use the fact that (op1.ts == op2.ts) (except for the power
2489 Operators need no special handling for scalarized expressions as long as
2490 they call gfc_conv_simple_val to get their operands.
2491 Character strings get special handling. */
2494 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2496 enum tree_code code
;
2505 switch (expr
->value
.op
.op
)
2507 case INTRINSIC_PARENTHESES
:
2508 if ((expr
->ts
.type
== BT_REAL
2509 || expr
->ts
.type
== BT_COMPLEX
)
2510 && gfc_option
.flag_protect_parens
)
2512 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2513 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2518 case INTRINSIC_UPLUS
:
2519 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2522 case INTRINSIC_UMINUS
:
2523 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2527 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2530 case INTRINSIC_PLUS
:
2534 case INTRINSIC_MINUS
:
2538 case INTRINSIC_TIMES
:
2542 case INTRINSIC_DIVIDE
:
2543 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2544 an integer, we must round towards zero, so we use a
2546 if (expr
->ts
.type
== BT_INTEGER
)
2547 code
= TRUNC_DIV_EXPR
;
2552 case INTRINSIC_POWER
:
2553 gfc_conv_power_op (se
, expr
);
2556 case INTRINSIC_CONCAT
:
2557 gfc_conv_concat_op (se
, expr
);
2561 code
= TRUTH_ANDIF_EXPR
;
2566 code
= TRUTH_ORIF_EXPR
;
2570 /* EQV and NEQV only work on logicals, but since we represent them
2571 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2573 case INTRINSIC_EQ_OS
:
2581 case INTRINSIC_NE_OS
:
2582 case INTRINSIC_NEQV
:
2589 case INTRINSIC_GT_OS
:
2596 case INTRINSIC_GE_OS
:
2603 case INTRINSIC_LT_OS
:
2610 case INTRINSIC_LE_OS
:
2616 case INTRINSIC_USER
:
2617 case INTRINSIC_ASSIGN
:
2618 /* These should be converted into function calls by the frontend. */
2622 fatal_error ("Unknown intrinsic op");
2626 /* The only exception to this is **, which is handled separately anyway. */
2627 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2629 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2633 gfc_init_se (&lse
, se
);
2634 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2635 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2638 gfc_init_se (&rse
, se
);
2639 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2640 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2644 gfc_conv_string_parameter (&lse
);
2645 gfc_conv_string_parameter (&rse
);
2647 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2648 rse
.string_length
, rse
.expr
,
2649 expr
->value
.op
.op1
->ts
.kind
,
2651 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2652 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2655 type
= gfc_typenode_for_spec (&expr
->ts
);
2659 /* The result of logical ops is always boolean_type_node. */
2660 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2661 lse
.expr
, rse
.expr
);
2662 se
->expr
= convert (type
, tmp
);
2665 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2667 /* Add the post blocks. */
2668 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2669 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2672 /* If a string's length is one, we convert it to a single character. */
2675 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2679 || !tree_fits_uhwi_p (len
)
2680 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2683 if (TREE_INT_CST_LOW (len
) == 1)
2685 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2686 return build_fold_indirect_ref_loc (input_location
, str
);
2690 && TREE_CODE (str
) == ADDR_EXPR
2691 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2692 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2693 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2694 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2695 && TREE_INT_CST_LOW (len
) > 1
2696 && TREE_INT_CST_LOW (len
)
2697 == (unsigned HOST_WIDE_INT
)
2698 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2700 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2701 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2702 if (TREE_CODE (ret
) == INTEGER_CST
)
2704 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2705 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2706 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2708 for (i
= 1; i
< length
; i
++)
2721 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2724 if (sym
->backend_decl
)
2726 /* This becomes the nominal_type in
2727 function.c:assign_parm_find_data_types. */
2728 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2729 /* This becomes the passed_type in
2730 function.c:assign_parm_find_data_types. C promotes char to
2731 integer for argument passing. */
2732 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2734 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2739 /* If we have a constant character expression, make it into an
2741 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2746 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2747 (int)(*expr
)->value
.character
.string
[0]);
2748 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2750 /* The expr needs to be compatible with a C int. If the
2751 conversion fails, then the 2 causes an ICE. */
2752 ts
.type
= BT_INTEGER
;
2753 ts
.kind
= gfc_c_int_kind
;
2754 gfc_convert_type (*expr
, &ts
, 2);
2757 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2759 if ((*expr
)->ref
== NULL
)
2761 se
->expr
= gfc_string_to_single_character
2762 (build_int_cst (integer_type_node
, 1),
2763 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2765 ((*expr
)->symtree
->n
.sym
)),
2770 gfc_conv_variable (se
, *expr
);
2771 se
->expr
= gfc_string_to_single_character
2772 (build_int_cst (integer_type_node
, 1),
2773 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2781 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2782 if STR is a string literal, otherwise return -1. */
2785 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2788 && TREE_CODE (str
) == ADDR_EXPR
2789 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2790 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2791 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2792 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2793 && tree_fits_uhwi_p (len
)
2794 && tree_to_uhwi (len
) >= 1
2795 && tree_to_uhwi (len
)
2796 == (unsigned HOST_WIDE_INT
)
2797 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2799 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2800 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2801 if (TREE_CODE (folded
) == INTEGER_CST
)
2803 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2804 int length
= TREE_STRING_LENGTH (string_cst
);
2805 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2807 for (; length
> 0; length
--)
2808 if (ptr
[length
- 1] != ' ')
2817 /* Helper to build a call to memcmp. */
2820 build_memcmp_call (tree s1
, tree s2
, tree n
)
2824 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2825 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2827 s1
= fold_convert (pvoid_type_node
, s1
);
2829 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2830 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2832 s2
= fold_convert (pvoid_type_node
, s2
);
2834 n
= fold_convert (size_type_node
, n
);
2836 tmp
= build_call_expr_loc (input_location
,
2837 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2840 return fold_convert (integer_type_node
, tmp
);
2843 /* Compare two strings. If they are all single characters, the result is the
2844 subtraction of them. Otherwise, we build a library call. */
2847 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2848 enum tree_code code
)
2854 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2855 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2857 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2858 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2860 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2862 /* Deal with single character specially. */
2863 sc1
= fold_convert (integer_type_node
, sc1
);
2864 sc2
= fold_convert (integer_type_node
, sc2
);
2865 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2869 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2871 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2873 /* If one string is a string literal with LEN_TRIM longer
2874 than the length of the second string, the strings
2876 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2877 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2878 return integer_one_node
;
2879 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2880 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2881 return integer_one_node
;
2884 /* We can compare via memcpy if the strings are known to be equal
2885 in length and they are
2887 - kind=4 and the comparison is for (in)equality. */
2889 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2890 && tree_int_cst_equal (len1
, len2
)
2891 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2896 chartype
= gfc_get_char_type (kind
);
2897 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2898 fold_convert (TREE_TYPE(len1
),
2899 TYPE_SIZE_UNIT(chartype
)),
2901 return build_memcmp_call (str1
, str2
, tmp
);
2904 /* Build a call for the comparison. */
2906 fndecl
= gfor_fndecl_compare_string
;
2908 fndecl
= gfor_fndecl_compare_string_char4
;
2912 return build_call_expr_loc (input_location
, fndecl
, 4,
2913 len1
, str1
, len2
, str2
);
2917 /* Return the backend_decl for a procedure pointer component. */
2920 get_proc_ptr_comp (gfc_expr
*e
)
2926 gfc_init_se (&comp_se
, NULL
);
2927 e2
= gfc_copy_expr (e
);
2928 /* We have to restore the expr type later so that gfc_free_expr frees
2929 the exact same thing that was allocated.
2930 TODO: This is ugly. */
2931 old_type
= e2
->expr_type
;
2932 e2
->expr_type
= EXPR_VARIABLE
;
2933 gfc_conv_expr (&comp_se
, e2
);
2934 e2
->expr_type
= old_type
;
2936 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2940 /* Convert a typebound function reference from a class object. */
2942 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2947 if (TREE_CODE (base_object
) != VAR_DECL
)
2949 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2950 gfc_add_modify (&se
->pre
, var
, base_object
);
2952 se
->expr
= gfc_class_vptr_get (base_object
);
2953 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2955 while (ref
&& ref
->next
)
2957 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2958 if (ref
->u
.c
.sym
->attr
.extension
)
2959 conv_parent_component_references (se
, ref
);
2960 gfc_conv_component_ref (se
, ref
);
2961 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2966 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2970 if (gfc_is_proc_ptr_comp (expr
))
2971 tmp
= get_proc_ptr_comp (expr
);
2972 else if (sym
->attr
.dummy
)
2974 tmp
= gfc_get_symbol_decl (sym
);
2975 if (sym
->attr
.proc_pointer
)
2976 tmp
= build_fold_indirect_ref_loc (input_location
,
2978 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2979 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2983 if (!sym
->backend_decl
)
2984 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2986 TREE_USED (sym
->backend_decl
) = 1;
2988 tmp
= sym
->backend_decl
;
2990 if (sym
->attr
.cray_pointee
)
2992 /* TODO - make the cray pointee a pointer to a procedure,
2993 assign the pointer to it and use it for the call. This
2995 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2996 gfc_get_symbol_decl (sym
->cp_pointer
));
2997 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3000 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3002 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3003 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3010 /* Initialize MAPPING. */
3013 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3015 mapping
->syms
= NULL
;
3016 mapping
->charlens
= NULL
;
3020 /* Free all memory held by MAPPING (but not MAPPING itself). */
3023 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3025 gfc_interface_sym_mapping
*sym
;
3026 gfc_interface_sym_mapping
*nextsym
;
3028 gfc_charlen
*nextcl
;
3030 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3032 nextsym
= sym
->next
;
3033 sym
->new_sym
->n
.sym
->formal
= NULL
;
3034 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3035 gfc_free_expr (sym
->expr
);
3036 free (sym
->new_sym
);
3039 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3042 gfc_free_expr (cl
->length
);
3048 /* Return a copy of gfc_charlen CL. Add the returned structure to
3049 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3051 static gfc_charlen
*
3052 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3055 gfc_charlen
*new_charlen
;
3057 new_charlen
= gfc_get_charlen ();
3058 new_charlen
->next
= mapping
->charlens
;
3059 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3061 mapping
->charlens
= new_charlen
;
3066 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3067 array variable that can be used as the actual argument for dummy
3068 argument SYM. Add any initialization code to BLOCK. PACKED is as
3069 for gfc_get_nodesc_array_type and DATA points to the first element
3070 in the passed array. */
3073 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3074 gfc_packed packed
, tree data
)
3079 type
= gfc_typenode_for_spec (&sym
->ts
);
3080 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3081 !sym
->attr
.target
&& !sym
->attr
.pointer
3082 && !sym
->attr
.proc_pointer
);
3084 var
= gfc_create_var (type
, "ifm");
3085 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3091 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3092 and offset of descriptorless array type TYPE given that it has the same
3093 size as DESC. Add any set-up code to BLOCK. */
3096 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3103 offset
= gfc_index_zero_node
;
3104 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3106 dim
= gfc_rank_cst
[n
];
3107 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3108 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3110 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3111 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3112 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3113 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3115 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3117 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3118 gfc_array_index_type
,
3119 gfc_conv_descriptor_ubound_get (desc
, dim
),
3120 gfc_conv_descriptor_lbound_get (desc
, dim
));
3121 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3122 gfc_array_index_type
,
3123 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3124 tmp
= gfc_evaluate_now (tmp
, block
);
3125 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3127 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3128 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3129 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3130 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3131 gfc_array_index_type
, offset
, tmp
);
3133 offset
= gfc_evaluate_now (offset
, block
);
3134 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3138 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3139 in SE. The caller may still use se->expr and se->string_length after
3140 calling this function. */
3143 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3144 gfc_symbol
* sym
, gfc_se
* se
,
3147 gfc_interface_sym_mapping
*sm
;
3151 gfc_symbol
*new_sym
;
3153 gfc_symtree
*new_symtree
;
3155 /* Create a new symbol to represent the actual argument. */
3156 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3157 new_sym
->ts
= sym
->ts
;
3158 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3159 new_sym
->attr
.referenced
= 1;
3160 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3161 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3162 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3163 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3164 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3165 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3166 new_sym
->attr
.function
= sym
->attr
.function
;
3168 /* Ensure that the interface is available and that
3169 descriptors are passed for array actual arguments. */
3170 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3172 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3173 new_sym
->attr
.always_explicit
3174 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3177 /* Create a fake symtree for it. */
3179 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3180 new_symtree
->n
.sym
= new_sym
;
3181 gcc_assert (new_symtree
== root
);
3183 /* Create a dummy->actual mapping. */
3184 sm
= XCNEW (gfc_interface_sym_mapping
);
3185 sm
->next
= mapping
->syms
;
3187 sm
->new_sym
= new_symtree
;
3188 sm
->expr
= gfc_copy_expr (expr
);
3191 /* Stabilize the argument's value. */
3192 if (!sym
->attr
.function
&& se
)
3193 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3195 if (sym
->ts
.type
== BT_CHARACTER
)
3197 /* Create a copy of the dummy argument's length. */
3198 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3199 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3201 /* If the length is specified as "*", record the length that
3202 the caller is passing. We should use the callee's length
3203 in all other cases. */
3204 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3206 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3207 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3214 /* Use the passed value as-is if the argument is a function. */
3215 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3218 /* If the argument is either a string or a pointer to a string,
3219 convert it to a boundless character type. */
3220 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3222 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3223 tmp
= build_pointer_type (tmp
);
3224 if (sym
->attr
.pointer
)
3225 value
= build_fold_indirect_ref_loc (input_location
,
3229 value
= fold_convert (tmp
, value
);
3232 /* If the argument is a scalar, a pointer to an array or an allocatable,
3234 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3235 value
= build_fold_indirect_ref_loc (input_location
,
3238 /* For character(*), use the actual argument's descriptor. */
3239 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3240 value
= build_fold_indirect_ref_loc (input_location
,
3243 /* If the argument is an array descriptor, use it to determine
3244 information about the actual argument's shape. */
3245 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3246 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3248 /* Get the actual argument's descriptor. */
3249 desc
= build_fold_indirect_ref_loc (input_location
,
3252 /* Create the replacement variable. */
3253 tmp
= gfc_conv_descriptor_data_get (desc
);
3254 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3257 /* Use DESC to work out the upper bounds, strides and offset. */
3258 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3261 /* Otherwise we have a packed array. */
3262 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3263 PACKED_FULL
, se
->expr
);
3265 new_sym
->backend_decl
= value
;
3269 /* Called once all dummy argument mappings have been added to MAPPING,
3270 but before the mapping is used to evaluate expressions. Pre-evaluate
3271 the length of each argument, adding any initialization code to PRE and
3272 any finalization code to POST. */
3275 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3276 stmtblock_t
* pre
, stmtblock_t
* post
)
3278 gfc_interface_sym_mapping
*sym
;
3282 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3283 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3284 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3286 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3287 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3288 gfc_init_se (&se
, NULL
);
3289 gfc_conv_expr (&se
, expr
);
3290 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3291 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3292 gfc_add_block_to_block (pre
, &se
.pre
);
3293 gfc_add_block_to_block (post
, &se
.post
);
3295 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3300 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3304 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3305 gfc_constructor_base base
)
3308 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3310 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3313 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3314 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3315 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3321 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3325 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3330 for (; ref
; ref
= ref
->next
)
3334 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3336 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3337 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3338 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3346 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3347 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3353 /* Convert intrinsic function calls into result expressions. */
3356 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3364 arg1
= expr
->value
.function
.actual
->expr
;
3365 if (expr
->value
.function
.actual
->next
)
3366 arg2
= expr
->value
.function
.actual
->next
->expr
;
3370 sym
= arg1
->symtree
->n
.sym
;
3372 if (sym
->attr
.dummy
)
3377 switch (expr
->value
.function
.isym
->id
)
3380 /* TODO figure out why this condition is necessary. */
3381 if (sym
->attr
.function
3382 && (arg1
->ts
.u
.cl
->length
== NULL
3383 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3384 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3387 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3391 if (!sym
->as
|| sym
->as
->rank
== 0)
3394 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3396 dup
= mpz_get_si (arg2
->value
.integer
);
3401 dup
= sym
->as
->rank
;
3405 for (; d
< dup
; d
++)
3409 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3411 gfc_free_expr (new_expr
);
3415 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3416 gfc_get_int_expr (gfc_default_integer_kind
,
3418 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3420 new_expr
= gfc_multiply (new_expr
, tmp
);
3426 case GFC_ISYM_LBOUND
:
3427 case GFC_ISYM_UBOUND
:
3428 /* TODO These implementations of lbound and ubound do not limit if
3429 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3431 if (!sym
->as
|| sym
->as
->rank
== 0)
3434 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3435 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3437 /* TODO: If the need arises, this could produce an array of
3441 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3443 if (sym
->as
->lower
[d
])
3444 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3448 if (sym
->as
->upper
[d
])
3449 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3457 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3461 gfc_replace_expr (expr
, new_expr
);
3467 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3468 gfc_interface_mapping
* mapping
)
3470 gfc_formal_arglist
*f
;
3471 gfc_actual_arglist
*actual
;
3473 actual
= expr
->value
.function
.actual
;
3474 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3476 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3481 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3484 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3489 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3491 for (d
= 0; d
< as
->rank
; d
++)
3493 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3494 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3497 expr
->value
.function
.esym
->as
= as
;
3500 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3502 expr
->value
.function
.esym
->ts
.u
.cl
->length
3503 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3505 gfc_apply_interface_mapping_to_expr (mapping
,
3506 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3511 /* EXPR is a copy of an expression that appeared in the interface
3512 associated with MAPPING. Walk it recursively looking for references to
3513 dummy arguments that MAPPING maps to actual arguments. Replace each such
3514 reference with a reference to the associated actual argument. */
3517 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3520 gfc_interface_sym_mapping
*sym
;
3521 gfc_actual_arglist
*actual
;
3526 /* Copying an expression does not copy its length, so do that here. */
3527 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3529 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3530 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3533 /* Apply the mapping to any references. */
3534 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3536 /* ...and to the expression's symbol, if it has one. */
3537 /* TODO Find out why the condition on expr->symtree had to be moved into
3538 the loop rather than being outside it, as originally. */
3539 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3540 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3542 if (sym
->new_sym
->n
.sym
->backend_decl
)
3543 expr
->symtree
= sym
->new_sym
;
3545 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3546 /* Replace base type for polymorphic arguments. */
3547 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3548 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3549 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3552 /* ...and to subexpressions in expr->value. */
3553 switch (expr
->expr_type
)
3558 case EXPR_SUBSTRING
:
3562 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3563 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3567 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3568 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3570 if (expr
->value
.function
.esym
== NULL
3571 && expr
->value
.function
.isym
!= NULL
3572 && expr
->value
.function
.actual
->expr
->symtree
3573 && gfc_map_intrinsic_function (expr
, mapping
))
3576 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3577 if (sym
->old
== expr
->value
.function
.esym
)
3579 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3580 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3581 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3586 case EXPR_STRUCTURE
:
3587 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3600 /* Evaluate interface expression EXPR using MAPPING. Store the result
3604 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3605 gfc_se
* se
, gfc_expr
* expr
)
3607 expr
= gfc_copy_expr (expr
);
3608 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3609 gfc_conv_expr (se
, expr
);
3610 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3611 gfc_free_expr (expr
);
3615 /* Returns a reference to a temporary array into which a component of
3616 an actual argument derived type array is copied and then returned
3617 after the function call. */
3619 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3620 sym_intent intent
, bool formal_ptr
)
3628 gfc_array_info
*info
;
3638 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3640 gfc_init_se (&lse
, NULL
);
3641 gfc_init_se (&rse
, NULL
);
3643 /* Walk the argument expression. */
3644 rss
= gfc_walk_expr (expr
);
3646 gcc_assert (rss
!= gfc_ss_terminator
);
3648 /* Initialize the scalarizer. */
3649 gfc_init_loopinfo (&loop
);
3650 gfc_add_ss_to_loop (&loop
, rss
);
3652 /* Calculate the bounds of the scalarization. */
3653 gfc_conv_ss_startstride (&loop
);
3655 /* Build an ss for the temporary. */
3656 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3657 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3659 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3660 if (GFC_ARRAY_TYPE_P (base_type
)
3661 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3662 base_type
= gfc_get_element_type (base_type
);
3664 if (expr
->ts
.type
== BT_CLASS
)
3665 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3667 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3668 ? expr
->ts
.u
.cl
->backend_decl
3672 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3674 /* Associate the SS with the loop. */
3675 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3677 /* Setup the scalarizing loops. */
3678 gfc_conv_loop_setup (&loop
, &expr
->where
);
3680 /* Pass the temporary descriptor back to the caller. */
3681 info
= &loop
.temp_ss
->info
->data
.array
;
3682 parmse
->expr
= info
->descriptor
;
3684 /* Setup the gfc_se structures. */
3685 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3686 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3689 lse
.ss
= loop
.temp_ss
;
3690 gfc_mark_ss_chain_used (rss
, 1);
3691 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3693 /* Start the scalarized loop body. */
3694 gfc_start_scalarized_body (&loop
, &body
);
3696 /* Translate the expression. */
3697 gfc_conv_expr (&rse
, expr
);
3699 gfc_conv_tmp_array_ref (&lse
);
3701 if (intent
!= INTENT_OUT
)
3703 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3704 gfc_add_expr_to_block (&body
, tmp
);
3705 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3706 gfc_trans_scalarizing_loops (&loop
, &body
);
3710 /* Make sure that the temporary declaration survives by merging
3711 all the loop declarations into the current context. */
3712 for (n
= 0; n
< loop
.dimen
; n
++)
3714 gfc_merge_block_scope (&body
);
3715 body
= loop
.code
[loop
.order
[n
]];
3717 gfc_merge_block_scope (&body
);
3720 /* Add the post block after the second loop, so that any
3721 freeing of allocated memory is done at the right time. */
3722 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3724 /**********Copy the temporary back again.*********/
3726 gfc_init_se (&lse
, NULL
);
3727 gfc_init_se (&rse
, NULL
);
3729 /* Walk the argument expression. */
3730 lss
= gfc_walk_expr (expr
);
3731 rse
.ss
= loop
.temp_ss
;
3734 /* Initialize the scalarizer. */
3735 gfc_init_loopinfo (&loop2
);
3736 gfc_add_ss_to_loop (&loop2
, lss
);
3738 /* Calculate the bounds of the scalarization. */
3739 gfc_conv_ss_startstride (&loop2
);
3741 /* Setup the scalarizing loops. */
3742 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3744 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3745 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3747 gfc_mark_ss_chain_used (lss
, 1);
3748 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3750 /* Declare the variable to hold the temporary offset and start the
3751 scalarized loop body. */
3752 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3753 gfc_start_scalarized_body (&loop2
, &body
);
3755 /* Build the offsets for the temporary from the loop variables. The
3756 temporary array has lbounds of zero and strides of one in all
3757 dimensions, so this is very simple. The offset is only computed
3758 outside the innermost loop, so the overall transfer could be
3759 optimized further. */
3760 info
= &rse
.ss
->info
->data
.array
;
3761 dimen
= rse
.ss
->dimen
;
3763 tmp_index
= gfc_index_zero_node
;
3764 for (n
= dimen
- 1; n
> 0; n
--)
3767 tmp
= rse
.loop
->loopvar
[n
];
3768 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3769 tmp
, rse
.loop
->from
[n
]);
3770 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3773 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3774 gfc_array_index_type
,
3775 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3776 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3777 gfc_array_index_type
,
3778 tmp_str
, gfc_index_one_node
);
3780 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3781 gfc_array_index_type
, tmp
, tmp_str
);
3784 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3785 gfc_array_index_type
,
3786 tmp_index
, rse
.loop
->from
[0]);
3787 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3789 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3790 gfc_array_index_type
,
3791 rse
.loop
->loopvar
[0], offset
);
3793 /* Now use the offset for the reference. */
3794 tmp
= build_fold_indirect_ref_loc (input_location
,
3796 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3798 if (expr
->ts
.type
== BT_CHARACTER
)
3799 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3801 gfc_conv_expr (&lse
, expr
);
3803 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3805 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3806 gfc_add_expr_to_block (&body
, tmp
);
3808 /* Generate the copying loops. */
3809 gfc_trans_scalarizing_loops (&loop2
, &body
);
3811 /* Wrap the whole thing up by adding the second loop to the post-block
3812 and following it by the post-block of the first loop. In this way,
3813 if the temporary needs freeing, it is done after use! */
3814 if (intent
!= INTENT_IN
)
3816 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3817 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3820 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3822 gfc_cleanup_loop (&loop
);
3823 gfc_cleanup_loop (&loop2
);
3825 /* Pass the string length to the argument expression. */
3826 if (expr
->ts
.type
== BT_CHARACTER
)
3827 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3829 /* Determine the offset for pointer formal arguments and set the
3833 size
= gfc_index_one_node
;
3834 offset
= gfc_index_zero_node
;
3835 for (n
= 0; n
< dimen
; n
++)
3837 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3839 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3840 gfc_array_index_type
, tmp
,
3841 gfc_index_one_node
);
3842 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3846 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3849 gfc_index_one_node
);
3850 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3851 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3852 gfc_array_index_type
,
3854 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3855 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3856 gfc_array_index_type
,
3857 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3858 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3859 gfc_array_index_type
,
3860 tmp
, gfc_index_one_node
);
3861 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3862 gfc_array_index_type
, size
, tmp
);
3865 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3869 /* We want either the address for the data or the address of the descriptor,
3870 depending on the mode of passing array arguments. */
3872 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3874 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3880 /* Generate the code for argument list functions. */
3883 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3885 /* Pass by value for g77 %VAL(arg), pass the address
3886 indirectly for %LOC, else by reference. Thus %REF
3887 is a "do-nothing" and %LOC is the same as an F95
3889 if (strncmp (name
, "%VAL", 4) == 0)
3890 gfc_conv_expr (se
, expr
);
3891 else if (strncmp (name
, "%LOC", 4) == 0)
3893 gfc_conv_expr_reference (se
, expr
);
3894 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3896 else if (strncmp (name
, "%REF", 4) == 0)
3897 gfc_conv_expr_reference (se
, expr
);
3899 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3903 /* Generate code for a procedure call. Note can return se->post != NULL.
3904 If se->direct_byref is set then se->expr contains the return parameter.
3905 Return nonzero, if the call has alternate specifiers.
3906 'expr' is only needed for procedure pointer components. */
3909 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3910 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3911 vec
<tree
, va_gc
> *append_args
)
3913 gfc_interface_mapping mapping
;
3914 vec
<tree
, va_gc
> *arglist
;
3915 vec
<tree
, va_gc
> *retargs
;
3919 gfc_array_info
*info
;
3926 vec
<tree
, va_gc
> *stringargs
;
3927 vec
<tree
, va_gc
> *optionalargs
;
3929 gfc_formal_arglist
*formal
;
3930 gfc_actual_arglist
*arg
;
3931 int has_alternate_specifier
= 0;
3932 bool need_interface_mapping
;
3939 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3940 gfc_component
*comp
= NULL
;
3946 optionalargs
= NULL
;
3951 comp
= gfc_get_proc_ptr_comp (expr
);
3955 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3957 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3958 if (se
->ss
->info
->useflags
)
3960 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3961 && sym
->result
->attr
.dimension
)
3962 || (comp
&& comp
->attr
.dimension
));
3963 gcc_assert (se
->loop
!= NULL
);
3965 /* Access the previously obtained result. */
3966 gfc_conv_tmp_array_ref (se
);
3970 info
= &se
->ss
->info
->data
.array
;
3975 gfc_init_block (&post
);
3976 gfc_init_interface_mapping (&mapping
);
3979 formal
= gfc_sym_get_dummy_args (sym
);
3980 need_interface_mapping
= sym
->attr
.dimension
||
3981 (sym
->ts
.type
== BT_CHARACTER
3982 && sym
->ts
.u
.cl
->length
3983 && sym
->ts
.u
.cl
->length
->expr_type
3988 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3989 need_interface_mapping
= comp
->attr
.dimension
||
3990 (comp
->ts
.type
== BT_CHARACTER
3991 && comp
->ts
.u
.cl
->length
3992 && comp
->ts
.u
.cl
->length
->expr_type
3996 base_object
= NULL_TREE
;
3998 /* Evaluate the arguments. */
3999 for (arg
= args
; arg
!= NULL
;
4000 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4003 fsym
= formal
? formal
->sym
: NULL
;
4004 parm_kind
= MISSING
;
4006 /* Class array expressions are sometimes coming completely unadorned
4007 with either arrayspec or _data component. Correct that here.
4008 OOP-TODO: Move this to the frontend. */
4009 if (e
&& e
->expr_type
== EXPR_VARIABLE
4011 && e
->ts
.type
== BT_CLASS
4012 && (CLASS_DATA (e
)->attr
.codimension
4013 || CLASS_DATA (e
)->attr
.dimension
))
4015 gfc_typespec temp_ts
= e
->ts
;
4016 gfc_add_class_array_ref (e
);
4022 if (se
->ignore_optional
)
4024 /* Some intrinsics have already been resolved to the correct
4028 else if (arg
->label
)
4030 has_alternate_specifier
= 1;
4035 gfc_init_se (&parmse
, NULL
);
4037 /* For scalar arguments with VALUE attribute which are passed by
4038 value, pass "0" and a hidden argument gives the optional
4040 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4041 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4042 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4044 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4046 vec_safe_push (optionalargs
, boolean_false_node
);
4050 /* Pass a NULL pointer for an absent arg. */
4051 parmse
.expr
= null_pointer_node
;
4052 if (arg
->missing_arg_type
== BT_CHARACTER
)
4053 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4058 else if (arg
->expr
->expr_type
== EXPR_NULL
4059 && fsym
&& !fsym
->attr
.pointer
4060 && (fsym
->ts
.type
!= BT_CLASS
4061 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4063 /* Pass a NULL pointer to denote an absent arg. */
4064 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4065 && (fsym
->ts
.type
!= BT_CLASS
4066 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4067 gfc_init_se (&parmse
, NULL
);
4068 parmse
.expr
= null_pointer_node
;
4069 if (arg
->missing_arg_type
== BT_CHARACTER
)
4070 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4072 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4073 && e
->ts
.type
== BT_DERIVED
)
4075 /* The derived type needs to be converted to a temporary
4077 gfc_init_se (&parmse
, se
);
4078 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4080 && e
->expr_type
== EXPR_VARIABLE
4081 && e
->symtree
->n
.sym
->attr
.optional
,
4082 CLASS_DATA (fsym
)->attr
.class_pointer
4083 || CLASS_DATA (fsym
)->attr
.allocatable
);
4085 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4087 /* The intrinsic type needs to be converted to a temporary
4088 CLASS object for the unlimited polymorphic formal. */
4089 gfc_init_se (&parmse
, se
);
4090 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4092 else if (se
->ss
&& se
->ss
->info
->useflags
)
4098 /* An elemental function inside a scalarized loop. */
4099 gfc_init_se (&parmse
, se
);
4100 parm_kind
= ELEMENTAL
;
4102 if (fsym
&& fsym
->attr
.value
)
4103 gfc_conv_expr (&parmse
, e
);
4105 gfc_conv_expr_reference (&parmse
, e
);
4107 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4108 && e
->expr_type
== EXPR_FUNCTION
)
4109 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4112 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4113 && gfc_is_class_container_ref (e
))
4115 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4117 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4118 && e
->symtree
->n
.sym
->attr
.optional
)
4120 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4121 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4122 TREE_TYPE (parmse
.expr
),
4124 fold_convert (TREE_TYPE (parmse
.expr
),
4125 null_pointer_node
));
4129 /* If we are passing an absent array as optional dummy to an
4130 elemental procedure, make sure that we pass NULL when the data
4131 pointer is NULL. We need this extra conditional because of
4132 scalarization which passes arrays elements to the procedure,
4133 ignoring the fact that the array can be absent/unallocated/... */
4134 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4136 tree descriptor_data
;
4138 descriptor_data
= ss
->info
->data
.array
.data
;
4139 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4141 fold_convert (TREE_TYPE (descriptor_data
),
4142 null_pointer_node
));
4144 = fold_build3_loc (input_location
, COND_EXPR
,
4145 TREE_TYPE (parmse
.expr
),
4146 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4147 fold_convert (TREE_TYPE (parmse
.expr
),
4152 /* The scalarizer does not repackage the reference to a class
4153 array - instead it returns a pointer to the data element. */
4154 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4155 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4156 fsym
->attr
.intent
!= INTENT_IN
4157 && (CLASS_DATA (fsym
)->attr
.class_pointer
4158 || CLASS_DATA (fsym
)->attr
.allocatable
),
4160 && e
->expr_type
== EXPR_VARIABLE
4161 && e
->symtree
->n
.sym
->attr
.optional
,
4162 CLASS_DATA (fsym
)->attr
.class_pointer
4163 || CLASS_DATA (fsym
)->attr
.allocatable
);
4170 gfc_init_se (&parmse
, NULL
);
4172 /* Check whether the expression is a scalar or not; we cannot use
4173 e->rank as it can be nonzero for functions arguments. */
4174 argss
= gfc_walk_expr (e
);
4175 scalar
= argss
== gfc_ss_terminator
;
4177 gfc_free_ss_chain (argss
);
4179 /* Special handling for passing scalar polymorphic coarrays;
4180 otherwise one passes "class->_data.data" instead of "&class". */
4181 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4182 && fsym
&& fsym
->ts
.type
== BT_CLASS
4183 && CLASS_DATA (fsym
)->attr
.codimension
4184 && !CLASS_DATA (fsym
)->attr
.dimension
)
4186 gfc_add_class_array_ref (e
);
4187 parmse
.want_coarray
= 1;
4191 /* A scalar or transformational function. */
4194 if (e
->expr_type
== EXPR_VARIABLE
4195 && e
->symtree
->n
.sym
->attr
.cray_pointee
4196 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4198 /* The Cray pointer needs to be converted to a pointer to
4199 a type given by the expression. */
4200 gfc_conv_expr (&parmse
, e
);
4201 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4202 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4203 parmse
.expr
= convert (type
, tmp
);
4205 else if (fsym
&& fsym
->attr
.value
)
4207 if (fsym
->ts
.type
== BT_CHARACTER
4208 && fsym
->ts
.is_c_interop
4209 && fsym
->ns
->proc_name
!= NULL
4210 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4213 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4214 if (parmse
.expr
== NULL
)
4215 gfc_conv_expr (&parmse
, e
);
4219 gfc_conv_expr (&parmse
, e
);
4220 if (fsym
->attr
.optional
4221 && fsym
->ts
.type
!= BT_CLASS
4222 && fsym
->ts
.type
!= BT_DERIVED
)
4224 if (e
->expr_type
!= EXPR_VARIABLE
4225 || !e
->symtree
->n
.sym
->attr
.optional
4227 vec_safe_push (optionalargs
, boolean_true_node
);
4230 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4231 if (!e
->symtree
->n
.sym
->attr
.value
)
4233 = fold_build3_loc (input_location
, COND_EXPR
,
4234 TREE_TYPE (parmse
.expr
),
4236 fold_convert (TREE_TYPE (parmse
.expr
),
4237 integer_zero_node
));
4239 vec_safe_push (optionalargs
, tmp
);
4244 else if (arg
->name
&& arg
->name
[0] == '%')
4245 /* Argument list functions %VAL, %LOC and %REF are signalled
4246 through arg->name. */
4247 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4248 else if ((e
->expr_type
== EXPR_FUNCTION
)
4249 && ((e
->value
.function
.esym
4250 && e
->value
.function
.esym
->result
->attr
.pointer
)
4251 || (!e
->value
.function
.esym
4252 && e
->symtree
->n
.sym
->attr
.pointer
))
4253 && fsym
&& fsym
->attr
.target
)
4255 gfc_conv_expr (&parmse
, e
);
4256 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4258 else if (e
->expr_type
== EXPR_FUNCTION
4259 && e
->symtree
->n
.sym
->result
4260 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4261 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4263 /* Functions returning procedure pointers. */
4264 gfc_conv_expr (&parmse
, e
);
4265 if (fsym
&& fsym
->attr
.proc_pointer
)
4266 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4270 if (e
->ts
.type
== BT_CLASS
&& fsym
4271 && fsym
->ts
.type
== BT_CLASS
4272 && (!CLASS_DATA (fsym
)->as
4273 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4274 && CLASS_DATA (e
)->attr
.codimension
)
4276 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4277 gcc_assert (!CLASS_DATA (fsym
)->as
);
4278 gfc_add_class_array_ref (e
);
4279 parmse
.want_coarray
= 1;
4280 gfc_conv_expr_reference (&parmse
, e
);
4281 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4283 && e
->expr_type
== EXPR_VARIABLE
);
4286 gfc_conv_expr_reference (&parmse
, e
);
4288 /* Catch base objects that are not variables. */
4289 if (e
->ts
.type
== BT_CLASS
4290 && e
->expr_type
!= EXPR_VARIABLE
4291 && expr
&& e
== expr
->base_expr
)
4292 base_object
= build_fold_indirect_ref_loc (input_location
,
4295 /* A class array element needs converting back to be a
4296 class object, if the formal argument is a class object. */
4297 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4298 && e
->ts
.type
== BT_CLASS
4299 && ((CLASS_DATA (fsym
)->as
4300 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4301 || CLASS_DATA (e
)->attr
.dimension
))
4302 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4303 fsym
->attr
.intent
!= INTENT_IN
4304 && (CLASS_DATA (fsym
)->attr
.class_pointer
4305 || CLASS_DATA (fsym
)->attr
.allocatable
),
4307 && e
->expr_type
== EXPR_VARIABLE
4308 && e
->symtree
->n
.sym
->attr
.optional
,
4309 CLASS_DATA (fsym
)->attr
.class_pointer
4310 || CLASS_DATA (fsym
)->attr
.allocatable
);
4312 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4313 allocated on entry, it must be deallocated. */
4314 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4315 && (fsym
->attr
.allocatable
4316 || (fsym
->ts
.type
== BT_CLASS
4317 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4322 gfc_init_block (&block
);
4324 if (e
->ts
.type
== BT_CLASS
)
4325 ptr
= gfc_class_data_get (ptr
);
4327 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4329 gfc_add_expr_to_block (&block
, tmp
);
4330 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4331 void_type_node
, ptr
,
4333 gfc_add_expr_to_block (&block
, tmp
);
4335 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4337 gfc_add_modify (&block
, ptr
,
4338 fold_convert (TREE_TYPE (ptr
),
4339 null_pointer_node
));
4340 gfc_add_expr_to_block (&block
, tmp
);
4342 else if (fsym
->ts
.type
== BT_CLASS
)
4345 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4346 tmp
= gfc_get_symbol_decl (vtab
);
4347 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4348 ptr
= gfc_class_vptr_get (parmse
.expr
);
4349 gfc_add_modify (&block
, ptr
,
4350 fold_convert (TREE_TYPE (ptr
), tmp
));
4351 gfc_add_expr_to_block (&block
, tmp
);
4354 if (fsym
->attr
.optional
4355 && e
->expr_type
== EXPR_VARIABLE
4356 && e
->symtree
->n
.sym
->attr
.optional
)
4358 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4360 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4361 gfc_finish_block (&block
),
4362 build_empty_stmt (input_location
));
4365 tmp
= gfc_finish_block (&block
);
4367 gfc_add_expr_to_block (&se
->pre
, tmp
);
4370 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4371 || fsym
->ts
.type
== BT_ASSUMED
)
4372 && e
->ts
.type
== BT_CLASS
4373 && !CLASS_DATA (e
)->attr
.dimension
4374 && !CLASS_DATA (e
)->attr
.codimension
)
4375 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4377 /* Wrap scalar variable in a descriptor. We need to convert
4378 the address of a pointer back to the pointer itself before,
4379 we can assign it to the data field. */
4381 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4382 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4385 if (TREE_CODE (tmp
) == ADDR_EXPR
4386 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4387 tmp
= TREE_OPERAND (tmp
, 0);
4388 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4390 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4393 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4394 && ((fsym
->attr
.pointer
4395 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4396 || (fsym
->attr
.proc_pointer
4397 && !(e
->expr_type
== EXPR_VARIABLE
4398 && e
->symtree
->n
.sym
->attr
.dummy
))
4399 || (fsym
->attr
.proc_pointer
4400 && e
->expr_type
== EXPR_VARIABLE
4401 && gfc_is_proc_ptr_comp (e
))
4402 || (fsym
->attr
.allocatable
4403 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4405 /* Scalar pointer dummy args require an extra level of
4406 indirection. The null pointer already contains
4407 this level of indirection. */
4408 parm_kind
= SCALAR_POINTER
;
4409 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4413 else if (e
->ts
.type
== BT_CLASS
4414 && fsym
&& fsym
->ts
.type
== BT_CLASS
4415 && (CLASS_DATA (fsym
)->attr
.dimension
4416 || CLASS_DATA (fsym
)->attr
.codimension
))
4418 /* Pass a class array. */
4419 parmse
.use_offset
= 1;
4420 gfc_conv_expr_descriptor (&parmse
, e
);
4422 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4423 allocated on entry, it must be deallocated. */
4424 if (fsym
->attr
.intent
== INTENT_OUT
4425 && CLASS_DATA (fsym
)->attr
.allocatable
)
4430 gfc_init_block (&block
);
4432 ptr
= gfc_class_data_get (ptr
);
4434 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4435 NULL_TREE
, NULL_TREE
,
4438 gfc_add_expr_to_block (&block
, tmp
);
4439 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4440 void_type_node
, ptr
,
4442 gfc_add_expr_to_block (&block
, tmp
);
4443 gfc_reset_vptr (&block
, e
);
4445 if (fsym
->attr
.optional
4446 && e
->expr_type
== EXPR_VARIABLE
4448 || (e
->ref
->type
== REF_ARRAY
4449 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4450 && e
->symtree
->n
.sym
->attr
.optional
)
4452 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4454 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4455 gfc_finish_block (&block
),
4456 build_empty_stmt (input_location
));
4459 tmp
= gfc_finish_block (&block
);
4461 gfc_add_expr_to_block (&se
->pre
, tmp
);
4464 /* The conversion does not repackage the reference to a class
4465 array - _data descriptor. */
4466 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4467 fsym
->attr
.intent
!= INTENT_IN
4468 && (CLASS_DATA (fsym
)->attr
.class_pointer
4469 || CLASS_DATA (fsym
)->attr
.allocatable
),
4471 && e
->expr_type
== EXPR_VARIABLE
4472 && e
->symtree
->n
.sym
->attr
.optional
,
4473 CLASS_DATA (fsym
)->attr
.class_pointer
4474 || CLASS_DATA (fsym
)->attr
.allocatable
);
4478 /* If the procedure requires an explicit interface, the actual
4479 argument is passed according to the corresponding formal
4480 argument. If the corresponding formal argument is a POINTER,
4481 ALLOCATABLE or assumed shape, we do not use g77's calling
4482 convention, and pass the address of the array descriptor
4483 instead. Otherwise we use g77's calling convention. */
4486 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4487 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4488 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4490 f
= f
|| !comp
->attr
.always_explicit
;
4492 f
= f
|| !sym
->attr
.always_explicit
;
4494 /* If the argument is a function call that may not create
4495 a temporary for the result, we have to check that we
4496 can do it, i.e. that there is no alias between this
4497 argument and another one. */
4498 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4504 intent
= fsym
->attr
.intent
;
4506 intent
= INTENT_UNKNOWN
;
4508 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4510 parmse
.force_tmp
= 1;
4512 iarg
= e
->value
.function
.actual
->expr
;
4514 /* Temporary needed if aliasing due to host association. */
4515 if (sym
->attr
.contained
4517 && !sym
->attr
.implicit_pure
4518 && !sym
->attr
.use_assoc
4519 && iarg
->expr_type
== EXPR_VARIABLE
4520 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4521 parmse
.force_tmp
= 1;
4523 /* Ditto within module. */
4524 if (sym
->attr
.use_assoc
4526 && !sym
->attr
.implicit_pure
4527 && iarg
->expr_type
== EXPR_VARIABLE
4528 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4529 parmse
.force_tmp
= 1;
4532 if (e
->expr_type
== EXPR_VARIABLE
4533 && is_subref_array (e
))
4534 /* The actual argument is a component reference to an
4535 array of derived types. In this case, the argument
4536 is converted to a temporary, which is passed and then
4537 written back after the procedure call. */
4538 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4539 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4540 fsym
&& fsym
->attr
.pointer
);
4541 else if (gfc_is_class_array_ref (e
, NULL
)
4542 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4543 /* The actual argument is a component reference to an
4544 array of derived types. In this case, the argument
4545 is converted to a temporary, which is passed and then
4546 written back after the procedure call.
4547 OOP-TODO: Insert code so that if the dynamic type is
4548 the same as the declared type, copy-in/copy-out does
4550 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4551 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4552 fsym
&& fsym
->attr
.pointer
);
4554 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4556 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4557 allocated on entry, it must be deallocated. */
4558 if (fsym
&& fsym
->attr
.allocatable
4559 && fsym
->attr
.intent
== INTENT_OUT
)
4561 tmp
= build_fold_indirect_ref_loc (input_location
,
4563 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4564 if (fsym
->attr
.optional
4565 && e
->expr_type
== EXPR_VARIABLE
4566 && e
->symtree
->n
.sym
->attr
.optional
)
4567 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4569 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4570 tmp
, build_empty_stmt (input_location
));
4571 gfc_add_expr_to_block (&se
->pre
, tmp
);
4576 /* The case with fsym->attr.optional is that of a user subroutine
4577 with an interface indicating an optional argument. When we call
4578 an intrinsic subroutine, however, fsym is NULL, but we might still
4579 have an optional argument, so we proceed to the substitution
4581 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4583 /* If an optional argument is itself an optional dummy argument,
4584 check its presence and substitute a null if absent. This is
4585 only needed when passing an array to an elemental procedure
4586 as then array elements are accessed - or no NULL pointer is
4587 allowed and a "1" or "0" should be passed if not present.
4588 When passing a non-array-descriptor full array to a
4589 non-array-descriptor dummy, no check is needed. For
4590 array-descriptor actual to array-descriptor dummy, see
4591 PR 41911 for why a check has to be inserted.
4592 fsym == NULL is checked as intrinsics required the descriptor
4593 but do not always set fsym. */
4594 if (e
->expr_type
== EXPR_VARIABLE
4595 && e
->symtree
->n
.sym
->attr
.optional
4596 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4597 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4601 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4602 || fsym
->as
->type
== AS_ASSUMED_RANK
4603 || fsym
->as
->type
== AS_DEFERRED
))))))
4604 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4605 e
->representation
.length
);
4610 /* Obtain the character length of an assumed character length
4611 length procedure from the typespec. */
4612 if (fsym
->ts
.type
== BT_CHARACTER
4613 && parmse
.string_length
== NULL_TREE
4614 && e
->ts
.type
== BT_PROCEDURE
4615 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4616 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4617 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4619 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4620 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4624 if (fsym
&& need_interface_mapping
&& e
)
4625 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4627 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4628 gfc_add_block_to_block (&post
, &parmse
.post
);
4630 /* Allocated allocatable components of derived types must be
4631 deallocated for non-variable scalars. Non-variable arrays are
4632 dealt with in trans-array.c(gfc_conv_array_parameter). */
4633 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4634 && e
->ts
.u
.derived
->attr
.alloc_comp
4635 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4636 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4639 tmp
= build_fold_indirect_ref_loc (input_location
,
4641 parm_rank
= e
->rank
;
4649 case (SCALAR_POINTER
):
4650 tmp
= build_fold_indirect_ref_loc (input_location
,
4655 if (e
->expr_type
== EXPR_OP
4656 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4657 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4660 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4661 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4662 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4665 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4667 /* The derived type is passed to gfc_deallocate_alloc_comp.
4668 Therefore, class actuals can handled correctly but derived
4669 types passed to class formals need the _data component. */
4670 tmp
= gfc_class_data_get (tmp
);
4671 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4672 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4675 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4677 gfc_add_expr_to_block (&se
->post
, tmp
);
4680 /* Add argument checking of passing an unallocated/NULL actual to
4681 a nonallocatable/nonpointer dummy. */
4683 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4685 symbol_attribute attr
;
4689 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4690 attr
= gfc_expr_attr (e
);
4692 goto end_pointer_check
;
4694 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4695 allocatable to an optional dummy, cf. 12.5.2.12. */
4696 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4697 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4698 goto end_pointer_check
;
4702 /* If the actual argument is an optional pointer/allocatable and
4703 the formal argument takes an nonpointer optional value,
4704 it is invalid to pass a non-present argument on, even
4705 though there is no technical reason for this in gfortran.
4706 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4707 tree present
, null_ptr
, type
;
4709 if (attr
.allocatable
4710 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4711 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4712 "allocated or not present", e
->symtree
->n
.sym
->name
);
4713 else if (attr
.pointer
4714 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4715 asprintf (&msg
, "Pointer actual argument '%s' is not "
4716 "associated or not present",
4717 e
->symtree
->n
.sym
->name
);
4718 else if (attr
.proc_pointer
4719 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4720 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4721 "associated or not present",
4722 e
->symtree
->n
.sym
->name
);
4724 goto end_pointer_check
;
4726 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4727 type
= TREE_TYPE (present
);
4728 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4729 boolean_type_node
, present
,
4731 null_pointer_node
));
4732 type
= TREE_TYPE (parmse
.expr
);
4733 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4734 boolean_type_node
, parmse
.expr
,
4736 null_pointer_node
));
4737 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4738 boolean_type_node
, present
, null_ptr
);
4742 if (attr
.allocatable
4743 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4744 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4745 "allocated", e
->symtree
->n
.sym
->name
);
4746 else if (attr
.pointer
4747 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4748 asprintf (&msg
, "Pointer actual argument '%s' is not "
4749 "associated", e
->symtree
->n
.sym
->name
);
4750 else if (attr
.proc_pointer
4751 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4752 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4753 "associated", e
->symtree
->n
.sym
->name
);
4755 goto end_pointer_check
;
4759 /* If the argument is passed by value, we need to strip the
4761 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4762 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4764 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4765 boolean_type_node
, tmp
,
4766 fold_convert (TREE_TYPE (tmp
),
4767 null_pointer_node
));
4770 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4776 /* Deferred length dummies pass the character length by reference
4777 so that the value can be returned. */
4778 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4780 tmp
= parmse
.string_length
;
4781 if (TREE_CODE (tmp
) != VAR_DECL
)
4782 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4783 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4786 /* Character strings are passed as two parameters, a length and a
4787 pointer - except for Bind(c) which only passes the pointer.
4788 An unlimited polymorphic formal argument likewise does not
4790 if (parmse
.string_length
!= NULL_TREE
4791 && !sym
->attr
.is_bind_c
4792 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4793 vec_safe_push (stringargs
, parmse
.string_length
);
4795 /* When calling __copy for character expressions to unlimited
4796 polymorphic entities, the dst argument needs a string length. */
4797 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4798 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4799 && arg
->next
&& arg
->next
->expr
4800 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4801 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4802 vec_safe_push (stringargs
, parmse
.string_length
);
4804 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4805 pass the token and the offset as additional arguments. */
4806 if (fsym
&& e
== NULL
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4807 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4808 && !fsym
->attr
.allocatable
)
4809 || (fsym
->ts
.type
== BT_CLASS
4810 && CLASS_DATA (fsym
)->attr
.codimension
4811 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4813 /* Token and offset. */
4814 vec_safe_push (stringargs
, null_pointer_node
);
4815 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4816 gcc_assert (fsym
->attr
.optional
);
4818 else if (fsym
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4819 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4820 && !fsym
->attr
.allocatable
)
4821 || (fsym
->ts
.type
== BT_CLASS
4822 && CLASS_DATA (fsym
)->attr
.codimension
4823 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4825 tree caf_decl
, caf_type
;
4828 caf_decl
= gfc_get_tree_for_caf_expr (e
);
4829 caf_type
= TREE_TYPE (caf_decl
);
4831 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4832 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
4833 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
4834 tmp
= gfc_conv_descriptor_token (caf_decl
);
4835 else if (DECL_LANG_SPECIFIC (caf_decl
)
4836 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4837 tmp
= GFC_DECL_TOKEN (caf_decl
);
4840 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4841 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4842 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4845 vec_safe_push (stringargs
, tmp
);
4847 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4848 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4849 offset
= build_int_cst (gfc_array_index_type
, 0);
4850 else if (DECL_LANG_SPECIFIC (caf_decl
)
4851 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4852 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4853 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4854 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4856 offset
= build_int_cst (gfc_array_index_type
, 0);
4858 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4859 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4862 gcc_assert (POINTER_TYPE_P (caf_type
));
4866 tmp2
= fsym
->ts
.type
== BT_CLASS
4867 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
4868 if ((fsym
->ts
.type
!= BT_CLASS
4869 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4870 || fsym
->as
->type
== AS_ASSUMED_RANK
))
4871 || (fsym
->ts
.type
== BT_CLASS
4872 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
4873 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
4875 if (fsym
->ts
.type
== BT_CLASS
)
4876 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4879 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4880 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
4882 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
4883 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4885 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
4886 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4889 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4892 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4893 gfc_array_index_type
,
4894 fold_convert (gfc_array_index_type
, tmp2
),
4895 fold_convert (gfc_array_index_type
, tmp
));
4896 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4897 gfc_array_index_type
, offset
, tmp
);
4899 vec_safe_push (stringargs
, offset
);
4902 vec_safe_push (arglist
, parmse
.expr
);
4904 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4911 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4912 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4913 else if (ts
.type
== BT_CHARACTER
)
4915 if (ts
.u
.cl
->length
== NULL
)
4917 /* Assumed character length results are not allowed by 5.1.1.5 of the
4918 standard and are trapped in resolve.c; except in the case of SPREAD
4919 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4920 we take the character length of the first argument for the result.
4921 For dummies, we have to look through the formal argument list for
4922 this function and use the character length found there.*/
4924 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4925 else if (!sym
->attr
.dummy
)
4926 cl
.backend_decl
= (*stringargs
)[0];
4929 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4930 for (; formal
; formal
= formal
->next
)
4931 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4932 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4934 len
= cl
.backend_decl
;
4940 /* Calculate the length of the returned string. */
4941 gfc_init_se (&parmse
, NULL
);
4942 if (need_interface_mapping
)
4943 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4945 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4946 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4947 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4949 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4950 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4951 gfc_charlen_type_node
, tmp
,
4952 build_int_cst (gfc_charlen_type_node
, 0));
4953 cl
.backend_decl
= tmp
;
4956 /* Set up a charlen structure for it. */
4961 len
= cl
.backend_decl
;
4964 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4965 || (!comp
&& gfc_return_by_reference (sym
));
4968 if (se
->direct_byref
)
4970 /* Sometimes, too much indirection can be applied; e.g. for
4971 function_result = array_valued_recursive_function. */
4972 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4973 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4974 && GFC_DESCRIPTOR_TYPE_P
4975 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4976 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4979 /* If the lhs of an assignment x = f(..) is allocatable and
4980 f2003 is allowed, we must do the automatic reallocation.
4981 TODO - deal with intrinsics, without using a temporary. */
4982 if (gfc_option
.flag_realloc_lhs
4983 && se
->ss
&& se
->ss
->loop_chain
4984 && se
->ss
->loop_chain
->is_alloc_lhs
4985 && !expr
->value
.function
.isym
4986 && sym
->result
->as
!= NULL
)
4988 /* Evaluate the bounds of the result, if known. */
4989 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4992 /* Perform the automatic reallocation. */
4993 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4995 gfc_add_expr_to_block (&se
->pre
, tmp
);
4997 /* Pass the temporary as the first argument. */
4998 result
= info
->descriptor
;
5001 result
= build_fold_indirect_ref_loc (input_location
,
5003 vec_safe_push (retargs
, se
->expr
);
5005 else if (comp
&& comp
->attr
.dimension
)
5007 gcc_assert (se
->loop
&& info
);
5009 /* Set the type of the array. */
5010 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5011 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5013 /* Evaluate the bounds of the result, if known. */
5014 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5016 /* If the lhs of an assignment x = f(..) is allocatable and
5017 f2003 is allowed, we must not generate the function call
5018 here but should just send back the results of the mapping.
5019 This is signalled by the function ss being flagged. */
5020 if (gfc_option
.flag_realloc_lhs
5021 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5023 gfc_free_interface_mapping (&mapping
);
5024 return has_alternate_specifier
;
5027 /* Create a temporary to store the result. In case the function
5028 returns a pointer, the temporary will be a shallow copy and
5029 mustn't be deallocated. */
5030 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5031 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5032 tmp
, NULL_TREE
, false,
5033 !comp
->attr
.pointer
, callee_alloc
,
5034 &se
->ss
->info
->expr
->where
);
5036 /* Pass the temporary as the first argument. */
5037 result
= info
->descriptor
;
5038 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5039 vec_safe_push (retargs
, tmp
);
5041 else if (!comp
&& sym
->result
->attr
.dimension
)
5043 gcc_assert (se
->loop
&& info
);
5045 /* Set the type of the array. */
5046 tmp
= gfc_typenode_for_spec (&ts
);
5047 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5049 /* Evaluate the bounds of the result, if known. */
5050 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5052 /* If the lhs of an assignment x = f(..) is allocatable and
5053 f2003 is allowed, we must not generate the function call
5054 here but should just send back the results of the mapping.
5055 This is signalled by the function ss being flagged. */
5056 if (gfc_option
.flag_realloc_lhs
5057 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5059 gfc_free_interface_mapping (&mapping
);
5060 return has_alternate_specifier
;
5063 /* Create a temporary to store the result. In case the function
5064 returns a pointer, the temporary will be a shallow copy and
5065 mustn't be deallocated. */
5066 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5067 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5068 tmp
, NULL_TREE
, false,
5069 !sym
->attr
.pointer
, callee_alloc
,
5070 &se
->ss
->info
->expr
->where
);
5072 /* Pass the temporary as the first argument. */
5073 result
= info
->descriptor
;
5074 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5075 vec_safe_push (retargs
, tmp
);
5077 else if (ts
.type
== BT_CHARACTER
)
5079 /* Pass the string length. */
5080 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5081 type
= build_pointer_type (type
);
5083 /* Return an address to a char[0:len-1]* temporary for
5084 character pointers. */
5085 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5086 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5088 var
= gfc_create_var (type
, "pstr");
5090 if ((!comp
&& sym
->attr
.allocatable
)
5091 || (comp
&& comp
->attr
.allocatable
))
5093 gfc_add_modify (&se
->pre
, var
,
5094 fold_convert (TREE_TYPE (var
),
5095 null_pointer_node
));
5096 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5097 gfc_add_expr_to_block (&se
->post
, tmp
);
5100 /* Provide an address expression for the function arguments. */
5101 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5104 var
= gfc_conv_string_tmp (se
, type
, len
);
5106 vec_safe_push (retargs
, var
);
5110 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5112 type
= gfc_get_complex_type (ts
.kind
);
5113 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5114 vec_safe_push (retargs
, var
);
5117 /* Add the string length to the argument list. */
5118 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5121 if (TREE_CODE (tmp
) != VAR_DECL
)
5122 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5123 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5124 vec_safe_push (retargs
, tmp
);
5126 else if (ts
.type
== BT_CHARACTER
)
5127 vec_safe_push (retargs
, len
);
5129 gfc_free_interface_mapping (&mapping
);
5131 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5132 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5133 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5134 vec_safe_reserve (retargs
, arglen
);
5136 /* Add the return arguments. */
5137 retargs
->splice (arglist
);
5139 /* Add the hidden present status for optional+value to the arguments. */
5140 retargs
->splice (optionalargs
);
5142 /* Add the hidden string length parameters to the arguments. */
5143 retargs
->splice (stringargs
);
5145 /* We may want to append extra arguments here. This is used e.g. for
5146 calls to libgfortran_matmul_??, which need extra information. */
5147 if (!vec_safe_is_empty (append_args
))
5148 retargs
->splice (append_args
);
5151 /* Generate the actual call. */
5152 if (base_object
== NULL_TREE
)
5153 conv_function_val (se
, sym
, expr
);
5155 conv_base_obj_fcn_val (se
, base_object
, expr
);
5157 /* If there are alternate return labels, function type should be
5158 integer. Can't modify the type in place though, since it can be shared
5159 with other functions. For dummy arguments, the typing is done to
5160 this result, even if it has to be repeated for each call. */
5161 if (has_alternate_specifier
5162 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5164 if (!sym
->attr
.dummy
)
5166 TREE_TYPE (sym
->backend_decl
)
5167 = build_function_type (integer_type_node
,
5168 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5169 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5172 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5175 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5176 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5178 /* If we have a pointer function, but we don't want a pointer, e.g.
5181 where f is pointer valued, we have to dereference the result. */
5182 if (!se
->want_pointer
&& !byref
5183 && ((!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
, se
->expr
);
5187 /* f2c calling conventions require a scalar default real function to
5188 return a double precision result. Convert this back to default
5189 real. We only care about the cases that can happen in Fortran 77.
5191 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5192 && sym
->ts
.kind
== gfc_default_real_kind
5193 && !sym
->attr
.always_explicit
)
5194 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5196 /* A pure function may still have side-effects - it may modify its
5198 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5200 if (!sym
->attr
.pure
)
5201 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5206 /* Add the function call to the pre chain. There is no expression. */
5207 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5208 se
->expr
= NULL_TREE
;
5210 if (!se
->direct_byref
)
5212 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5214 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5216 /* Check the data pointer hasn't been modified. This would
5217 happen in a function returning a pointer. */
5218 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5219 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5222 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5225 se
->expr
= info
->descriptor
;
5226 /* Bundle in the string length. */
5227 se
->string_length
= len
;
5229 else if (ts
.type
== BT_CHARACTER
)
5231 /* Dereference for character pointer results. */
5232 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5233 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5234 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5238 se
->string_length
= len
;
5242 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5243 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5248 /* Follow the function call with the argument post block. */
5251 gfc_add_block_to_block (&se
->pre
, &post
);
5253 /* Transformational functions of derived types with allocatable
5254 components must have the result allocatable components copied. */
5255 arg
= expr
->value
.function
.actual
;
5256 if (result
&& arg
&& expr
->rank
5257 && expr
->value
.function
.isym
5258 && expr
->value
.function
.isym
->transformational
5259 && arg
->expr
->ts
.type
== BT_DERIVED
5260 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5263 /* Copy the allocatable components. We have to use a
5264 temporary here to prevent source allocatable components
5265 from being corrupted. */
5266 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5267 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5268 result
, tmp2
, expr
->rank
);
5269 gfc_add_expr_to_block (&se
->pre
, tmp
);
5270 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5272 gfc_add_expr_to_block (&se
->pre
, tmp
);
5274 /* Finally free the temporary's data field. */
5275 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5276 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5277 NULL_TREE
, NULL_TREE
, true,
5279 gfc_add_expr_to_block (&se
->pre
, tmp
);
5283 gfc_add_block_to_block (&se
->post
, &post
);
5285 return has_alternate_specifier
;
5289 /* Fill a character string with spaces. */
5292 fill_with_spaces (tree start
, tree type
, tree size
)
5294 stmtblock_t block
, loop
;
5295 tree i
, el
, exit_label
, cond
, tmp
;
5297 /* For a simple char type, we can call memset(). */
5298 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5299 return build_call_expr_loc (input_location
,
5300 builtin_decl_explicit (BUILT_IN_MEMSET
),
5302 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5303 lang_hooks
.to_target_charset (' ')),
5306 /* Otherwise, we use a loop:
5307 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5311 /* Initialize variables. */
5312 gfc_init_block (&block
);
5313 i
= gfc_create_var (sizetype
, "i");
5314 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5315 el
= gfc_create_var (build_pointer_type (type
), "el");
5316 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5317 exit_label
= gfc_build_label_decl (NULL_TREE
);
5318 TREE_USED (exit_label
) = 1;
5322 gfc_init_block (&loop
);
5324 /* Exit condition. */
5325 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5326 build_zero_cst (sizetype
));
5327 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5328 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5329 build_empty_stmt (input_location
));
5330 gfc_add_expr_to_block (&loop
, tmp
);
5333 gfc_add_modify (&loop
,
5334 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5335 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5337 /* Increment loop variables. */
5338 gfc_add_modify (&loop
, i
,
5339 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5340 TYPE_SIZE_UNIT (type
)));
5341 gfc_add_modify (&loop
, el
,
5342 fold_build_pointer_plus_loc (input_location
,
5343 el
, TYPE_SIZE_UNIT (type
)));
5345 /* Making the loop... actually loop! */
5346 tmp
= gfc_finish_block (&loop
);
5347 tmp
= build1_v (LOOP_EXPR
, tmp
);
5348 gfc_add_expr_to_block (&block
, tmp
);
5350 /* The exit label. */
5351 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5352 gfc_add_expr_to_block (&block
, tmp
);
5355 return gfc_finish_block (&block
);
5359 /* Generate code to copy a string. */
5362 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5363 int dkind
, tree slength
, tree src
, int skind
)
5365 tree tmp
, dlen
, slen
;
5374 stmtblock_t tempblock
;
5376 gcc_assert (dkind
== skind
);
5378 if (slength
!= NULL_TREE
)
5380 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5381 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5385 slen
= build_int_cst (size_type_node
, 1);
5389 if (dlength
!= NULL_TREE
)
5391 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5392 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5396 dlen
= build_int_cst (size_type_node
, 1);
5400 /* Assign directly if the types are compatible. */
5401 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5402 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5404 gfc_add_modify (block
, dsc
, ssc
);
5408 /* Do nothing if the destination length is zero. */
5409 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5410 build_int_cst (size_type_node
, 0));
5412 /* The following code was previously in _gfortran_copy_string:
5414 // The two strings may overlap so we use memmove.
5416 copy_string (GFC_INTEGER_4 destlen, char * dest,
5417 GFC_INTEGER_4 srclen, const char * src)
5419 if (srclen >= destlen)
5421 // This will truncate if too long.
5422 memmove (dest, src, destlen);
5426 memmove (dest, src, srclen);
5428 memset (&dest[srclen], ' ', destlen - srclen);
5432 We're now doing it here for better optimization, but the logic
5435 /* For non-default character kinds, we have to multiply the string
5436 length by the base type size. */
5437 chartype
= gfc_get_char_type (dkind
);
5438 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5439 fold_convert (size_type_node
, slen
),
5440 fold_convert (size_type_node
,
5441 TYPE_SIZE_UNIT (chartype
)));
5442 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5443 fold_convert (size_type_node
, dlen
),
5444 fold_convert (size_type_node
,
5445 TYPE_SIZE_UNIT (chartype
)));
5447 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5448 dest
= fold_convert (pvoid_type_node
, dest
);
5450 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5452 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5453 src
= fold_convert (pvoid_type_node
, src
);
5455 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5457 /* Truncate string if source is too long. */
5458 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5460 tmp2
= build_call_expr_loc (input_location
,
5461 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5462 3, dest
, src
, dlen
);
5464 /* Else copy and pad with spaces. */
5465 tmp3
= build_call_expr_loc (input_location
,
5466 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5467 3, dest
, src
, slen
);
5469 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5470 tmp4
= fill_with_spaces (tmp4
, chartype
,
5471 fold_build2_loc (input_location
, MINUS_EXPR
,
5472 TREE_TYPE(dlen
), dlen
, slen
));
5474 gfc_init_block (&tempblock
);
5475 gfc_add_expr_to_block (&tempblock
, tmp3
);
5476 gfc_add_expr_to_block (&tempblock
, tmp4
);
5477 tmp3
= gfc_finish_block (&tempblock
);
5479 /* The whole copy_string function is there. */
5480 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5482 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5483 build_empty_stmt (input_location
));
5484 gfc_add_expr_to_block (block
, tmp
);
5488 /* Translate a statement function.
5489 The value of a statement function reference is obtained by evaluating the
5490 expression using the values of the actual arguments for the values of the
5491 corresponding dummy arguments. */
5494 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5498 gfc_formal_arglist
*fargs
;
5499 gfc_actual_arglist
*args
;
5502 gfc_saved_var
*saved_vars
;
5508 sym
= expr
->symtree
->n
.sym
;
5509 args
= expr
->value
.function
.actual
;
5510 gfc_init_se (&lse
, NULL
);
5511 gfc_init_se (&rse
, NULL
);
5514 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5516 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5517 temp_vars
= XCNEWVEC (tree
, n
);
5519 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5520 fargs
= fargs
->next
, n
++)
5522 /* Each dummy shall be specified, explicitly or implicitly, to be
5524 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5527 if (fsym
->ts
.type
== BT_CHARACTER
)
5529 /* Copy string arguments. */
5532 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5533 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5535 /* Create a temporary to hold the value. */
5536 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5537 fsym
->ts
.u
.cl
->backend_decl
5538 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5540 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5541 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5543 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5545 gfc_conv_expr (&rse
, args
->expr
);
5546 gfc_conv_string_parameter (&rse
);
5547 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5548 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5550 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5551 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5552 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5553 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5557 /* For everything else, just evaluate the expression. */
5559 /* Create a temporary to hold the value. */
5560 type
= gfc_typenode_for_spec (&fsym
->ts
);
5561 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5563 gfc_conv_expr (&lse
, args
->expr
);
5565 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5566 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5567 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5573 /* Use the temporary variables in place of the real ones. */
5574 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5575 fargs
= fargs
->next
, n
++)
5576 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5578 gfc_conv_expr (se
, sym
->value
);
5580 if (sym
->ts
.type
== BT_CHARACTER
)
5582 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5584 /* Force the expression to the correct length. */
5585 if (!INTEGER_CST_P (se
->string_length
)
5586 || tree_int_cst_lt (se
->string_length
,
5587 sym
->ts
.u
.cl
->backend_decl
))
5589 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5590 tmp
= gfc_create_var (type
, sym
->name
);
5591 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5592 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5593 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5597 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5600 /* Restore the original variables. */
5601 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5602 fargs
= fargs
->next
, n
++)
5603 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5609 /* Translate a function expression. */
5612 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5616 if (expr
->value
.function
.isym
)
5618 gfc_conv_intrinsic_function (se
, expr
);
5622 /* expr.value.function.esym is the resolved (specific) function symbol for
5623 most functions. However this isn't set for dummy procedures. */
5624 sym
= expr
->value
.function
.esym
;
5626 sym
= expr
->symtree
->n
.sym
;
5628 /* We distinguish statement functions from general functions to improve
5629 runtime performance. */
5630 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5632 gfc_conv_statement_function (se
, expr
);
5636 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5641 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5644 is_zero_initializer_p (gfc_expr
* expr
)
5646 if (expr
->expr_type
!= EXPR_CONSTANT
)
5649 /* We ignore constants with prescribed memory representations for now. */
5650 if (expr
->representation
.string
)
5653 switch (expr
->ts
.type
)
5656 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5659 return mpfr_zero_p (expr
->value
.real
)
5660 && MPFR_SIGN (expr
->value
.real
) >= 0;
5663 return expr
->value
.logical
== 0;
5666 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5667 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5668 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5669 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5679 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5684 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5685 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5687 gfc_conv_tmp_array_ref (se
);
5691 /* Build a static initializer. EXPR is the expression for the initial value.
5692 The other parameters describe the variable of the component being
5693 initialized. EXPR may be null. */
5696 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5697 bool array
, bool pointer
, bool procptr
)
5701 if (!(expr
|| pointer
|| procptr
))
5704 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5705 (these are the only two iso_c_binding derived types that can be
5706 used as initialization expressions). If so, we need to modify
5707 the 'expr' to be that for a (void *). */
5708 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5709 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5711 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5713 /* The derived symbol has already been converted to a (void *). Use
5715 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5716 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5718 gfc_init_se (&se
, NULL
);
5719 gfc_conv_constant (&se
, expr
);
5720 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5724 if (array
&& !procptr
)
5727 /* Arrays need special handling. */
5729 ctor
= gfc_build_null_descriptor (type
);
5730 /* Special case assigning an array to zero. */
5731 else if (is_zero_initializer_p (expr
))
5732 ctor
= build_constructor (type
, NULL
);
5734 ctor
= gfc_conv_array_initializer (type
, expr
);
5735 TREE_STATIC (ctor
) = 1;
5738 else if (pointer
|| procptr
)
5740 if (ts
->type
== BT_CLASS
&& !procptr
)
5742 gfc_init_se (&se
, NULL
);
5743 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5744 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5745 TREE_STATIC (se
.expr
) = 1;
5748 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5749 return fold_convert (type
, null_pointer_node
);
5752 gfc_init_se (&se
, NULL
);
5753 se
.want_pointer
= 1;
5754 gfc_conv_expr (&se
, expr
);
5755 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5765 gfc_init_se (&se
, NULL
);
5766 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5767 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5769 gfc_conv_structure (&se
, expr
, 1);
5770 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5771 TREE_STATIC (se
.expr
) = 1;
5776 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5777 TREE_STATIC (ctor
) = 1;
5782 gfc_init_se (&se
, NULL
);
5783 gfc_conv_constant (&se
, expr
);
5784 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5791 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5797 gfc_array_info
*lss_array
;
5804 gfc_start_block (&block
);
5806 /* Initialize the scalarizer. */
5807 gfc_init_loopinfo (&loop
);
5809 gfc_init_se (&lse
, NULL
);
5810 gfc_init_se (&rse
, NULL
);
5813 rss
= gfc_walk_expr (expr
);
5814 if (rss
== gfc_ss_terminator
)
5815 /* The rhs is scalar. Add a ss for the expression. */
5816 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5818 /* Create a SS for the destination. */
5819 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5821 lss_array
= &lss
->info
->data
.array
;
5822 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5823 lss_array
->descriptor
= dest
;
5824 lss_array
->data
= gfc_conv_array_data (dest
);
5825 lss_array
->offset
= gfc_conv_array_offset (dest
);
5826 for (n
= 0; n
< cm
->as
->rank
; n
++)
5828 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5829 lss_array
->stride
[n
] = gfc_index_one_node
;
5831 mpz_init (lss_array
->shape
[n
]);
5832 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5833 cm
->as
->lower
[n
]->value
.integer
);
5834 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5837 /* Associate the SS with the loop. */
5838 gfc_add_ss_to_loop (&loop
, lss
);
5839 gfc_add_ss_to_loop (&loop
, rss
);
5841 /* Calculate the bounds of the scalarization. */
5842 gfc_conv_ss_startstride (&loop
);
5844 /* Setup the scalarizing loops. */
5845 gfc_conv_loop_setup (&loop
, &expr
->where
);
5847 /* Setup the gfc_se structures. */
5848 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5849 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5852 gfc_mark_ss_chain_used (rss
, 1);
5854 gfc_mark_ss_chain_used (lss
, 1);
5856 /* Start the scalarized loop body. */
5857 gfc_start_scalarized_body (&loop
, &body
);
5859 gfc_conv_tmp_array_ref (&lse
);
5860 if (cm
->ts
.type
== BT_CHARACTER
)
5861 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5863 gfc_conv_expr (&rse
, expr
);
5865 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5866 gfc_add_expr_to_block (&body
, tmp
);
5868 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5870 /* Generate the copying loops. */
5871 gfc_trans_scalarizing_loops (&loop
, &body
);
5873 /* Wrap the whole thing up. */
5874 gfc_add_block_to_block (&block
, &loop
.pre
);
5875 gfc_add_block_to_block (&block
, &loop
.post
);
5877 gcc_assert (lss_array
->shape
!= NULL
);
5878 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5879 gfc_cleanup_loop (&loop
);
5881 return gfc_finish_block (&block
);
5886 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5896 gfc_expr
*arg
= NULL
;
5898 gfc_start_block (&block
);
5899 gfc_init_se (&se
, NULL
);
5901 /* Get the descriptor for the expressions. */
5902 se
.want_pointer
= 0;
5903 gfc_conv_expr_descriptor (&se
, expr
);
5904 gfc_add_block_to_block (&block
, &se
.pre
);
5905 gfc_add_modify (&block
, dest
, se
.expr
);
5907 /* Deal with arrays of derived types with allocatable components. */
5908 if (cm
->ts
.type
== BT_DERIVED
5909 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5910 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5914 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5915 TREE_TYPE(cm
->backend_decl
),
5918 gfc_add_expr_to_block (&block
, tmp
);
5919 gfc_add_block_to_block (&block
, &se
.post
);
5921 if (expr
->expr_type
!= EXPR_VARIABLE
)
5922 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5925 /* We need to know if the argument of a conversion function is a
5926 variable, so that the correct lower bound can be used. */
5927 if (expr
->expr_type
== EXPR_FUNCTION
5928 && expr
->value
.function
.isym
5929 && expr
->value
.function
.isym
->conversion
5930 && expr
->value
.function
.actual
->expr
5931 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5932 arg
= expr
->value
.function
.actual
->expr
;
5934 /* Obtain the array spec of full array references. */
5936 as
= gfc_get_full_arrayspec_from_expr (arg
);
5938 as
= gfc_get_full_arrayspec_from_expr (expr
);
5940 /* Shift the lbound and ubound of temporaries to being unity,
5941 rather than zero, based. Always calculate the offset. */
5942 offset
= gfc_conv_descriptor_offset_get (dest
);
5943 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5944 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5946 for (n
= 0; n
< expr
->rank
; n
++)
5951 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5952 TODO It looks as if gfc_conv_expr_descriptor should return
5953 the correct bounds and that the following should not be
5954 necessary. This would simplify gfc_conv_intrinsic_bound
5956 if (as
&& as
->lower
[n
])
5959 gfc_init_se (&lbse
, NULL
);
5960 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5961 gfc_add_block_to_block (&block
, &lbse
.pre
);
5962 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5966 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5967 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5971 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5974 lbound
= gfc_index_one_node
;
5976 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5978 /* Shift the bounds and set the offset accordingly. */
5979 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5980 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5981 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5982 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5984 gfc_conv_descriptor_ubound_set (&block
, dest
,
5985 gfc_rank_cst
[n
], tmp
);
5986 gfc_conv_descriptor_lbound_set (&block
, dest
,
5987 gfc_rank_cst
[n
], lbound
);
5989 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5990 gfc_conv_descriptor_lbound_get (dest
,
5992 gfc_conv_descriptor_stride_get (dest
,
5994 gfc_add_modify (&block
, tmp2
, tmp
);
5995 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5997 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6002 /* If a conversion expression has a null data pointer
6003 argument, nullify the allocatable component. */
6007 if (arg
->symtree
->n
.sym
->attr
.allocatable
6008 || arg
->symtree
->n
.sym
->attr
.pointer
)
6010 non_null_expr
= gfc_finish_block (&block
);
6011 gfc_start_block (&block
);
6012 gfc_conv_descriptor_data_set (&block
, dest
,
6014 null_expr
= gfc_finish_block (&block
);
6015 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6016 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6017 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6018 return build3_v (COND_EXPR
, tmp
,
6019 null_expr
, non_null_expr
);
6023 return gfc_finish_block (&block
);
6027 /* Assign a single component of a derived type constructor. */
6030 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6037 gfc_start_block (&block
);
6039 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6041 gfc_init_se (&se
, NULL
);
6042 /* Pointer component. */
6043 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6044 && !cm
->attr
.proc_pointer
)
6046 /* Array pointer. */
6047 if (expr
->expr_type
== EXPR_NULL
)
6048 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6051 se
.direct_byref
= 1;
6053 gfc_conv_expr_descriptor (&se
, expr
);
6054 gfc_add_block_to_block (&block
, &se
.pre
);
6055 gfc_add_block_to_block (&block
, &se
.post
);
6060 /* Scalar pointers. */
6061 se
.want_pointer
= 1;
6062 gfc_conv_expr (&se
, expr
);
6063 gfc_add_block_to_block (&block
, &se
.pre
);
6065 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6066 && expr
->symtree
->n
.sym
->attr
.dummy
)
6067 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6069 gfc_add_modify (&block
, dest
,
6070 fold_convert (TREE_TYPE (dest
), se
.expr
));
6071 gfc_add_block_to_block (&block
, &se
.post
);
6074 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6076 /* NULL initialization for CLASS components. */
6077 tmp
= gfc_trans_structure_assign (dest
,
6078 gfc_class_initializer (&cm
->ts
, expr
));
6079 gfc_add_expr_to_block (&block
, tmp
);
6081 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6082 && !cm
->attr
.proc_pointer
)
6084 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6085 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6086 else if (cm
->attr
.allocatable
)
6088 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6089 gfc_add_expr_to_block (&block
, tmp
);
6093 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6094 gfc_add_expr_to_block (&block
, tmp
);
6097 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6099 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6101 gfc_init_se (&se
, NULL
);
6102 gfc_conv_expr (&se
, expr
);
6103 gfc_add_block_to_block (&block
, &se
.pre
);
6104 gfc_add_modify (&block
, dest
,
6105 fold_convert (TREE_TYPE (dest
), se
.expr
));
6106 gfc_add_block_to_block (&block
, &se
.post
);
6110 /* Nested constructors. */
6111 tmp
= gfc_trans_structure_assign (dest
, expr
);
6112 gfc_add_expr_to_block (&block
, tmp
);
6115 else if (gfc_deferred_strlen (cm
, &tmp
))
6119 gcc_assert (strlen
);
6120 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6122 TREE_OPERAND (dest
, 0),
6125 if (expr
->expr_type
== EXPR_NULL
)
6127 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6128 gfc_add_modify (&block
, dest
, tmp
);
6129 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6130 gfc_add_modify (&block
, strlen
, tmp
);
6135 gfc_init_se (&se
, NULL
);
6136 gfc_conv_expr (&se
, expr
);
6137 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6138 tmp
= build_call_expr_loc (input_location
,
6139 builtin_decl_explicit (BUILT_IN_MALLOC
),
6141 gfc_add_modify (&block
, dest
,
6142 fold_convert (TREE_TYPE (dest
), tmp
));
6143 gfc_add_modify (&block
, strlen
, se
.string_length
);
6144 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6145 gfc_add_expr_to_block (&block
, tmp
);
6148 else if (!cm
->attr
.deferred_parameter
)
6150 /* Scalar component (excluding deferred parameters). */
6151 gfc_init_se (&se
, NULL
);
6152 gfc_init_se (&lse
, NULL
);
6154 gfc_conv_expr (&se
, expr
);
6155 if (cm
->ts
.type
== BT_CHARACTER
)
6156 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6158 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6159 gfc_add_expr_to_block (&block
, tmp
);
6161 return gfc_finish_block (&block
);
6164 /* Assign a derived type constructor to a variable. */
6167 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6175 gfc_start_block (&block
);
6176 cm
= expr
->ts
.u
.derived
->components
;
6178 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6179 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6180 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6184 gcc_assert (cm
->backend_decl
== NULL
);
6185 gfc_init_se (&se
, NULL
);
6186 gfc_init_se (&lse
, NULL
);
6187 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6189 gfc_add_modify (&block
, lse
.expr
,
6190 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6192 return gfc_finish_block (&block
);
6195 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6196 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6198 /* Skip absent members in default initializers. */
6202 field
= cm
->backend_decl
;
6203 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6204 dest
, field
, NULL_TREE
);
6205 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6206 gfc_add_expr_to_block (&block
, tmp
);
6208 return gfc_finish_block (&block
);
6211 /* Build an expression for a constructor. If init is nonzero then
6212 this is part of a static variable initializer. */
6215 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6222 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6224 gcc_assert (se
->ss
== NULL
);
6225 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6226 type
= gfc_typenode_for_spec (&expr
->ts
);
6230 /* Create a temporary variable and fill it in. */
6231 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6232 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6233 gfc_add_expr_to_block (&se
->pre
, tmp
);
6237 cm
= expr
->ts
.u
.derived
->components
;
6239 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6240 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6242 /* Skip absent members in default initializers and allocatable
6243 components. Although the latter have a default initializer
6244 of EXPR_NULL,... by default, the static nullify is not needed
6245 since this is done every time we come into scope. */
6246 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6249 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6250 && strcmp (cm
->name
, "_extends") == 0
6251 && cm
->initializer
->symtree
)
6255 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6256 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6257 vtab
= unshare_expr_without_location (vtab
);
6258 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6260 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6262 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6263 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6264 fold_convert (TREE_TYPE (cm
->backend_decl
),
6269 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6270 TREE_TYPE (cm
->backend_decl
),
6271 cm
->attr
.dimension
, cm
->attr
.pointer
,
6272 cm
->attr
.proc_pointer
);
6273 val
= unshare_expr_without_location (val
);
6275 /* Append it to the constructor list. */
6276 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6279 se
->expr
= build_constructor (type
, v
);
6281 TREE_CONSTANT (se
->expr
) = 1;
6285 /* Translate a substring expression. */
6288 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6294 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6296 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6297 expr
->value
.character
.length
,
6298 expr
->value
.character
.string
);
6300 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6301 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6304 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6308 /* Entry point for expression translation. Evaluates a scalar quantity.
6309 EXPR is the expression to be translated, and SE is the state structure if
6310 called from within the scalarized. */
6313 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6318 if (ss
&& ss
->info
->expr
== expr
6319 && (ss
->info
->type
== GFC_SS_SCALAR
6320 || ss
->info
->type
== GFC_SS_REFERENCE
))
6322 gfc_ss_info
*ss_info
;
6325 /* Substitute a scalar expression evaluated outside the scalarization
6327 se
->expr
= ss_info
->data
.scalar
.value
;
6328 /* If the reference can be NULL, the value field contains the reference,
6329 not the value the reference points to (see gfc_add_loop_ss_code). */
6330 if (ss_info
->can_be_null_ref
)
6331 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6333 se
->string_length
= ss_info
->string_length
;
6334 gfc_advance_se_ss_chain (se
);
6338 /* We need to convert the expressions for the iso_c_binding derived types.
6339 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6340 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6341 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6342 updated to be an integer with a kind equal to the size of a (void *). */
6343 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6345 if (expr
->expr_type
== EXPR_VARIABLE
6346 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6347 || expr
->symtree
->n
.sym
->intmod_sym_id
6348 == ISOCBINDING_NULL_FUNPTR
))
6350 /* Set expr_type to EXPR_NULL, which will result in
6351 null_pointer_node being used below. */
6352 expr
->expr_type
= EXPR_NULL
;
6356 /* Update the type/kind of the expression to be what the new
6357 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6358 expr
->ts
.type
= BT_INTEGER
;
6359 expr
->ts
.f90_type
= BT_VOID
;
6360 expr
->ts
.kind
= gfc_index_integer_kind
;
6364 gfc_fix_class_refs (expr
);
6366 switch (expr
->expr_type
)
6369 gfc_conv_expr_op (se
, expr
);
6373 gfc_conv_function_expr (se
, expr
);
6377 gfc_conv_constant (se
, expr
);
6381 gfc_conv_variable (se
, expr
);
6385 se
->expr
= null_pointer_node
;
6388 case EXPR_SUBSTRING
:
6389 gfc_conv_substring_expr (se
, expr
);
6392 case EXPR_STRUCTURE
:
6393 gfc_conv_structure (se
, expr
, 0);
6397 gfc_conv_array_constructor_expr (se
, expr
);
6406 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6407 of an assignment. */
6409 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6411 gfc_conv_expr (se
, expr
);
6412 /* All numeric lvalues should have empty post chains. If not we need to
6413 figure out a way of rewriting an lvalue so that it has no post chain. */
6414 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6417 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6418 numeric expressions. Used for scalar values where inserting cleanup code
6421 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6425 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6426 gfc_conv_expr (se
, expr
);
6429 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6430 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6432 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6436 /* Helper to translate an expression and convert it to a particular type. */
6438 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6440 gfc_conv_expr_val (se
, expr
);
6441 se
->expr
= convert (type
, se
->expr
);
6445 /* Converts an expression so that it can be passed by reference. Scalar
6449 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6455 if (ss
&& ss
->info
->expr
== expr
6456 && ss
->info
->type
== GFC_SS_REFERENCE
)
6458 /* Returns a reference to the scalar evaluated outside the loop
6460 gfc_conv_expr (se
, expr
);
6462 if (expr
->ts
.type
== BT_CHARACTER
6463 && expr
->expr_type
!= EXPR_FUNCTION
)
6464 gfc_conv_string_parameter (se
);
6466 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6471 if (expr
->ts
.type
== BT_CHARACTER
)
6473 gfc_conv_expr (se
, expr
);
6474 gfc_conv_string_parameter (se
);
6478 if (expr
->expr_type
== EXPR_VARIABLE
)
6480 se
->want_pointer
= 1;
6481 gfc_conv_expr (se
, expr
);
6484 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6485 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6486 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6492 if (expr
->expr_type
== EXPR_FUNCTION
6493 && ((expr
->value
.function
.esym
6494 && expr
->value
.function
.esym
->result
->attr
.pointer
6495 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6496 || (!expr
->value
.function
.esym
&& !expr
->ref
6497 && expr
->symtree
->n
.sym
->attr
.pointer
6498 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6500 se
->want_pointer
= 1;
6501 gfc_conv_expr (se
, expr
);
6502 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6503 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6508 gfc_conv_expr (se
, expr
);
6510 /* Create a temporary var to hold the value. */
6511 if (TREE_CONSTANT (se
->expr
))
6513 tree tmp
= se
->expr
;
6514 STRIP_TYPE_NOPS (tmp
);
6515 var
= build_decl (input_location
,
6516 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6517 DECL_INITIAL (var
) = tmp
;
6518 TREE_STATIC (var
) = 1;
6523 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6524 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6526 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6528 /* Take the address of that value. */
6529 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6530 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6531 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6532 && expr
->ts
.u
.derived
->attr
.alloc_comp
6533 && expr
->expr_type
!= EXPR_VARIABLE
)
6537 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6538 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6540 /* The components shall be deallocated before
6541 their containing entity. */
6542 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6548 gfc_trans_pointer_assign (gfc_code
* code
)
6550 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6554 /* Generate code for a pointer assignment. */
6557 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6559 gfc_expr
*expr1_vptr
= NULL
;
6569 gfc_start_block (&block
);
6571 gfc_init_se (&lse
, NULL
);
6573 /* Check whether the expression is a scalar or not; we cannot use
6574 expr1->rank as it can be nonzero for proc pointers. */
6575 ss
= gfc_walk_expr (expr1
);
6576 scalar
= ss
== gfc_ss_terminator
;
6578 gfc_free_ss_chain (ss
);
6580 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6581 && expr2
->expr_type
!= EXPR_FUNCTION
)
6583 gfc_add_data_component (expr2
);
6584 /* The following is required as gfc_add_data_component doesn't
6585 update ts.type if there is a tailing REF_ARRAY. */
6586 expr2
->ts
.type
= BT_DERIVED
;
6591 /* Scalar pointers. */
6592 lse
.want_pointer
= 1;
6593 gfc_conv_expr (&lse
, expr1
);
6594 gfc_init_se (&rse
, NULL
);
6595 rse
.want_pointer
= 1;
6596 gfc_conv_expr (&rse
, expr2
);
6598 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6599 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6600 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6603 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6604 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6605 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6608 gfc_add_block_to_block (&block
, &lse
.pre
);
6609 gfc_add_block_to_block (&block
, &rse
.pre
);
6611 /* Check character lengths if character expression. The test is only
6612 really added if -fbounds-check is enabled. Exclude deferred
6613 character length lefthand sides. */
6614 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6615 && !expr1
->ts
.deferred
6616 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6617 && !gfc_is_proc_ptr_comp (expr1
))
6619 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6620 gcc_assert (lse
.string_length
&& rse
.string_length
);
6621 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6622 lse
.string_length
, rse
.string_length
,
6626 /* The assignment to an deferred character length sets the string
6627 length to that of the rhs. */
6628 if (expr1
->ts
.deferred
)
6630 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6631 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6632 else if (lse
.string_length
!= NULL
)
6633 gfc_add_modify (&block
, lse
.string_length
,
6634 build_int_cst (gfc_charlen_type_node
, 0));
6637 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6638 rse
.expr
= gfc_class_data_get (rse
.expr
);
6640 gfc_add_modify (&block
, lse
.expr
,
6641 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6643 gfc_add_block_to_block (&block
, &rse
.post
);
6644 gfc_add_block_to_block (&block
, &lse
.post
);
6651 tree strlen_rhs
= NULL_TREE
;
6653 /* Array pointer. Find the last reference on the LHS and if it is an
6654 array section ref, we're dealing with bounds remapping. In this case,
6655 set it to AR_FULL so that gfc_conv_expr_descriptor does
6656 not see it and process the bounds remapping afterwards explicitly. */
6657 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6658 if (!remap
->next
&& remap
->type
== REF_ARRAY
6659 && remap
->u
.ar
.type
== AR_SECTION
)
6661 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6663 gfc_init_se (&lse
, NULL
);
6665 lse
.descriptor_only
= 1;
6666 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6667 && expr1
->ts
.type
== BT_CLASS
)
6668 expr1_vptr
= gfc_copy_expr (expr1
);
6669 gfc_conv_expr_descriptor (&lse
, expr1
);
6670 strlen_lhs
= lse
.string_length
;
6673 if (expr2
->expr_type
== EXPR_NULL
)
6675 /* Just set the data pointer to null. */
6676 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6678 else if (rank_remap
)
6680 /* If we are rank-remapping, just get the RHS's descriptor and
6681 process this later on. */
6682 gfc_init_se (&rse
, NULL
);
6683 rse
.direct_byref
= 1;
6684 rse
.byref_noassign
= 1;
6686 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6688 gfc_conv_function_expr (&rse
, expr2
);
6690 if (expr1
->ts
.type
!= BT_CLASS
)
6691 rse
.expr
= gfc_class_data_get (rse
.expr
);
6694 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6695 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6697 gfc_add_vptr_component (expr1_vptr
);
6698 gfc_init_se (&rse
, NULL
);
6699 rse
.want_pointer
= 1;
6700 gfc_conv_expr (&rse
, expr1_vptr
);
6701 gfc_add_modify (&lse
.pre
, rse
.expr
,
6702 fold_convert (TREE_TYPE (rse
.expr
),
6703 gfc_class_vptr_get (tmp
)));
6704 rse
.expr
= gfc_class_data_get (tmp
);
6707 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6709 tree bound
[GFC_MAX_DIMENSIONS
];
6712 for (i
= 0; i
< expr2
->rank
; i
++)
6713 bound
[i
] = NULL_TREE
;
6714 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6715 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6717 GFC_ARRAY_POINTER_CONT
, false);
6718 tmp
= gfc_create_var (tmp
, "ptrtemp");
6720 lse
.direct_byref
= 1;
6721 gfc_conv_expr_descriptor (&lse
, expr2
);
6722 strlen_rhs
= lse
.string_length
;
6727 gfc_conv_expr_descriptor (&rse
, expr2
);
6728 strlen_rhs
= rse
.string_length
;
6731 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6733 /* Assign directly to the LHS's descriptor. */
6734 lse
.direct_byref
= 1;
6735 gfc_conv_expr_descriptor (&lse
, expr2
);
6736 strlen_rhs
= lse
.string_length
;
6738 /* If this is a subreference array pointer assignment, use the rhs
6739 descriptor element size for the lhs span. */
6740 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6742 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6743 gfc_init_se (&rse
, NULL
);
6744 rse
.descriptor_only
= 1;
6745 gfc_conv_expr (&rse
, expr2
);
6746 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6747 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6748 if (!INTEGER_CST_P (tmp
))
6749 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6750 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6753 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6755 gfc_init_se (&rse
, NULL
);
6756 rse
.want_pointer
= 1;
6757 gfc_conv_function_expr (&rse
, expr2
);
6758 if (expr1
->ts
.type
!= BT_CLASS
)
6760 rse
.expr
= gfc_class_data_get (rse
.expr
);
6761 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6765 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6766 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6768 gfc_add_vptr_component (expr1_vptr
);
6769 gfc_init_se (&rse
, NULL
);
6770 rse
.want_pointer
= 1;
6771 gfc_conv_expr (&rse
, expr1_vptr
);
6772 gfc_add_modify (&lse
.pre
, rse
.expr
,
6773 fold_convert (TREE_TYPE (rse
.expr
),
6774 gfc_class_vptr_get (tmp
)));
6775 rse
.expr
= gfc_class_data_get (tmp
);
6776 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6781 /* Assign to a temporary descriptor and then copy that
6782 temporary to the pointer. */
6783 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6785 lse
.direct_byref
= 1;
6786 gfc_conv_expr_descriptor (&lse
, expr2
);
6787 strlen_rhs
= lse
.string_length
;
6788 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6792 gfc_free_expr (expr1_vptr
);
6794 gfc_add_block_to_block (&block
, &lse
.pre
);
6796 gfc_add_block_to_block (&block
, &rse
.pre
);
6798 /* If we do bounds remapping, update LHS descriptor accordingly. */
6802 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6806 /* Do rank remapping. We already have the RHS's descriptor
6807 converted in rse and now have to build the correct LHS
6808 descriptor for it. */
6812 tree lbound
, ubound
;
6815 dtype
= gfc_conv_descriptor_dtype (desc
);
6816 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6817 gfc_add_modify (&block
, dtype
, tmp
);
6819 /* Copy data pointer. */
6820 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6821 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6823 /* Copy offset but adjust it such that it would correspond
6824 to a lbound of zero. */
6825 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6826 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6828 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6830 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6832 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6833 gfc_array_index_type
, stride
, lbound
);
6834 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6835 gfc_array_index_type
, offs
, tmp
);
6837 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6839 /* Set the bounds as declared for the LHS and calculate strides as
6840 well as another offset update accordingly. */
6841 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6843 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6848 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6850 /* Convert declared bounds. */
6851 gfc_init_se (&lower_se
, NULL
);
6852 gfc_init_se (&upper_se
, NULL
);
6853 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6854 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6856 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6857 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6859 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6860 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6862 lbound
= gfc_evaluate_now (lbound
, &block
);
6863 ubound
= gfc_evaluate_now (ubound
, &block
);
6865 gfc_add_block_to_block (&block
, &lower_se
.post
);
6866 gfc_add_block_to_block (&block
, &upper_se
.post
);
6868 /* Set bounds in descriptor. */
6869 gfc_conv_descriptor_lbound_set (&block
, desc
,
6870 gfc_rank_cst
[dim
], lbound
);
6871 gfc_conv_descriptor_ubound_set (&block
, desc
,
6872 gfc_rank_cst
[dim
], ubound
);
6875 stride
= gfc_evaluate_now (stride
, &block
);
6876 gfc_conv_descriptor_stride_set (&block
, desc
,
6877 gfc_rank_cst
[dim
], stride
);
6879 /* Update offset. */
6880 offs
= gfc_conv_descriptor_offset_get (desc
);
6881 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6882 gfc_array_index_type
, lbound
, stride
);
6883 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6884 gfc_array_index_type
, offs
, tmp
);
6885 offs
= gfc_evaluate_now (offs
, &block
);
6886 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6888 /* Update stride. */
6889 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6890 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6891 gfc_array_index_type
, stride
, tmp
);
6896 /* Bounds remapping. Just shift the lower bounds. */
6898 gcc_assert (expr1
->rank
== expr2
->rank
);
6900 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6904 gcc_assert (remap
->u
.ar
.start
[dim
]);
6905 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6906 gfc_init_se (&lbound_se
, NULL
);
6907 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6909 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6910 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6911 dim
, lbound_se
.expr
);
6912 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6917 /* Check string lengths if applicable. The check is only really added
6918 to the output code if -fbounds-check is enabled. */
6919 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6921 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6922 gcc_assert (strlen_lhs
&& strlen_rhs
);
6923 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6924 strlen_lhs
, strlen_rhs
, &block
);
6927 /* If rank remapping was done, check with -fcheck=bounds that
6928 the target is at least as large as the pointer. */
6929 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6935 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6936 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6938 lsize
= gfc_evaluate_now (lsize
, &block
);
6939 rsize
= gfc_evaluate_now (rsize
, &block
);
6940 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6943 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6944 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6948 gfc_add_block_to_block (&block
, &lse
.post
);
6950 gfc_add_block_to_block (&block
, &rse
.post
);
6953 return gfc_finish_block (&block
);
6957 /* Makes sure se is suitable for passing as a function string parameter. */
6958 /* TODO: Need to check all callers of this function. It may be abused. */
6961 gfc_conv_string_parameter (gfc_se
* se
)
6965 if (TREE_CODE (se
->expr
) == STRING_CST
)
6967 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6968 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6972 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6974 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6976 type
= TREE_TYPE (se
->expr
);
6977 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6981 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6983 type
= build_pointer_type (type
);
6984 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6988 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6992 /* Generate code for assignment of scalar variables. Includes character
6993 strings and derived types with allocatable components.
6994 If you know that the LHS has no allocations, set dealloc to false.
6996 DEEP_COPY has no effect if the typespec TS is not a derived type with
6997 allocatable components. Otherwise, if it is set, an explicit copy of each
6998 allocatable component is made. This is necessary as a simple copy of the
6999 whole object would copy array descriptors as is, so that the lhs's
7000 allocatable components would point to the rhs's after the assignment.
7001 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7002 necessary if the rhs is a non-pointer function, as the allocatable components
7003 are not accessible by other means than the function's result after the
7004 function has returned. It is even more subtle when temporaries are involved,
7005 as the two following examples show:
7006 1. When we evaluate an array constructor, a temporary is created. Thus
7007 there is theoretically no alias possible. However, no deep copy is
7008 made for this temporary, so that if the constructor is made of one or
7009 more variable with allocatable components, those components still point
7010 to the variable's: DEEP_COPY should be set for the assignment from the
7011 temporary to the lhs in that case.
7012 2. When assigning a scalar to an array, we evaluate the scalar value out
7013 of the loop, store it into a temporary variable, and assign from that.
7014 In that case, deep copying when assigning to the temporary would be a
7015 waste of resources; however deep copies should happen when assigning from
7016 the temporary to each array element: again DEEP_COPY should be set for
7017 the assignment from the temporary to the lhs. */
7020 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7021 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7027 gfc_init_block (&block
);
7029 if (ts
.type
== BT_CHARACTER
)
7034 if (lse
->string_length
!= NULL_TREE
)
7036 gfc_conv_string_parameter (lse
);
7037 gfc_add_block_to_block (&block
, &lse
->pre
);
7038 llen
= lse
->string_length
;
7041 if (rse
->string_length
!= NULL_TREE
)
7043 gcc_assert (rse
->string_length
!= NULL_TREE
);
7044 gfc_conv_string_parameter (rse
);
7045 gfc_add_block_to_block (&block
, &rse
->pre
);
7046 rlen
= rse
->string_length
;
7049 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7050 rse
->expr
, ts
.kind
);
7052 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7054 tree tmp_var
= NULL_TREE
;
7057 /* Are the rhs and the lhs the same? */
7060 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7061 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7062 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7063 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7066 /* Deallocate the lhs allocated components as long as it is not
7067 the same as the rhs. This must be done following the assignment
7068 to prevent deallocating data that could be used in the rhs
7070 if (!l_is_temp
&& dealloc
)
7072 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7073 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7075 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7077 gfc_add_expr_to_block (&lse
->post
, tmp
);
7080 gfc_add_block_to_block (&block
, &rse
->pre
);
7081 gfc_add_block_to_block (&block
, &lse
->pre
);
7083 gfc_add_modify (&block
, lse
->expr
,
7084 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7086 /* Restore pointer address of coarray components. */
7087 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7089 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7090 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7092 gfc_add_expr_to_block (&block
, tmp
);
7095 /* Do a deep copy if the rhs is a variable, if it is not the
7099 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7100 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7102 gfc_add_expr_to_block (&block
, tmp
);
7105 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7107 gfc_add_block_to_block (&block
, &lse
->pre
);
7108 gfc_add_block_to_block (&block
, &rse
->pre
);
7109 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7110 TREE_TYPE (lse
->expr
), rse
->expr
);
7111 gfc_add_modify (&block
, lse
->expr
, tmp
);
7115 gfc_add_block_to_block (&block
, &lse
->pre
);
7116 gfc_add_block_to_block (&block
, &rse
->pre
);
7118 gfc_add_modify (&block
, lse
->expr
,
7119 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7122 gfc_add_block_to_block (&block
, &lse
->post
);
7123 gfc_add_block_to_block (&block
, &rse
->post
);
7125 return gfc_finish_block (&block
);
7129 /* There are quite a lot of restrictions on the optimisation in using an
7130 array function assign without a temporary. */
7133 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7136 bool seen_array_ref
;
7138 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7140 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7141 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7144 /* Elemental functions are scalarized so that they don't need a
7145 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7146 they would need special treatment in gfc_trans_arrayfunc_assign. */
7147 if (expr2
->value
.function
.esym
!= NULL
7148 && expr2
->value
.function
.esym
->attr
.elemental
)
7151 /* Need a temporary if rhs is not FULL or a contiguous section. */
7152 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7155 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7156 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7159 /* Functions returning pointers or allocatables need temporaries. */
7160 c
= expr2
->value
.function
.esym
7161 ? (expr2
->value
.function
.esym
->attr
.pointer
7162 || expr2
->value
.function
.esym
->attr
.allocatable
)
7163 : (expr2
->symtree
->n
.sym
->attr
.pointer
7164 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7168 /* Character array functions need temporaries unless the
7169 character lengths are the same. */
7170 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7172 if (expr1
->ts
.u
.cl
->length
== NULL
7173 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7176 if (expr2
->ts
.u
.cl
->length
== NULL
7177 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7180 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7181 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7185 /* Check that no LHS component references appear during an array
7186 reference. This is needed because we do not have the means to
7187 span any arbitrary stride with an array descriptor. This check
7188 is not needed for the rhs because the function result has to be
7190 seen_array_ref
= false;
7191 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7193 if (ref
->type
== REF_ARRAY
)
7194 seen_array_ref
= true;
7195 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7199 /* Check for a dependency. */
7200 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7201 expr2
->value
.function
.esym
,
7202 expr2
->value
.function
.actual
,
7206 /* If we have reached here with an intrinsic function, we do not
7207 need a temporary except in the particular case that reallocation
7208 on assignment is active and the lhs is allocatable and a target. */
7209 if (expr2
->value
.function
.isym
)
7210 return (gfc_option
.flag_realloc_lhs
7211 && sym
->attr
.allocatable
7212 && sym
->attr
.target
);
7214 /* If the LHS is a dummy, we need a temporary if it is not
7216 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7219 /* If the lhs has been host_associated, is in common, a pointer or is
7220 a target and the function is not using a RESULT variable, aliasing
7221 can occur and a temporary is needed. */
7222 if ((sym
->attr
.host_assoc
7223 || sym
->attr
.in_common
7224 || sym
->attr
.pointer
7225 || sym
->attr
.cray_pointee
7226 || sym
->attr
.target
)
7227 && expr2
->symtree
!= NULL
7228 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7231 /* A PURE function can unconditionally be called without a temporary. */
7232 if (expr2
->value
.function
.esym
!= NULL
7233 && expr2
->value
.function
.esym
->attr
.pure
)
7236 /* Implicit_pure functions are those which could legally be declared
7238 if (expr2
->value
.function
.esym
!= NULL
7239 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7242 if (!sym
->attr
.use_assoc
7243 && !sym
->attr
.in_common
7244 && !sym
->attr
.pointer
7245 && !sym
->attr
.target
7246 && !sym
->attr
.cray_pointee
7247 && expr2
->value
.function
.esym
)
7249 /* A temporary is not needed if the function is not contained and
7250 the variable is local or host associated and not a pointer or
7252 if (!expr2
->value
.function
.esym
->attr
.contained
)
7255 /* A temporary is not needed if the lhs has never been host
7256 associated and the procedure is contained. */
7257 else if (!sym
->attr
.host_assoc
)
7260 /* A temporary is not needed if the variable is local and not
7261 a pointer, a target or a result. */
7263 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7267 /* Default to temporary use. */
7272 /* Provide the loop info so that the lhs descriptor can be built for
7273 reallocatable assignments from extrinsic function calls. */
7276 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7279 /* Signal that the function call should not be made by
7280 gfc_conv_loop_setup. */
7281 se
->ss
->is_alloc_lhs
= 1;
7282 gfc_init_loopinfo (loop
);
7283 gfc_add_ss_to_loop (loop
, *ss
);
7284 gfc_add_ss_to_loop (loop
, se
->ss
);
7285 gfc_conv_ss_startstride (loop
);
7286 gfc_conv_loop_setup (loop
, where
);
7287 gfc_copy_loopinfo_to_se (se
, loop
);
7288 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7289 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7290 se
->ss
->is_alloc_lhs
= 0;
7294 /* For assignment to a reallocatable lhs from intrinsic functions,
7295 replace the se.expr (ie. the result) with a temporary descriptor.
7296 Null the data field so that the library allocates space for the
7297 result. Free the data of the original descriptor after the function,
7298 in case it appears in an argument expression and transfer the
7299 result to the original descriptor. */
7302 fcncall_realloc_result (gfc_se
*se
, int rank
)
7311 /* Use the allocation done by the library. Substitute the lhs
7312 descriptor with a copy, whose data field is nulled.*/
7313 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7314 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7315 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7317 /* Unallocated, the descriptor does not have a dtype. */
7318 tmp
= gfc_conv_descriptor_dtype (desc
);
7319 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7321 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7322 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7323 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7325 /* Free the lhs after the function call and copy the result data to
7326 the lhs descriptor. */
7327 tmp
= gfc_conv_descriptor_data_get (desc
);
7328 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7329 boolean_type_node
, tmp
,
7330 build_int_cst (TREE_TYPE (tmp
), 0));
7331 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7332 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7333 gfc_add_expr_to_block (&se
->post
, tmp
);
7335 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7336 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7338 /* Check that the shapes are the same between lhs and expression. */
7339 for (n
= 0 ; n
< rank
; n
++)
7342 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7343 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7344 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7345 gfc_array_index_type
, tmp
, tmp1
);
7346 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7347 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7348 gfc_array_index_type
, tmp
, tmp1
);
7349 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7350 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7351 gfc_array_index_type
, tmp
, tmp1
);
7352 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7353 boolean_type_node
, tmp
,
7354 gfc_index_zero_node
);
7355 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7356 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7357 boolean_type_node
, tmp
,
7361 /* 'zero_cond' being true is equal to lhs not being allocated or the
7362 shapes being different. */
7363 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7365 /* Now reset the bounds returned from the function call to bounds based
7366 on the lhs lbounds, except where the lhs is not allocated or the shapes
7367 of 'variable and 'expr' are different. Set the offset accordingly. */
7368 offset
= gfc_index_zero_node
;
7369 for (n
= 0 ; n
< rank
; n
++)
7373 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7374 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7375 gfc_array_index_type
, zero_cond
,
7376 gfc_index_one_node
, lbound
);
7377 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7379 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7380 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7381 gfc_array_index_type
, tmp
, lbound
);
7382 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7383 gfc_rank_cst
[n
], lbound
);
7384 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7385 gfc_rank_cst
[n
], tmp
);
7387 /* Set stride and accumulate the offset. */
7388 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7389 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7390 gfc_rank_cst
[n
], tmp
);
7391 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7392 gfc_array_index_type
, lbound
, tmp
);
7393 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7394 gfc_array_index_type
, offset
, tmp
);
7395 offset
= gfc_evaluate_now (offset
, &se
->post
);
7398 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7403 /* Try to translate array(:) = func (...), where func is a transformational
7404 array function, without using a temporary. Returns NULL if this isn't the
7408 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7412 gfc_component
*comp
= NULL
;
7415 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7418 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7420 comp
= gfc_get_proc_ptr_comp (expr2
);
7421 gcc_assert (expr2
->value
.function
.isym
7422 || (comp
&& comp
->attr
.dimension
)
7423 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7424 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7426 gfc_init_se (&se
, NULL
);
7427 gfc_start_block (&se
.pre
);
7428 se
.want_pointer
= 1;
7430 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7432 if (expr1
->ts
.type
== BT_DERIVED
7433 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7436 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7438 gfc_add_expr_to_block (&se
.pre
, tmp
);
7441 se
.direct_byref
= 1;
7442 se
.ss
= gfc_walk_expr (expr2
);
7443 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7445 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7446 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7447 Clearly, this cannot be done for an allocatable function result, since
7448 the shape of the result is unknown and, in any case, the function must
7449 correctly take care of the reallocation internally. For intrinsic
7450 calls, the array data is freed and the library takes care of allocation.
7451 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7453 if (gfc_option
.flag_realloc_lhs
7454 && gfc_is_reallocatable_lhs (expr1
)
7455 && !gfc_expr_attr (expr1
).codimension
7456 && !gfc_is_coindexed (expr1
)
7457 && !(expr2
->value
.function
.esym
7458 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7460 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7462 if (!expr2
->value
.function
.isym
)
7464 ss
= gfc_walk_expr (expr1
);
7465 gcc_assert (ss
!= gfc_ss_terminator
);
7467 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7468 ss
->is_alloc_lhs
= 1;
7471 fcncall_realloc_result (&se
, expr1
->rank
);
7474 gfc_conv_function_expr (&se
, expr2
);
7475 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7478 gfc_cleanup_loop (&loop
);
7480 gfc_free_ss_chain (se
.ss
);
7482 return gfc_finish_block (&se
.pre
);
7486 /* Try to efficiently translate array(:) = 0. Return NULL if this
7490 gfc_trans_zero_assign (gfc_expr
* expr
)
7492 tree dest
, len
, type
;
7496 sym
= expr
->symtree
->n
.sym
;
7497 dest
= gfc_get_symbol_decl (sym
);
7499 type
= TREE_TYPE (dest
);
7500 if (POINTER_TYPE_P (type
))
7501 type
= TREE_TYPE (type
);
7502 if (!GFC_ARRAY_TYPE_P (type
))
7505 /* Determine the length of the array. */
7506 len
= GFC_TYPE_ARRAY_SIZE (type
);
7507 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7510 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7511 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7512 fold_convert (gfc_array_index_type
, tmp
));
7514 /* If we are zeroing a local array avoid taking its address by emitting
7516 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7517 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7518 dest
, build_constructor (TREE_TYPE (dest
),
7521 /* Convert arguments to the correct types. */
7522 dest
= fold_convert (pvoid_type_node
, dest
);
7523 len
= fold_convert (size_type_node
, len
);
7525 /* Construct call to __builtin_memset. */
7526 tmp
= build_call_expr_loc (input_location
,
7527 builtin_decl_explicit (BUILT_IN_MEMSET
),
7528 3, dest
, integer_zero_node
, len
);
7529 return fold_convert (void_type_node
, tmp
);
7533 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7534 that constructs the call to __builtin_memcpy. */
7537 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7541 /* Convert arguments to the correct types. */
7542 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7543 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7545 dst
= fold_convert (pvoid_type_node
, dst
);
7547 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7548 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7550 src
= fold_convert (pvoid_type_node
, src
);
7552 len
= fold_convert (size_type_node
, len
);
7554 /* Construct call to __builtin_memcpy. */
7555 tmp
= build_call_expr_loc (input_location
,
7556 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7558 return fold_convert (void_type_node
, tmp
);
7562 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7563 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7564 source/rhs, both are gfc_full_array_ref_p which have been checked for
7568 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7570 tree dst
, dlen
, dtype
;
7571 tree src
, slen
, stype
;
7574 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7575 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7577 dtype
= TREE_TYPE (dst
);
7578 if (POINTER_TYPE_P (dtype
))
7579 dtype
= TREE_TYPE (dtype
);
7580 stype
= TREE_TYPE (src
);
7581 if (POINTER_TYPE_P (stype
))
7582 stype
= TREE_TYPE (stype
);
7584 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7587 /* Determine the lengths of the arrays. */
7588 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7589 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7591 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7592 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7593 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7595 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7596 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7598 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7599 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7600 slen
, fold_convert (gfc_array_index_type
, tmp
));
7602 /* Sanity check that they are the same. This should always be
7603 the case, as we should already have checked for conformance. */
7604 if (!tree_int_cst_equal (slen
, dlen
))
7607 return gfc_build_memcpy_call (dst
, src
, dlen
);
7611 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7612 this can't be done. EXPR1 is the destination/lhs for which
7613 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7616 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7618 unsigned HOST_WIDE_INT nelem
;
7624 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7628 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7629 dtype
= TREE_TYPE (dst
);
7630 if (POINTER_TYPE_P (dtype
))
7631 dtype
= TREE_TYPE (dtype
);
7632 if (!GFC_ARRAY_TYPE_P (dtype
))
7635 /* Determine the lengths of the array. */
7636 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7637 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7640 /* Confirm that the constructor is the same size. */
7641 if (compare_tree_int (len
, nelem
) != 0)
7644 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7645 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7646 fold_convert (gfc_array_index_type
, tmp
));
7648 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7649 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7651 stype
= TREE_TYPE (src
);
7652 if (POINTER_TYPE_P (stype
))
7653 stype
= TREE_TYPE (stype
);
7655 return gfc_build_memcpy_call (dst
, src
, len
);
7659 /* Tells whether the expression is to be treated as a variable reference. */
7662 expr_is_variable (gfc_expr
*expr
)
7665 gfc_component
*comp
;
7666 gfc_symbol
*func_ifc
;
7668 if (expr
->expr_type
== EXPR_VARIABLE
)
7671 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7674 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7675 return expr_is_variable (arg
);
7678 /* A data-pointer-returning function should be considered as a variable
7680 if (expr
->expr_type
== EXPR_FUNCTION
7681 && expr
->ref
== NULL
)
7683 if (expr
->value
.function
.isym
!= NULL
)
7686 if (expr
->value
.function
.esym
!= NULL
)
7688 func_ifc
= expr
->value
.function
.esym
;
7693 gcc_assert (expr
->symtree
);
7694 func_ifc
= expr
->symtree
->n
.sym
;
7701 comp
= gfc_get_proc_ptr_comp (expr
);
7702 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7705 func_ifc
= comp
->ts
.interface
;
7709 if (expr
->expr_type
== EXPR_COMPCALL
)
7711 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7712 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7719 gcc_assert (func_ifc
->attr
.function
7720 && func_ifc
->result
!= NULL
);
7721 return func_ifc
->result
->attr
.pointer
;
7725 /* Is the lhs OK for automatic reallocation? */
7728 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7732 /* An allocatable variable with no reference. */
7733 if (expr
->symtree
->n
.sym
->attr
.allocatable
7737 /* All that can be left are allocatable components. */
7738 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7739 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7740 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7743 /* Find an allocatable component ref last. */
7744 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7745 if (ref
->type
== REF_COMPONENT
7747 && ref
->u
.c
.component
->attr
.allocatable
)
7754 /* Allocate or reallocate scalar lhs, as necessary. */
7757 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7771 if (!expr1
|| expr1
->rank
)
7774 if (!expr2
|| expr2
->rank
)
7777 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7779 /* Since this is a scalar lhs, we can afford to do this. That is,
7780 there is no risk of side effects being repeated. */
7781 gfc_init_se (&lse
, NULL
);
7782 lse
.want_pointer
= 1;
7783 gfc_conv_expr (&lse
, expr1
);
7785 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7786 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7788 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7789 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7790 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7792 tmp
= build3_v (COND_EXPR
, cond
,
7793 build1_v (GOTO_EXPR
, jump_label1
),
7794 build_empty_stmt (input_location
));
7795 gfc_add_expr_to_block (block
, tmp
);
7797 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7799 /* Use the rhs string length and the lhs element size. */
7800 size
= string_length
;
7801 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7802 tmp
= TYPE_SIZE_UNIT (tmp
);
7803 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7804 TREE_TYPE (tmp
), tmp
,
7805 fold_convert (TREE_TYPE (tmp
), size
));
7809 /* Otherwise use the length in bytes of the rhs. */
7810 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7811 size_in_bytes
= size
;
7814 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7815 size_in_bytes
, size_one_node
);
7817 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7819 tmp
= build_call_expr_loc (input_location
,
7820 builtin_decl_explicit (BUILT_IN_CALLOC
),
7821 2, build_one_cst (size_type_node
),
7823 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7824 gfc_add_modify (block
, lse
.expr
, tmp
);
7828 tmp
= build_call_expr_loc (input_location
,
7829 builtin_decl_explicit (BUILT_IN_MALLOC
),
7831 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7832 gfc_add_modify (block
, lse
.expr
, tmp
);
7835 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7837 /* Deferred characters need checking for lhs and rhs string
7838 length. Other deferred parameter variables will have to
7840 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7841 gfc_add_expr_to_block (block
, tmp
);
7843 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7844 gfc_add_expr_to_block (block
, tmp
);
7846 /* For a deferred length character, reallocate if lengths of lhs and
7847 rhs are different. */
7848 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7850 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7851 expr1
->ts
.u
.cl
->backend_decl
, size
);
7852 /* Jump past the realloc if the lengths are the same. */
7853 tmp
= build3_v (COND_EXPR
, cond
,
7854 build1_v (GOTO_EXPR
, jump_label2
),
7855 build_empty_stmt (input_location
));
7856 gfc_add_expr_to_block (block
, tmp
);
7857 tmp
= build_call_expr_loc (input_location
,
7858 builtin_decl_explicit (BUILT_IN_REALLOC
),
7859 2, fold_convert (pvoid_type_node
, lse
.expr
),
7861 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7862 gfc_add_modify (block
, lse
.expr
, tmp
);
7863 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7864 gfc_add_expr_to_block (block
, tmp
);
7866 /* Update the lhs character length. */
7867 size
= string_length
;
7868 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
7869 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7871 gfc_add_modify (block
, lse
.string_length
, size
);
7875 /* Check for assignments of the type
7879 to make sure we do not check for reallocation unneccessarily. */
7883 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7885 gfc_actual_arglist
*a
;
7888 switch (expr2
->expr_type
)
7891 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7894 if (expr2
->value
.function
.esym
7895 && expr2
->value
.function
.esym
->attr
.elemental
)
7897 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7900 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7905 else if (expr2
->value
.function
.isym
7906 && expr2
->value
.function
.isym
->elemental
)
7908 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7911 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7920 switch (expr2
->value
.op
.op
)
7923 case INTRINSIC_UPLUS
:
7924 case INTRINSIC_UMINUS
:
7925 case INTRINSIC_PARENTHESES
:
7926 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7928 case INTRINSIC_PLUS
:
7929 case INTRINSIC_MINUS
:
7930 case INTRINSIC_TIMES
:
7931 case INTRINSIC_DIVIDE
:
7932 case INTRINSIC_POWER
:
7936 case INTRINSIC_NEQV
:
7943 case INTRINSIC_EQ_OS
:
7944 case INTRINSIC_NE_OS
:
7945 case INTRINSIC_GT_OS
:
7946 case INTRINSIC_GE_OS
:
7947 case INTRINSIC_LT_OS
:
7948 case INTRINSIC_LE_OS
:
7950 e1
= expr2
->value
.op
.op1
;
7951 e2
= expr2
->value
.op
.op2
;
7953 if (e1
->rank
== 0 && e2
->rank
> 0)
7954 return is_runtime_conformable (expr1
, e2
);
7955 else if (e1
->rank
> 0 && e2
->rank
== 0)
7956 return is_runtime_conformable (expr1
, e1
);
7957 else if (e1
->rank
> 0 && e2
->rank
> 0)
7958 return is_runtime_conformable (expr1
, e1
)
7959 && is_runtime_conformable (expr1
, e2
);
7975 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7976 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7977 init_flag indicates initialization expressions and dealloc that no
7978 deallocate prior assignment is needed (if in doubt, set true). */
7981 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7987 gfc_ss
*lss_section
;
7994 bool scalar_to_array
;
7998 /* Assignment of the form lhs = rhs. */
7999 gfc_start_block (&block
);
8001 gfc_init_se (&lse
, NULL
);
8002 gfc_init_se (&rse
, NULL
);
8005 lss
= gfc_walk_expr (expr1
);
8006 if (gfc_is_reallocatable_lhs (expr1
)
8007 && !(expr2
->expr_type
== EXPR_FUNCTION
8008 && expr2
->value
.function
.isym
!= NULL
))
8009 lss
->is_alloc_lhs
= 1;
8011 if (lss
!= gfc_ss_terminator
)
8013 /* The assignment needs scalarization. */
8016 /* Find a non-scalar SS from the lhs. */
8017 while (lss_section
!= gfc_ss_terminator
8018 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8019 lss_section
= lss_section
->next
;
8021 gcc_assert (lss_section
!= gfc_ss_terminator
);
8023 /* Initialize the scalarizer. */
8024 gfc_init_loopinfo (&loop
);
8027 rss
= gfc_walk_expr (expr2
);
8028 if (rss
== gfc_ss_terminator
)
8029 /* The rhs is scalar. Add a ss for the expression. */
8030 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8032 /* Associate the SS with the loop. */
8033 gfc_add_ss_to_loop (&loop
, lss
);
8034 gfc_add_ss_to_loop (&loop
, rss
);
8036 /* Calculate the bounds of the scalarization. */
8037 gfc_conv_ss_startstride (&loop
);
8038 /* Enable loop reversal. */
8039 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8040 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8041 /* Resolve any data dependencies in the statement. */
8042 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8043 /* Setup the scalarizing loops. */
8044 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8046 /* Setup the gfc_se structures. */
8047 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8048 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8051 gfc_mark_ss_chain_used (rss
, 1);
8052 if (loop
.temp_ss
== NULL
)
8055 gfc_mark_ss_chain_used (lss
, 1);
8059 lse
.ss
= loop
.temp_ss
;
8060 gfc_mark_ss_chain_used (lss
, 3);
8061 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8064 /* Allow the scalarizer to workshare array assignments. */
8065 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8066 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8068 /* Start the scalarized loop body. */
8069 gfc_start_scalarized_body (&loop
, &body
);
8072 gfc_init_block (&body
);
8074 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8076 /* Translate the expression. */
8077 gfc_conv_expr (&rse
, expr2
);
8079 /* Stabilize a string length for temporaries. */
8080 if (expr2
->ts
.type
== BT_CHARACTER
)
8081 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8083 string_length
= NULL_TREE
;
8087 gfc_conv_tmp_array_ref (&lse
);
8088 if (expr2
->ts
.type
== BT_CHARACTER
)
8089 lse
.string_length
= string_length
;
8092 gfc_conv_expr (&lse
, expr1
);
8094 /* Assignments of scalar derived types with allocatable components
8095 to arrays must be done with a deep copy and the rhs temporary
8096 must have its components deallocated afterwards. */
8097 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8098 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8099 && !expr_is_variable (expr2
)
8100 && !gfc_is_constant_expr (expr2
)
8101 && expr1
->rank
&& !expr2
->rank
);
8102 if (scalar_to_array
&& dealloc
)
8104 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8105 gfc_add_expr_to_block (&loop
.post
, tmp
);
8108 /* When assigning a character function result to a deferred-length variable,
8109 the function call must happen before the (re)allocation of the lhs -
8110 otherwise the character length of the result is not known.
8111 NOTE: This relies on having the exact dependence of the length type
8112 parameter available to the caller; gfortran saves it in the .mod files. */
8113 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
8114 && expr1
->ts
.deferred
)
8115 gfc_add_block_to_block (&block
, &rse
.pre
);
8117 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8118 l_is_temp
|| init_flag
,
8119 expr_is_variable (expr2
) || scalar_to_array
8120 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8121 gfc_add_expr_to_block (&body
, tmp
);
8123 if (lss
== gfc_ss_terminator
)
8125 /* F2003: Add the code for reallocation on assignment. */
8126 if (gfc_option
.flag_realloc_lhs
8127 && is_scalar_reallocatable_lhs (expr1
))
8128 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8131 /* Use the scalar assignment as is. */
8132 gfc_add_block_to_block (&block
, &body
);
8136 gcc_assert (lse
.ss
== gfc_ss_terminator
8137 && rse
.ss
== gfc_ss_terminator
);
8141 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8143 /* We need to copy the temporary to the actual lhs. */
8144 gfc_init_se (&lse
, NULL
);
8145 gfc_init_se (&rse
, NULL
);
8146 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8147 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8149 rse
.ss
= loop
.temp_ss
;
8152 gfc_conv_tmp_array_ref (&rse
);
8153 gfc_conv_expr (&lse
, expr1
);
8155 gcc_assert (lse
.ss
== gfc_ss_terminator
8156 && rse
.ss
== gfc_ss_terminator
);
8158 if (expr2
->ts
.type
== BT_CHARACTER
)
8159 rse
.string_length
= string_length
;
8161 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8162 false, false, dealloc
);
8163 gfc_add_expr_to_block (&body
, tmp
);
8166 /* F2003: Allocate or reallocate lhs of allocatable array. */
8167 if (gfc_option
.flag_realloc_lhs
8168 && gfc_is_reallocatable_lhs (expr1
)
8169 && !gfc_expr_attr (expr1
).codimension
8170 && !gfc_is_coindexed (expr1
)
8172 && !is_runtime_conformable (expr1
, expr2
))
8174 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8175 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8176 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8177 if (tmp
!= NULL_TREE
)
8178 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8181 /* Generate the copying loops. */
8182 gfc_trans_scalarizing_loops (&loop
, &body
);
8184 /* Wrap the whole thing up. */
8185 gfc_add_block_to_block (&block
, &loop
.pre
);
8186 gfc_add_block_to_block (&block
, &loop
.post
);
8188 gfc_cleanup_loop (&loop
);
8191 return gfc_finish_block (&block
);
8195 /* Check whether EXPR is a copyable array. */
8198 copyable_array_p (gfc_expr
* expr
)
8200 if (expr
->expr_type
!= EXPR_VARIABLE
)
8203 /* First check it's an array. */
8204 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8207 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8210 /* Next check that it's of a simple enough type. */
8211 switch (expr
->ts
.type
)
8223 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8232 /* Translate an assignment. */
8235 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8240 /* Special case a single function returning an array. */
8241 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8243 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8248 /* Special case assigning an array to zero. */
8249 if (copyable_array_p (expr1
)
8250 && is_zero_initializer_p (expr2
))
8252 tmp
= gfc_trans_zero_assign (expr1
);
8257 /* Special case copying one array to another. */
8258 if (copyable_array_p (expr1
)
8259 && copyable_array_p (expr2
)
8260 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8261 && !gfc_check_dependency (expr1
, expr2
, 0))
8263 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8268 /* Special case initializing an array from a constant array constructor. */
8269 if (copyable_array_p (expr1
)
8270 && expr2
->expr_type
== EXPR_ARRAY
8271 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8273 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8278 /* Fallback to the scalarizer to generate explicit loops. */
8279 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8283 gfc_trans_init_assign (gfc_code
* code
)
8285 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8289 gfc_trans_assign (gfc_code
* code
)
8291 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);