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 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
593 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
598 parmse
->use_offset
= 1;
599 gfc_conv_expr_descriptor (parmse
, e
);
600 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
604 /* Pass the address of the class object. */
605 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
609 /* Takes a scalarized class array expression and returns the
610 address of a temporary scalar class object of the 'declared'
612 OOP-TODO: This could be improved by adding code that branched on
613 the dynamic type being the same as the declared type. In this case
614 the original class expression can be passed directly.
615 optional_alloc_ptr is false when the dummy is neither allocatable
616 nor a pointer; that's relevant for the optional handling.
617 Set copyback to true if class container's _data and _vtab pointers
618 might get modified. */
621 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
622 bool elemental
, bool copyback
, bool optional
,
623 bool optional_alloc_ptr
)
629 tree cond
= NULL_TREE
;
633 bool full_array
= false;
635 gfc_init_block (&block
);
638 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
640 if (ref
->type
== REF_COMPONENT
641 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
644 if (ref
->next
== NULL
)
648 if ((ref
== NULL
|| class_ref
== ref
)
649 && (!class_ts
.u
.derived
->components
->as
650 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
653 /* Test for FULL_ARRAY. */
654 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
655 && gfc_expr_attr (e
).dimension
)
658 gfc_is_class_array_ref (e
, &full_array
);
660 /* The derived type needs to be converted to a temporary
662 tmp
= gfc_typenode_for_spec (&class_ts
);
663 var
= gfc_create_var (tmp
, "class");
666 ctree
= gfc_class_data_get (var
);
667 if (class_ts
.u
.derived
->components
->as
668 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
672 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
674 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
675 gfc_get_dtype (type
));
677 tmp
= gfc_class_data_get (parmse
->expr
);
678 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
679 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
681 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
684 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
688 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
689 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
690 TREE_TYPE (ctree
), parmse
->expr
);
691 gfc_add_modify (&block
, ctree
, parmse
->expr
);
694 /* Return the data component, except in the case of scalarized array
695 references, where nullification of the cannot occur and so there
697 if (!elemental
&& full_array
&& copyback
)
699 if (class_ts
.u
.derived
->components
->as
700 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
703 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
704 gfc_conv_descriptor_data_get (ctree
));
706 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
709 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
713 ctree
= gfc_class_vptr_get (var
);
715 /* The vptr is the second field of the actual argument.
716 First we have to find the corresponding class reference. */
719 if (class_ref
== NULL
720 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
721 tmp
= e
->symtree
->n
.sym
->backend_decl
;
724 /* Remove everything after the last class reference, convert the
725 expression and then recover its tailend once more. */
727 ref
= class_ref
->next
;
728 class_ref
->next
= NULL
;
729 gfc_init_se (&tmpse
, NULL
);
730 gfc_conv_expr (&tmpse
, e
);
731 class_ref
->next
= ref
;
735 gcc_assert (tmp
!= NULL_TREE
);
737 /* Dereference if needs be. */
738 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
739 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
741 vptr
= gfc_class_vptr_get (tmp
);
742 gfc_add_modify (&block
, ctree
,
743 fold_convert (TREE_TYPE (ctree
), vptr
));
745 /* Return the vptr component, except in the case of scalarized array
746 references, where the dynamic type cannot change. */
747 if (!elemental
&& full_array
&& copyback
)
748 gfc_add_modify (&parmse
->post
, vptr
,
749 fold_convert (TREE_TYPE (vptr
), ctree
));
755 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
756 tmp
= gfc_finish_block (&block
);
758 if (optional_alloc_ptr
)
759 tmp2
= build_empty_stmt (input_location
);
762 gfc_init_block (&block
);
764 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
765 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
767 tmp2
= gfc_finish_block (&block
);
770 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
772 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
775 gfc_add_block_to_block (&parmse
->pre
, &block
);
777 /* Pass the address of the class object. */
778 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
780 if (optional
&& optional_alloc_ptr
)
781 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
782 TREE_TYPE (parmse
->expr
),
784 fold_convert (TREE_TYPE (parmse
->expr
),
789 /* Given a class array declaration and an index, returns the address
790 of the referenced element. */
793 gfc_get_class_array_ref (tree index
, tree class_decl
)
795 tree data
= gfc_class_data_get (class_decl
);
796 tree size
= gfc_vtable_size_get (class_decl
);
797 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
798 gfc_array_index_type
,
801 data
= gfc_conv_descriptor_data_get (data
);
802 ptr
= fold_convert (pvoid_type_node
, data
);
803 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
804 return fold_convert (TREE_TYPE (data
), ptr
);
808 /* Copies one class expression to another, assuming that if either
809 'to' or 'from' are arrays they are packed. Should 'from' be
810 NULL_TREE, the initialization expression for 'to' is used, assuming
811 that the _vptr is set. */
814 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
822 vec
<tree
, va_gc
> *args
;
825 stmtblock_t loopbody
;
831 if (from
!= NULL_TREE
)
832 fcn
= gfc_vtable_copy_get (from
);
834 fcn
= gfc_vtable_copy_get (to
);
836 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
838 if (from
!= NULL_TREE
)
839 from_data
= gfc_class_data_get (from
);
841 from_data
= gfc_vtable_def_init_get (to
);
843 to_data
= gfc_class_data_get (to
);
845 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
847 gfc_init_block (&body
);
848 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
849 gfc_array_index_type
, nelems
,
851 nelems
= gfc_evaluate_now (tmp
, &body
);
852 index
= gfc_create_var (gfc_array_index_type
, "S");
854 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
856 from_ref
= gfc_get_class_array_ref (index
, from
);
857 vec_safe_push (args
, from_ref
);
860 vec_safe_push (args
, from_data
);
862 to_ref
= gfc_get_class_array_ref (index
, to
);
863 vec_safe_push (args
, to_ref
);
865 tmp
= build_call_vec (fcn_type
, fcn
, args
);
867 /* Build the body of the loop. */
868 gfc_init_block (&loopbody
);
869 gfc_add_expr_to_block (&loopbody
, tmp
);
871 /* Build the loop and return. */
872 gfc_init_loopinfo (&loop
);
874 loop
.from
[0] = gfc_index_zero_node
;
875 loop
.loopvar
[0] = index
;
877 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
878 gfc_add_block_to_block (&body
, &loop
.pre
);
879 tmp
= gfc_finish_block (&body
);
880 gfc_cleanup_loop (&loop
);
884 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
885 vec_safe_push (args
, from_data
);
886 vec_safe_push (args
, to_data
);
887 tmp
= build_call_vec (fcn_type
, fcn
, args
);
894 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
896 gfc_actual_arglist
*actual
;
901 actual
= gfc_get_actual_arglist ();
902 actual
->expr
= gfc_copy_expr (rhs
);
903 actual
->next
= gfc_get_actual_arglist ();
904 actual
->next
->expr
= gfc_copy_expr (lhs
);
905 ppc
= gfc_copy_expr (obj
);
906 gfc_add_vptr_component (ppc
);
907 gfc_add_component_ref (ppc
, "_copy");
908 ppc_code
= gfc_get_code (EXEC_CALL
);
909 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
910 /* Although '_copy' is set to be elemental in class.c, it is
911 not staying that way. Find out why, sometime.... */
912 ppc_code
->resolved_sym
->attr
.elemental
= 1;
913 ppc_code
->ext
.actual
= actual
;
914 ppc_code
->expr1
= ppc
;
915 /* Since '_copy' is elemental, the scalarizer will take care
916 of arrays in gfc_trans_call. */
917 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
918 gfc_free_statements (ppc_code
);
922 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
923 A MEMCPY is needed to copy the full data from the default initializer
924 of the dynamic type. */
927 gfc_trans_class_init_assign (gfc_code
*code
)
931 gfc_se dst
,src
,memsz
;
932 gfc_expr
*lhs
, *rhs
, *sz
;
934 gfc_start_block (&block
);
936 lhs
= gfc_copy_expr (code
->expr1
);
937 gfc_add_data_component (lhs
);
939 rhs
= gfc_copy_expr (code
->expr1
);
940 gfc_add_vptr_component (rhs
);
942 /* Make sure that the component backend_decls have been built, which
943 will not have happened if the derived types concerned have not
945 gfc_get_derived_type (rhs
->ts
.u
.derived
);
946 gfc_add_def_init_component (rhs
);
948 if (code
->expr1
->ts
.type
== BT_CLASS
949 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
950 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
953 sz
= gfc_copy_expr (code
->expr1
);
954 gfc_add_vptr_component (sz
);
955 gfc_add_size_component (sz
);
957 gfc_init_se (&dst
, NULL
);
958 gfc_init_se (&src
, NULL
);
959 gfc_init_se (&memsz
, NULL
);
960 gfc_conv_expr (&dst
, lhs
);
961 gfc_conv_expr (&src
, rhs
);
962 gfc_conv_expr (&memsz
, sz
);
963 gfc_add_block_to_block (&block
, &src
.pre
);
964 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
966 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
969 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
970 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
972 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
973 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
975 build_empty_stmt (input_location
));
978 gfc_add_expr_to_block (&block
, tmp
);
980 return gfc_finish_block (&block
);
984 /* Translate an assignment to a CLASS object
985 (pointer or ordinary assignment). */
988 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
996 gfc_start_block (&block
);
999 while (ref
&& ref
->next
)
1002 /* Class valued proc_pointer assignments do not need any further
1004 if (ref
&& ref
->type
== REF_COMPONENT
1005 && ref
->u
.c
.component
->attr
.proc_pointer
1006 && expr2
->expr_type
== EXPR_VARIABLE
1007 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1008 && op
== EXEC_POINTER_ASSIGN
)
1011 if (expr2
->ts
.type
!= BT_CLASS
)
1013 /* Insert an additional assignment which sets the '_vptr' field. */
1014 gfc_symbol
*vtab
= NULL
;
1017 lhs
= gfc_copy_expr (expr1
);
1018 gfc_add_vptr_component (lhs
);
1020 if (UNLIMITED_POLY (expr1
)
1021 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1023 rhs
= gfc_get_null_expr (&expr2
->where
);
1027 if (expr2
->expr_type
== EXPR_NULL
)
1028 vtab
= gfc_find_vtab (&expr1
->ts
);
1030 vtab
= gfc_find_vtab (&expr2
->ts
);
1033 rhs
= gfc_get_expr ();
1034 rhs
->expr_type
= EXPR_VARIABLE
;
1035 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1039 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1040 gfc_add_expr_to_block (&block
, tmp
);
1042 gfc_free_expr (lhs
);
1043 gfc_free_expr (rhs
);
1045 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1047 /* F2003:C717 only sequence and bind-C types can come here. */
1048 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1049 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1050 gfc_add_data_component (expr2
);
1053 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1055 /* Insert an additional assignment which sets the '_vptr' field. */
1056 lhs
= gfc_copy_expr (expr1
);
1057 gfc_add_vptr_component (lhs
);
1059 rhs
= gfc_copy_expr (expr2
);
1060 gfc_add_vptr_component (rhs
);
1062 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1063 gfc_add_expr_to_block (&block
, tmp
);
1065 gfc_free_expr (lhs
);
1066 gfc_free_expr (rhs
);
1069 /* Do the actual CLASS assignment. */
1070 if (expr2
->ts
.type
== BT_CLASS
1071 && !CLASS_DATA (expr2
)->attr
.dimension
)
1073 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1074 || !CLASS_DATA (expr2
)->attr
.dimension
)
1075 gfc_add_data_component (expr1
);
1079 if (op
== EXEC_ASSIGN
)
1080 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1081 else if (op
== EXEC_POINTER_ASSIGN
)
1082 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1086 gfc_add_expr_to_block (&block
, tmp
);
1088 return gfc_finish_block (&block
);
1092 /* End of prototype trans-class.c */
1096 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1098 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1099 && gfc_option
.warn_realloc_lhs
)
1100 gfc_warning ("Code for reallocating the allocatable array at %L will "
1102 else if (gfc_option
.warn_realloc_lhs_all
)
1103 gfc_warning ("Code for reallocating the allocatable variable at %L "
1104 "will be added", where
);
1108 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1109 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1112 /* Copy the scalarization loop variables. */
1115 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1118 dest
->loop
= src
->loop
;
1122 /* Initialize a simple expression holder.
1124 Care must be taken when multiple se are created with the same parent.
1125 The child se must be kept in sync. The easiest way is to delay creation
1126 of a child se until after after the previous se has been translated. */
1129 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1131 memset (se
, 0, sizeof (gfc_se
));
1132 gfc_init_block (&se
->pre
);
1133 gfc_init_block (&se
->post
);
1135 se
->parent
= parent
;
1138 gfc_copy_se_loopvars (se
, parent
);
1142 /* Advances to the next SS in the chain. Use this rather than setting
1143 se->ss = se->ss->next because all the parents needs to be kept in sync.
1147 gfc_advance_se_ss_chain (gfc_se
* se
)
1152 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1155 /* Walk down the parent chain. */
1158 /* Simple consistency check. */
1159 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1160 || p
->parent
->ss
->nested_ss
== p
->ss
);
1162 /* If we were in a nested loop, the next scalarized expression can be
1163 on the parent ss' next pointer. Thus we should not take the next
1164 pointer blindly, but rather go up one nest level as long as next
1165 is the end of chain. */
1167 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1177 /* Ensures the result of the expression as either a temporary variable
1178 or a constant so that it can be used repeatedly. */
1181 gfc_make_safe_expr (gfc_se
* se
)
1185 if (CONSTANT_CLASS_P (se
->expr
))
1188 /* We need a temporary for this result. */
1189 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1190 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1195 /* Return an expression which determines if a dummy parameter is present.
1196 Also used for arguments to procedures with multiple entry points. */
1199 gfc_conv_expr_present (gfc_symbol
* sym
)
1203 gcc_assert (sym
->attr
.dummy
);
1204 decl
= gfc_get_symbol_decl (sym
);
1206 /* Intrinsic scalars with VALUE attribute which are passed by value
1207 use a hidden argument to denote the present status. */
1208 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1209 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1210 && !sym
->attr
.dimension
)
1212 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1215 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1217 strcpy (&name
[1], sym
->name
);
1218 tree_name
= get_identifier (name
);
1220 /* Walk function argument list to find hidden arg. */
1221 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1222 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1223 if (DECL_NAME (cond
) == tree_name
)
1230 if (TREE_CODE (decl
) != PARM_DECL
)
1232 /* Array parameters use a temporary descriptor, we want the real
1234 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1235 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1236 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1239 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1240 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1242 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1243 as actual argument to denote absent dummies. For array descriptors,
1244 we thus also need to check the array descriptor. For BT_CLASS, it
1245 can also occur for scalars and F2003 due to type->class wrapping and
1246 class->class wrapping. Note further that BT_CLASS always uses an
1247 array descriptor for arrays, also for explicit-shape/assumed-size. */
1249 if (!sym
->attr
.allocatable
1250 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1251 || (sym
->ts
.type
== BT_CLASS
1252 && !CLASS_DATA (sym
)->attr
.allocatable
1253 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1254 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1255 || sym
->ts
.type
== BT_CLASS
))
1259 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1260 || sym
->as
->type
== AS_ASSUMED_RANK
1261 || sym
->attr
.codimension
))
1262 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1264 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1265 if (sym
->ts
.type
== BT_CLASS
)
1266 tmp
= gfc_class_data_get (tmp
);
1267 tmp
= gfc_conv_array_data (tmp
);
1269 else if (sym
->ts
.type
== BT_CLASS
)
1270 tmp
= gfc_class_data_get (decl
);
1274 if (tmp
!= NULL_TREE
)
1276 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1277 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1278 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1279 boolean_type_node
, cond
, tmp
);
1287 /* Converts a missing, dummy argument into a null or zero. */
1290 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1295 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1299 /* Create a temporary and convert it to the correct type. */
1300 tmp
= gfc_get_int_type (kind
);
1301 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1304 /* Test for a NULL value. */
1305 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1306 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1307 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1308 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1312 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1314 build_zero_cst (TREE_TYPE (se
->expr
)));
1315 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1319 if (ts
.type
== BT_CHARACTER
)
1321 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1322 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1323 present
, se
->string_length
, tmp
);
1324 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1325 se
->string_length
= tmp
;
1331 /* Get the character length of an expression, looking through gfc_refs
1335 gfc_get_expr_charlen (gfc_expr
*e
)
1340 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1341 && e
->ts
.type
== BT_CHARACTER
);
1343 length
= NULL
; /* To silence compiler warning. */
1345 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1348 gfc_init_se (&tmpse
, NULL
);
1349 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1350 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1354 /* First candidate: if the variable is of type CHARACTER, the
1355 expression's length could be the length of the character
1357 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1358 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1360 /* Look through the reference chain for component references. */
1361 for (r
= e
->ref
; r
; r
= r
->next
)
1366 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1367 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1375 /* We should never got substring references here. These will be
1376 broken down by the scalarizer. */
1382 gcc_assert (length
!= NULL
);
1387 /* Return for an expression the backend decl of the coarray. */
1390 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1396 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1398 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1399 gcc_assert (caf_decl
);
1400 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1401 caf_decl
= gfc_class_data_get (caf_decl
);
1402 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1405 /* The following code assumes that the coarray is a component reachable via
1406 only scalar components/variables; the Fortran standard guarantees this. */
1408 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1409 if (ref
->type
== REF_COMPONENT
)
1411 gfc_component
*comp
= ref
->u
.c
.component
;
1413 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1414 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1415 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1416 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1417 comp
->backend_decl
, NULL_TREE
);
1418 if (comp
->ts
.type
== BT_CLASS
)
1419 caf_decl
= gfc_class_data_get (caf_decl
);
1420 if (comp
->attr
.codimension
)
1426 gcc_assert (found
&& caf_decl
);
1431 /* For each character array constructor subexpression without a ts.u.cl->length,
1432 replace it by its first element (if there aren't any elements, the length
1433 should already be set to zero). */
1436 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1438 gfc_actual_arglist
* arg
;
1444 switch (e
->expr_type
)
1448 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1449 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1453 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1457 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1458 flatten_array_ctors_without_strlen (arg
->expr
);
1463 /* We've found what we're looking for. */
1464 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1469 gcc_assert (e
->value
.constructor
);
1471 c
= gfc_constructor_first (e
->value
.constructor
);
1475 flatten_array_ctors_without_strlen (new_expr
);
1476 gfc_replace_expr (e
, new_expr
);
1480 /* Otherwise, fall through to handle constructor elements. */
1481 case EXPR_STRUCTURE
:
1482 for (c
= gfc_constructor_first (e
->value
.constructor
);
1483 c
; c
= gfc_constructor_next (c
))
1484 flatten_array_ctors_without_strlen (c
->expr
);
1494 /* Generate code to initialize a string length variable. Returns the
1495 value. For array constructors, cl->length might be NULL and in this case,
1496 the first element of the constructor is needed. expr is the original
1497 expression so we can access it but can be NULL if this is not needed. */
1500 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1504 gfc_init_se (&se
, NULL
);
1508 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1511 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1512 "flatten" array constructors by taking their first element; all elements
1513 should be the same length or a cl->length should be present. */
1516 gfc_expr
* expr_flat
;
1518 expr_flat
= gfc_copy_expr (expr
);
1519 flatten_array_ctors_without_strlen (expr_flat
);
1520 gfc_resolve_expr (expr_flat
);
1522 gfc_conv_expr (&se
, expr_flat
);
1523 gfc_add_block_to_block (pblock
, &se
.pre
);
1524 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1526 gfc_free_expr (expr_flat
);
1530 /* Convert cl->length. */
1532 gcc_assert (cl
->length
);
1534 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1535 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1536 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1537 gfc_add_block_to_block (pblock
, &se
.pre
);
1539 if (cl
->backend_decl
)
1540 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1542 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1547 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1548 const char *name
, locus
*where
)
1558 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1559 type
= build_pointer_type (type
);
1561 gfc_init_se (&start
, se
);
1562 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1563 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1565 if (integer_onep (start
.expr
))
1566 gfc_conv_string_parameter (se
);
1571 /* Avoid multiple evaluation of substring start. */
1572 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1573 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1575 /* Change the start of the string. */
1576 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1579 tmp
= build_fold_indirect_ref_loc (input_location
,
1581 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1582 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1585 /* Length = end + 1 - start. */
1586 gfc_init_se (&end
, se
);
1587 if (ref
->u
.ss
.end
== NULL
)
1588 end
.expr
= se
->string_length
;
1591 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1592 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1596 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1597 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1599 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1601 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1602 boolean_type_node
, start
.expr
,
1605 /* Check lower bound. */
1606 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1608 build_int_cst (gfc_charlen_type_node
, 1));
1609 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1610 boolean_type_node
, nonempty
, fault
);
1612 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1613 "is less than one", name
);
1615 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1616 "is less than one");
1617 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1618 fold_convert (long_integer_type_node
,
1622 /* Check upper bound. */
1623 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1624 end
.expr
, se
->string_length
);
1625 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1626 boolean_type_node
, nonempty
, fault
);
1628 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1629 "exceeds string length (%%ld)", name
);
1631 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1632 "exceeds string length (%%ld)");
1633 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1634 fold_convert (long_integer_type_node
, end
.expr
),
1635 fold_convert (long_integer_type_node
,
1636 se
->string_length
));
1640 /* Try to calculate the length from the start and end expressions. */
1642 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1646 i_len
= mpz_get_si (length
) + 1;
1650 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1651 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1655 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1656 end
.expr
, start
.expr
);
1657 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1658 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1659 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1660 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1663 se
->string_length
= tmp
;
1667 /* Convert a derived type component reference. */
1670 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1677 c
= ref
->u
.c
.component
;
1679 gcc_assert (c
->backend_decl
);
1681 field
= c
->backend_decl
;
1682 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1685 /* Components can correspond to fields of different containing
1686 types, as components are created without context, whereas
1687 a concrete use of a component has the type of decl as context.
1688 So, if the type doesn't match, we search the corresponding
1689 FIELD_DECL in the parent type. To not waste too much time
1690 we cache this result in norestrict_decl. */
1692 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1694 tree f2
= c
->norestrict_decl
;
1695 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1696 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1697 if (TREE_CODE (f2
) == FIELD_DECL
1698 && DECL_NAME (f2
) == DECL_NAME (field
))
1701 c
->norestrict_decl
= f2
;
1705 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1706 decl
, field
, NULL_TREE
);
1710 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1712 tmp
= c
->ts
.u
.cl
->backend_decl
;
1713 /* Components must always be constant length. */
1714 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1715 se
->string_length
= tmp
;
1718 if (gfc_deferred_strlen (c
, &field
))
1720 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1722 decl
, field
, NULL_TREE
);
1723 se
->string_length
= tmp
;
1726 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1727 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1728 && c
->ts
.type
!= BT_CHARACTER
)
1729 || c
->attr
.proc_pointer
)
1730 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1735 /* This function deals with component references to components of the
1736 parent type for derived type extensions. */
1738 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1746 c
= ref
->u
.c
.component
;
1748 /* Return if the component is in the parent type. */
1749 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1750 if (strcmp (c
->name
, cmp
->name
) == 0)
1753 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1754 parent
.type
= REF_COMPONENT
;
1756 parent
.u
.c
.sym
= dt
;
1757 parent
.u
.c
.component
= dt
->components
;
1759 if (dt
->backend_decl
== NULL
)
1760 gfc_get_derived_type (dt
);
1762 /* Build the reference and call self. */
1763 gfc_conv_component_ref (se
, &parent
);
1764 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1765 parent
.u
.c
.component
= c
;
1766 conv_parent_component_references (se
, &parent
);
1769 /* Return the contents of a variable. Also handles reference/pointer
1770 variables (all Fortran pointer references are implicit). */
1773 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1778 tree parent_decl
= NULL_TREE
;
1781 bool alternate_entry
;
1784 sym
= expr
->symtree
->n
.sym
;
1788 gfc_ss_info
*ss_info
= ss
->info
;
1790 /* Check that something hasn't gone horribly wrong. */
1791 gcc_assert (ss
!= gfc_ss_terminator
);
1792 gcc_assert (ss_info
->expr
== expr
);
1794 /* A scalarized term. We already know the descriptor. */
1795 se
->expr
= ss_info
->data
.array
.descriptor
;
1796 se
->string_length
= ss_info
->string_length
;
1797 ref
= ss_info
->data
.array
.ref
;
1799 gcc_assert (ref
->type
== REF_ARRAY
1800 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1802 gfc_conv_tmp_array_ref (se
);
1806 tree se_expr
= NULL_TREE
;
1808 se
->expr
= gfc_get_symbol_decl (sym
);
1810 /* Deal with references to a parent results or entries by storing
1811 the current_function_decl and moving to the parent_decl. */
1812 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1813 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1814 && sym
->result
== sym
;
1815 entry_master
= sym
->attr
.result
1816 && sym
->ns
->proc_name
->attr
.entry_master
1817 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1818 if (current_function_decl
)
1819 parent_decl
= DECL_CONTEXT (current_function_decl
);
1821 if ((se
->expr
== parent_decl
&& return_value
)
1822 || (sym
->ns
&& sym
->ns
->proc_name
1824 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1825 && (alternate_entry
|| entry_master
)))
1830 /* Special case for assigning the return value of a function.
1831 Self recursive functions must have an explicit return value. */
1832 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1833 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1835 /* Similarly for alternate entry points. */
1836 else if (alternate_entry
1837 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1840 gfc_entry_list
*el
= NULL
;
1842 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1845 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1850 else if (entry_master
1851 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1853 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1858 /* Procedure actual arguments. */
1859 else if (sym
->attr
.flavor
== FL_PROCEDURE
1860 && se
->expr
!= current_function_decl
)
1862 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1864 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1865 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1871 /* Dereference the expression, where needed. Since characters
1872 are entirely different from other types, they are treated
1874 if (sym
->ts
.type
== BT_CHARACTER
)
1876 /* Dereference character pointer dummy arguments
1878 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1880 || sym
->attr
.function
1881 || sym
->attr
.result
))
1882 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1886 else if (!sym
->attr
.value
)
1888 /* Dereference non-character scalar dummy arguments. */
1889 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1890 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1891 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1894 /* Dereference scalar hidden result. */
1895 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1896 && (sym
->attr
.function
|| sym
->attr
.result
)
1897 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1898 && !sym
->attr
.always_explicit
)
1899 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1902 /* Dereference non-character pointer variables.
1903 These must be dummies, results, or scalars. */
1904 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1905 || gfc_is_associate_pointer (sym
)
1906 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1908 || sym
->attr
.function
1910 || (!sym
->attr
.dimension
1911 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1912 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1919 /* For character variables, also get the length. */
1920 if (sym
->ts
.type
== BT_CHARACTER
)
1922 /* If the character length of an entry isn't set, get the length from
1923 the master function instead. */
1924 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1925 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1927 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1928 gcc_assert (se
->string_length
);
1936 /* Return the descriptor if that's what we want and this is an array
1937 section reference. */
1938 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1940 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1941 /* Return the descriptor for array pointers and allocations. */
1942 if (se
->want_pointer
1943 && ref
->next
== NULL
&& (se
->descriptor_only
))
1946 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1947 /* Return a pointer to an element. */
1951 if (ref
->u
.c
.sym
->attr
.extension
)
1952 conv_parent_component_references (se
, ref
);
1954 gfc_conv_component_ref (se
, ref
);
1955 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1956 && se
->want_pointer
&& se
->descriptor_only
)
1962 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1963 expr
->symtree
->name
, &expr
->where
);
1972 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1974 if (se
->want_pointer
)
1976 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1977 gfc_conv_string_parameter (se
);
1979 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1984 /* Unary ops are easy... Or they would be if ! was a valid op. */
1987 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1992 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1993 /* Initialize the operand. */
1994 gfc_init_se (&operand
, se
);
1995 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1996 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1998 type
= gfc_typenode_for_spec (&expr
->ts
);
2000 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2001 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2002 All other unary operators have an equivalent GIMPLE unary operator. */
2003 if (code
== TRUTH_NOT_EXPR
)
2004 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2005 build_int_cst (type
, 0));
2007 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2011 /* Expand power operator to optimal multiplications when a value is raised
2012 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2013 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2014 Programming", 3rd Edition, 1998. */
2016 /* This code is mostly duplicated from expand_powi in the backend.
2017 We establish the "optimal power tree" lookup table with the defined size.
2018 The items in the table are the exponents used to calculate the index
2019 exponents. Any integer n less than the value can get an "addition chain",
2020 with the first node being one. */
2021 #define POWI_TABLE_SIZE 256
2023 /* The table is from builtins.c. */
2024 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2026 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2027 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2028 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2029 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2030 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2031 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2032 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2033 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2034 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2035 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2036 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2037 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2038 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2039 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2040 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2041 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2042 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2043 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2044 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2045 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2046 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2047 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2048 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2049 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2050 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2051 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2052 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2053 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2054 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2055 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2056 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2057 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2060 /* If n is larger than lookup table's max index, we use the "window
2062 #define POWI_WINDOW_SIZE 3
2064 /* Recursive function to expand the power operator. The temporary
2065 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2067 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2074 if (n
< POWI_TABLE_SIZE
)
2079 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2080 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2084 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2085 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2086 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2090 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2094 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2095 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2097 if (n
< POWI_TABLE_SIZE
)
2104 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2105 return 1. Else return 0 and a call to runtime library functions
2106 will have to be built. */
2108 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2113 tree vartmp
[POWI_TABLE_SIZE
];
2115 unsigned HOST_WIDE_INT n
;
2117 wide_int wrhs
= rhs
;
2119 /* If exponent is too large, we won't expand it anyway, so don't bother
2120 with large integer values. */
2121 if (!wi::fits_shwi_p (wrhs
))
2124 m
= wrhs
.to_shwi ();
2125 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2126 of the asymmetric range of the integer type. */
2127 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2129 type
= TREE_TYPE (lhs
);
2130 sgn
= tree_int_cst_sgn (rhs
);
2132 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2133 || optimize_size
) && (m
> 2 || m
< -1))
2139 se
->expr
= gfc_build_const (type
, integer_one_node
);
2143 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2144 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2146 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2147 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2148 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2149 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2152 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2155 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2156 boolean_type_node
, tmp
, cond
);
2157 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2158 tmp
, build_int_cst (type
, 1),
2159 build_int_cst (type
, 0));
2163 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2164 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2165 build_int_cst (type
, -1),
2166 build_int_cst (type
, 0));
2167 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2168 cond
, build_int_cst (type
, 1), tmp
);
2172 memset (vartmp
, 0, sizeof (vartmp
));
2176 tmp
= gfc_build_const (type
, integer_one_node
);
2177 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2181 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2187 /* Power op (**). Constant integer exponent has special handling. */
2190 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2192 tree gfc_int4_type_node
;
2195 int res_ikind_1
, res_ikind_2
;
2200 gfc_init_se (&lse
, se
);
2201 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2202 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2203 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2205 gfc_init_se (&rse
, se
);
2206 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2207 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2209 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2210 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2211 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2214 gfc_int4_type_node
= gfc_get_int_type (4);
2216 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2217 library routine. But in the end, we have to convert the result back
2218 if this case applies -- with res_ikind_K, we keep track whether operand K
2219 falls into this case. */
2223 kind
= expr
->value
.op
.op1
->ts
.kind
;
2224 switch (expr
->value
.op
.op2
->ts
.type
)
2227 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2232 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2233 res_ikind_2
= ikind
;
2255 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2257 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2284 switch (expr
->value
.op
.op1
->ts
.type
)
2287 if (kind
== 3) /* Case 16 was not handled properly above. */
2289 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2293 /* Use builtins for real ** int4. */
2299 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2303 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2307 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2311 /* Use the __builtin_powil() only if real(kind=16) is
2312 actually the C long double type. */
2313 if (!gfc_real16_is_float128
)
2314 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2322 /* If we don't have a good builtin for this, go for the
2323 library function. */
2325 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2329 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2338 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2342 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2350 se
->expr
= build_call_expr_loc (input_location
,
2351 fndecl
, 2, lse
.expr
, rse
.expr
);
2353 /* Convert the result back if it is of wrong integer kind. */
2354 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2356 /* We want the maximum of both operand kinds as result. */
2357 if (res_ikind_1
< res_ikind_2
)
2358 res_ikind_1
= res_ikind_2
;
2359 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2364 /* Generate code to allocate a string temporary. */
2367 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2372 if (gfc_can_put_var_on_stack (len
))
2374 /* Create a temporary variable to hold the result. */
2375 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2376 gfc_charlen_type_node
, len
,
2377 build_int_cst (gfc_charlen_type_node
, 1));
2378 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2380 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2381 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2383 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2385 var
= gfc_create_var (tmp
, "str");
2386 var
= gfc_build_addr_expr (type
, var
);
2390 /* Allocate a temporary to hold the result. */
2391 var
= gfc_create_var (type
, "pstr");
2392 gcc_assert (POINTER_TYPE_P (type
));
2393 tmp
= TREE_TYPE (type
);
2394 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2395 tmp
= TREE_TYPE (tmp
);
2396 tmp
= TYPE_SIZE_UNIT (tmp
);
2397 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2398 fold_convert (size_type_node
, len
),
2399 fold_convert (size_type_node
, tmp
));
2400 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2401 gfc_add_modify (&se
->pre
, var
, tmp
);
2403 /* Free the temporary afterwards. */
2404 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2405 gfc_add_expr_to_block (&se
->post
, tmp
);
2412 /* Handle a string concatenation operation. A temporary will be allocated to
2416 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2419 tree len
, type
, var
, tmp
, fndecl
;
2421 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2422 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2423 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2425 gfc_init_se (&lse
, se
);
2426 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2427 gfc_conv_string_parameter (&lse
);
2428 gfc_init_se (&rse
, se
);
2429 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2430 gfc_conv_string_parameter (&rse
);
2432 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2433 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2435 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2436 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2437 if (len
== NULL_TREE
)
2439 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2440 TREE_TYPE (lse
.string_length
),
2441 lse
.string_length
, rse
.string_length
);
2444 type
= build_pointer_type (type
);
2446 var
= gfc_conv_string_tmp (se
, type
, len
);
2448 /* Do the actual concatenation. */
2449 if (expr
->ts
.kind
== 1)
2450 fndecl
= gfor_fndecl_concat_string
;
2451 else if (expr
->ts
.kind
== 4)
2452 fndecl
= gfor_fndecl_concat_string_char4
;
2456 tmp
= build_call_expr_loc (input_location
,
2457 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2458 rse
.string_length
, rse
.expr
);
2459 gfc_add_expr_to_block (&se
->pre
, tmp
);
2461 /* Add the cleanup for the operands. */
2462 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2463 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2466 se
->string_length
= len
;
2469 /* Translates an op expression. Common (binary) cases are handled by this
2470 function, others are passed on. Recursion is used in either case.
2471 We use the fact that (op1.ts == op2.ts) (except for the power
2473 Operators need no special handling for scalarized expressions as long as
2474 they call gfc_conv_simple_val to get their operands.
2475 Character strings get special handling. */
2478 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2480 enum tree_code code
;
2489 switch (expr
->value
.op
.op
)
2491 case INTRINSIC_PARENTHESES
:
2492 if ((expr
->ts
.type
== BT_REAL
2493 || expr
->ts
.type
== BT_COMPLEX
)
2494 && gfc_option
.flag_protect_parens
)
2496 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2497 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2502 case INTRINSIC_UPLUS
:
2503 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2506 case INTRINSIC_UMINUS
:
2507 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2511 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2514 case INTRINSIC_PLUS
:
2518 case INTRINSIC_MINUS
:
2522 case INTRINSIC_TIMES
:
2526 case INTRINSIC_DIVIDE
:
2527 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2528 an integer, we must round towards zero, so we use a
2530 if (expr
->ts
.type
== BT_INTEGER
)
2531 code
= TRUNC_DIV_EXPR
;
2536 case INTRINSIC_POWER
:
2537 gfc_conv_power_op (se
, expr
);
2540 case INTRINSIC_CONCAT
:
2541 gfc_conv_concat_op (se
, expr
);
2545 code
= TRUTH_ANDIF_EXPR
;
2550 code
= TRUTH_ORIF_EXPR
;
2554 /* EQV and NEQV only work on logicals, but since we represent them
2555 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2557 case INTRINSIC_EQ_OS
:
2565 case INTRINSIC_NE_OS
:
2566 case INTRINSIC_NEQV
:
2573 case INTRINSIC_GT_OS
:
2580 case INTRINSIC_GE_OS
:
2587 case INTRINSIC_LT_OS
:
2594 case INTRINSIC_LE_OS
:
2600 case INTRINSIC_USER
:
2601 case INTRINSIC_ASSIGN
:
2602 /* These should be converted into function calls by the frontend. */
2606 fatal_error ("Unknown intrinsic op");
2610 /* The only exception to this is **, which is handled separately anyway. */
2611 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2613 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2617 gfc_init_se (&lse
, se
);
2618 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2619 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2622 gfc_init_se (&rse
, se
);
2623 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2624 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2628 gfc_conv_string_parameter (&lse
);
2629 gfc_conv_string_parameter (&rse
);
2631 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2632 rse
.string_length
, rse
.expr
,
2633 expr
->value
.op
.op1
->ts
.kind
,
2635 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2636 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2639 type
= gfc_typenode_for_spec (&expr
->ts
);
2643 /* The result of logical ops is always boolean_type_node. */
2644 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2645 lse
.expr
, rse
.expr
);
2646 se
->expr
= convert (type
, tmp
);
2649 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2651 /* Add the post blocks. */
2652 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2653 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2656 /* If a string's length is one, we convert it to a single character. */
2659 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2663 || !tree_fits_uhwi_p (len
)
2664 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2667 if (TREE_INT_CST_LOW (len
) == 1)
2669 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2670 return build_fold_indirect_ref_loc (input_location
, str
);
2674 && TREE_CODE (str
) == ADDR_EXPR
2675 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2676 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2677 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2678 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2679 && TREE_INT_CST_LOW (len
) > 1
2680 && TREE_INT_CST_LOW (len
)
2681 == (unsigned HOST_WIDE_INT
)
2682 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2684 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2685 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2686 if (TREE_CODE (ret
) == INTEGER_CST
)
2688 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2689 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2690 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2692 for (i
= 1; i
< length
; i
++)
2705 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2708 if (sym
->backend_decl
)
2710 /* This becomes the nominal_type in
2711 function.c:assign_parm_find_data_types. */
2712 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2713 /* This becomes the passed_type in
2714 function.c:assign_parm_find_data_types. C promotes char to
2715 integer for argument passing. */
2716 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2718 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2723 /* If we have a constant character expression, make it into an
2725 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2730 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2731 (int)(*expr
)->value
.character
.string
[0]);
2732 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2734 /* The expr needs to be compatible with a C int. If the
2735 conversion fails, then the 2 causes an ICE. */
2736 ts
.type
= BT_INTEGER
;
2737 ts
.kind
= gfc_c_int_kind
;
2738 gfc_convert_type (*expr
, &ts
, 2);
2741 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2743 if ((*expr
)->ref
== NULL
)
2745 se
->expr
= gfc_string_to_single_character
2746 (build_int_cst (integer_type_node
, 1),
2747 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2749 ((*expr
)->symtree
->n
.sym
)),
2754 gfc_conv_variable (se
, *expr
);
2755 se
->expr
= gfc_string_to_single_character
2756 (build_int_cst (integer_type_node
, 1),
2757 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2765 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2766 if STR is a string literal, otherwise return -1. */
2769 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2772 && TREE_CODE (str
) == ADDR_EXPR
2773 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2774 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2775 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2776 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2777 && tree_fits_uhwi_p (len
)
2778 && tree_to_uhwi (len
) >= 1
2779 && tree_to_uhwi (len
)
2780 == (unsigned HOST_WIDE_INT
)
2781 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2783 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2784 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2785 if (TREE_CODE (folded
) == INTEGER_CST
)
2787 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2788 int length
= TREE_STRING_LENGTH (string_cst
);
2789 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2791 for (; length
> 0; length
--)
2792 if (ptr
[length
- 1] != ' ')
2801 /* Helper to build a call to memcmp. */
2804 build_memcmp_call (tree s1
, tree s2
, tree n
)
2808 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2809 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2811 s1
= fold_convert (pvoid_type_node
, s1
);
2813 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2814 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2816 s2
= fold_convert (pvoid_type_node
, s2
);
2818 n
= fold_convert (size_type_node
, n
);
2820 tmp
= build_call_expr_loc (input_location
,
2821 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2824 return fold_convert (integer_type_node
, tmp
);
2827 /* Compare two strings. If they are all single characters, the result is the
2828 subtraction of them. Otherwise, we build a library call. */
2831 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2832 enum tree_code code
)
2838 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2839 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2841 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2842 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2844 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2846 /* Deal with single character specially. */
2847 sc1
= fold_convert (integer_type_node
, sc1
);
2848 sc2
= fold_convert (integer_type_node
, sc2
);
2849 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2853 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2855 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2857 /* If one string is a string literal with LEN_TRIM longer
2858 than the length of the second string, the strings
2860 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2861 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2862 return integer_one_node
;
2863 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2864 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2865 return integer_one_node
;
2868 /* We can compare via memcpy if the strings are known to be equal
2869 in length and they are
2871 - kind=4 and the comparison is for (in)equality. */
2873 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2874 && tree_int_cst_equal (len1
, len2
)
2875 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2880 chartype
= gfc_get_char_type (kind
);
2881 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2882 fold_convert (TREE_TYPE(len1
),
2883 TYPE_SIZE_UNIT(chartype
)),
2885 return build_memcmp_call (str1
, str2
, tmp
);
2888 /* Build a call for the comparison. */
2890 fndecl
= gfor_fndecl_compare_string
;
2892 fndecl
= gfor_fndecl_compare_string_char4
;
2896 return build_call_expr_loc (input_location
, fndecl
, 4,
2897 len1
, str1
, len2
, str2
);
2901 /* Return the backend_decl for a procedure pointer component. */
2904 get_proc_ptr_comp (gfc_expr
*e
)
2910 gfc_init_se (&comp_se
, NULL
);
2911 e2
= gfc_copy_expr (e
);
2912 /* We have to restore the expr type later so that gfc_free_expr frees
2913 the exact same thing that was allocated.
2914 TODO: This is ugly. */
2915 old_type
= e2
->expr_type
;
2916 e2
->expr_type
= EXPR_VARIABLE
;
2917 gfc_conv_expr (&comp_se
, e2
);
2918 e2
->expr_type
= old_type
;
2920 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2924 /* Convert a typebound function reference from a class object. */
2926 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2931 if (TREE_CODE (base_object
) != VAR_DECL
)
2933 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2934 gfc_add_modify (&se
->pre
, var
, base_object
);
2936 se
->expr
= gfc_class_vptr_get (base_object
);
2937 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2939 while (ref
&& ref
->next
)
2941 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2942 if (ref
->u
.c
.sym
->attr
.extension
)
2943 conv_parent_component_references (se
, ref
);
2944 gfc_conv_component_ref (se
, ref
);
2945 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2950 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2954 if (gfc_is_proc_ptr_comp (expr
))
2955 tmp
= get_proc_ptr_comp (expr
);
2956 else if (sym
->attr
.dummy
)
2958 tmp
= gfc_get_symbol_decl (sym
);
2959 if (sym
->attr
.proc_pointer
)
2960 tmp
= build_fold_indirect_ref_loc (input_location
,
2962 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2963 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2967 if (!sym
->backend_decl
)
2968 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2970 TREE_USED (sym
->backend_decl
) = 1;
2972 tmp
= sym
->backend_decl
;
2974 if (sym
->attr
.cray_pointee
)
2976 /* TODO - make the cray pointee a pointer to a procedure,
2977 assign the pointer to it and use it for the call. This
2979 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2980 gfc_get_symbol_decl (sym
->cp_pointer
));
2981 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2984 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2986 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2987 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2994 /* Initialize MAPPING. */
2997 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2999 mapping
->syms
= NULL
;
3000 mapping
->charlens
= NULL
;
3004 /* Free all memory held by MAPPING (but not MAPPING itself). */
3007 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3009 gfc_interface_sym_mapping
*sym
;
3010 gfc_interface_sym_mapping
*nextsym
;
3012 gfc_charlen
*nextcl
;
3014 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3016 nextsym
= sym
->next
;
3017 sym
->new_sym
->n
.sym
->formal
= NULL
;
3018 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3019 gfc_free_expr (sym
->expr
);
3020 free (sym
->new_sym
);
3023 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3026 gfc_free_expr (cl
->length
);
3032 /* Return a copy of gfc_charlen CL. Add the returned structure to
3033 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3035 static gfc_charlen
*
3036 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3039 gfc_charlen
*new_charlen
;
3041 new_charlen
= gfc_get_charlen ();
3042 new_charlen
->next
= mapping
->charlens
;
3043 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3045 mapping
->charlens
= new_charlen
;
3050 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3051 array variable that can be used as the actual argument for dummy
3052 argument SYM. Add any initialization code to BLOCK. PACKED is as
3053 for gfc_get_nodesc_array_type and DATA points to the first element
3054 in the passed array. */
3057 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3058 gfc_packed packed
, tree data
)
3063 type
= gfc_typenode_for_spec (&sym
->ts
);
3064 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3065 !sym
->attr
.target
&& !sym
->attr
.pointer
3066 && !sym
->attr
.proc_pointer
);
3068 var
= gfc_create_var (type
, "ifm");
3069 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3075 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3076 and offset of descriptorless array type TYPE given that it has the same
3077 size as DESC. Add any set-up code to BLOCK. */
3080 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3087 offset
= gfc_index_zero_node
;
3088 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3090 dim
= gfc_rank_cst
[n
];
3091 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3092 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3094 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3095 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3096 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3097 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3099 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3101 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3102 gfc_array_index_type
,
3103 gfc_conv_descriptor_ubound_get (desc
, dim
),
3104 gfc_conv_descriptor_lbound_get (desc
, dim
));
3105 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3106 gfc_array_index_type
,
3107 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3108 tmp
= gfc_evaluate_now (tmp
, block
);
3109 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3111 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3112 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3113 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3114 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3115 gfc_array_index_type
, offset
, tmp
);
3117 offset
= gfc_evaluate_now (offset
, block
);
3118 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3122 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3123 in SE. The caller may still use se->expr and se->string_length after
3124 calling this function. */
3127 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3128 gfc_symbol
* sym
, gfc_se
* se
,
3131 gfc_interface_sym_mapping
*sm
;
3135 gfc_symbol
*new_sym
;
3137 gfc_symtree
*new_symtree
;
3139 /* Create a new symbol to represent the actual argument. */
3140 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3141 new_sym
->ts
= sym
->ts
;
3142 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3143 new_sym
->attr
.referenced
= 1;
3144 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3145 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3146 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3147 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3148 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3149 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3150 new_sym
->attr
.function
= sym
->attr
.function
;
3152 /* Ensure that the interface is available and that
3153 descriptors are passed for array actual arguments. */
3154 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3156 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3157 new_sym
->attr
.always_explicit
3158 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3161 /* Create a fake symtree for it. */
3163 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3164 new_symtree
->n
.sym
= new_sym
;
3165 gcc_assert (new_symtree
== root
);
3167 /* Create a dummy->actual mapping. */
3168 sm
= XCNEW (gfc_interface_sym_mapping
);
3169 sm
->next
= mapping
->syms
;
3171 sm
->new_sym
= new_symtree
;
3172 sm
->expr
= gfc_copy_expr (expr
);
3175 /* Stabilize the argument's value. */
3176 if (!sym
->attr
.function
&& se
)
3177 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3179 if (sym
->ts
.type
== BT_CHARACTER
)
3181 /* Create a copy of the dummy argument's length. */
3182 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3183 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3185 /* If the length is specified as "*", record the length that
3186 the caller is passing. We should use the callee's length
3187 in all other cases. */
3188 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3190 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3191 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3198 /* Use the passed value as-is if the argument is a function. */
3199 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3202 /* If the argument is either a string or a pointer to a string,
3203 convert it to a boundless character type. */
3204 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3206 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3207 tmp
= build_pointer_type (tmp
);
3208 if (sym
->attr
.pointer
)
3209 value
= build_fold_indirect_ref_loc (input_location
,
3213 value
= fold_convert (tmp
, value
);
3216 /* If the argument is a scalar, a pointer to an array or an allocatable,
3218 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3219 value
= build_fold_indirect_ref_loc (input_location
,
3222 /* For character(*), use the actual argument's descriptor. */
3223 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3224 value
= build_fold_indirect_ref_loc (input_location
,
3227 /* If the argument is an array descriptor, use it to determine
3228 information about the actual argument's shape. */
3229 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3230 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3232 /* Get the actual argument's descriptor. */
3233 desc
= build_fold_indirect_ref_loc (input_location
,
3236 /* Create the replacement variable. */
3237 tmp
= gfc_conv_descriptor_data_get (desc
);
3238 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3241 /* Use DESC to work out the upper bounds, strides and offset. */
3242 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3245 /* Otherwise we have a packed array. */
3246 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3247 PACKED_FULL
, se
->expr
);
3249 new_sym
->backend_decl
= value
;
3253 /* Called once all dummy argument mappings have been added to MAPPING,
3254 but before the mapping is used to evaluate expressions. Pre-evaluate
3255 the length of each argument, adding any initialization code to PRE and
3256 any finalization code to POST. */
3259 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3260 stmtblock_t
* pre
, stmtblock_t
* post
)
3262 gfc_interface_sym_mapping
*sym
;
3266 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3267 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3268 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3270 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3271 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3272 gfc_init_se (&se
, NULL
);
3273 gfc_conv_expr (&se
, expr
);
3274 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3275 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3276 gfc_add_block_to_block (pre
, &se
.pre
);
3277 gfc_add_block_to_block (post
, &se
.post
);
3279 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3284 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3288 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3289 gfc_constructor_base base
)
3292 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3294 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3297 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3298 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3299 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3305 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3309 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3314 for (; ref
; ref
= ref
->next
)
3318 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3320 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3321 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3322 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3330 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3331 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3337 /* Convert intrinsic function calls into result expressions. */
3340 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3348 arg1
= expr
->value
.function
.actual
->expr
;
3349 if (expr
->value
.function
.actual
->next
)
3350 arg2
= expr
->value
.function
.actual
->next
->expr
;
3354 sym
= arg1
->symtree
->n
.sym
;
3356 if (sym
->attr
.dummy
)
3361 switch (expr
->value
.function
.isym
->id
)
3364 /* TODO figure out why this condition is necessary. */
3365 if (sym
->attr
.function
3366 && (arg1
->ts
.u
.cl
->length
== NULL
3367 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3368 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3371 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3375 if (!sym
->as
|| sym
->as
->rank
== 0)
3378 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3380 dup
= mpz_get_si (arg2
->value
.integer
);
3385 dup
= sym
->as
->rank
;
3389 for (; d
< dup
; d
++)
3393 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3395 gfc_free_expr (new_expr
);
3399 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3400 gfc_get_int_expr (gfc_default_integer_kind
,
3402 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3404 new_expr
= gfc_multiply (new_expr
, tmp
);
3410 case GFC_ISYM_LBOUND
:
3411 case GFC_ISYM_UBOUND
:
3412 /* TODO These implementations of lbound and ubound do not limit if
3413 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3415 if (!sym
->as
|| sym
->as
->rank
== 0)
3418 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3419 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3421 /* TODO: If the need arises, this could produce an array of
3425 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3427 if (sym
->as
->lower
[d
])
3428 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3432 if (sym
->as
->upper
[d
])
3433 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3441 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3445 gfc_replace_expr (expr
, new_expr
);
3451 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3452 gfc_interface_mapping
* mapping
)
3454 gfc_formal_arglist
*f
;
3455 gfc_actual_arglist
*actual
;
3457 actual
= expr
->value
.function
.actual
;
3458 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3460 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3465 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3468 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3473 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3475 for (d
= 0; d
< as
->rank
; d
++)
3477 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3478 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3481 expr
->value
.function
.esym
->as
= as
;
3484 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3486 expr
->value
.function
.esym
->ts
.u
.cl
->length
3487 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3489 gfc_apply_interface_mapping_to_expr (mapping
,
3490 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3495 /* EXPR is a copy of an expression that appeared in the interface
3496 associated with MAPPING. Walk it recursively looking for references to
3497 dummy arguments that MAPPING maps to actual arguments. Replace each such
3498 reference with a reference to the associated actual argument. */
3501 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3504 gfc_interface_sym_mapping
*sym
;
3505 gfc_actual_arglist
*actual
;
3510 /* Copying an expression does not copy its length, so do that here. */
3511 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3513 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3514 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3517 /* Apply the mapping to any references. */
3518 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3520 /* ...and to the expression's symbol, if it has one. */
3521 /* TODO Find out why the condition on expr->symtree had to be moved into
3522 the loop rather than being outside it, as originally. */
3523 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3524 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3526 if (sym
->new_sym
->n
.sym
->backend_decl
)
3527 expr
->symtree
= sym
->new_sym
;
3529 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3530 /* Replace base type for polymorphic arguments. */
3531 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3532 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3533 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3536 /* ...and to subexpressions in expr->value. */
3537 switch (expr
->expr_type
)
3542 case EXPR_SUBSTRING
:
3546 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3547 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3551 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3552 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3554 if (expr
->value
.function
.esym
== NULL
3555 && expr
->value
.function
.isym
!= NULL
3556 && expr
->value
.function
.actual
->expr
->symtree
3557 && gfc_map_intrinsic_function (expr
, mapping
))
3560 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3561 if (sym
->old
== expr
->value
.function
.esym
)
3563 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3564 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3565 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3570 case EXPR_STRUCTURE
:
3571 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3584 /* Evaluate interface expression EXPR using MAPPING. Store the result
3588 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3589 gfc_se
* se
, gfc_expr
* expr
)
3591 expr
= gfc_copy_expr (expr
);
3592 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3593 gfc_conv_expr (se
, expr
);
3594 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3595 gfc_free_expr (expr
);
3599 /* Returns a reference to a temporary array into which a component of
3600 an actual argument derived type array is copied and then returned
3601 after the function call. */
3603 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3604 sym_intent intent
, bool formal_ptr
)
3612 gfc_array_info
*info
;
3622 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3624 gfc_init_se (&lse
, NULL
);
3625 gfc_init_se (&rse
, NULL
);
3627 /* Walk the argument expression. */
3628 rss
= gfc_walk_expr (expr
);
3630 gcc_assert (rss
!= gfc_ss_terminator
);
3632 /* Initialize the scalarizer. */
3633 gfc_init_loopinfo (&loop
);
3634 gfc_add_ss_to_loop (&loop
, rss
);
3636 /* Calculate the bounds of the scalarization. */
3637 gfc_conv_ss_startstride (&loop
);
3639 /* Build an ss for the temporary. */
3640 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3641 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3643 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3644 if (GFC_ARRAY_TYPE_P (base_type
)
3645 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3646 base_type
= gfc_get_element_type (base_type
);
3648 if (expr
->ts
.type
== BT_CLASS
)
3649 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3651 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3652 ? expr
->ts
.u
.cl
->backend_decl
3656 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3658 /* Associate the SS with the loop. */
3659 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3661 /* Setup the scalarizing loops. */
3662 gfc_conv_loop_setup (&loop
, &expr
->where
);
3664 /* Pass the temporary descriptor back to the caller. */
3665 info
= &loop
.temp_ss
->info
->data
.array
;
3666 parmse
->expr
= info
->descriptor
;
3668 /* Setup the gfc_se structures. */
3669 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3670 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3673 lse
.ss
= loop
.temp_ss
;
3674 gfc_mark_ss_chain_used (rss
, 1);
3675 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3677 /* Start the scalarized loop body. */
3678 gfc_start_scalarized_body (&loop
, &body
);
3680 /* Translate the expression. */
3681 gfc_conv_expr (&rse
, expr
);
3683 gfc_conv_tmp_array_ref (&lse
);
3685 if (intent
!= INTENT_OUT
)
3687 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3688 gfc_add_expr_to_block (&body
, tmp
);
3689 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3690 gfc_trans_scalarizing_loops (&loop
, &body
);
3694 /* Make sure that the temporary declaration survives by merging
3695 all the loop declarations into the current context. */
3696 for (n
= 0; n
< loop
.dimen
; n
++)
3698 gfc_merge_block_scope (&body
);
3699 body
= loop
.code
[loop
.order
[n
]];
3701 gfc_merge_block_scope (&body
);
3704 /* Add the post block after the second loop, so that any
3705 freeing of allocated memory is done at the right time. */
3706 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3708 /**********Copy the temporary back again.*********/
3710 gfc_init_se (&lse
, NULL
);
3711 gfc_init_se (&rse
, NULL
);
3713 /* Walk the argument expression. */
3714 lss
= gfc_walk_expr (expr
);
3715 rse
.ss
= loop
.temp_ss
;
3718 /* Initialize the scalarizer. */
3719 gfc_init_loopinfo (&loop2
);
3720 gfc_add_ss_to_loop (&loop2
, lss
);
3722 /* Calculate the bounds of the scalarization. */
3723 gfc_conv_ss_startstride (&loop2
);
3725 /* Setup the scalarizing loops. */
3726 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3728 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3729 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3731 gfc_mark_ss_chain_used (lss
, 1);
3732 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3734 /* Declare the variable to hold the temporary offset and start the
3735 scalarized loop body. */
3736 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3737 gfc_start_scalarized_body (&loop2
, &body
);
3739 /* Build the offsets for the temporary from the loop variables. The
3740 temporary array has lbounds of zero and strides of one in all
3741 dimensions, so this is very simple. The offset is only computed
3742 outside the innermost loop, so the overall transfer could be
3743 optimized further. */
3744 info
= &rse
.ss
->info
->data
.array
;
3745 dimen
= rse
.ss
->dimen
;
3747 tmp_index
= gfc_index_zero_node
;
3748 for (n
= dimen
- 1; n
> 0; n
--)
3751 tmp
= rse
.loop
->loopvar
[n
];
3752 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3753 tmp
, rse
.loop
->from
[n
]);
3754 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3757 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3758 gfc_array_index_type
,
3759 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3760 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3761 gfc_array_index_type
,
3762 tmp_str
, gfc_index_one_node
);
3764 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3765 gfc_array_index_type
, tmp
, tmp_str
);
3768 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3769 gfc_array_index_type
,
3770 tmp_index
, rse
.loop
->from
[0]);
3771 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3773 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3774 gfc_array_index_type
,
3775 rse
.loop
->loopvar
[0], offset
);
3777 /* Now use the offset for the reference. */
3778 tmp
= build_fold_indirect_ref_loc (input_location
,
3780 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3782 if (expr
->ts
.type
== BT_CHARACTER
)
3783 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3785 gfc_conv_expr (&lse
, expr
);
3787 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3789 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3790 gfc_add_expr_to_block (&body
, tmp
);
3792 /* Generate the copying loops. */
3793 gfc_trans_scalarizing_loops (&loop2
, &body
);
3795 /* Wrap the whole thing up by adding the second loop to the post-block
3796 and following it by the post-block of the first loop. In this way,
3797 if the temporary needs freeing, it is done after use! */
3798 if (intent
!= INTENT_IN
)
3800 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3801 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3804 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3806 gfc_cleanup_loop (&loop
);
3807 gfc_cleanup_loop (&loop2
);
3809 /* Pass the string length to the argument expression. */
3810 if (expr
->ts
.type
== BT_CHARACTER
)
3811 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3813 /* Determine the offset for pointer formal arguments and set the
3817 size
= gfc_index_one_node
;
3818 offset
= gfc_index_zero_node
;
3819 for (n
= 0; n
< dimen
; n
++)
3821 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3823 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3824 gfc_array_index_type
, tmp
,
3825 gfc_index_one_node
);
3826 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3830 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3833 gfc_index_one_node
);
3834 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3835 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3836 gfc_array_index_type
,
3838 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3839 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3840 gfc_array_index_type
,
3841 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3842 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3843 gfc_array_index_type
,
3844 tmp
, gfc_index_one_node
);
3845 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3846 gfc_array_index_type
, size
, tmp
);
3849 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3853 /* We want either the address for the data or the address of the descriptor,
3854 depending on the mode of passing array arguments. */
3856 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3858 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3864 /* Generate the code for argument list functions. */
3867 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3869 /* Pass by value for g77 %VAL(arg), pass the address
3870 indirectly for %LOC, else by reference. Thus %REF
3871 is a "do-nothing" and %LOC is the same as an F95
3873 if (strncmp (name
, "%VAL", 4) == 0)
3874 gfc_conv_expr (se
, expr
);
3875 else if (strncmp (name
, "%LOC", 4) == 0)
3877 gfc_conv_expr_reference (se
, expr
);
3878 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3880 else if (strncmp (name
, "%REF", 4) == 0)
3881 gfc_conv_expr_reference (se
, expr
);
3883 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3887 /* Generate code for a procedure call. Note can return se->post != NULL.
3888 If se->direct_byref is set then se->expr contains the return parameter.
3889 Return nonzero, if the call has alternate specifiers.
3890 'expr' is only needed for procedure pointer components. */
3893 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3894 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3895 vec
<tree
, va_gc
> *append_args
)
3897 gfc_interface_mapping mapping
;
3898 vec
<tree
, va_gc
> *arglist
;
3899 vec
<tree
, va_gc
> *retargs
;
3903 gfc_array_info
*info
;
3910 vec
<tree
, va_gc
> *stringargs
;
3911 vec
<tree
, va_gc
> *optionalargs
;
3913 gfc_formal_arglist
*formal
;
3914 gfc_actual_arglist
*arg
;
3915 int has_alternate_specifier
= 0;
3916 bool need_interface_mapping
;
3923 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3924 gfc_component
*comp
= NULL
;
3930 optionalargs
= NULL
;
3935 comp
= gfc_get_proc_ptr_comp (expr
);
3939 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3941 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3942 if (se
->ss
->info
->useflags
)
3944 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3945 && sym
->result
->attr
.dimension
)
3946 || (comp
&& comp
->attr
.dimension
));
3947 gcc_assert (se
->loop
!= NULL
);
3949 /* Access the previously obtained result. */
3950 gfc_conv_tmp_array_ref (se
);
3954 info
= &se
->ss
->info
->data
.array
;
3959 gfc_init_block (&post
);
3960 gfc_init_interface_mapping (&mapping
);
3963 formal
= gfc_sym_get_dummy_args (sym
);
3964 need_interface_mapping
= sym
->attr
.dimension
||
3965 (sym
->ts
.type
== BT_CHARACTER
3966 && sym
->ts
.u
.cl
->length
3967 && sym
->ts
.u
.cl
->length
->expr_type
3972 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3973 need_interface_mapping
= comp
->attr
.dimension
||
3974 (comp
->ts
.type
== BT_CHARACTER
3975 && comp
->ts
.u
.cl
->length
3976 && comp
->ts
.u
.cl
->length
->expr_type
3980 base_object
= NULL_TREE
;
3982 /* Evaluate the arguments. */
3983 for (arg
= args
; arg
!= NULL
;
3984 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3987 fsym
= formal
? formal
->sym
: NULL
;
3988 parm_kind
= MISSING
;
3990 /* Class array expressions are sometimes coming completely unadorned
3991 with either arrayspec or _data component. Correct that here.
3992 OOP-TODO: Move this to the frontend. */
3993 if (e
&& e
->expr_type
== EXPR_VARIABLE
3995 && e
->ts
.type
== BT_CLASS
3996 && (CLASS_DATA (e
)->attr
.codimension
3997 || CLASS_DATA (e
)->attr
.dimension
))
3999 gfc_typespec temp_ts
= e
->ts
;
4000 gfc_add_class_array_ref (e
);
4006 if (se
->ignore_optional
)
4008 /* Some intrinsics have already been resolved to the correct
4012 else if (arg
->label
)
4014 has_alternate_specifier
= 1;
4019 gfc_init_se (&parmse
, NULL
);
4021 /* For scalar arguments with VALUE attribute which are passed by
4022 value, pass "0" and a hidden argument gives the optional
4024 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4025 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4026 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4028 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4030 vec_safe_push (optionalargs
, boolean_false_node
);
4034 /* Pass a NULL pointer for an absent arg. */
4035 parmse
.expr
= null_pointer_node
;
4036 if (arg
->missing_arg_type
== BT_CHARACTER
)
4037 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4042 else if (arg
->expr
->expr_type
== EXPR_NULL
4043 && fsym
&& !fsym
->attr
.pointer
4044 && (fsym
->ts
.type
!= BT_CLASS
4045 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4047 /* Pass a NULL pointer to denote an absent arg. */
4048 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4049 && (fsym
->ts
.type
!= BT_CLASS
4050 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4051 gfc_init_se (&parmse
, NULL
);
4052 parmse
.expr
= null_pointer_node
;
4053 if (arg
->missing_arg_type
== BT_CHARACTER
)
4054 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4056 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4057 && e
->ts
.type
== BT_DERIVED
)
4059 /* The derived type needs to be converted to a temporary
4061 gfc_init_se (&parmse
, se
);
4062 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4064 && e
->expr_type
== EXPR_VARIABLE
4065 && e
->symtree
->n
.sym
->attr
.optional
,
4066 CLASS_DATA (fsym
)->attr
.class_pointer
4067 || CLASS_DATA (fsym
)->attr
.allocatable
);
4069 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4071 /* The intrinsic type needs to be converted to a temporary
4072 CLASS object for the unlimited polymorphic formal. */
4073 gfc_init_se (&parmse
, se
);
4074 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4076 else if (se
->ss
&& se
->ss
->info
->useflags
)
4082 /* An elemental function inside a scalarized loop. */
4083 gfc_init_se (&parmse
, se
);
4084 parm_kind
= ELEMENTAL
;
4086 if (fsym
&& fsym
->attr
.value
)
4087 gfc_conv_expr (&parmse
, e
);
4089 gfc_conv_expr_reference (&parmse
, e
);
4091 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4092 && e
->expr_type
== EXPR_FUNCTION
)
4093 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4096 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4097 && gfc_is_class_container_ref (e
))
4099 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4101 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4102 && e
->symtree
->n
.sym
->attr
.optional
)
4104 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4105 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4106 TREE_TYPE (parmse
.expr
),
4108 fold_convert (TREE_TYPE (parmse
.expr
),
4109 null_pointer_node
));
4113 /* If we are passing an absent array as optional dummy to an
4114 elemental procedure, make sure that we pass NULL when the data
4115 pointer is NULL. We need this extra conditional because of
4116 scalarization which passes arrays elements to the procedure,
4117 ignoring the fact that the array can be absent/unallocated/... */
4118 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4120 tree descriptor_data
;
4122 descriptor_data
= ss
->info
->data
.array
.data
;
4123 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4125 fold_convert (TREE_TYPE (descriptor_data
),
4126 null_pointer_node
));
4128 = fold_build3_loc (input_location
, COND_EXPR
,
4129 TREE_TYPE (parmse
.expr
),
4130 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4131 fold_convert (TREE_TYPE (parmse
.expr
),
4136 /* The scalarizer does not repackage the reference to a class
4137 array - instead it returns a pointer to the data element. */
4138 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4139 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4140 fsym
->attr
.intent
!= INTENT_IN
4141 && (CLASS_DATA (fsym
)->attr
.class_pointer
4142 || CLASS_DATA (fsym
)->attr
.allocatable
),
4144 && e
->expr_type
== EXPR_VARIABLE
4145 && e
->symtree
->n
.sym
->attr
.optional
,
4146 CLASS_DATA (fsym
)->attr
.class_pointer
4147 || CLASS_DATA (fsym
)->attr
.allocatable
);
4154 gfc_init_se (&parmse
, NULL
);
4156 /* Check whether the expression is a scalar or not; we cannot use
4157 e->rank as it can be nonzero for functions arguments. */
4158 argss
= gfc_walk_expr (e
);
4159 scalar
= argss
== gfc_ss_terminator
;
4161 gfc_free_ss_chain (argss
);
4163 /* Special handling for passing scalar polymorphic coarrays;
4164 otherwise one passes "class->_data.data" instead of "&class". */
4165 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4166 && fsym
&& fsym
->ts
.type
== BT_CLASS
4167 && CLASS_DATA (fsym
)->attr
.codimension
4168 && !CLASS_DATA (fsym
)->attr
.dimension
)
4170 gfc_add_class_array_ref (e
);
4171 parmse
.want_coarray
= 1;
4175 /* A scalar or transformational function. */
4178 if (e
->expr_type
== EXPR_VARIABLE
4179 && e
->symtree
->n
.sym
->attr
.cray_pointee
4180 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4182 /* The Cray pointer needs to be converted to a pointer to
4183 a type given by the expression. */
4184 gfc_conv_expr (&parmse
, e
);
4185 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4186 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4187 parmse
.expr
= convert (type
, tmp
);
4189 else if (fsym
&& fsym
->attr
.value
)
4191 if (fsym
->ts
.type
== BT_CHARACTER
4192 && fsym
->ts
.is_c_interop
4193 && fsym
->ns
->proc_name
!= NULL
4194 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4197 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4198 if (parmse
.expr
== NULL
)
4199 gfc_conv_expr (&parmse
, e
);
4203 gfc_conv_expr (&parmse
, e
);
4204 if (fsym
->attr
.optional
4205 && fsym
->ts
.type
!= BT_CLASS
4206 && fsym
->ts
.type
!= BT_DERIVED
)
4208 if (e
->expr_type
!= EXPR_VARIABLE
4209 || !e
->symtree
->n
.sym
->attr
.optional
4211 vec_safe_push (optionalargs
, boolean_true_node
);
4214 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4215 if (!e
->symtree
->n
.sym
->attr
.value
)
4217 = fold_build3_loc (input_location
, COND_EXPR
,
4218 TREE_TYPE (parmse
.expr
),
4220 fold_convert (TREE_TYPE (parmse
.expr
),
4221 integer_zero_node
));
4223 vec_safe_push (optionalargs
, tmp
);
4228 else if (arg
->name
&& arg
->name
[0] == '%')
4229 /* Argument list functions %VAL, %LOC and %REF are signalled
4230 through arg->name. */
4231 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4232 else if ((e
->expr_type
== EXPR_FUNCTION
)
4233 && ((e
->value
.function
.esym
4234 && e
->value
.function
.esym
->result
->attr
.pointer
)
4235 || (!e
->value
.function
.esym
4236 && e
->symtree
->n
.sym
->attr
.pointer
))
4237 && fsym
&& fsym
->attr
.target
)
4239 gfc_conv_expr (&parmse
, e
);
4240 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4242 else if (e
->expr_type
== EXPR_FUNCTION
4243 && e
->symtree
->n
.sym
->result
4244 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4245 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4247 /* Functions returning procedure pointers. */
4248 gfc_conv_expr (&parmse
, e
);
4249 if (fsym
&& fsym
->attr
.proc_pointer
)
4250 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4254 if (e
->ts
.type
== BT_CLASS
&& fsym
4255 && fsym
->ts
.type
== BT_CLASS
4256 && (!CLASS_DATA (fsym
)->as
4257 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4258 && CLASS_DATA (e
)->attr
.codimension
)
4260 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4261 gcc_assert (!CLASS_DATA (fsym
)->as
);
4262 gfc_add_class_array_ref (e
);
4263 parmse
.want_coarray
= 1;
4264 gfc_conv_expr_reference (&parmse
, e
);
4265 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4267 && e
->expr_type
== EXPR_VARIABLE
);
4270 gfc_conv_expr_reference (&parmse
, e
);
4272 /* Catch base objects that are not variables. */
4273 if (e
->ts
.type
== BT_CLASS
4274 && e
->expr_type
!= EXPR_VARIABLE
4275 && expr
&& e
== expr
->base_expr
)
4276 base_object
= build_fold_indirect_ref_loc (input_location
,
4279 /* A class array element needs converting back to be a
4280 class object, if the formal argument is a class object. */
4281 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4282 && e
->ts
.type
== BT_CLASS
4283 && ((CLASS_DATA (fsym
)->as
4284 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4285 || CLASS_DATA (e
)->attr
.dimension
))
4286 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4287 fsym
->attr
.intent
!= INTENT_IN
4288 && (CLASS_DATA (fsym
)->attr
.class_pointer
4289 || CLASS_DATA (fsym
)->attr
.allocatable
),
4291 && e
->expr_type
== EXPR_VARIABLE
4292 && e
->symtree
->n
.sym
->attr
.optional
,
4293 CLASS_DATA (fsym
)->attr
.class_pointer
4294 || CLASS_DATA (fsym
)->attr
.allocatable
);
4296 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4297 allocated on entry, it must be deallocated. */
4298 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4299 && (fsym
->attr
.allocatable
4300 || (fsym
->ts
.type
== BT_CLASS
4301 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4306 gfc_init_block (&block
);
4308 if (e
->ts
.type
== BT_CLASS
)
4309 ptr
= gfc_class_data_get (ptr
);
4311 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4313 gfc_add_expr_to_block (&block
, tmp
);
4314 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4315 void_type_node
, ptr
,
4317 gfc_add_expr_to_block (&block
, tmp
);
4319 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4321 gfc_add_modify (&block
, ptr
,
4322 fold_convert (TREE_TYPE (ptr
),
4323 null_pointer_node
));
4324 gfc_add_expr_to_block (&block
, tmp
);
4326 else if (fsym
->ts
.type
== BT_CLASS
)
4329 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4330 tmp
= gfc_get_symbol_decl (vtab
);
4331 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4332 ptr
= gfc_class_vptr_get (parmse
.expr
);
4333 gfc_add_modify (&block
, ptr
,
4334 fold_convert (TREE_TYPE (ptr
), tmp
));
4335 gfc_add_expr_to_block (&block
, tmp
);
4338 if (fsym
->attr
.optional
4339 && e
->expr_type
== EXPR_VARIABLE
4340 && e
->symtree
->n
.sym
->attr
.optional
)
4342 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4344 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4345 gfc_finish_block (&block
),
4346 build_empty_stmt (input_location
));
4349 tmp
= gfc_finish_block (&block
);
4351 gfc_add_expr_to_block (&se
->pre
, tmp
);
4354 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4355 || fsym
->ts
.type
== BT_ASSUMED
)
4356 && e
->ts
.type
== BT_CLASS
4357 && !CLASS_DATA (e
)->attr
.dimension
4358 && !CLASS_DATA (e
)->attr
.codimension
)
4359 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4361 /* Wrap scalar variable in a descriptor. We need to convert
4362 the address of a pointer back to the pointer itself before,
4363 we can assign it to the data field. */
4365 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4366 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4369 if (TREE_CODE (tmp
) == ADDR_EXPR
4370 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4371 tmp
= TREE_OPERAND (tmp
, 0);
4372 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4374 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4377 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4378 && ((fsym
->attr
.pointer
4379 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4380 || (fsym
->attr
.proc_pointer
4381 && !(e
->expr_type
== EXPR_VARIABLE
4382 && e
->symtree
->n
.sym
->attr
.dummy
))
4383 || (fsym
->attr
.proc_pointer
4384 && e
->expr_type
== EXPR_VARIABLE
4385 && gfc_is_proc_ptr_comp (e
))
4386 || (fsym
->attr
.allocatable
4387 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4389 /* Scalar pointer dummy args require an extra level of
4390 indirection. The null pointer already contains
4391 this level of indirection. */
4392 parm_kind
= SCALAR_POINTER
;
4393 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4397 else if (e
->ts
.type
== BT_CLASS
4398 && fsym
&& fsym
->ts
.type
== BT_CLASS
4399 && (CLASS_DATA (fsym
)->attr
.dimension
4400 || CLASS_DATA (fsym
)->attr
.codimension
))
4402 /* Pass a class array. */
4403 parmse
.use_offset
= 1;
4404 gfc_conv_expr_descriptor (&parmse
, e
);
4406 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4407 allocated on entry, it must be deallocated. */
4408 if (fsym
->attr
.intent
== INTENT_OUT
4409 && CLASS_DATA (fsym
)->attr
.allocatable
)
4414 gfc_init_block (&block
);
4416 ptr
= gfc_class_data_get (ptr
);
4418 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4419 NULL_TREE
, NULL_TREE
,
4422 gfc_add_expr_to_block (&block
, tmp
);
4423 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4424 void_type_node
, ptr
,
4426 gfc_add_expr_to_block (&block
, tmp
);
4427 gfc_reset_vptr (&block
, e
);
4429 if (fsym
->attr
.optional
4430 && e
->expr_type
== EXPR_VARIABLE
4432 || (e
->ref
->type
== REF_ARRAY
4433 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4434 && e
->symtree
->n
.sym
->attr
.optional
)
4436 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4438 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4439 gfc_finish_block (&block
),
4440 build_empty_stmt (input_location
));
4443 tmp
= gfc_finish_block (&block
);
4445 gfc_add_expr_to_block (&se
->pre
, tmp
);
4448 /* The conversion does not repackage the reference to a class
4449 array - _data descriptor. */
4450 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4451 fsym
->attr
.intent
!= INTENT_IN
4452 && (CLASS_DATA (fsym
)->attr
.class_pointer
4453 || CLASS_DATA (fsym
)->attr
.allocatable
),
4455 && e
->expr_type
== EXPR_VARIABLE
4456 && e
->symtree
->n
.sym
->attr
.optional
,
4457 CLASS_DATA (fsym
)->attr
.class_pointer
4458 || CLASS_DATA (fsym
)->attr
.allocatable
);
4462 /* If the procedure requires an explicit interface, the actual
4463 argument is passed according to the corresponding formal
4464 argument. If the corresponding formal argument is a POINTER,
4465 ALLOCATABLE or assumed shape, we do not use g77's calling
4466 convention, and pass the address of the array descriptor
4467 instead. Otherwise we use g77's calling convention. */
4470 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4471 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4472 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4474 f
= f
|| !comp
->attr
.always_explicit
;
4476 f
= f
|| !sym
->attr
.always_explicit
;
4478 /* If the argument is a function call that may not create
4479 a temporary for the result, we have to check that we
4480 can do it, i.e. that there is no alias between this
4481 argument and another one. */
4482 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4488 intent
= fsym
->attr
.intent
;
4490 intent
= INTENT_UNKNOWN
;
4492 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4494 parmse
.force_tmp
= 1;
4496 iarg
= e
->value
.function
.actual
->expr
;
4498 /* Temporary needed if aliasing due to host association. */
4499 if (sym
->attr
.contained
4501 && !sym
->attr
.implicit_pure
4502 && !sym
->attr
.use_assoc
4503 && iarg
->expr_type
== EXPR_VARIABLE
4504 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4505 parmse
.force_tmp
= 1;
4507 /* Ditto within module. */
4508 if (sym
->attr
.use_assoc
4510 && !sym
->attr
.implicit_pure
4511 && iarg
->expr_type
== EXPR_VARIABLE
4512 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4513 parmse
.force_tmp
= 1;
4516 if (e
->expr_type
== EXPR_VARIABLE
4517 && is_subref_array (e
))
4518 /* The actual argument is a component reference to an
4519 array of derived types. In this case, the argument
4520 is converted to a temporary, which is passed and then
4521 written back after the procedure call. */
4522 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4523 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4524 fsym
&& fsym
->attr
.pointer
);
4525 else if (gfc_is_class_array_ref (e
, NULL
)
4526 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4527 /* The actual argument is a component reference to an
4528 array of derived types. In this case, the argument
4529 is converted to a temporary, which is passed and then
4530 written back after the procedure call.
4531 OOP-TODO: Insert code so that if the dynamic type is
4532 the same as the declared type, copy-in/copy-out does
4534 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4535 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4536 fsym
&& fsym
->attr
.pointer
);
4538 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4540 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4541 allocated on entry, it must be deallocated. */
4542 if (fsym
&& fsym
->attr
.allocatable
4543 && fsym
->attr
.intent
== INTENT_OUT
)
4545 tmp
= build_fold_indirect_ref_loc (input_location
,
4547 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4548 if (fsym
->attr
.optional
4549 && e
->expr_type
== EXPR_VARIABLE
4550 && e
->symtree
->n
.sym
->attr
.optional
)
4551 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4553 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4554 tmp
, build_empty_stmt (input_location
));
4555 gfc_add_expr_to_block (&se
->pre
, tmp
);
4560 /* The case with fsym->attr.optional is that of a user subroutine
4561 with an interface indicating an optional argument. When we call
4562 an intrinsic subroutine, however, fsym is NULL, but we might still
4563 have an optional argument, so we proceed to the substitution
4565 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4567 /* If an optional argument is itself an optional dummy argument,
4568 check its presence and substitute a null if absent. This is
4569 only needed when passing an array to an elemental procedure
4570 as then array elements are accessed - or no NULL pointer is
4571 allowed and a "1" or "0" should be passed if not present.
4572 When passing a non-array-descriptor full array to a
4573 non-array-descriptor dummy, no check is needed. For
4574 array-descriptor actual to array-descriptor dummy, see
4575 PR 41911 for why a check has to be inserted.
4576 fsym == NULL is checked as intrinsics required the descriptor
4577 but do not always set fsym. */
4578 if (e
->expr_type
== EXPR_VARIABLE
4579 && e
->symtree
->n
.sym
->attr
.optional
4580 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4581 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4585 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4586 || fsym
->as
->type
== AS_ASSUMED_RANK
4587 || fsym
->as
->type
== AS_DEFERRED
))))))
4588 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4589 e
->representation
.length
);
4594 /* Obtain the character length of an assumed character length
4595 length procedure from the typespec. */
4596 if (fsym
->ts
.type
== BT_CHARACTER
4597 && parmse
.string_length
== NULL_TREE
4598 && e
->ts
.type
== BT_PROCEDURE
4599 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4600 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4601 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4603 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4604 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4608 if (fsym
&& need_interface_mapping
&& e
)
4609 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4611 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4612 gfc_add_block_to_block (&post
, &parmse
.post
);
4614 /* Allocated allocatable components of derived types must be
4615 deallocated for non-variable scalars. Non-variable arrays are
4616 dealt with in trans-array.c(gfc_conv_array_parameter). */
4617 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4618 && e
->ts
.u
.derived
->attr
.alloc_comp
4619 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4620 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4623 tmp
= build_fold_indirect_ref_loc (input_location
,
4625 parm_rank
= e
->rank
;
4633 case (SCALAR_POINTER
):
4634 tmp
= build_fold_indirect_ref_loc (input_location
,
4639 if (e
->expr_type
== EXPR_OP
4640 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4641 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4644 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4645 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4646 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4649 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4651 /* The derived type is passed to gfc_deallocate_alloc_comp.
4652 Therefore, class actuals can handled correctly but derived
4653 types passed to class formals need the _data component. */
4654 tmp
= gfc_class_data_get (tmp
);
4655 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4656 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4659 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4661 gfc_add_expr_to_block (&se
->post
, tmp
);
4664 /* Add argument checking of passing an unallocated/NULL actual to
4665 a nonallocatable/nonpointer dummy. */
4667 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4669 symbol_attribute attr
;
4673 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4674 attr
= gfc_expr_attr (e
);
4676 goto end_pointer_check
;
4678 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4679 allocatable to an optional dummy, cf. 12.5.2.12. */
4680 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4681 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4682 goto end_pointer_check
;
4686 /* If the actual argument is an optional pointer/allocatable and
4687 the formal argument takes an nonpointer optional value,
4688 it is invalid to pass a non-present argument on, even
4689 though there is no technical reason for this in gfortran.
4690 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4691 tree present
, null_ptr
, type
;
4693 if (attr
.allocatable
4694 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4695 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4696 "allocated or not present", e
->symtree
->n
.sym
->name
);
4697 else if (attr
.pointer
4698 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4699 asprintf (&msg
, "Pointer actual argument '%s' is not "
4700 "associated or not present",
4701 e
->symtree
->n
.sym
->name
);
4702 else if (attr
.proc_pointer
4703 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4704 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4705 "associated or not present",
4706 e
->symtree
->n
.sym
->name
);
4708 goto end_pointer_check
;
4710 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4711 type
= TREE_TYPE (present
);
4712 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4713 boolean_type_node
, present
,
4715 null_pointer_node
));
4716 type
= TREE_TYPE (parmse
.expr
);
4717 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4718 boolean_type_node
, parmse
.expr
,
4720 null_pointer_node
));
4721 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4722 boolean_type_node
, present
, null_ptr
);
4726 if (attr
.allocatable
4727 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4728 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4729 "allocated", e
->symtree
->n
.sym
->name
);
4730 else if (attr
.pointer
4731 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4732 asprintf (&msg
, "Pointer actual argument '%s' is not "
4733 "associated", e
->symtree
->n
.sym
->name
);
4734 else if (attr
.proc_pointer
4735 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4736 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4737 "associated", e
->symtree
->n
.sym
->name
);
4739 goto end_pointer_check
;
4743 /* If the argument is passed by value, we need to strip the
4745 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4746 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4748 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4749 boolean_type_node
, tmp
,
4750 fold_convert (TREE_TYPE (tmp
),
4751 null_pointer_node
));
4754 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4760 /* Deferred length dummies pass the character length by reference
4761 so that the value can be returned. */
4762 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4764 tmp
= parmse
.string_length
;
4765 if (TREE_CODE (tmp
) != VAR_DECL
)
4766 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4767 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4770 /* Character strings are passed as two parameters, a length and a
4771 pointer - except for Bind(c) which only passes the pointer.
4772 An unlimited polymorphic formal argument likewise does not
4774 if (parmse
.string_length
!= NULL_TREE
4775 && !sym
->attr
.is_bind_c
4776 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4777 vec_safe_push (stringargs
, parmse
.string_length
);
4779 /* When calling __copy for character expressions to unlimited
4780 polymorphic entities, the dst argument needs a string length. */
4781 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4782 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4783 && arg
->next
&& arg
->next
->expr
4784 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4785 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4786 vec_safe_push (stringargs
, parmse
.string_length
);
4788 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4789 pass the token and the offset as additional arguments. */
4790 if (fsym
&& e
== NULL
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4791 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4792 && !fsym
->attr
.allocatable
)
4793 || (fsym
->ts
.type
== BT_CLASS
4794 && CLASS_DATA (fsym
)->attr
.codimension
4795 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4797 /* Token and offset. */
4798 vec_safe_push (stringargs
, null_pointer_node
);
4799 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4800 gcc_assert (fsym
->attr
.optional
);
4802 else if (fsym
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4803 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4804 && !fsym
->attr
.allocatable
)
4805 || (fsym
->ts
.type
== BT_CLASS
4806 && CLASS_DATA (fsym
)->attr
.codimension
4807 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4809 tree caf_decl
, caf_type
;
4812 caf_decl
= gfc_get_tree_for_caf_expr (e
);
4813 caf_type
= TREE_TYPE (caf_decl
);
4815 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4816 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4817 tmp
= gfc_conv_descriptor_token (caf_decl
);
4818 else if (DECL_LANG_SPECIFIC (caf_decl
)
4819 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4820 tmp
= GFC_DECL_TOKEN (caf_decl
);
4823 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4824 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4825 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4828 vec_safe_push (stringargs
, tmp
);
4830 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4831 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4832 offset
= build_int_cst (gfc_array_index_type
, 0);
4833 else if (DECL_LANG_SPECIFIC (caf_decl
)
4834 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4835 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4836 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4837 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4839 offset
= build_int_cst (gfc_array_index_type
, 0);
4841 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4842 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4845 gcc_assert (POINTER_TYPE_P (caf_type
));
4849 tmp2
= fsym
->ts
.type
== BT_CLASS
4850 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
4851 if ((fsym
->ts
.type
!= BT_CLASS
4852 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4853 || fsym
->as
->type
== AS_ASSUMED_RANK
))
4854 || (fsym
->ts
.type
== BT_CLASS
4855 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
4856 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
4858 if (fsym
->ts
.type
== BT_CLASS
)
4859 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4862 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4863 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
4865 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
4866 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4868 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
4869 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4872 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
4875 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4876 gfc_array_index_type
,
4877 fold_convert (gfc_array_index_type
, tmp2
),
4878 fold_convert (gfc_array_index_type
, tmp
));
4879 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4880 gfc_array_index_type
, offset
, tmp
);
4882 vec_safe_push (stringargs
, offset
);
4885 vec_safe_push (arglist
, parmse
.expr
);
4887 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4894 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4895 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4896 else if (ts
.type
== BT_CHARACTER
)
4898 if (ts
.u
.cl
->length
== NULL
)
4900 /* Assumed character length results are not allowed by 5.1.1.5 of the
4901 standard and are trapped in resolve.c; except in the case of SPREAD
4902 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4903 we take the character length of the first argument for the result.
4904 For dummies, we have to look through the formal argument list for
4905 this function and use the character length found there.*/
4907 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4908 else if (!sym
->attr
.dummy
)
4909 cl
.backend_decl
= (*stringargs
)[0];
4912 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4913 for (; formal
; formal
= formal
->next
)
4914 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4915 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4917 len
= cl
.backend_decl
;
4923 /* Calculate the length of the returned string. */
4924 gfc_init_se (&parmse
, NULL
);
4925 if (need_interface_mapping
)
4926 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4928 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4929 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4930 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4932 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4933 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4934 gfc_charlen_type_node
, tmp
,
4935 build_int_cst (gfc_charlen_type_node
, 0));
4936 cl
.backend_decl
= tmp
;
4939 /* Set up a charlen structure for it. */
4944 len
= cl
.backend_decl
;
4947 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4948 || (!comp
&& gfc_return_by_reference (sym
));
4951 if (se
->direct_byref
)
4953 /* Sometimes, too much indirection can be applied; e.g. for
4954 function_result = array_valued_recursive_function. */
4955 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4956 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4957 && GFC_DESCRIPTOR_TYPE_P
4958 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4959 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4962 /* If the lhs of an assignment x = f(..) is allocatable and
4963 f2003 is allowed, we must do the automatic reallocation.
4964 TODO - deal with intrinsics, without using a temporary. */
4965 if (gfc_option
.flag_realloc_lhs
4966 && se
->ss
&& se
->ss
->loop_chain
4967 && se
->ss
->loop_chain
->is_alloc_lhs
4968 && !expr
->value
.function
.isym
4969 && sym
->result
->as
!= NULL
)
4971 /* Evaluate the bounds of the result, if known. */
4972 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4975 /* Perform the automatic reallocation. */
4976 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4978 gfc_add_expr_to_block (&se
->pre
, tmp
);
4980 /* Pass the temporary as the first argument. */
4981 result
= info
->descriptor
;
4984 result
= build_fold_indirect_ref_loc (input_location
,
4986 vec_safe_push (retargs
, se
->expr
);
4988 else if (comp
&& comp
->attr
.dimension
)
4990 gcc_assert (se
->loop
&& info
);
4992 /* Set the type of the array. */
4993 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4994 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4996 /* Evaluate the bounds of the result, if known. */
4997 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4999 /* If the lhs of an assignment x = f(..) is allocatable and
5000 f2003 is allowed, we must not generate the function call
5001 here but should just send back the results of the mapping.
5002 This is signalled by the function ss being flagged. */
5003 if (gfc_option
.flag_realloc_lhs
5004 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5006 gfc_free_interface_mapping (&mapping
);
5007 return has_alternate_specifier
;
5010 /* Create a temporary to store the result. In case the function
5011 returns a pointer, the temporary will be a shallow copy and
5012 mustn't be deallocated. */
5013 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5014 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5015 tmp
, NULL_TREE
, false,
5016 !comp
->attr
.pointer
, callee_alloc
,
5017 &se
->ss
->info
->expr
->where
);
5019 /* Pass the temporary as the first argument. */
5020 result
= info
->descriptor
;
5021 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5022 vec_safe_push (retargs
, tmp
);
5024 else if (!comp
&& sym
->result
->attr
.dimension
)
5026 gcc_assert (se
->loop
&& info
);
5028 /* Set the type of the array. */
5029 tmp
= gfc_typenode_for_spec (&ts
);
5030 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5032 /* Evaluate the bounds of the result, if known. */
5033 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5035 /* If the lhs of an assignment x = f(..) is allocatable and
5036 f2003 is allowed, we must not generate the function call
5037 here but should just send back the results of the mapping.
5038 This is signalled by the function ss being flagged. */
5039 if (gfc_option
.flag_realloc_lhs
5040 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5042 gfc_free_interface_mapping (&mapping
);
5043 return has_alternate_specifier
;
5046 /* Create a temporary to store the result. In case the function
5047 returns a pointer, the temporary will be a shallow copy and
5048 mustn't be deallocated. */
5049 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5050 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5051 tmp
, NULL_TREE
, false,
5052 !sym
->attr
.pointer
, callee_alloc
,
5053 &se
->ss
->info
->expr
->where
);
5055 /* Pass the temporary as the first argument. */
5056 result
= info
->descriptor
;
5057 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5058 vec_safe_push (retargs
, tmp
);
5060 else if (ts
.type
== BT_CHARACTER
)
5062 /* Pass the string length. */
5063 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5064 type
= build_pointer_type (type
);
5066 /* Return an address to a char[0:len-1]* temporary for
5067 character pointers. */
5068 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5069 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5071 var
= gfc_create_var (type
, "pstr");
5073 if ((!comp
&& sym
->attr
.allocatable
)
5074 || (comp
&& comp
->attr
.allocatable
))
5076 gfc_add_modify (&se
->pre
, var
,
5077 fold_convert (TREE_TYPE (var
),
5078 null_pointer_node
));
5079 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5080 gfc_add_expr_to_block (&se
->post
, tmp
);
5083 /* Provide an address expression for the function arguments. */
5084 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5087 var
= gfc_conv_string_tmp (se
, type
, len
);
5089 vec_safe_push (retargs
, var
);
5093 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5095 type
= gfc_get_complex_type (ts
.kind
);
5096 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5097 vec_safe_push (retargs
, var
);
5100 /* Add the string length to the argument list. */
5101 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5104 if (TREE_CODE (tmp
) != VAR_DECL
)
5105 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5106 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5107 vec_safe_push (retargs
, tmp
);
5109 else if (ts
.type
== BT_CHARACTER
)
5110 vec_safe_push (retargs
, len
);
5112 gfc_free_interface_mapping (&mapping
);
5114 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5115 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5116 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5117 vec_safe_reserve (retargs
, arglen
);
5119 /* Add the return arguments. */
5120 retargs
->splice (arglist
);
5122 /* Add the hidden present status for optional+value to the arguments. */
5123 retargs
->splice (optionalargs
);
5125 /* Add the hidden string length parameters to the arguments. */
5126 retargs
->splice (stringargs
);
5128 /* We may want to append extra arguments here. This is used e.g. for
5129 calls to libgfortran_matmul_??, which need extra information. */
5130 if (!vec_safe_is_empty (append_args
))
5131 retargs
->splice (append_args
);
5134 /* Generate the actual call. */
5135 if (base_object
== NULL_TREE
)
5136 conv_function_val (se
, sym
, expr
);
5138 conv_base_obj_fcn_val (se
, base_object
, expr
);
5140 /* If there are alternate return labels, function type should be
5141 integer. Can't modify the type in place though, since it can be shared
5142 with other functions. For dummy arguments, the typing is done to
5143 this result, even if it has to be repeated for each call. */
5144 if (has_alternate_specifier
5145 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5147 if (!sym
->attr
.dummy
)
5149 TREE_TYPE (sym
->backend_decl
)
5150 = build_function_type (integer_type_node
,
5151 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5152 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5155 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5158 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5159 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5161 /* If we have a pointer function, but we don't want a pointer, e.g.
5164 where f is pointer valued, we have to dereference the result. */
5165 if (!se
->want_pointer
&& !byref
5166 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5167 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5168 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5170 /* f2c calling conventions require a scalar default real function to
5171 return a double precision result. Convert this back to default
5172 real. We only care about the cases that can happen in Fortran 77.
5174 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5175 && sym
->ts
.kind
== gfc_default_real_kind
5176 && !sym
->attr
.always_explicit
)
5177 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5179 /* A pure function may still have side-effects - it may modify its
5181 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5183 if (!sym
->attr
.pure
)
5184 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5189 /* Add the function call to the pre chain. There is no expression. */
5190 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5191 se
->expr
= NULL_TREE
;
5193 if (!se
->direct_byref
)
5195 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5197 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5199 /* Check the data pointer hasn't been modified. This would
5200 happen in a function returning a pointer. */
5201 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5202 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5205 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5208 se
->expr
= info
->descriptor
;
5209 /* Bundle in the string length. */
5210 se
->string_length
= len
;
5212 else if (ts
.type
== BT_CHARACTER
)
5214 /* Dereference for character pointer results. */
5215 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5216 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5217 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5221 se
->string_length
= len
;
5225 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5226 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5231 /* Follow the function call with the argument post block. */
5234 gfc_add_block_to_block (&se
->pre
, &post
);
5236 /* Transformational functions of derived types with allocatable
5237 components must have the result allocatable components copied. */
5238 arg
= expr
->value
.function
.actual
;
5239 if (result
&& arg
&& expr
->rank
5240 && expr
->value
.function
.isym
5241 && expr
->value
.function
.isym
->transformational
5242 && arg
->expr
->ts
.type
== BT_DERIVED
5243 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5246 /* Copy the allocatable components. We have to use a
5247 temporary here to prevent source allocatable components
5248 from being corrupted. */
5249 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5250 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5251 result
, tmp2
, expr
->rank
);
5252 gfc_add_expr_to_block (&se
->pre
, tmp
);
5253 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5255 gfc_add_expr_to_block (&se
->pre
, tmp
);
5257 /* Finally free the temporary's data field. */
5258 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5259 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5260 NULL_TREE
, NULL_TREE
, true,
5262 gfc_add_expr_to_block (&se
->pre
, tmp
);
5266 gfc_add_block_to_block (&se
->post
, &post
);
5268 return has_alternate_specifier
;
5272 /* Fill a character string with spaces. */
5275 fill_with_spaces (tree start
, tree type
, tree size
)
5277 stmtblock_t block
, loop
;
5278 tree i
, el
, exit_label
, cond
, tmp
;
5280 /* For a simple char type, we can call memset(). */
5281 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5282 return build_call_expr_loc (input_location
,
5283 builtin_decl_explicit (BUILT_IN_MEMSET
),
5285 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5286 lang_hooks
.to_target_charset (' ')),
5289 /* Otherwise, we use a loop:
5290 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5294 /* Initialize variables. */
5295 gfc_init_block (&block
);
5296 i
= gfc_create_var (sizetype
, "i");
5297 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5298 el
= gfc_create_var (build_pointer_type (type
), "el");
5299 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5300 exit_label
= gfc_build_label_decl (NULL_TREE
);
5301 TREE_USED (exit_label
) = 1;
5305 gfc_init_block (&loop
);
5307 /* Exit condition. */
5308 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5309 build_zero_cst (sizetype
));
5310 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5311 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5312 build_empty_stmt (input_location
));
5313 gfc_add_expr_to_block (&loop
, tmp
);
5316 gfc_add_modify (&loop
,
5317 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5318 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5320 /* Increment loop variables. */
5321 gfc_add_modify (&loop
, i
,
5322 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5323 TYPE_SIZE_UNIT (type
)));
5324 gfc_add_modify (&loop
, el
,
5325 fold_build_pointer_plus_loc (input_location
,
5326 el
, TYPE_SIZE_UNIT (type
)));
5328 /* Making the loop... actually loop! */
5329 tmp
= gfc_finish_block (&loop
);
5330 tmp
= build1_v (LOOP_EXPR
, tmp
);
5331 gfc_add_expr_to_block (&block
, tmp
);
5333 /* The exit label. */
5334 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5335 gfc_add_expr_to_block (&block
, tmp
);
5338 return gfc_finish_block (&block
);
5342 /* Generate code to copy a string. */
5345 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5346 int dkind
, tree slength
, tree src
, int skind
)
5348 tree tmp
, dlen
, slen
;
5357 stmtblock_t tempblock
;
5359 gcc_assert (dkind
== skind
);
5361 if (slength
!= NULL_TREE
)
5363 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5364 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5368 slen
= build_int_cst (size_type_node
, 1);
5372 if (dlength
!= NULL_TREE
)
5374 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5375 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5379 dlen
= build_int_cst (size_type_node
, 1);
5383 /* Assign directly if the types are compatible. */
5384 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5385 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5387 gfc_add_modify (block
, dsc
, ssc
);
5391 /* Do nothing if the destination length is zero. */
5392 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5393 build_int_cst (size_type_node
, 0));
5395 /* The following code was previously in _gfortran_copy_string:
5397 // The two strings may overlap so we use memmove.
5399 copy_string (GFC_INTEGER_4 destlen, char * dest,
5400 GFC_INTEGER_4 srclen, const char * src)
5402 if (srclen >= destlen)
5404 // This will truncate if too long.
5405 memmove (dest, src, destlen);
5409 memmove (dest, src, srclen);
5411 memset (&dest[srclen], ' ', destlen - srclen);
5415 We're now doing it here for better optimization, but the logic
5418 /* For non-default character kinds, we have to multiply the string
5419 length by the base type size. */
5420 chartype
= gfc_get_char_type (dkind
);
5421 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5422 fold_convert (size_type_node
, slen
),
5423 fold_convert (size_type_node
,
5424 TYPE_SIZE_UNIT (chartype
)));
5425 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5426 fold_convert (size_type_node
, dlen
),
5427 fold_convert (size_type_node
,
5428 TYPE_SIZE_UNIT (chartype
)));
5430 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5431 dest
= fold_convert (pvoid_type_node
, dest
);
5433 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5435 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5436 src
= fold_convert (pvoid_type_node
, src
);
5438 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5440 /* Truncate string if source is too long. */
5441 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5443 tmp2
= build_call_expr_loc (input_location
,
5444 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5445 3, dest
, src
, dlen
);
5447 /* Else copy and pad with spaces. */
5448 tmp3
= build_call_expr_loc (input_location
,
5449 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5450 3, dest
, src
, slen
);
5452 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5453 tmp4
= fill_with_spaces (tmp4
, chartype
,
5454 fold_build2_loc (input_location
, MINUS_EXPR
,
5455 TREE_TYPE(dlen
), dlen
, slen
));
5457 gfc_init_block (&tempblock
);
5458 gfc_add_expr_to_block (&tempblock
, tmp3
);
5459 gfc_add_expr_to_block (&tempblock
, tmp4
);
5460 tmp3
= gfc_finish_block (&tempblock
);
5462 /* The whole copy_string function is there. */
5463 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5465 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5466 build_empty_stmt (input_location
));
5467 gfc_add_expr_to_block (block
, tmp
);
5471 /* Translate a statement function.
5472 The value of a statement function reference is obtained by evaluating the
5473 expression using the values of the actual arguments for the values of the
5474 corresponding dummy arguments. */
5477 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5481 gfc_formal_arglist
*fargs
;
5482 gfc_actual_arglist
*args
;
5485 gfc_saved_var
*saved_vars
;
5491 sym
= expr
->symtree
->n
.sym
;
5492 args
= expr
->value
.function
.actual
;
5493 gfc_init_se (&lse
, NULL
);
5494 gfc_init_se (&rse
, NULL
);
5497 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5499 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5500 temp_vars
= XCNEWVEC (tree
, n
);
5502 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5503 fargs
= fargs
->next
, n
++)
5505 /* Each dummy shall be specified, explicitly or implicitly, to be
5507 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5510 if (fsym
->ts
.type
== BT_CHARACTER
)
5512 /* Copy string arguments. */
5515 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5516 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5518 /* Create a temporary to hold the value. */
5519 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5520 fsym
->ts
.u
.cl
->backend_decl
5521 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5523 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5524 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5526 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5528 gfc_conv_expr (&rse
, args
->expr
);
5529 gfc_conv_string_parameter (&rse
);
5530 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5531 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5533 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5534 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5535 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5536 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5540 /* For everything else, just evaluate the expression. */
5542 /* Create a temporary to hold the value. */
5543 type
= gfc_typenode_for_spec (&fsym
->ts
);
5544 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5546 gfc_conv_expr (&lse
, args
->expr
);
5548 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5549 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5550 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5556 /* Use the temporary variables in place of the real ones. */
5557 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5558 fargs
= fargs
->next
, n
++)
5559 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5561 gfc_conv_expr (se
, sym
->value
);
5563 if (sym
->ts
.type
== BT_CHARACTER
)
5565 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5567 /* Force the expression to the correct length. */
5568 if (!INTEGER_CST_P (se
->string_length
)
5569 || tree_int_cst_lt (se
->string_length
,
5570 sym
->ts
.u
.cl
->backend_decl
))
5572 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5573 tmp
= gfc_create_var (type
, sym
->name
);
5574 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5575 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5576 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5580 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5583 /* Restore the original variables. */
5584 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5585 fargs
= fargs
->next
, n
++)
5586 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5592 /* Translate a function expression. */
5595 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5599 if (expr
->value
.function
.isym
)
5601 gfc_conv_intrinsic_function (se
, expr
);
5605 /* expr.value.function.esym is the resolved (specific) function symbol for
5606 most functions. However this isn't set for dummy procedures. */
5607 sym
= expr
->value
.function
.esym
;
5609 sym
= expr
->symtree
->n
.sym
;
5611 /* We distinguish statement functions from general functions to improve
5612 runtime performance. */
5613 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5615 gfc_conv_statement_function (se
, expr
);
5619 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5624 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5627 is_zero_initializer_p (gfc_expr
* expr
)
5629 if (expr
->expr_type
!= EXPR_CONSTANT
)
5632 /* We ignore constants with prescribed memory representations for now. */
5633 if (expr
->representation
.string
)
5636 switch (expr
->ts
.type
)
5639 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5642 return mpfr_zero_p (expr
->value
.real
)
5643 && MPFR_SIGN (expr
->value
.real
) >= 0;
5646 return expr
->value
.logical
== 0;
5649 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5650 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5651 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5652 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5662 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5667 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5668 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5670 gfc_conv_tmp_array_ref (se
);
5674 /* Build a static initializer. EXPR is the expression for the initial value.
5675 The other parameters describe the variable of the component being
5676 initialized. EXPR may be null. */
5679 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5680 bool array
, bool pointer
, bool procptr
)
5684 if (!(expr
|| pointer
|| procptr
))
5687 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5688 (these are the only two iso_c_binding derived types that can be
5689 used as initialization expressions). If so, we need to modify
5690 the 'expr' to be that for a (void *). */
5691 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5692 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5694 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5696 /* The derived symbol has already been converted to a (void *). Use
5698 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5699 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5701 gfc_init_se (&se
, NULL
);
5702 gfc_conv_constant (&se
, expr
);
5703 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5707 if (array
&& !procptr
)
5710 /* Arrays need special handling. */
5712 ctor
= gfc_build_null_descriptor (type
);
5713 /* Special case assigning an array to zero. */
5714 else if (is_zero_initializer_p (expr
))
5715 ctor
= build_constructor (type
, NULL
);
5717 ctor
= gfc_conv_array_initializer (type
, expr
);
5718 TREE_STATIC (ctor
) = 1;
5721 else if (pointer
|| procptr
)
5723 if (ts
->type
== BT_CLASS
&& !procptr
)
5725 gfc_init_se (&se
, NULL
);
5726 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5727 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5728 TREE_STATIC (se
.expr
) = 1;
5731 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5732 return fold_convert (type
, null_pointer_node
);
5735 gfc_init_se (&se
, NULL
);
5736 se
.want_pointer
= 1;
5737 gfc_conv_expr (&se
, expr
);
5738 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5748 gfc_init_se (&se
, NULL
);
5749 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5750 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5752 gfc_conv_structure (&se
, expr
, 1);
5753 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5754 TREE_STATIC (se
.expr
) = 1;
5759 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5760 TREE_STATIC (ctor
) = 1;
5765 gfc_init_se (&se
, NULL
);
5766 gfc_conv_constant (&se
, expr
);
5767 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5774 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5780 gfc_array_info
*lss_array
;
5787 gfc_start_block (&block
);
5789 /* Initialize the scalarizer. */
5790 gfc_init_loopinfo (&loop
);
5792 gfc_init_se (&lse
, NULL
);
5793 gfc_init_se (&rse
, NULL
);
5796 rss
= gfc_walk_expr (expr
);
5797 if (rss
== gfc_ss_terminator
)
5798 /* The rhs is scalar. Add a ss for the expression. */
5799 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5801 /* Create a SS for the destination. */
5802 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5804 lss_array
= &lss
->info
->data
.array
;
5805 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5806 lss_array
->descriptor
= dest
;
5807 lss_array
->data
= gfc_conv_array_data (dest
);
5808 lss_array
->offset
= gfc_conv_array_offset (dest
);
5809 for (n
= 0; n
< cm
->as
->rank
; n
++)
5811 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5812 lss_array
->stride
[n
] = gfc_index_one_node
;
5814 mpz_init (lss_array
->shape
[n
]);
5815 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5816 cm
->as
->lower
[n
]->value
.integer
);
5817 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5820 /* Associate the SS with the loop. */
5821 gfc_add_ss_to_loop (&loop
, lss
);
5822 gfc_add_ss_to_loop (&loop
, rss
);
5824 /* Calculate the bounds of the scalarization. */
5825 gfc_conv_ss_startstride (&loop
);
5827 /* Setup the scalarizing loops. */
5828 gfc_conv_loop_setup (&loop
, &expr
->where
);
5830 /* Setup the gfc_se structures. */
5831 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5832 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5835 gfc_mark_ss_chain_used (rss
, 1);
5837 gfc_mark_ss_chain_used (lss
, 1);
5839 /* Start the scalarized loop body. */
5840 gfc_start_scalarized_body (&loop
, &body
);
5842 gfc_conv_tmp_array_ref (&lse
);
5843 if (cm
->ts
.type
== BT_CHARACTER
)
5844 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5846 gfc_conv_expr (&rse
, expr
);
5848 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5849 gfc_add_expr_to_block (&body
, tmp
);
5851 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5853 /* Generate the copying loops. */
5854 gfc_trans_scalarizing_loops (&loop
, &body
);
5856 /* Wrap the whole thing up. */
5857 gfc_add_block_to_block (&block
, &loop
.pre
);
5858 gfc_add_block_to_block (&block
, &loop
.post
);
5860 gcc_assert (lss_array
->shape
!= NULL
);
5861 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5862 gfc_cleanup_loop (&loop
);
5864 return gfc_finish_block (&block
);
5869 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5879 gfc_expr
*arg
= NULL
;
5881 gfc_start_block (&block
);
5882 gfc_init_se (&se
, NULL
);
5884 /* Get the descriptor for the expressions. */
5885 se
.want_pointer
= 0;
5886 gfc_conv_expr_descriptor (&se
, expr
);
5887 gfc_add_block_to_block (&block
, &se
.pre
);
5888 gfc_add_modify (&block
, dest
, se
.expr
);
5890 /* Deal with arrays of derived types with allocatable components. */
5891 if (cm
->ts
.type
== BT_DERIVED
5892 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5893 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5897 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5898 TREE_TYPE(cm
->backend_decl
),
5901 gfc_add_expr_to_block (&block
, tmp
);
5902 gfc_add_block_to_block (&block
, &se
.post
);
5904 if (expr
->expr_type
!= EXPR_VARIABLE
)
5905 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5908 /* We need to know if the argument of a conversion function is a
5909 variable, so that the correct lower bound can be used. */
5910 if (expr
->expr_type
== EXPR_FUNCTION
5911 && expr
->value
.function
.isym
5912 && expr
->value
.function
.isym
->conversion
5913 && expr
->value
.function
.actual
->expr
5914 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5915 arg
= expr
->value
.function
.actual
->expr
;
5917 /* Obtain the array spec of full array references. */
5919 as
= gfc_get_full_arrayspec_from_expr (arg
);
5921 as
= gfc_get_full_arrayspec_from_expr (expr
);
5923 /* Shift the lbound and ubound of temporaries to being unity,
5924 rather than zero, based. Always calculate the offset. */
5925 offset
= gfc_conv_descriptor_offset_get (dest
);
5926 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5927 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5929 for (n
= 0; n
< expr
->rank
; n
++)
5934 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5935 TODO It looks as if gfc_conv_expr_descriptor should return
5936 the correct bounds and that the following should not be
5937 necessary. This would simplify gfc_conv_intrinsic_bound
5939 if (as
&& as
->lower
[n
])
5942 gfc_init_se (&lbse
, NULL
);
5943 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5944 gfc_add_block_to_block (&block
, &lbse
.pre
);
5945 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5949 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5950 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5954 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5957 lbound
= gfc_index_one_node
;
5959 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5961 /* Shift the bounds and set the offset accordingly. */
5962 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5963 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5964 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5965 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5967 gfc_conv_descriptor_ubound_set (&block
, dest
,
5968 gfc_rank_cst
[n
], tmp
);
5969 gfc_conv_descriptor_lbound_set (&block
, dest
,
5970 gfc_rank_cst
[n
], lbound
);
5972 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5973 gfc_conv_descriptor_lbound_get (dest
,
5975 gfc_conv_descriptor_stride_get (dest
,
5977 gfc_add_modify (&block
, tmp2
, tmp
);
5978 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5980 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5985 /* If a conversion expression has a null data pointer
5986 argument, nullify the allocatable component. */
5990 if (arg
->symtree
->n
.sym
->attr
.allocatable
5991 || arg
->symtree
->n
.sym
->attr
.pointer
)
5993 non_null_expr
= gfc_finish_block (&block
);
5994 gfc_start_block (&block
);
5995 gfc_conv_descriptor_data_set (&block
, dest
,
5997 null_expr
= gfc_finish_block (&block
);
5998 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5999 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6000 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6001 return build3_v (COND_EXPR
, tmp
,
6002 null_expr
, non_null_expr
);
6006 return gfc_finish_block (&block
);
6010 /* Assign a single component of a derived type constructor. */
6013 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6020 gfc_start_block (&block
);
6022 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6024 gfc_init_se (&se
, NULL
);
6025 /* Pointer component. */
6026 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6027 && !cm
->attr
.proc_pointer
)
6029 /* Array pointer. */
6030 if (expr
->expr_type
== EXPR_NULL
)
6031 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6034 se
.direct_byref
= 1;
6036 gfc_conv_expr_descriptor (&se
, expr
);
6037 gfc_add_block_to_block (&block
, &se
.pre
);
6038 gfc_add_block_to_block (&block
, &se
.post
);
6043 /* Scalar pointers. */
6044 se
.want_pointer
= 1;
6045 gfc_conv_expr (&se
, expr
);
6046 gfc_add_block_to_block (&block
, &se
.pre
);
6048 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6049 && expr
->symtree
->n
.sym
->attr
.dummy
)
6050 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6052 gfc_add_modify (&block
, dest
,
6053 fold_convert (TREE_TYPE (dest
), se
.expr
));
6054 gfc_add_block_to_block (&block
, &se
.post
);
6057 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6059 /* NULL initialization for CLASS components. */
6060 tmp
= gfc_trans_structure_assign (dest
,
6061 gfc_class_initializer (&cm
->ts
, expr
));
6062 gfc_add_expr_to_block (&block
, tmp
);
6064 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6065 && !cm
->attr
.proc_pointer
)
6067 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6068 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6069 else if (cm
->attr
.allocatable
)
6071 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6072 gfc_add_expr_to_block (&block
, tmp
);
6076 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6077 gfc_add_expr_to_block (&block
, tmp
);
6080 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6082 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6084 gfc_init_se (&se
, NULL
);
6085 gfc_conv_expr (&se
, expr
);
6086 gfc_add_block_to_block (&block
, &se
.pre
);
6087 gfc_add_modify (&block
, dest
,
6088 fold_convert (TREE_TYPE (dest
), se
.expr
));
6089 gfc_add_block_to_block (&block
, &se
.post
);
6093 /* Nested constructors. */
6094 tmp
= gfc_trans_structure_assign (dest
, expr
);
6095 gfc_add_expr_to_block (&block
, tmp
);
6098 else if (gfc_deferred_strlen (cm
, &tmp
))
6102 gcc_assert (strlen
);
6103 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6105 TREE_OPERAND (dest
, 0),
6108 if (expr
->expr_type
== EXPR_NULL
)
6110 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6111 gfc_add_modify (&block
, dest
, tmp
);
6112 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6113 gfc_add_modify (&block
, strlen
, tmp
);
6118 gfc_init_se (&se
, NULL
);
6119 gfc_conv_expr (&se
, expr
);
6120 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6121 tmp
= build_call_expr_loc (input_location
,
6122 builtin_decl_explicit (BUILT_IN_MALLOC
),
6124 gfc_add_modify (&block
, dest
,
6125 fold_convert (TREE_TYPE (dest
), tmp
));
6126 gfc_add_modify (&block
, strlen
, se
.string_length
);
6127 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6128 gfc_add_expr_to_block (&block
, tmp
);
6131 else if (!cm
->attr
.deferred_parameter
)
6133 /* Scalar component (excluding deferred parameters). */
6134 gfc_init_se (&se
, NULL
);
6135 gfc_init_se (&lse
, NULL
);
6137 gfc_conv_expr (&se
, expr
);
6138 if (cm
->ts
.type
== BT_CHARACTER
)
6139 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6141 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6142 gfc_add_expr_to_block (&block
, tmp
);
6144 return gfc_finish_block (&block
);
6147 /* Assign a derived type constructor to a variable. */
6150 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6158 gfc_start_block (&block
);
6159 cm
= expr
->ts
.u
.derived
->components
;
6161 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6162 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6163 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6167 gcc_assert (cm
->backend_decl
== NULL
);
6168 gfc_init_se (&se
, NULL
);
6169 gfc_init_se (&lse
, NULL
);
6170 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6172 gfc_add_modify (&block
, lse
.expr
,
6173 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6175 return gfc_finish_block (&block
);
6178 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6179 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6181 /* Skip absent members in default initializers. */
6185 field
= cm
->backend_decl
;
6186 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6187 dest
, field
, NULL_TREE
);
6188 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6189 gfc_add_expr_to_block (&block
, tmp
);
6191 return gfc_finish_block (&block
);
6194 /* Build an expression for a constructor. If init is nonzero then
6195 this is part of a static variable initializer. */
6198 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6205 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6207 gcc_assert (se
->ss
== NULL
);
6208 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6209 type
= gfc_typenode_for_spec (&expr
->ts
);
6213 /* Create a temporary variable and fill it in. */
6214 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6215 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6216 gfc_add_expr_to_block (&se
->pre
, tmp
);
6220 cm
= expr
->ts
.u
.derived
->components
;
6222 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6223 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6225 /* Skip absent members in default initializers and allocatable
6226 components. Although the latter have a default initializer
6227 of EXPR_NULL,... by default, the static nullify is not needed
6228 since this is done every time we come into scope. */
6229 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6232 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6233 && strcmp (cm
->name
, "_extends") == 0
6234 && cm
->initializer
->symtree
)
6238 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6239 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6240 vtab
= unshare_expr_without_location (vtab
);
6241 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6243 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6245 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6246 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6250 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6251 TREE_TYPE (cm
->backend_decl
),
6252 cm
->attr
.dimension
, cm
->attr
.pointer
,
6253 cm
->attr
.proc_pointer
);
6254 val
= unshare_expr_without_location (val
);
6256 /* Append it to the constructor list. */
6257 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6260 se
->expr
= build_constructor (type
, v
);
6262 TREE_CONSTANT (se
->expr
) = 1;
6266 /* Translate a substring expression. */
6269 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6275 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6277 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6278 expr
->value
.character
.length
,
6279 expr
->value
.character
.string
);
6281 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6282 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6285 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6289 /* Entry point for expression translation. Evaluates a scalar quantity.
6290 EXPR is the expression to be translated, and SE is the state structure if
6291 called from within the scalarized. */
6294 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6299 if (ss
&& ss
->info
->expr
== expr
6300 && (ss
->info
->type
== GFC_SS_SCALAR
6301 || ss
->info
->type
== GFC_SS_REFERENCE
))
6303 gfc_ss_info
*ss_info
;
6306 /* Substitute a scalar expression evaluated outside the scalarization
6308 se
->expr
= ss_info
->data
.scalar
.value
;
6309 /* If the reference can be NULL, the value field contains the reference,
6310 not the value the reference points to (see gfc_add_loop_ss_code). */
6311 if (ss_info
->can_be_null_ref
)
6312 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6314 se
->string_length
= ss_info
->string_length
;
6315 gfc_advance_se_ss_chain (se
);
6319 /* We need to convert the expressions for the iso_c_binding derived types.
6320 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6321 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6322 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6323 updated to be an integer with a kind equal to the size of a (void *). */
6324 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6326 if (expr
->expr_type
== EXPR_VARIABLE
6327 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6328 || expr
->symtree
->n
.sym
->intmod_sym_id
6329 == ISOCBINDING_NULL_FUNPTR
))
6331 /* Set expr_type to EXPR_NULL, which will result in
6332 null_pointer_node being used below. */
6333 expr
->expr_type
= EXPR_NULL
;
6337 /* Update the type/kind of the expression to be what the new
6338 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6339 expr
->ts
.type
= BT_INTEGER
;
6340 expr
->ts
.f90_type
= BT_VOID
;
6341 expr
->ts
.kind
= gfc_index_integer_kind
;
6345 gfc_fix_class_refs (expr
);
6347 switch (expr
->expr_type
)
6350 gfc_conv_expr_op (se
, expr
);
6354 gfc_conv_function_expr (se
, expr
);
6358 gfc_conv_constant (se
, expr
);
6362 gfc_conv_variable (se
, expr
);
6366 se
->expr
= null_pointer_node
;
6369 case EXPR_SUBSTRING
:
6370 gfc_conv_substring_expr (se
, expr
);
6373 case EXPR_STRUCTURE
:
6374 gfc_conv_structure (se
, expr
, 0);
6378 gfc_conv_array_constructor_expr (se
, expr
);
6387 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6388 of an assignment. */
6390 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6392 gfc_conv_expr (se
, expr
);
6393 /* All numeric lvalues should have empty post chains. If not we need to
6394 figure out a way of rewriting an lvalue so that it has no post chain. */
6395 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6398 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6399 numeric expressions. Used for scalar values where inserting cleanup code
6402 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6406 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6407 gfc_conv_expr (se
, expr
);
6410 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6411 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6413 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6417 /* Helper to translate an expression and convert it to a particular type. */
6419 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6421 gfc_conv_expr_val (se
, expr
);
6422 se
->expr
= convert (type
, se
->expr
);
6426 /* Converts an expression so that it can be passed by reference. Scalar
6430 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6436 if (ss
&& ss
->info
->expr
== expr
6437 && ss
->info
->type
== GFC_SS_REFERENCE
)
6439 /* Returns a reference to the scalar evaluated outside the loop
6441 gfc_conv_expr (se
, expr
);
6443 if (expr
->ts
.type
== BT_CHARACTER
6444 && expr
->expr_type
!= EXPR_FUNCTION
)
6445 gfc_conv_string_parameter (se
);
6447 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6452 if (expr
->ts
.type
== BT_CHARACTER
)
6454 gfc_conv_expr (se
, expr
);
6455 gfc_conv_string_parameter (se
);
6459 if (expr
->expr_type
== EXPR_VARIABLE
)
6461 se
->want_pointer
= 1;
6462 gfc_conv_expr (se
, expr
);
6465 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6466 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6467 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6473 if (expr
->expr_type
== EXPR_FUNCTION
6474 && ((expr
->value
.function
.esym
6475 && expr
->value
.function
.esym
->result
->attr
.pointer
6476 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6477 || (!expr
->value
.function
.esym
&& !expr
->ref
6478 && expr
->symtree
->n
.sym
->attr
.pointer
6479 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6481 se
->want_pointer
= 1;
6482 gfc_conv_expr (se
, expr
);
6483 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6484 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6489 gfc_conv_expr (se
, expr
);
6491 /* Create a temporary var to hold the value. */
6492 if (TREE_CONSTANT (se
->expr
))
6494 tree tmp
= se
->expr
;
6495 STRIP_TYPE_NOPS (tmp
);
6496 var
= build_decl (input_location
,
6497 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6498 DECL_INITIAL (var
) = tmp
;
6499 TREE_STATIC (var
) = 1;
6504 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6505 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6507 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6509 /* Take the address of that value. */
6510 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6511 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6512 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6513 && expr
->ts
.u
.derived
->attr
.alloc_comp
6514 && expr
->expr_type
!= EXPR_VARIABLE
)
6518 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6519 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6521 /* The components shall be deallocated before
6522 their containing entity. */
6523 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6529 gfc_trans_pointer_assign (gfc_code
* code
)
6531 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6535 /* Generate code for a pointer assignment. */
6538 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6540 gfc_expr
*expr1_vptr
= NULL
;
6550 gfc_start_block (&block
);
6552 gfc_init_se (&lse
, NULL
);
6554 /* Check whether the expression is a scalar or not; we cannot use
6555 expr1->rank as it can be nonzero for proc pointers. */
6556 ss
= gfc_walk_expr (expr1
);
6557 scalar
= ss
== gfc_ss_terminator
;
6559 gfc_free_ss_chain (ss
);
6561 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6562 && expr2
->expr_type
!= EXPR_FUNCTION
)
6564 gfc_add_data_component (expr2
);
6565 /* The following is required as gfc_add_data_component doesn't
6566 update ts.type if there is a tailing REF_ARRAY. */
6567 expr2
->ts
.type
= BT_DERIVED
;
6572 /* Scalar pointers. */
6573 lse
.want_pointer
= 1;
6574 gfc_conv_expr (&lse
, expr1
);
6575 gfc_init_se (&rse
, NULL
);
6576 rse
.want_pointer
= 1;
6577 gfc_conv_expr (&rse
, expr2
);
6579 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6580 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6581 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6584 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6585 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6586 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6589 gfc_add_block_to_block (&block
, &lse
.pre
);
6590 gfc_add_block_to_block (&block
, &rse
.pre
);
6592 /* Check character lengths if character expression. The test is only
6593 really added if -fbounds-check is enabled. Exclude deferred
6594 character length lefthand sides. */
6595 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6596 && !expr1
->ts
.deferred
6597 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6598 && !gfc_is_proc_ptr_comp (expr1
))
6600 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6601 gcc_assert (lse
.string_length
&& rse
.string_length
);
6602 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6603 lse
.string_length
, rse
.string_length
,
6607 /* The assignment to an deferred character length sets the string
6608 length to that of the rhs. */
6609 if (expr1
->ts
.deferred
)
6611 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6612 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6613 else if (lse
.string_length
!= NULL
)
6614 gfc_add_modify (&block
, lse
.string_length
,
6615 build_int_cst (gfc_charlen_type_node
, 0));
6618 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6619 rse
.expr
= gfc_class_data_get (rse
.expr
);
6621 gfc_add_modify (&block
, lse
.expr
,
6622 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6624 gfc_add_block_to_block (&block
, &rse
.post
);
6625 gfc_add_block_to_block (&block
, &lse
.post
);
6632 tree strlen_rhs
= NULL_TREE
;
6634 /* Array pointer. Find the last reference on the LHS and if it is an
6635 array section ref, we're dealing with bounds remapping. In this case,
6636 set it to AR_FULL so that gfc_conv_expr_descriptor does
6637 not see it and process the bounds remapping afterwards explicitly. */
6638 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6639 if (!remap
->next
&& remap
->type
== REF_ARRAY
6640 && remap
->u
.ar
.type
== AR_SECTION
)
6642 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6644 gfc_init_se (&lse
, NULL
);
6646 lse
.descriptor_only
= 1;
6647 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6648 && expr1
->ts
.type
== BT_CLASS
)
6649 expr1_vptr
= gfc_copy_expr (expr1
);
6650 gfc_conv_expr_descriptor (&lse
, expr1
);
6651 strlen_lhs
= lse
.string_length
;
6654 if (expr2
->expr_type
== EXPR_NULL
)
6656 /* Just set the data pointer to null. */
6657 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6659 else if (rank_remap
)
6661 /* If we are rank-remapping, just get the RHS's descriptor and
6662 process this later on. */
6663 gfc_init_se (&rse
, NULL
);
6664 rse
.direct_byref
= 1;
6665 rse
.byref_noassign
= 1;
6667 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6669 gfc_conv_function_expr (&rse
, expr2
);
6671 if (expr1
->ts
.type
!= BT_CLASS
)
6672 rse
.expr
= gfc_class_data_get (rse
.expr
);
6675 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6676 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6678 gfc_add_vptr_component (expr1_vptr
);
6679 gfc_init_se (&rse
, NULL
);
6680 rse
.want_pointer
= 1;
6681 gfc_conv_expr (&rse
, expr1_vptr
);
6682 gfc_add_modify (&lse
.pre
, rse
.expr
,
6683 fold_convert (TREE_TYPE (rse
.expr
),
6684 gfc_class_vptr_get (tmp
)));
6685 rse
.expr
= gfc_class_data_get (tmp
);
6688 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6690 tree bound
[GFC_MAX_DIMENSIONS
];
6693 for (i
= 0; i
< expr2
->rank
; i
++)
6694 bound
[i
] = NULL_TREE
;
6695 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6696 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6698 GFC_ARRAY_POINTER_CONT
, false);
6699 tmp
= gfc_create_var (tmp
, "ptrtemp");
6701 lse
.direct_byref
= 1;
6702 gfc_conv_expr_descriptor (&lse
, expr2
);
6703 strlen_rhs
= lse
.string_length
;
6708 gfc_conv_expr_descriptor (&rse
, expr2
);
6709 strlen_rhs
= rse
.string_length
;
6712 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6714 /* Assign directly to the LHS's descriptor. */
6715 lse
.direct_byref
= 1;
6716 gfc_conv_expr_descriptor (&lse
, expr2
);
6717 strlen_rhs
= lse
.string_length
;
6719 /* If this is a subreference array pointer assignment, use the rhs
6720 descriptor element size for the lhs span. */
6721 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6723 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6724 gfc_init_se (&rse
, NULL
);
6725 rse
.descriptor_only
= 1;
6726 gfc_conv_expr (&rse
, expr2
);
6727 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6728 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6729 if (!INTEGER_CST_P (tmp
))
6730 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6731 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6734 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6736 gfc_init_se (&rse
, NULL
);
6737 rse
.want_pointer
= 1;
6738 gfc_conv_function_expr (&rse
, expr2
);
6739 if (expr1
->ts
.type
!= BT_CLASS
)
6741 rse
.expr
= gfc_class_data_get (rse
.expr
);
6742 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6746 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6747 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6749 gfc_add_vptr_component (expr1_vptr
);
6750 gfc_init_se (&rse
, NULL
);
6751 rse
.want_pointer
= 1;
6752 gfc_conv_expr (&rse
, expr1_vptr
);
6753 gfc_add_modify (&lse
.pre
, rse
.expr
,
6754 fold_convert (TREE_TYPE (rse
.expr
),
6755 gfc_class_vptr_get (tmp
)));
6756 rse
.expr
= gfc_class_data_get (tmp
);
6757 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6762 /* Assign to a temporary descriptor and then copy that
6763 temporary to the pointer. */
6764 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6766 lse
.direct_byref
= 1;
6767 gfc_conv_expr_descriptor (&lse
, expr2
);
6768 strlen_rhs
= lse
.string_length
;
6769 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6773 gfc_free_expr (expr1_vptr
);
6775 gfc_add_block_to_block (&block
, &lse
.pre
);
6777 gfc_add_block_to_block (&block
, &rse
.pre
);
6779 /* If we do bounds remapping, update LHS descriptor accordingly. */
6783 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6787 /* Do rank remapping. We already have the RHS's descriptor
6788 converted in rse and now have to build the correct LHS
6789 descriptor for it. */
6793 tree lbound
, ubound
;
6796 dtype
= gfc_conv_descriptor_dtype (desc
);
6797 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6798 gfc_add_modify (&block
, dtype
, tmp
);
6800 /* Copy data pointer. */
6801 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6802 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6804 /* Copy offset but adjust it such that it would correspond
6805 to a lbound of zero. */
6806 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6807 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6809 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6811 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6813 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6814 gfc_array_index_type
, stride
, lbound
);
6815 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6816 gfc_array_index_type
, offs
, tmp
);
6818 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6820 /* Set the bounds as declared for the LHS and calculate strides as
6821 well as another offset update accordingly. */
6822 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6824 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6829 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6831 /* Convert declared bounds. */
6832 gfc_init_se (&lower_se
, NULL
);
6833 gfc_init_se (&upper_se
, NULL
);
6834 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6835 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6837 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6838 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6840 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6841 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6843 lbound
= gfc_evaluate_now (lbound
, &block
);
6844 ubound
= gfc_evaluate_now (ubound
, &block
);
6846 gfc_add_block_to_block (&block
, &lower_se
.post
);
6847 gfc_add_block_to_block (&block
, &upper_se
.post
);
6849 /* Set bounds in descriptor. */
6850 gfc_conv_descriptor_lbound_set (&block
, desc
,
6851 gfc_rank_cst
[dim
], lbound
);
6852 gfc_conv_descriptor_ubound_set (&block
, desc
,
6853 gfc_rank_cst
[dim
], ubound
);
6856 stride
= gfc_evaluate_now (stride
, &block
);
6857 gfc_conv_descriptor_stride_set (&block
, desc
,
6858 gfc_rank_cst
[dim
], stride
);
6860 /* Update offset. */
6861 offs
= gfc_conv_descriptor_offset_get (desc
);
6862 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6863 gfc_array_index_type
, lbound
, stride
);
6864 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6865 gfc_array_index_type
, offs
, tmp
);
6866 offs
= gfc_evaluate_now (offs
, &block
);
6867 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6869 /* Update stride. */
6870 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6871 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6872 gfc_array_index_type
, stride
, tmp
);
6877 /* Bounds remapping. Just shift the lower bounds. */
6879 gcc_assert (expr1
->rank
== expr2
->rank
);
6881 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6885 gcc_assert (remap
->u
.ar
.start
[dim
]);
6886 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6887 gfc_init_se (&lbound_se
, NULL
);
6888 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6890 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6891 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6892 dim
, lbound_se
.expr
);
6893 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6898 /* Check string lengths if applicable. The check is only really added
6899 to the output code if -fbounds-check is enabled. */
6900 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6902 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6903 gcc_assert (strlen_lhs
&& strlen_rhs
);
6904 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6905 strlen_lhs
, strlen_rhs
, &block
);
6908 /* If rank remapping was done, check with -fcheck=bounds that
6909 the target is at least as large as the pointer. */
6910 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6916 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6917 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6919 lsize
= gfc_evaluate_now (lsize
, &block
);
6920 rsize
= gfc_evaluate_now (rsize
, &block
);
6921 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6924 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6925 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6929 gfc_add_block_to_block (&block
, &lse
.post
);
6931 gfc_add_block_to_block (&block
, &rse
.post
);
6934 return gfc_finish_block (&block
);
6938 /* Makes sure se is suitable for passing as a function string parameter. */
6939 /* TODO: Need to check all callers of this function. It may be abused. */
6942 gfc_conv_string_parameter (gfc_se
* se
)
6946 if (TREE_CODE (se
->expr
) == STRING_CST
)
6948 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6949 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6953 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6955 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6957 type
= TREE_TYPE (se
->expr
);
6958 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6962 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6964 type
= build_pointer_type (type
);
6965 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6969 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6973 /* Generate code for assignment of scalar variables. Includes character
6974 strings and derived types with allocatable components.
6975 If you know that the LHS has no allocations, set dealloc to false.
6977 DEEP_COPY has no effect if the typespec TS is not a derived type with
6978 allocatable components. Otherwise, if it is set, an explicit copy of each
6979 allocatable component is made. This is necessary as a simple copy of the
6980 whole object would copy array descriptors as is, so that the lhs's
6981 allocatable components would point to the rhs's after the assignment.
6982 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6983 necessary if the rhs is a non-pointer function, as the allocatable components
6984 are not accessible by other means than the function's result after the
6985 function has returned. It is even more subtle when temporaries are involved,
6986 as the two following examples show:
6987 1. When we evaluate an array constructor, a temporary is created. Thus
6988 there is theoretically no alias possible. However, no deep copy is
6989 made for this temporary, so that if the constructor is made of one or
6990 more variable with allocatable components, those components still point
6991 to the variable's: DEEP_COPY should be set for the assignment from the
6992 temporary to the lhs in that case.
6993 2. When assigning a scalar to an array, we evaluate the scalar value out
6994 of the loop, store it into a temporary variable, and assign from that.
6995 In that case, deep copying when assigning to the temporary would be a
6996 waste of resources; however deep copies should happen when assigning from
6997 the temporary to each array element: again DEEP_COPY should be set for
6998 the assignment from the temporary to the lhs. */
7001 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7002 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7008 gfc_init_block (&block
);
7010 if (ts
.type
== BT_CHARACTER
)
7015 if (lse
->string_length
!= NULL_TREE
)
7017 gfc_conv_string_parameter (lse
);
7018 gfc_add_block_to_block (&block
, &lse
->pre
);
7019 llen
= lse
->string_length
;
7022 if (rse
->string_length
!= NULL_TREE
)
7024 gcc_assert (rse
->string_length
!= NULL_TREE
);
7025 gfc_conv_string_parameter (rse
);
7026 gfc_add_block_to_block (&block
, &rse
->pre
);
7027 rlen
= rse
->string_length
;
7030 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7031 rse
->expr
, ts
.kind
);
7033 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7035 tree tmp_var
= NULL_TREE
;
7038 /* Are the rhs and the lhs the same? */
7041 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7042 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7043 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7044 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7047 /* Deallocate the lhs allocated components as long as it is not
7048 the same as the rhs. This must be done following the assignment
7049 to prevent deallocating data that could be used in the rhs
7051 if (!l_is_temp
&& dealloc
)
7053 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7054 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7056 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7058 gfc_add_expr_to_block (&lse
->post
, tmp
);
7061 gfc_add_block_to_block (&block
, &rse
->pre
);
7062 gfc_add_block_to_block (&block
, &lse
->pre
);
7064 gfc_add_modify (&block
, lse
->expr
,
7065 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7067 /* Restore pointer address of coarray components. */
7068 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7070 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7071 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7073 gfc_add_expr_to_block (&block
, tmp
);
7076 /* Do a deep copy if the rhs is a variable, if it is not the
7080 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7081 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7083 gfc_add_expr_to_block (&block
, tmp
);
7086 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7088 gfc_add_block_to_block (&block
, &lse
->pre
);
7089 gfc_add_block_to_block (&block
, &rse
->pre
);
7090 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7091 TREE_TYPE (lse
->expr
), rse
->expr
);
7092 gfc_add_modify (&block
, lse
->expr
, tmp
);
7096 gfc_add_block_to_block (&block
, &lse
->pre
);
7097 gfc_add_block_to_block (&block
, &rse
->pre
);
7099 gfc_add_modify (&block
, lse
->expr
,
7100 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7103 gfc_add_block_to_block (&block
, &lse
->post
);
7104 gfc_add_block_to_block (&block
, &rse
->post
);
7106 return gfc_finish_block (&block
);
7110 /* There are quite a lot of restrictions on the optimisation in using an
7111 array function assign without a temporary. */
7114 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7117 bool seen_array_ref
;
7119 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7121 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7122 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7125 /* Elemental functions are scalarized so that they don't need a
7126 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7127 they would need special treatment in gfc_trans_arrayfunc_assign. */
7128 if (expr2
->value
.function
.esym
!= NULL
7129 && expr2
->value
.function
.esym
->attr
.elemental
)
7132 /* Need a temporary if rhs is not FULL or a contiguous section. */
7133 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7136 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7137 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7140 /* Functions returning pointers or allocatables need temporaries. */
7141 c
= expr2
->value
.function
.esym
7142 ? (expr2
->value
.function
.esym
->attr
.pointer
7143 || expr2
->value
.function
.esym
->attr
.allocatable
)
7144 : (expr2
->symtree
->n
.sym
->attr
.pointer
7145 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7149 /* Character array functions need temporaries unless the
7150 character lengths are the same. */
7151 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7153 if (expr1
->ts
.u
.cl
->length
== NULL
7154 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7157 if (expr2
->ts
.u
.cl
->length
== NULL
7158 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7161 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7162 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7166 /* Check that no LHS component references appear during an array
7167 reference. This is needed because we do not have the means to
7168 span any arbitrary stride with an array descriptor. This check
7169 is not needed for the rhs because the function result has to be
7171 seen_array_ref
= false;
7172 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7174 if (ref
->type
== REF_ARRAY
)
7175 seen_array_ref
= true;
7176 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7180 /* Check for a dependency. */
7181 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7182 expr2
->value
.function
.esym
,
7183 expr2
->value
.function
.actual
,
7187 /* If we have reached here with an intrinsic function, we do not
7188 need a temporary except in the particular case that reallocation
7189 on assignment is active and the lhs is allocatable and a target. */
7190 if (expr2
->value
.function
.isym
)
7191 return (gfc_option
.flag_realloc_lhs
7192 && sym
->attr
.allocatable
7193 && sym
->attr
.target
);
7195 /* If the LHS is a dummy, we need a temporary if it is not
7197 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7200 /* If the lhs has been host_associated, is in common, a pointer or is
7201 a target and the function is not using a RESULT variable, aliasing
7202 can occur and a temporary is needed. */
7203 if ((sym
->attr
.host_assoc
7204 || sym
->attr
.in_common
7205 || sym
->attr
.pointer
7206 || sym
->attr
.cray_pointee
7207 || sym
->attr
.target
)
7208 && expr2
->symtree
!= NULL
7209 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7212 /* A PURE function can unconditionally be called without a temporary. */
7213 if (expr2
->value
.function
.esym
!= NULL
7214 && expr2
->value
.function
.esym
->attr
.pure
)
7217 /* Implicit_pure functions are those which could legally be declared
7219 if (expr2
->value
.function
.esym
!= NULL
7220 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7223 if (!sym
->attr
.use_assoc
7224 && !sym
->attr
.in_common
7225 && !sym
->attr
.pointer
7226 && !sym
->attr
.target
7227 && !sym
->attr
.cray_pointee
7228 && expr2
->value
.function
.esym
)
7230 /* A temporary is not needed if the function is not contained and
7231 the variable is local or host associated and not a pointer or
7233 if (!expr2
->value
.function
.esym
->attr
.contained
)
7236 /* A temporary is not needed if the lhs has never been host
7237 associated and the procedure is contained. */
7238 else if (!sym
->attr
.host_assoc
)
7241 /* A temporary is not needed if the variable is local and not
7242 a pointer, a target or a result. */
7244 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7248 /* Default to temporary use. */
7253 /* Provide the loop info so that the lhs descriptor can be built for
7254 reallocatable assignments from extrinsic function calls. */
7257 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7260 /* Signal that the function call should not be made by
7261 gfc_conv_loop_setup. */
7262 se
->ss
->is_alloc_lhs
= 1;
7263 gfc_init_loopinfo (loop
);
7264 gfc_add_ss_to_loop (loop
, *ss
);
7265 gfc_add_ss_to_loop (loop
, se
->ss
);
7266 gfc_conv_ss_startstride (loop
);
7267 gfc_conv_loop_setup (loop
, where
);
7268 gfc_copy_loopinfo_to_se (se
, loop
);
7269 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7270 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7271 se
->ss
->is_alloc_lhs
= 0;
7275 /* For assignment to a reallocatable lhs from intrinsic functions,
7276 replace the se.expr (ie. the result) with a temporary descriptor.
7277 Null the data field so that the library allocates space for the
7278 result. Free the data of the original descriptor after the function,
7279 in case it appears in an argument expression and transfer the
7280 result to the original descriptor. */
7283 fcncall_realloc_result (gfc_se
*se
, int rank
)
7292 /* Use the allocation done by the library. Substitute the lhs
7293 descriptor with a copy, whose data field is nulled.*/
7294 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7295 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7296 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7298 /* Unallocated, the descriptor does not have a dtype. */
7299 tmp
= gfc_conv_descriptor_dtype (desc
);
7300 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7302 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7303 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7304 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
7306 /* Free the lhs after the function call and copy the result data to
7307 the lhs descriptor. */
7308 tmp
= gfc_conv_descriptor_data_get (desc
);
7309 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7310 boolean_type_node
, tmp
,
7311 build_int_cst (TREE_TYPE (tmp
), 0));
7312 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7313 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7314 gfc_add_expr_to_block (&se
->post
, tmp
);
7316 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7317 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7319 /* Check that the shapes are the same between lhs and expression. */
7320 for (n
= 0 ; n
< rank
; n
++)
7323 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7324 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7325 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7326 gfc_array_index_type
, tmp
, tmp1
);
7327 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7328 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7329 gfc_array_index_type
, tmp
, tmp1
);
7330 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7331 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7332 gfc_array_index_type
, tmp
, tmp1
);
7333 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7334 boolean_type_node
, tmp
,
7335 gfc_index_zero_node
);
7336 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7337 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7338 boolean_type_node
, tmp
,
7342 /* 'zero_cond' being true is equal to lhs not being allocated or the
7343 shapes being different. */
7344 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7346 /* Now reset the bounds returned from the function call to bounds based
7347 on the lhs lbounds, except where the lhs is not allocated or the shapes
7348 of 'variable and 'expr' are different. Set the offset accordingly. */
7349 offset
= gfc_index_zero_node
;
7350 for (n
= 0 ; n
< rank
; n
++)
7354 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7355 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7356 gfc_array_index_type
, zero_cond
,
7357 gfc_index_one_node
, lbound
);
7358 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7360 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7361 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7362 gfc_array_index_type
, tmp
, lbound
);
7363 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7364 gfc_rank_cst
[n
], lbound
);
7365 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7366 gfc_rank_cst
[n
], tmp
);
7368 /* Set stride and accumulate the offset. */
7369 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7370 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7371 gfc_rank_cst
[n
], tmp
);
7372 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7373 gfc_array_index_type
, lbound
, tmp
);
7374 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7375 gfc_array_index_type
, offset
, tmp
);
7376 offset
= gfc_evaluate_now (offset
, &se
->post
);
7379 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7384 /* Try to translate array(:) = func (...), where func is a transformational
7385 array function, without using a temporary. Returns NULL if this isn't the
7389 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7393 gfc_component
*comp
= NULL
;
7396 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7399 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7401 comp
= gfc_get_proc_ptr_comp (expr2
);
7402 gcc_assert (expr2
->value
.function
.isym
7403 || (comp
&& comp
->attr
.dimension
)
7404 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7405 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7407 gfc_init_se (&se
, NULL
);
7408 gfc_start_block (&se
.pre
);
7409 se
.want_pointer
= 1;
7411 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7413 if (expr1
->ts
.type
== BT_DERIVED
7414 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7417 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7419 gfc_add_expr_to_block (&se
.pre
, tmp
);
7422 se
.direct_byref
= 1;
7423 se
.ss
= gfc_walk_expr (expr2
);
7424 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7426 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7427 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7428 Clearly, this cannot be done for an allocatable function result, since
7429 the shape of the result is unknown and, in any case, the function must
7430 correctly take care of the reallocation internally. For intrinsic
7431 calls, the array data is freed and the library takes care of allocation.
7432 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7434 if (gfc_option
.flag_realloc_lhs
7435 && gfc_is_reallocatable_lhs (expr1
)
7436 && !gfc_expr_attr (expr1
).codimension
7437 && !gfc_is_coindexed (expr1
)
7438 && !(expr2
->value
.function
.esym
7439 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7441 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7443 if (!expr2
->value
.function
.isym
)
7445 ss
= gfc_walk_expr (expr1
);
7446 gcc_assert (ss
!= gfc_ss_terminator
);
7448 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7449 ss
->is_alloc_lhs
= 1;
7452 fcncall_realloc_result (&se
, expr1
->rank
);
7455 gfc_conv_function_expr (&se
, expr2
);
7456 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7459 gfc_cleanup_loop (&loop
);
7461 gfc_free_ss_chain (se
.ss
);
7463 return gfc_finish_block (&se
.pre
);
7467 /* Try to efficiently translate array(:) = 0. Return NULL if this
7471 gfc_trans_zero_assign (gfc_expr
* expr
)
7473 tree dest
, len
, type
;
7477 sym
= expr
->symtree
->n
.sym
;
7478 dest
= gfc_get_symbol_decl (sym
);
7480 type
= TREE_TYPE (dest
);
7481 if (POINTER_TYPE_P (type
))
7482 type
= TREE_TYPE (type
);
7483 if (!GFC_ARRAY_TYPE_P (type
))
7486 /* Determine the length of the array. */
7487 len
= GFC_TYPE_ARRAY_SIZE (type
);
7488 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7491 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7492 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7493 fold_convert (gfc_array_index_type
, tmp
));
7495 /* If we are zeroing a local array avoid taking its address by emitting
7497 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7498 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7499 dest
, build_constructor (TREE_TYPE (dest
),
7502 /* Convert arguments to the correct types. */
7503 dest
= fold_convert (pvoid_type_node
, dest
);
7504 len
= fold_convert (size_type_node
, len
);
7506 /* Construct call to __builtin_memset. */
7507 tmp
= build_call_expr_loc (input_location
,
7508 builtin_decl_explicit (BUILT_IN_MEMSET
),
7509 3, dest
, integer_zero_node
, len
);
7510 return fold_convert (void_type_node
, tmp
);
7514 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7515 that constructs the call to __builtin_memcpy. */
7518 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7522 /* Convert arguments to the correct types. */
7523 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7524 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7526 dst
= fold_convert (pvoid_type_node
, dst
);
7528 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7529 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7531 src
= fold_convert (pvoid_type_node
, src
);
7533 len
= fold_convert (size_type_node
, len
);
7535 /* Construct call to __builtin_memcpy. */
7536 tmp
= build_call_expr_loc (input_location
,
7537 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7539 return fold_convert (void_type_node
, tmp
);
7543 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7544 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7545 source/rhs, both are gfc_full_array_ref_p which have been checked for
7549 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7551 tree dst
, dlen
, dtype
;
7552 tree src
, slen
, stype
;
7555 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7556 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7558 dtype
= TREE_TYPE (dst
);
7559 if (POINTER_TYPE_P (dtype
))
7560 dtype
= TREE_TYPE (dtype
);
7561 stype
= TREE_TYPE (src
);
7562 if (POINTER_TYPE_P (stype
))
7563 stype
= TREE_TYPE (stype
);
7565 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7568 /* Determine the lengths of the arrays. */
7569 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7570 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7572 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7573 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7574 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7576 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7577 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7579 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7580 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7581 slen
, fold_convert (gfc_array_index_type
, tmp
));
7583 /* Sanity check that they are the same. This should always be
7584 the case, as we should already have checked for conformance. */
7585 if (!tree_int_cst_equal (slen
, dlen
))
7588 return gfc_build_memcpy_call (dst
, src
, dlen
);
7592 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7593 this can't be done. EXPR1 is the destination/lhs for which
7594 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7597 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7599 unsigned HOST_WIDE_INT nelem
;
7605 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7609 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7610 dtype
= TREE_TYPE (dst
);
7611 if (POINTER_TYPE_P (dtype
))
7612 dtype
= TREE_TYPE (dtype
);
7613 if (!GFC_ARRAY_TYPE_P (dtype
))
7616 /* Determine the lengths of the array. */
7617 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7618 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7621 /* Confirm that the constructor is the same size. */
7622 if (compare_tree_int (len
, nelem
) != 0)
7625 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7626 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7627 fold_convert (gfc_array_index_type
, tmp
));
7629 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7630 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7632 stype
= TREE_TYPE (src
);
7633 if (POINTER_TYPE_P (stype
))
7634 stype
= TREE_TYPE (stype
);
7636 return gfc_build_memcpy_call (dst
, src
, len
);
7640 /* Tells whether the expression is to be treated as a variable reference. */
7643 expr_is_variable (gfc_expr
*expr
)
7646 gfc_component
*comp
;
7647 gfc_symbol
*func_ifc
;
7649 if (expr
->expr_type
== EXPR_VARIABLE
)
7652 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7655 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7656 return expr_is_variable (arg
);
7659 /* A data-pointer-returning function should be considered as a variable
7661 if (expr
->expr_type
== EXPR_FUNCTION
7662 && expr
->ref
== NULL
)
7664 if (expr
->value
.function
.isym
!= NULL
)
7667 if (expr
->value
.function
.esym
!= NULL
)
7669 func_ifc
= expr
->value
.function
.esym
;
7674 gcc_assert (expr
->symtree
);
7675 func_ifc
= expr
->symtree
->n
.sym
;
7682 comp
= gfc_get_proc_ptr_comp (expr
);
7683 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7686 func_ifc
= comp
->ts
.interface
;
7690 if (expr
->expr_type
== EXPR_COMPCALL
)
7692 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7693 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7700 gcc_assert (func_ifc
->attr
.function
7701 && func_ifc
->result
!= NULL
);
7702 return func_ifc
->result
->attr
.pointer
;
7706 /* Is the lhs OK for automatic reallocation? */
7709 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7713 /* An allocatable variable with no reference. */
7714 if (expr
->symtree
->n
.sym
->attr
.allocatable
7718 /* All that can be left are allocatable components. */
7719 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7720 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7721 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7724 /* Find an allocatable component ref last. */
7725 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7726 if (ref
->type
== REF_COMPONENT
7728 && ref
->u
.c
.component
->attr
.allocatable
)
7735 /* Allocate or reallocate scalar lhs, as necessary. */
7738 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7752 if (!expr1
|| expr1
->rank
)
7755 if (!expr2
|| expr2
->rank
)
7758 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7760 /* Since this is a scalar lhs, we can afford to do this. That is,
7761 there is no risk of side effects being repeated. */
7762 gfc_init_se (&lse
, NULL
);
7763 lse
.want_pointer
= 1;
7764 gfc_conv_expr (&lse
, expr1
);
7766 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7767 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7769 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7770 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7771 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7773 tmp
= build3_v (COND_EXPR
, cond
,
7774 build1_v (GOTO_EXPR
, jump_label1
),
7775 build_empty_stmt (input_location
));
7776 gfc_add_expr_to_block (block
, tmp
);
7778 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7780 /* Use the rhs string length and the lhs element size. */
7781 size
= string_length
;
7782 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7783 tmp
= TYPE_SIZE_UNIT (tmp
);
7784 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7785 TREE_TYPE (tmp
), tmp
,
7786 fold_convert (TREE_TYPE (tmp
), size
));
7790 /* Otherwise use the length in bytes of the rhs. */
7791 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7792 size_in_bytes
= size
;
7795 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7796 size_in_bytes
, size_one_node
);
7798 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7800 tmp
= build_call_expr_loc (input_location
,
7801 builtin_decl_explicit (BUILT_IN_CALLOC
),
7802 2, build_one_cst (size_type_node
),
7804 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7805 gfc_add_modify (block
, lse
.expr
, tmp
);
7809 tmp
= build_call_expr_loc (input_location
,
7810 builtin_decl_explicit (BUILT_IN_MALLOC
),
7812 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7813 gfc_add_modify (block
, lse
.expr
, tmp
);
7816 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7818 /* Deferred characters need checking for lhs and rhs string
7819 length. Other deferred parameter variables will have to
7821 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7822 gfc_add_expr_to_block (block
, tmp
);
7824 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7825 gfc_add_expr_to_block (block
, tmp
);
7827 /* For a deferred length character, reallocate if lengths of lhs and
7828 rhs are different. */
7829 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7831 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7832 expr1
->ts
.u
.cl
->backend_decl
, size
);
7833 /* Jump past the realloc if the lengths are the same. */
7834 tmp
= build3_v (COND_EXPR
, cond
,
7835 build1_v (GOTO_EXPR
, jump_label2
),
7836 build_empty_stmt (input_location
));
7837 gfc_add_expr_to_block (block
, tmp
);
7838 tmp
= build_call_expr_loc (input_location
,
7839 builtin_decl_explicit (BUILT_IN_REALLOC
),
7840 2, fold_convert (pvoid_type_node
, lse
.expr
),
7842 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7843 gfc_add_modify (block
, lse
.expr
, tmp
);
7844 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7845 gfc_add_expr_to_block (block
, tmp
);
7847 /* Update the lhs character length. */
7848 size
= string_length
;
7849 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
7850 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7852 gfc_add_modify (block
, lse
.string_length
, size
);
7856 /* Check for assignments of the type
7860 to make sure we do not check for reallocation unneccessarily. */
7864 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7866 gfc_actual_arglist
*a
;
7869 switch (expr2
->expr_type
)
7872 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7875 if (expr2
->value
.function
.esym
7876 && expr2
->value
.function
.esym
->attr
.elemental
)
7878 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7881 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7886 else if (expr2
->value
.function
.isym
7887 && expr2
->value
.function
.isym
->elemental
)
7889 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7892 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7901 switch (expr2
->value
.op
.op
)
7904 case INTRINSIC_UPLUS
:
7905 case INTRINSIC_UMINUS
:
7906 case INTRINSIC_PARENTHESES
:
7907 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7909 case INTRINSIC_PLUS
:
7910 case INTRINSIC_MINUS
:
7911 case INTRINSIC_TIMES
:
7912 case INTRINSIC_DIVIDE
:
7913 case INTRINSIC_POWER
:
7917 case INTRINSIC_NEQV
:
7924 case INTRINSIC_EQ_OS
:
7925 case INTRINSIC_NE_OS
:
7926 case INTRINSIC_GT_OS
:
7927 case INTRINSIC_GE_OS
:
7928 case INTRINSIC_LT_OS
:
7929 case INTRINSIC_LE_OS
:
7931 e1
= expr2
->value
.op
.op1
;
7932 e2
= expr2
->value
.op
.op2
;
7934 if (e1
->rank
== 0 && e2
->rank
> 0)
7935 return is_runtime_conformable (expr1
, e2
);
7936 else if (e1
->rank
> 0 && e2
->rank
== 0)
7937 return is_runtime_conformable (expr1
, e1
);
7938 else if (e1
->rank
> 0 && e2
->rank
> 0)
7939 return is_runtime_conformable (expr1
, e1
)
7940 && is_runtime_conformable (expr1
, e2
);
7956 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7957 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7958 init_flag indicates initialization expressions and dealloc that no
7959 deallocate prior assignment is needed (if in doubt, set true). */
7962 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7968 gfc_ss
*lss_section
;
7975 bool scalar_to_array
;
7979 /* Assignment of the form lhs = rhs. */
7980 gfc_start_block (&block
);
7982 gfc_init_se (&lse
, NULL
);
7983 gfc_init_se (&rse
, NULL
);
7986 lss
= gfc_walk_expr (expr1
);
7987 if (gfc_is_reallocatable_lhs (expr1
)
7988 && !(expr2
->expr_type
== EXPR_FUNCTION
7989 && expr2
->value
.function
.isym
!= NULL
))
7990 lss
->is_alloc_lhs
= 1;
7992 if (lss
!= gfc_ss_terminator
)
7994 /* The assignment needs scalarization. */
7997 /* Find a non-scalar SS from the lhs. */
7998 while (lss_section
!= gfc_ss_terminator
7999 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8000 lss_section
= lss_section
->next
;
8002 gcc_assert (lss_section
!= gfc_ss_terminator
);
8004 /* Initialize the scalarizer. */
8005 gfc_init_loopinfo (&loop
);
8008 rss
= gfc_walk_expr (expr2
);
8009 if (rss
== gfc_ss_terminator
)
8010 /* The rhs is scalar. Add a ss for the expression. */
8011 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8013 /* Associate the SS with the loop. */
8014 gfc_add_ss_to_loop (&loop
, lss
);
8015 gfc_add_ss_to_loop (&loop
, rss
);
8017 /* Calculate the bounds of the scalarization. */
8018 gfc_conv_ss_startstride (&loop
);
8019 /* Enable loop reversal. */
8020 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8021 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8022 /* Resolve any data dependencies in the statement. */
8023 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8024 /* Setup the scalarizing loops. */
8025 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8027 /* Setup the gfc_se structures. */
8028 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8029 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8032 gfc_mark_ss_chain_used (rss
, 1);
8033 if (loop
.temp_ss
== NULL
)
8036 gfc_mark_ss_chain_used (lss
, 1);
8040 lse
.ss
= loop
.temp_ss
;
8041 gfc_mark_ss_chain_used (lss
, 3);
8042 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8045 /* Allow the scalarizer to workshare array assignments. */
8046 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8047 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8049 /* Start the scalarized loop body. */
8050 gfc_start_scalarized_body (&loop
, &body
);
8053 gfc_init_block (&body
);
8055 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8057 /* Translate the expression. */
8058 gfc_conv_expr (&rse
, expr2
);
8060 /* Stabilize a string length for temporaries. */
8061 if (expr2
->ts
.type
== BT_CHARACTER
)
8062 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8064 string_length
= NULL_TREE
;
8068 gfc_conv_tmp_array_ref (&lse
);
8069 if (expr2
->ts
.type
== BT_CHARACTER
)
8070 lse
.string_length
= string_length
;
8073 gfc_conv_expr (&lse
, expr1
);
8075 /* Assignments of scalar derived types with allocatable components
8076 to arrays must be done with a deep copy and the rhs temporary
8077 must have its components deallocated afterwards. */
8078 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8079 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8080 && !expr_is_variable (expr2
)
8081 && !gfc_is_constant_expr (expr2
)
8082 && expr1
->rank
&& !expr2
->rank
);
8083 if (scalar_to_array
&& dealloc
)
8085 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8086 gfc_add_expr_to_block (&loop
.post
, tmp
);
8089 /* When assigning a character function result to a deferred-length variable,
8090 the function call must happen before the (re)allocation of the lhs -
8091 otherwise the character length of the result is not known.
8092 NOTE: This relies on having the exact dependence of the length type
8093 parameter available to the caller; gfortran saves it in the .mod files. */
8094 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
8095 && expr1
->ts
.deferred
)
8096 gfc_add_block_to_block (&block
, &rse
.pre
);
8098 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8099 l_is_temp
|| init_flag
,
8100 expr_is_variable (expr2
) || scalar_to_array
8101 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8102 gfc_add_expr_to_block (&body
, tmp
);
8104 if (lss
== gfc_ss_terminator
)
8106 /* F2003: Add the code for reallocation on assignment. */
8107 if (gfc_option
.flag_realloc_lhs
8108 && is_scalar_reallocatable_lhs (expr1
))
8109 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8112 /* Use the scalar assignment as is. */
8113 gfc_add_block_to_block (&block
, &body
);
8117 gcc_assert (lse
.ss
== gfc_ss_terminator
8118 && rse
.ss
== gfc_ss_terminator
);
8122 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8124 /* We need to copy the temporary to the actual lhs. */
8125 gfc_init_se (&lse
, NULL
);
8126 gfc_init_se (&rse
, NULL
);
8127 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8128 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8130 rse
.ss
= loop
.temp_ss
;
8133 gfc_conv_tmp_array_ref (&rse
);
8134 gfc_conv_expr (&lse
, expr1
);
8136 gcc_assert (lse
.ss
== gfc_ss_terminator
8137 && rse
.ss
== gfc_ss_terminator
);
8139 if (expr2
->ts
.type
== BT_CHARACTER
)
8140 rse
.string_length
= string_length
;
8142 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8143 false, false, dealloc
);
8144 gfc_add_expr_to_block (&body
, tmp
);
8147 /* F2003: Allocate or reallocate lhs of allocatable array. */
8148 if (gfc_option
.flag_realloc_lhs
8149 && gfc_is_reallocatable_lhs (expr1
)
8150 && !gfc_expr_attr (expr1
).codimension
8151 && !gfc_is_coindexed (expr1
)
8153 && !is_runtime_conformable (expr1
, expr2
))
8155 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8156 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8157 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8158 if (tmp
!= NULL_TREE
)
8159 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8162 /* Generate the copying loops. */
8163 gfc_trans_scalarizing_loops (&loop
, &body
);
8165 /* Wrap the whole thing up. */
8166 gfc_add_block_to_block (&block
, &loop
.pre
);
8167 gfc_add_block_to_block (&block
, &loop
.post
);
8169 gfc_cleanup_loop (&loop
);
8172 return gfc_finish_block (&block
);
8176 /* Check whether EXPR is a copyable array. */
8179 copyable_array_p (gfc_expr
* expr
)
8181 if (expr
->expr_type
!= EXPR_VARIABLE
)
8184 /* First check it's an array. */
8185 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8188 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8191 /* Next check that it's of a simple enough type. */
8192 switch (expr
->ts
.type
)
8204 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8213 /* Translate an assignment. */
8216 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8221 /* Special case a single function returning an array. */
8222 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8224 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8229 /* Special case assigning an array to zero. */
8230 if (copyable_array_p (expr1
)
8231 && is_zero_initializer_p (expr2
))
8233 tmp
= gfc_trans_zero_assign (expr1
);
8238 /* Special case copying one array to another. */
8239 if (copyable_array_p (expr1
)
8240 && copyable_array_p (expr2
)
8241 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8242 && !gfc_check_dependency (expr1
, expr2
, 0))
8244 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8249 /* Special case initializing an array from a constant array constructor. */
8250 if (copyable_array_p (expr1
)
8251 && expr2
->expr_type
== EXPR_ARRAY
8252 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8254 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8259 /* Fallback to the scalarizer to generate explicit loops. */
8260 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8264 gfc_trans_init_assign (gfc_code
* code
)
8266 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8270 gfc_trans_assign (gfc_code
* code
)
8272 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);