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"
29 #include "stringpool.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
76 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
77 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
78 gfc_get_dtype (type
));
79 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
81 /* Copy pointer address back - but only if it could have changed and
82 if the actual argument is a pointer and not, e.g., NULL(). */
83 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
84 gfc_add_modify (&se
->post
, scalar
,
85 fold_convert (TREE_TYPE (scalar
),
86 gfc_conv_descriptor_data_get (desc
)));
91 /* This is the seed for an eventual trans-class.c
93 The following parameters should not be used directly since they might
94 in future implementations. Use the corresponding APIs. */
95 #define CLASS_DATA_FIELD 0
96 #define CLASS_VPTR_FIELD 1
97 #define VTABLE_HASH_FIELD 0
98 #define VTABLE_SIZE_FIELD 1
99 #define VTABLE_EXTENDS_FIELD 2
100 #define VTABLE_DEF_INIT_FIELD 3
101 #define VTABLE_COPY_FIELD 4
102 #define VTABLE_FINAL_FIELD 5
106 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
110 vec
<constructor_elt
, va_gc
> *init
= NULL
;
112 field
= TYPE_FIELDS (TREE_TYPE (decl
));
113 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
114 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
116 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
117 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
119 return build_constructor (TREE_TYPE (decl
), init
);
124 gfc_class_data_get (tree decl
)
127 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
128 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
129 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
131 return fold_build3_loc (input_location
, COMPONENT_REF
,
132 TREE_TYPE (data
), decl
, data
,
138 gfc_class_vptr_get (tree decl
)
141 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
142 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
143 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
145 return fold_build3_loc (input_location
, COMPONENT_REF
,
146 TREE_TYPE (vptr
), decl
, vptr
,
152 gfc_vtable_field_get (tree decl
, int field
)
156 vptr
= gfc_class_vptr_get (decl
);
157 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
158 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
160 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
161 TREE_TYPE (size
), vptr
, size
,
163 /* Always return size as an array index type. */
164 if (field
== VTABLE_SIZE_FIELD
)
165 size
= fold_convert (gfc_array_index_type
, size
);
172 gfc_vtable_hash_get (tree decl
)
174 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
179 gfc_vtable_size_get (tree decl
)
181 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
186 gfc_vtable_extends_get (tree decl
)
188 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
193 gfc_vtable_def_init_get (tree decl
)
195 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
200 gfc_vtable_copy_get (tree decl
)
202 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
207 gfc_vtable_final_get (tree decl
)
209 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
213 #undef CLASS_DATA_FIELD
214 #undef CLASS_VPTR_FIELD
215 #undef VTABLE_HASH_FIELD
216 #undef VTABLE_SIZE_FIELD
217 #undef VTABLE_EXTENDS_FIELD
218 #undef VTABLE_DEF_INIT_FIELD
219 #undef VTABLE_COPY_FIELD
220 #undef VTABLE_FINAL_FIELD
223 /* Reset the vptr to the declared type, e.g. after deallocation. */
226 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
228 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
233 /* If we have a class array, we need go back to the class
235 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
236 && lhs
->ref
->next
->type
== REF_ARRAY
237 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
238 && lhs
->ref
->type
== REF_COMPONENT
239 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
241 gfc_free_ref_list (lhs
->ref
);
245 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
246 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
247 && ref
->next
->next
->type
== REF_ARRAY
248 && ref
->next
->next
->u
.ar
.type
== AR_FULL
249 && ref
->next
->type
== REF_COMPONENT
250 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
252 gfc_free_ref_list (ref
->next
);
256 gfc_add_vptr_component (lhs
);
258 if (UNLIMITED_POLY (e
))
259 rhs
= gfc_get_null_expr (NULL
);
262 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
263 rhs
= gfc_lval_expr_from_sym (vtab
);
265 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
266 gfc_add_expr_to_block (block
, tmp
);
272 /* Obtain the vptr of the last class reference in an expression.
273 Return NULL_TREE if no class reference is found. */
276 gfc_get_vptr_from_expr (tree expr
)
281 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
283 type
= TREE_TYPE (tmp
);
286 if (GFC_CLASS_TYPE_P (type
))
287 return gfc_class_vptr_get (tmp
);
288 if (type
!= TYPE_CANONICAL (type
))
289 type
= TYPE_CANONICAL (type
);
293 if (TREE_CODE (tmp
) == VAR_DECL
)
301 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
304 tree tmp
, tmp2
, type
;
306 gfc_conv_descriptor_data_set (block
, lhs_desc
,
307 gfc_conv_descriptor_data_get (rhs_desc
));
308 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
309 gfc_conv_descriptor_offset_get (rhs_desc
));
311 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
312 gfc_conv_descriptor_dtype (rhs_desc
));
314 /* Assign the dimension as range-ref. */
315 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
316 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
318 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
319 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
320 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
321 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
322 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
323 gfc_add_modify (block
, tmp
, tmp2
);
327 /* Takes a derived type expression and returns the address of a temporary
328 class object of the 'declared' type. If vptr is not NULL, this is
329 used for the temporary class object.
330 optional_alloc_ptr is false when the dummy is neither allocatable
331 nor a pointer; that's only relevant for the optional handling. */
333 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
334 gfc_typespec class_ts
, tree vptr
, bool optional
,
335 bool optional_alloc_ptr
)
338 tree cond_optional
= NULL_TREE
;
344 /* The derived type needs to be converted to a temporary
346 tmp
= gfc_typenode_for_spec (&class_ts
);
347 var
= gfc_create_var (tmp
, "class");
350 ctree
= gfc_class_vptr_get (var
);
352 if (vptr
!= NULL_TREE
)
354 /* Use the dynamic vptr. */
359 /* In this case the vtab corresponds to the derived type and the
360 vptr must point to it. */
361 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
363 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
365 gfc_add_modify (&parmse
->pre
, ctree
,
366 fold_convert (TREE_TYPE (ctree
), tmp
));
368 /* Now set the data field. */
369 ctree
= gfc_class_data_get (var
);
372 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
374 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
376 /* For an array reference in an elemental procedure call we need
377 to retain the ss to provide the scalarized array reference. */
378 gfc_conv_expr_reference (parmse
, e
);
379 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
381 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
383 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
384 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
389 ss
= gfc_walk_expr (e
);
390 if (ss
== gfc_ss_terminator
)
393 gfc_conv_expr_reference (parmse
, e
);
395 /* Scalar to an assumed-rank array. */
396 if (class_ts
.u
.derived
->components
->as
)
399 type
= get_scalar_to_descriptor_type (parmse
->expr
,
401 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
402 gfc_get_dtype (type
));
404 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
405 TREE_TYPE (parmse
->expr
),
406 cond_optional
, parmse
->expr
,
407 fold_convert (TREE_TYPE (parmse
->expr
),
409 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
413 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
415 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
417 fold_convert (TREE_TYPE (tmp
),
419 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
425 gfc_init_block (&block
);
428 gfc_conv_expr_descriptor (parmse
, e
);
430 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
432 gcc_assert (class_ts
.u
.derived
->components
->as
->type
434 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
438 if (gfc_expr_attr (e
).codimension
)
439 parmse
->expr
= fold_build1_loc (input_location
,
443 gfc_add_modify (&block
, ctree
, parmse
->expr
);
448 tmp
= gfc_finish_block (&block
);
450 gfc_init_block (&block
);
451 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
453 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
454 gfc_finish_block (&block
));
455 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
458 gfc_add_block_to_block (&parmse
->pre
, &block
);
462 /* Pass the address of the class object. */
463 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
465 if (optional
&& optional_alloc_ptr
)
466 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
467 TREE_TYPE (parmse
->expr
),
468 cond_optional
, parmse
->expr
,
469 fold_convert (TREE_TYPE (parmse
->expr
),
474 /* Create a new class container, which is required as scalar coarrays
475 have an array descriptor while normal scalars haven't. Optionally,
476 NULL pointer checks are added if the argument is OPTIONAL. */
479 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
480 gfc_typespec class_ts
, bool optional
)
482 tree var
, ctree
, tmp
;
487 gfc_init_block (&block
);
490 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
492 if (ref
->type
== REF_COMPONENT
493 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
497 if (class_ref
== NULL
498 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
499 tmp
= e
->symtree
->n
.sym
->backend_decl
;
502 /* Remove everything after the last class reference, convert the
503 expression and then recover its tailend once more. */
505 ref
= class_ref
->next
;
506 class_ref
->next
= NULL
;
507 gfc_init_se (&tmpse
, NULL
);
508 gfc_conv_expr (&tmpse
, e
);
509 class_ref
->next
= ref
;
513 var
= gfc_typenode_for_spec (&class_ts
);
514 var
= gfc_create_var (var
, "class");
516 ctree
= gfc_class_vptr_get (var
);
517 gfc_add_modify (&block
, ctree
,
518 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
520 ctree
= gfc_class_data_get (var
);
521 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
522 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
524 /* Pass the address of the class object. */
525 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
529 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
532 tmp
= gfc_finish_block (&block
);
534 gfc_init_block (&block
);
535 tmp2
= gfc_class_data_get (var
);
536 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
538 tmp2
= gfc_finish_block (&block
);
540 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
542 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
545 gfc_add_block_to_block (&parmse
->pre
, &block
);
549 /* Takes an intrinsic type expression and returns the address of a temporary
550 class object of the 'declared' type. */
552 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
553 gfc_typespec class_ts
)
561 /* The intrinsic type needs to be converted to a temporary
563 tmp
= gfc_typenode_for_spec (&class_ts
);
564 var
= gfc_create_var (tmp
, "class");
567 ctree
= gfc_class_vptr_get (var
);
569 vtab
= gfc_find_vtab (&e
->ts
);
571 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
572 gfc_add_modify (&parmse
->pre
, ctree
,
573 fold_convert (TREE_TYPE (ctree
), tmp
));
575 /* Now set the data field. */
576 ctree
= gfc_class_data_get (var
);
577 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
579 /* For an array reference in an elemental procedure call we need
580 to retain the ss to provide the scalarized array reference. */
581 gfc_conv_expr_reference (parmse
, e
);
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
587 ss
= gfc_walk_expr (e
);
588 if (ss
== gfc_ss_terminator
)
591 gfc_conv_expr_reference (parmse
, e
);
592 if (class_ts
.u
.derived
->components
->as
593 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
595 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
597 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
598 TREE_TYPE (ctree
), tmp
);
601 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
602 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
607 parmse
->use_offset
= 1;
608 gfc_conv_expr_descriptor (parmse
, e
);
609 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
611 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
612 TREE_TYPE (ctree
), parmse
->expr
);
613 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
616 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
620 /* Pass the address of the class object. */
621 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
625 /* Takes a scalarized class array expression and returns the
626 address of a temporary scalar class object of the 'declared'
628 OOP-TODO: This could be improved by adding code that branched on
629 the dynamic type being the same as the declared type. In this case
630 the original class expression can be passed directly.
631 optional_alloc_ptr is false when the dummy is neither allocatable
632 nor a pointer; that's relevant for the optional handling.
633 Set copyback to true if class container's _data and _vtab pointers
634 might get modified. */
637 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
638 bool elemental
, bool copyback
, bool optional
,
639 bool optional_alloc_ptr
)
645 tree cond
= NULL_TREE
;
649 bool full_array
= false;
651 gfc_init_block (&block
);
654 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
656 if (ref
->type
== REF_COMPONENT
657 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
660 if (ref
->next
== NULL
)
664 if ((ref
== NULL
|| class_ref
== ref
)
665 && (!class_ts
.u
.derived
->components
->as
666 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
669 /* Test for FULL_ARRAY. */
670 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
671 && gfc_expr_attr (e
).dimension
)
674 gfc_is_class_array_ref (e
, &full_array
);
676 /* The derived type needs to be converted to a temporary
678 tmp
= gfc_typenode_for_spec (&class_ts
);
679 var
= gfc_create_var (tmp
, "class");
682 ctree
= gfc_class_data_get (var
);
683 if (class_ts
.u
.derived
->components
->as
684 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
688 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
690 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
691 gfc_get_dtype (type
));
693 tmp
= gfc_class_data_get (parmse
->expr
);
694 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
695 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
697 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
700 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
704 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
705 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
706 TREE_TYPE (ctree
), parmse
->expr
);
707 gfc_add_modify (&block
, ctree
, parmse
->expr
);
710 /* Return the data component, except in the case of scalarized array
711 references, where nullification of the cannot occur and so there
713 if (!elemental
&& full_array
&& copyback
)
715 if (class_ts
.u
.derived
->components
->as
716 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
719 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
720 gfc_conv_descriptor_data_get (ctree
));
722 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
725 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
729 ctree
= gfc_class_vptr_get (var
);
731 /* The vptr is the second field of the actual argument.
732 First we have to find the corresponding class reference. */
735 if (class_ref
== NULL
736 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
737 tmp
= e
->symtree
->n
.sym
->backend_decl
;
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
743 ref
= class_ref
->next
;
744 class_ref
->next
= NULL
;
745 gfc_init_se (&tmpse
, NULL
);
746 gfc_conv_expr (&tmpse
, e
);
747 class_ref
->next
= ref
;
751 gcc_assert (tmp
!= NULL_TREE
);
753 /* Dereference if needs be. */
754 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
755 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
757 vptr
= gfc_class_vptr_get (tmp
);
758 gfc_add_modify (&block
, ctree
,
759 fold_convert (TREE_TYPE (ctree
), vptr
));
761 /* Return the vptr component, except in the case of scalarized array
762 references, where the dynamic type cannot change. */
763 if (!elemental
&& full_array
&& copyback
)
764 gfc_add_modify (&parmse
->post
, vptr
,
765 fold_convert (TREE_TYPE (vptr
), ctree
));
771 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
772 tmp
= gfc_finish_block (&block
);
774 if (optional_alloc_ptr
)
775 tmp2
= build_empty_stmt (input_location
);
778 gfc_init_block (&block
);
780 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
781 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
783 tmp2
= gfc_finish_block (&block
);
786 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
788 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
791 gfc_add_block_to_block (&parmse
->pre
, &block
);
793 /* Pass the address of the class object. */
794 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
796 if (optional
&& optional_alloc_ptr
)
797 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
798 TREE_TYPE (parmse
->expr
),
800 fold_convert (TREE_TYPE (parmse
->expr
),
805 /* Given a class array declaration and an index, returns the address
806 of the referenced element. */
809 gfc_get_class_array_ref (tree index
, tree class_decl
)
811 tree data
= gfc_class_data_get (class_decl
);
812 tree size
= gfc_vtable_size_get (class_decl
);
813 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
814 gfc_array_index_type
,
817 data
= gfc_conv_descriptor_data_get (data
);
818 ptr
= fold_convert (pvoid_type_node
, data
);
819 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
820 return fold_convert (TREE_TYPE (data
), ptr
);
824 /* Copies one class expression to another, assuming that if either
825 'to' or 'from' are arrays they are packed. Should 'from' be
826 NULL_TREE, the initialization expression for 'to' is used, assuming
827 that the _vptr is set. */
830 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
838 vec
<tree
, va_gc
> *args
;
841 stmtblock_t loopbody
;
847 if (from
!= NULL_TREE
)
848 fcn
= gfc_vtable_copy_get (from
);
850 fcn
= gfc_vtable_copy_get (to
);
852 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
854 if (from
!= NULL_TREE
)
855 from_data
= gfc_class_data_get (from
);
857 from_data
= gfc_vtable_def_init_get (to
);
859 to_data
= gfc_class_data_get (to
);
861 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
863 gfc_init_block (&body
);
864 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
865 gfc_array_index_type
, nelems
,
867 nelems
= gfc_evaluate_now (tmp
, &body
);
868 index
= gfc_create_var (gfc_array_index_type
, "S");
870 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
872 from_ref
= gfc_get_class_array_ref (index
, from
);
873 vec_safe_push (args
, from_ref
);
876 vec_safe_push (args
, from_data
);
878 to_ref
= gfc_get_class_array_ref (index
, to
);
879 vec_safe_push (args
, to_ref
);
881 tmp
= build_call_vec (fcn_type
, fcn
, args
);
883 /* Build the body of the loop. */
884 gfc_init_block (&loopbody
);
885 gfc_add_expr_to_block (&loopbody
, tmp
);
887 /* Build the loop and return. */
888 gfc_init_loopinfo (&loop
);
890 loop
.from
[0] = gfc_index_zero_node
;
891 loop
.loopvar
[0] = index
;
893 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
894 gfc_add_block_to_block (&body
, &loop
.pre
);
895 tmp
= gfc_finish_block (&body
);
896 gfc_cleanup_loop (&loop
);
900 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
901 vec_safe_push (args
, from_data
);
902 vec_safe_push (args
, to_data
);
903 tmp
= build_call_vec (fcn_type
, fcn
, args
);
910 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
912 gfc_actual_arglist
*actual
;
917 actual
= gfc_get_actual_arglist ();
918 actual
->expr
= gfc_copy_expr (rhs
);
919 actual
->next
= gfc_get_actual_arglist ();
920 actual
->next
->expr
= gfc_copy_expr (lhs
);
921 ppc
= gfc_copy_expr (obj
);
922 gfc_add_vptr_component (ppc
);
923 gfc_add_component_ref (ppc
, "_copy");
924 ppc_code
= gfc_get_code (EXEC_CALL
);
925 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
926 /* Although '_copy' is set to be elemental in class.c, it is
927 not staying that way. Find out why, sometime.... */
928 ppc_code
->resolved_sym
->attr
.elemental
= 1;
929 ppc_code
->ext
.actual
= actual
;
930 ppc_code
->expr1
= ppc
;
931 /* Since '_copy' is elemental, the scalarizer will take care
932 of arrays in gfc_trans_call. */
933 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
934 gfc_free_statements (ppc_code
);
938 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
939 A MEMCPY is needed to copy the full data from the default initializer
940 of the dynamic type. */
943 gfc_trans_class_init_assign (gfc_code
*code
)
947 gfc_se dst
,src
,memsz
;
948 gfc_expr
*lhs
, *rhs
, *sz
;
950 gfc_start_block (&block
);
952 lhs
= gfc_copy_expr (code
->expr1
);
953 gfc_add_data_component (lhs
);
955 rhs
= gfc_copy_expr (code
->expr1
);
956 gfc_add_vptr_component (rhs
);
958 /* Make sure that the component backend_decls have been built, which
959 will not have happened if the derived types concerned have not
961 gfc_get_derived_type (rhs
->ts
.u
.derived
);
962 gfc_add_def_init_component (rhs
);
964 if (code
->expr1
->ts
.type
== BT_CLASS
965 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
966 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
969 sz
= gfc_copy_expr (code
->expr1
);
970 gfc_add_vptr_component (sz
);
971 gfc_add_size_component (sz
);
973 gfc_init_se (&dst
, NULL
);
974 gfc_init_se (&src
, NULL
);
975 gfc_init_se (&memsz
, NULL
);
976 gfc_conv_expr (&dst
, lhs
);
977 gfc_conv_expr (&src
, rhs
);
978 gfc_conv_expr (&memsz
, sz
);
979 gfc_add_block_to_block (&block
, &src
.pre
);
980 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
982 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
985 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
986 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
988 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
989 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
991 build_empty_stmt (input_location
));
994 gfc_add_expr_to_block (&block
, tmp
);
996 return gfc_finish_block (&block
);
1000 /* Translate an assignment to a CLASS object
1001 (pointer or ordinary assignment). */
1004 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1012 gfc_start_block (&block
);
1015 while (ref
&& ref
->next
)
1018 /* Class valued proc_pointer assignments do not need any further
1020 if (ref
&& ref
->type
== REF_COMPONENT
1021 && ref
->u
.c
.component
->attr
.proc_pointer
1022 && expr2
->expr_type
== EXPR_VARIABLE
1023 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1024 && op
== EXEC_POINTER_ASSIGN
)
1027 if (expr2
->ts
.type
!= BT_CLASS
)
1029 /* Insert an additional assignment which sets the '_vptr' field. */
1030 gfc_symbol
*vtab
= NULL
;
1033 lhs
= gfc_copy_expr (expr1
);
1034 gfc_add_vptr_component (lhs
);
1036 if (UNLIMITED_POLY (expr1
)
1037 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1039 rhs
= gfc_get_null_expr (&expr2
->where
);
1043 if (expr2
->expr_type
== EXPR_NULL
)
1044 vtab
= gfc_find_vtab (&expr1
->ts
);
1046 vtab
= gfc_find_vtab (&expr2
->ts
);
1049 rhs
= gfc_get_expr ();
1050 rhs
->expr_type
= EXPR_VARIABLE
;
1051 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1055 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1056 gfc_add_expr_to_block (&block
, tmp
);
1058 gfc_free_expr (lhs
);
1059 gfc_free_expr (rhs
);
1061 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1063 /* F2003:C717 only sequence and bind-C types can come here. */
1064 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1065 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1066 gfc_add_data_component (expr2
);
1069 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1071 /* Insert an additional assignment which sets the '_vptr' field. */
1072 lhs
= gfc_copy_expr (expr1
);
1073 gfc_add_vptr_component (lhs
);
1075 rhs
= gfc_copy_expr (expr2
);
1076 gfc_add_vptr_component (rhs
);
1078 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1079 gfc_add_expr_to_block (&block
, tmp
);
1081 gfc_free_expr (lhs
);
1082 gfc_free_expr (rhs
);
1085 /* Do the actual CLASS assignment. */
1086 if (expr2
->ts
.type
== BT_CLASS
1087 && !CLASS_DATA (expr2
)->attr
.dimension
)
1089 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1090 || !CLASS_DATA (expr2
)->attr
.dimension
)
1091 gfc_add_data_component (expr1
);
1095 if (op
== EXEC_ASSIGN
)
1096 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1097 else if (op
== EXEC_POINTER_ASSIGN
)
1098 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1102 gfc_add_expr_to_block (&block
, tmp
);
1104 return gfc_finish_block (&block
);
1108 /* End of prototype trans-class.c */
1112 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1114 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1115 gfc_warning (OPT_Wrealloc_lhs
,
1116 "Code for reallocating the allocatable array at %L will "
1118 else if (warn_realloc_lhs_all
)
1119 gfc_warning (OPT_Wrealloc_lhs_all
,
1120 "Code for reallocating the allocatable variable at %L "
1121 "will be added", where
);
1125 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1126 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1129 /* Copy the scalarization loop variables. */
1132 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1135 dest
->loop
= src
->loop
;
1139 /* Initialize a simple expression holder.
1141 Care must be taken when multiple se are created with the same parent.
1142 The child se must be kept in sync. The easiest way is to delay creation
1143 of a child se until after after the previous se has been translated. */
1146 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1148 memset (se
, 0, sizeof (gfc_se
));
1149 gfc_init_block (&se
->pre
);
1150 gfc_init_block (&se
->post
);
1152 se
->parent
= parent
;
1155 gfc_copy_se_loopvars (se
, parent
);
1159 /* Advances to the next SS in the chain. Use this rather than setting
1160 se->ss = se->ss->next because all the parents needs to be kept in sync.
1164 gfc_advance_se_ss_chain (gfc_se
* se
)
1169 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1172 /* Walk down the parent chain. */
1175 /* Simple consistency check. */
1176 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1177 || p
->parent
->ss
->nested_ss
== p
->ss
);
1179 /* If we were in a nested loop, the next scalarized expression can be
1180 on the parent ss' next pointer. Thus we should not take the next
1181 pointer blindly, but rather go up one nest level as long as next
1182 is the end of chain. */
1184 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1194 /* Ensures the result of the expression as either a temporary variable
1195 or a constant so that it can be used repeatedly. */
1198 gfc_make_safe_expr (gfc_se
* se
)
1202 if (CONSTANT_CLASS_P (se
->expr
))
1205 /* We need a temporary for this result. */
1206 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1207 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1212 /* Return an expression which determines if a dummy parameter is present.
1213 Also used for arguments to procedures with multiple entry points. */
1216 gfc_conv_expr_present (gfc_symbol
* sym
)
1220 gcc_assert (sym
->attr
.dummy
);
1221 decl
= gfc_get_symbol_decl (sym
);
1223 /* Intrinsic scalars with VALUE attribute which are passed by value
1224 use a hidden argument to denote the present status. */
1225 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1226 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1227 && !sym
->attr
.dimension
)
1229 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1232 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1234 strcpy (&name
[1], sym
->name
);
1235 tree_name
= get_identifier (name
);
1237 /* Walk function argument list to find hidden arg. */
1238 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1239 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1240 if (DECL_NAME (cond
) == tree_name
)
1247 if (TREE_CODE (decl
) != PARM_DECL
)
1249 /* Array parameters use a temporary descriptor, we want the real
1251 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1252 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1253 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1256 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1257 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1259 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1260 as actual argument to denote absent dummies. For array descriptors,
1261 we thus also need to check the array descriptor. For BT_CLASS, it
1262 can also occur for scalars and F2003 due to type->class wrapping and
1263 class->class wrapping. Note further that BT_CLASS always uses an
1264 array descriptor for arrays, also for explicit-shape/assumed-size. */
1266 if (!sym
->attr
.allocatable
1267 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1268 || (sym
->ts
.type
== BT_CLASS
1269 && !CLASS_DATA (sym
)->attr
.allocatable
1270 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1271 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1272 || sym
->ts
.type
== BT_CLASS
))
1276 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1277 || sym
->as
->type
== AS_ASSUMED_RANK
1278 || sym
->attr
.codimension
))
1279 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1281 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1282 if (sym
->ts
.type
== BT_CLASS
)
1283 tmp
= gfc_class_data_get (tmp
);
1284 tmp
= gfc_conv_array_data (tmp
);
1286 else if (sym
->ts
.type
== BT_CLASS
)
1287 tmp
= gfc_class_data_get (decl
);
1291 if (tmp
!= NULL_TREE
)
1293 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1294 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1295 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1296 boolean_type_node
, cond
, tmp
);
1304 /* Converts a missing, dummy argument into a null or zero. */
1307 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1312 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1316 /* Create a temporary and convert it to the correct type. */
1317 tmp
= gfc_get_int_type (kind
);
1318 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1321 /* Test for a NULL value. */
1322 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1323 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1324 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1325 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1329 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1331 build_zero_cst (TREE_TYPE (se
->expr
)));
1332 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1336 if (ts
.type
== BT_CHARACTER
)
1338 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1339 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1340 present
, se
->string_length
, tmp
);
1341 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1342 se
->string_length
= tmp
;
1348 /* Get the character length of an expression, looking through gfc_refs
1352 gfc_get_expr_charlen (gfc_expr
*e
)
1357 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1358 && e
->ts
.type
== BT_CHARACTER
);
1360 length
= NULL
; /* To silence compiler warning. */
1362 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1365 gfc_init_se (&tmpse
, NULL
);
1366 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1367 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1371 /* First candidate: if the variable is of type CHARACTER, the
1372 expression's length could be the length of the character
1374 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1375 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1377 /* Look through the reference chain for component references. */
1378 for (r
= e
->ref
; r
; r
= r
->next
)
1383 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1384 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1392 /* We should never got substring references here. These will be
1393 broken down by the scalarizer. */
1399 gcc_assert (length
!= NULL
);
1404 /* Return for an expression the backend decl of the coarray. */
1407 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1413 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1415 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1416 gcc_assert (caf_decl
);
1417 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1418 caf_decl
= gfc_class_data_get (caf_decl
);
1419 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1422 /* The following code assumes that the coarray is a component reachable via
1423 only scalar components/variables; the Fortran standard guarantees this. */
1425 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1426 if (ref
->type
== REF_COMPONENT
)
1428 gfc_component
*comp
= ref
->u
.c
.component
;
1430 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1431 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1432 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1433 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1434 comp
->backend_decl
, NULL_TREE
);
1435 if (comp
->ts
.type
== BT_CLASS
)
1436 caf_decl
= gfc_class_data_get (caf_decl
);
1437 if (comp
->attr
.codimension
)
1443 gcc_assert (found
&& caf_decl
);
1448 /* Obtain the Coarray token - and optionally also the offset. */
1451 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1456 /* Coarray token. */
1457 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1459 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1460 == GFC_ARRAY_ALLOCATABLE
1461 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1462 *token
= gfc_conv_descriptor_token (caf_decl
);
1464 else if (DECL_LANG_SPECIFIC (caf_decl
)
1465 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1466 *token
= GFC_DECL_TOKEN (caf_decl
);
1469 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1470 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1471 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1477 /* Offset between the coarray base address and the address wanted. */
1478 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1479 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1480 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1481 *offset
= build_int_cst (gfc_array_index_type
, 0);
1482 else if (DECL_LANG_SPECIFIC (caf_decl
)
1483 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1484 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1485 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1486 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1488 *offset
= build_int_cst (gfc_array_index_type
, 0);
1490 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1491 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1493 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1494 tmp
= gfc_conv_descriptor_data_get (tmp
);
1496 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1497 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1500 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1504 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1505 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1507 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1508 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1511 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1515 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1516 fold_convert (gfc_array_index_type
, *offset
),
1517 fold_convert (gfc_array_index_type
, tmp
));
1521 /* Convert the coindex of a coarray into an image index; the result is
1522 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1523 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1526 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1529 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1533 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1534 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1536 gcc_assert (ref
!= NULL
);
1538 img_idx
= integer_zero_node
;
1539 extent
= integer_one_node
;
1540 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1541 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1543 gfc_init_se (&se
, NULL
);
1544 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1545 gfc_add_block_to_block (block
, &se
.pre
);
1546 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1547 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1548 integer_type_node
, se
.expr
,
1549 fold_convert(integer_type_node
, lbound
));
1550 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1552 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1554 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1556 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1557 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1558 tmp
= fold_convert (integer_type_node
, tmp
);
1559 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1560 integer_type_node
, extent
, tmp
);
1564 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1566 gfc_init_se (&se
, NULL
);
1567 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1568 gfc_add_block_to_block (block
, &se
.pre
);
1569 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1570 lbound
= fold_convert (integer_type_node
, lbound
);
1571 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1572 integer_type_node
, se
.expr
, lbound
);
1573 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1575 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1577 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1579 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1580 ubound
= fold_convert (integer_type_node
, ubound
);
1581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1582 integer_type_node
, ubound
, lbound
);
1583 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1584 tmp
, integer_one_node
);
1585 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1586 integer_type_node
, extent
, tmp
);
1589 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1590 img_idx
, integer_one_node
);
1595 /* For each character array constructor subexpression without a ts.u.cl->length,
1596 replace it by its first element (if there aren't any elements, the length
1597 should already be set to zero). */
1600 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1602 gfc_actual_arglist
* arg
;
1608 switch (e
->expr_type
)
1612 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1613 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1617 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1621 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1622 flatten_array_ctors_without_strlen (arg
->expr
);
1627 /* We've found what we're looking for. */
1628 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1633 gcc_assert (e
->value
.constructor
);
1635 c
= gfc_constructor_first (e
->value
.constructor
);
1639 flatten_array_ctors_without_strlen (new_expr
);
1640 gfc_replace_expr (e
, new_expr
);
1644 /* Otherwise, fall through to handle constructor elements. */
1645 case EXPR_STRUCTURE
:
1646 for (c
= gfc_constructor_first (e
->value
.constructor
);
1647 c
; c
= gfc_constructor_next (c
))
1648 flatten_array_ctors_without_strlen (c
->expr
);
1658 /* Generate code to initialize a string length variable. Returns the
1659 value. For array constructors, cl->length might be NULL and in this case,
1660 the first element of the constructor is needed. expr is the original
1661 expression so we can access it but can be NULL if this is not needed. */
1664 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1668 gfc_init_se (&se
, NULL
);
1672 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1675 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1676 "flatten" array constructors by taking their first element; all elements
1677 should be the same length or a cl->length should be present. */
1680 gfc_expr
* expr_flat
;
1682 expr_flat
= gfc_copy_expr (expr
);
1683 flatten_array_ctors_without_strlen (expr_flat
);
1684 gfc_resolve_expr (expr_flat
);
1686 gfc_conv_expr (&se
, expr_flat
);
1687 gfc_add_block_to_block (pblock
, &se
.pre
);
1688 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1690 gfc_free_expr (expr_flat
);
1694 /* Convert cl->length. */
1696 gcc_assert (cl
->length
);
1698 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1699 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1700 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1701 gfc_add_block_to_block (pblock
, &se
.pre
);
1703 if (cl
->backend_decl
)
1704 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1706 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1711 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1712 const char *name
, locus
*where
)
1722 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1723 type
= build_pointer_type (type
);
1725 gfc_init_se (&start
, se
);
1726 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1727 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1729 if (integer_onep (start
.expr
))
1730 gfc_conv_string_parameter (se
);
1735 /* Avoid multiple evaluation of substring start. */
1736 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1737 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1739 /* Change the start of the string. */
1740 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1743 tmp
= build_fold_indirect_ref_loc (input_location
,
1745 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1746 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1749 /* Length = end + 1 - start. */
1750 gfc_init_se (&end
, se
);
1751 if (ref
->u
.ss
.end
== NULL
)
1752 end
.expr
= se
->string_length
;
1755 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1756 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1760 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1761 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1763 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1765 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1766 boolean_type_node
, start
.expr
,
1769 /* Check lower bound. */
1770 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1772 build_int_cst (gfc_charlen_type_node
, 1));
1773 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1774 boolean_type_node
, nonempty
, fault
);
1776 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1777 "is less than one", name
);
1779 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1780 "is less than one");
1781 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1782 fold_convert (long_integer_type_node
,
1786 /* Check upper bound. */
1787 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1788 end
.expr
, se
->string_length
);
1789 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1790 boolean_type_node
, nonempty
, fault
);
1792 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1793 "exceeds string length (%%ld)", name
);
1795 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1796 "exceeds string length (%%ld)");
1797 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1798 fold_convert (long_integer_type_node
, end
.expr
),
1799 fold_convert (long_integer_type_node
,
1800 se
->string_length
));
1804 /* Try to calculate the length from the start and end expressions. */
1806 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1810 i_len
= mpz_get_si (length
) + 1;
1814 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1815 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1819 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1820 end
.expr
, start
.expr
);
1821 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1822 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1823 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1824 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1827 se
->string_length
= tmp
;
1831 /* Convert a derived type component reference. */
1834 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1841 c
= ref
->u
.c
.component
;
1843 gcc_assert (c
->backend_decl
);
1845 field
= c
->backend_decl
;
1846 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1849 /* Components can correspond to fields of different containing
1850 types, as components are created without context, whereas
1851 a concrete use of a component has the type of decl as context.
1852 So, if the type doesn't match, we search the corresponding
1853 FIELD_DECL in the parent type. To not waste too much time
1854 we cache this result in norestrict_decl. */
1856 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1858 tree f2
= c
->norestrict_decl
;
1859 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1860 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1861 if (TREE_CODE (f2
) == FIELD_DECL
1862 && DECL_NAME (f2
) == DECL_NAME (field
))
1865 c
->norestrict_decl
= f2
;
1869 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1870 decl
, field
, NULL_TREE
);
1874 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1876 tmp
= c
->ts
.u
.cl
->backend_decl
;
1877 /* Components must always be constant length. */
1878 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1879 se
->string_length
= tmp
;
1882 if (gfc_deferred_strlen (c
, &field
))
1884 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1886 decl
, field
, NULL_TREE
);
1887 se
->string_length
= tmp
;
1890 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1891 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1892 && c
->ts
.type
!= BT_CHARACTER
)
1893 || c
->attr
.proc_pointer
)
1894 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1899 /* This function deals with component references to components of the
1900 parent type for derived type extensions. */
1902 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1910 c
= ref
->u
.c
.component
;
1912 /* Return if the component is in the parent type. */
1913 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1914 if (strcmp (c
->name
, cmp
->name
) == 0)
1917 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1918 parent
.type
= REF_COMPONENT
;
1920 parent
.u
.c
.sym
= dt
;
1921 parent
.u
.c
.component
= dt
->components
;
1923 if (dt
->backend_decl
== NULL
)
1924 gfc_get_derived_type (dt
);
1926 /* Build the reference and call self. */
1927 gfc_conv_component_ref (se
, &parent
);
1928 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1929 parent
.u
.c
.component
= c
;
1930 conv_parent_component_references (se
, &parent
);
1933 /* Return the contents of a variable. Also handles reference/pointer
1934 variables (all Fortran pointer references are implicit). */
1937 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1942 tree parent_decl
= NULL_TREE
;
1945 bool alternate_entry
;
1948 sym
= expr
->symtree
->n
.sym
;
1952 gfc_ss_info
*ss_info
= ss
->info
;
1954 /* Check that something hasn't gone horribly wrong. */
1955 gcc_assert (ss
!= gfc_ss_terminator
);
1956 gcc_assert (ss_info
->expr
== expr
);
1958 /* A scalarized term. We already know the descriptor. */
1959 se
->expr
= ss_info
->data
.array
.descriptor
;
1960 se
->string_length
= ss_info
->string_length
;
1961 ref
= ss_info
->data
.array
.ref
;
1963 gcc_assert (ref
->type
== REF_ARRAY
1964 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1966 gfc_conv_tmp_array_ref (se
);
1970 tree se_expr
= NULL_TREE
;
1972 se
->expr
= gfc_get_symbol_decl (sym
);
1974 /* Deal with references to a parent results or entries by storing
1975 the current_function_decl and moving to the parent_decl. */
1976 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1977 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1978 && sym
->result
== sym
;
1979 entry_master
= sym
->attr
.result
1980 && sym
->ns
->proc_name
->attr
.entry_master
1981 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1982 if (current_function_decl
)
1983 parent_decl
= DECL_CONTEXT (current_function_decl
);
1985 if ((se
->expr
== parent_decl
&& return_value
)
1986 || (sym
->ns
&& sym
->ns
->proc_name
1988 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1989 && (alternate_entry
|| entry_master
)))
1994 /* Special case for assigning the return value of a function.
1995 Self recursive functions must have an explicit return value. */
1996 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1997 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1999 /* Similarly for alternate entry points. */
2000 else if (alternate_entry
2001 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2004 gfc_entry_list
*el
= NULL
;
2006 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2009 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2014 else if (entry_master
2015 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2017 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2022 /* Procedure actual arguments. */
2023 else if (sym
->attr
.flavor
== FL_PROCEDURE
2024 && se
->expr
!= current_function_decl
)
2026 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2028 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2029 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2035 /* Dereference the expression, where needed. Since characters
2036 are entirely different from other types, they are treated
2038 if (sym
->ts
.type
== BT_CHARACTER
)
2040 /* Dereference character pointer dummy arguments
2042 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2044 || sym
->attr
.function
2045 || sym
->attr
.result
))
2046 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2050 else if (!sym
->attr
.value
)
2052 /* Dereference non-character scalar dummy arguments. */
2053 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2054 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
2055 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2058 /* Dereference scalar hidden result. */
2059 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2060 && (sym
->attr
.function
|| sym
->attr
.result
)
2061 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2062 && !sym
->attr
.always_explicit
)
2063 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2066 /* Dereference non-character pointer variables.
2067 These must be dummies, results, or scalars. */
2068 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2069 || gfc_is_associate_pointer (sym
)
2070 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2072 || sym
->attr
.function
2074 || (!sym
->attr
.dimension
2075 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2076 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2083 /* For character variables, also get the length. */
2084 if (sym
->ts
.type
== BT_CHARACTER
)
2086 /* If the character length of an entry isn't set, get the length from
2087 the master function instead. */
2088 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2089 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2091 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2092 gcc_assert (se
->string_length
);
2100 /* Return the descriptor if that's what we want and this is an array
2101 section reference. */
2102 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2104 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2105 /* Return the descriptor for array pointers and allocations. */
2106 if (se
->want_pointer
2107 && ref
->next
== NULL
&& (se
->descriptor_only
))
2110 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2111 /* Return a pointer to an element. */
2115 if (ref
->u
.c
.sym
->attr
.extension
)
2116 conv_parent_component_references (se
, ref
);
2118 gfc_conv_component_ref (se
, ref
);
2119 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2120 && se
->want_pointer
&& se
->descriptor_only
)
2126 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2127 expr
->symtree
->name
, &expr
->where
);
2136 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2138 if (se
->want_pointer
)
2140 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2141 gfc_conv_string_parameter (se
);
2143 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2148 /* Unary ops are easy... Or they would be if ! was a valid op. */
2151 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2156 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2157 /* Initialize the operand. */
2158 gfc_init_se (&operand
, se
);
2159 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2160 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2162 type
= gfc_typenode_for_spec (&expr
->ts
);
2164 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2165 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2166 All other unary operators have an equivalent GIMPLE unary operator. */
2167 if (code
== TRUTH_NOT_EXPR
)
2168 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2169 build_int_cst (type
, 0));
2171 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2175 /* Expand power operator to optimal multiplications when a value is raised
2176 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2177 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2178 Programming", 3rd Edition, 1998. */
2180 /* This code is mostly duplicated from expand_powi in the backend.
2181 We establish the "optimal power tree" lookup table with the defined size.
2182 The items in the table are the exponents used to calculate the index
2183 exponents. Any integer n less than the value can get an "addition chain",
2184 with the first node being one. */
2185 #define POWI_TABLE_SIZE 256
2187 /* The table is from builtins.c. */
2188 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2190 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2191 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2192 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2193 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2194 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2195 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2196 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2197 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2198 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2199 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2200 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2201 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2202 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2203 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2204 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2205 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2206 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2207 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2208 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2209 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2210 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2211 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2212 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2213 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2214 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2215 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2216 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2217 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2218 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2219 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2220 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2221 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2224 /* If n is larger than lookup table's max index, we use the "window
2226 #define POWI_WINDOW_SIZE 3
2228 /* Recursive function to expand the power operator. The temporary
2229 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2231 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2238 if (n
< POWI_TABLE_SIZE
)
2243 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2244 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2248 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2249 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2250 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2254 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2258 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2259 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2261 if (n
< POWI_TABLE_SIZE
)
2268 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2269 return 1. Else return 0 and a call to runtime library functions
2270 will have to be built. */
2272 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2277 tree vartmp
[POWI_TABLE_SIZE
];
2279 unsigned HOST_WIDE_INT n
;
2281 wide_int wrhs
= rhs
;
2283 /* If exponent is too large, we won't expand it anyway, so don't bother
2284 with large integer values. */
2285 if (!wi::fits_shwi_p (wrhs
))
2288 m
= wrhs
.to_shwi ();
2289 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2290 of the asymmetric range of the integer type. */
2291 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2293 type
= TREE_TYPE (lhs
);
2294 sgn
= tree_int_cst_sgn (rhs
);
2296 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2297 || optimize_size
) && (m
> 2 || m
< -1))
2303 se
->expr
= gfc_build_const (type
, integer_one_node
);
2307 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2308 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2310 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2311 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2312 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2313 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2316 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2319 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2320 boolean_type_node
, tmp
, cond
);
2321 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2322 tmp
, build_int_cst (type
, 1),
2323 build_int_cst (type
, 0));
2327 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2328 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2329 build_int_cst (type
, -1),
2330 build_int_cst (type
, 0));
2331 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2332 cond
, build_int_cst (type
, 1), tmp
);
2336 memset (vartmp
, 0, sizeof (vartmp
));
2340 tmp
= gfc_build_const (type
, integer_one_node
);
2341 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2345 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2351 /* Power op (**). Constant integer exponent has special handling. */
2354 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2356 tree gfc_int4_type_node
;
2359 int res_ikind_1
, res_ikind_2
;
2364 gfc_init_se (&lse
, se
);
2365 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2366 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2367 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2369 gfc_init_se (&rse
, se
);
2370 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2371 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2373 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2374 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2375 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2378 gfc_int4_type_node
= gfc_get_int_type (4);
2380 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2381 library routine. But in the end, we have to convert the result back
2382 if this case applies -- with res_ikind_K, we keep track whether operand K
2383 falls into this case. */
2387 kind
= expr
->value
.op
.op1
->ts
.kind
;
2388 switch (expr
->value
.op
.op2
->ts
.type
)
2391 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2396 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2397 res_ikind_2
= ikind
;
2419 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2421 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2448 switch (expr
->value
.op
.op1
->ts
.type
)
2451 if (kind
== 3) /* Case 16 was not handled properly above. */
2453 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2457 /* Use builtins for real ** int4. */
2463 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2467 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2471 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2475 /* Use the __builtin_powil() only if real(kind=16) is
2476 actually the C long double type. */
2477 if (!gfc_real16_is_float128
)
2478 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2486 /* If we don't have a good builtin for this, go for the
2487 library function. */
2489 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2493 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2502 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2506 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2514 se
->expr
= build_call_expr_loc (input_location
,
2515 fndecl
, 2, lse
.expr
, rse
.expr
);
2517 /* Convert the result back if it is of wrong integer kind. */
2518 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2520 /* We want the maximum of both operand kinds as result. */
2521 if (res_ikind_1
< res_ikind_2
)
2522 res_ikind_1
= res_ikind_2
;
2523 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2528 /* Generate code to allocate a string temporary. */
2531 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2536 if (gfc_can_put_var_on_stack (len
))
2538 /* Create a temporary variable to hold the result. */
2539 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2540 gfc_charlen_type_node
, len
,
2541 build_int_cst (gfc_charlen_type_node
, 1));
2542 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2544 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2545 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2547 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2549 var
= gfc_create_var (tmp
, "str");
2550 var
= gfc_build_addr_expr (type
, var
);
2554 /* Allocate a temporary to hold the result. */
2555 var
= gfc_create_var (type
, "pstr");
2556 gcc_assert (POINTER_TYPE_P (type
));
2557 tmp
= TREE_TYPE (type
);
2558 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2559 tmp
= TREE_TYPE (tmp
);
2560 tmp
= TYPE_SIZE_UNIT (tmp
);
2561 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2562 fold_convert (size_type_node
, len
),
2563 fold_convert (size_type_node
, tmp
));
2564 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2565 gfc_add_modify (&se
->pre
, var
, tmp
);
2567 /* Free the temporary afterwards. */
2568 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2569 gfc_add_expr_to_block (&se
->post
, tmp
);
2576 /* Handle a string concatenation operation. A temporary will be allocated to
2580 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2583 tree len
, type
, var
, tmp
, fndecl
;
2585 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2586 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2587 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2589 gfc_init_se (&lse
, se
);
2590 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2591 gfc_conv_string_parameter (&lse
);
2592 gfc_init_se (&rse
, se
);
2593 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2594 gfc_conv_string_parameter (&rse
);
2596 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2597 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2599 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2600 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2601 if (len
== NULL_TREE
)
2603 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2604 TREE_TYPE (lse
.string_length
),
2605 lse
.string_length
, rse
.string_length
);
2608 type
= build_pointer_type (type
);
2610 var
= gfc_conv_string_tmp (se
, type
, len
);
2612 /* Do the actual concatenation. */
2613 if (expr
->ts
.kind
== 1)
2614 fndecl
= gfor_fndecl_concat_string
;
2615 else if (expr
->ts
.kind
== 4)
2616 fndecl
= gfor_fndecl_concat_string_char4
;
2620 tmp
= build_call_expr_loc (input_location
,
2621 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2622 rse
.string_length
, rse
.expr
);
2623 gfc_add_expr_to_block (&se
->pre
, tmp
);
2625 /* Add the cleanup for the operands. */
2626 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2627 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2630 se
->string_length
= len
;
2633 /* Translates an op expression. Common (binary) cases are handled by this
2634 function, others are passed on. Recursion is used in either case.
2635 We use the fact that (op1.ts == op2.ts) (except for the power
2637 Operators need no special handling for scalarized expressions as long as
2638 they call gfc_conv_simple_val to get their operands.
2639 Character strings get special handling. */
2642 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2644 enum tree_code code
;
2653 switch (expr
->value
.op
.op
)
2655 case INTRINSIC_PARENTHESES
:
2656 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
2657 && flag_protect_parens
)
2659 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2660 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2665 case INTRINSIC_UPLUS
:
2666 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2669 case INTRINSIC_UMINUS
:
2670 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2674 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2677 case INTRINSIC_PLUS
:
2681 case INTRINSIC_MINUS
:
2685 case INTRINSIC_TIMES
:
2689 case INTRINSIC_DIVIDE
:
2690 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2691 an integer, we must round towards zero, so we use a
2693 if (expr
->ts
.type
== BT_INTEGER
)
2694 code
= TRUNC_DIV_EXPR
;
2699 case INTRINSIC_POWER
:
2700 gfc_conv_power_op (se
, expr
);
2703 case INTRINSIC_CONCAT
:
2704 gfc_conv_concat_op (se
, expr
);
2708 code
= TRUTH_ANDIF_EXPR
;
2713 code
= TRUTH_ORIF_EXPR
;
2717 /* EQV and NEQV only work on logicals, but since we represent them
2718 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2720 case INTRINSIC_EQ_OS
:
2728 case INTRINSIC_NE_OS
:
2729 case INTRINSIC_NEQV
:
2736 case INTRINSIC_GT_OS
:
2743 case INTRINSIC_GE_OS
:
2750 case INTRINSIC_LT_OS
:
2757 case INTRINSIC_LE_OS
:
2763 case INTRINSIC_USER
:
2764 case INTRINSIC_ASSIGN
:
2765 /* These should be converted into function calls by the frontend. */
2769 fatal_error ("Unknown intrinsic op");
2773 /* The only exception to this is **, which is handled separately anyway. */
2774 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2776 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2780 gfc_init_se (&lse
, se
);
2781 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2782 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2785 gfc_init_se (&rse
, se
);
2786 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2787 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2791 gfc_conv_string_parameter (&lse
);
2792 gfc_conv_string_parameter (&rse
);
2794 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2795 rse
.string_length
, rse
.expr
,
2796 expr
->value
.op
.op1
->ts
.kind
,
2798 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2799 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2802 type
= gfc_typenode_for_spec (&expr
->ts
);
2806 /* The result of logical ops is always boolean_type_node. */
2807 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2808 lse
.expr
, rse
.expr
);
2809 se
->expr
= convert (type
, tmp
);
2812 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2814 /* Add the post blocks. */
2815 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2816 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2819 /* If a string's length is one, we convert it to a single character. */
2822 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2826 || !tree_fits_uhwi_p (len
)
2827 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2830 if (TREE_INT_CST_LOW (len
) == 1)
2832 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2833 return build_fold_indirect_ref_loc (input_location
, str
);
2837 && TREE_CODE (str
) == ADDR_EXPR
2838 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2839 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2840 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2841 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2842 && TREE_INT_CST_LOW (len
) > 1
2843 && TREE_INT_CST_LOW (len
)
2844 == (unsigned HOST_WIDE_INT
)
2845 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2847 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2848 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2849 if (TREE_CODE (ret
) == INTEGER_CST
)
2851 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2852 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2853 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2855 for (i
= 1; i
< length
; i
++)
2868 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2871 if (sym
->backend_decl
)
2873 /* This becomes the nominal_type in
2874 function.c:assign_parm_find_data_types. */
2875 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2876 /* This becomes the passed_type in
2877 function.c:assign_parm_find_data_types. C promotes char to
2878 integer for argument passing. */
2879 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2881 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2886 /* If we have a constant character expression, make it into an
2888 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2893 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2894 (int)(*expr
)->value
.character
.string
[0]);
2895 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2897 /* The expr needs to be compatible with a C int. If the
2898 conversion fails, then the 2 causes an ICE. */
2899 ts
.type
= BT_INTEGER
;
2900 ts
.kind
= gfc_c_int_kind
;
2901 gfc_convert_type (*expr
, &ts
, 2);
2904 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2906 if ((*expr
)->ref
== NULL
)
2908 se
->expr
= gfc_string_to_single_character
2909 (build_int_cst (integer_type_node
, 1),
2910 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2912 ((*expr
)->symtree
->n
.sym
)),
2917 gfc_conv_variable (se
, *expr
);
2918 se
->expr
= gfc_string_to_single_character
2919 (build_int_cst (integer_type_node
, 1),
2920 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2928 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2929 if STR is a string literal, otherwise return -1. */
2932 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2935 && TREE_CODE (str
) == ADDR_EXPR
2936 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2937 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2938 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2939 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2940 && tree_fits_uhwi_p (len
)
2941 && tree_to_uhwi (len
) >= 1
2942 && tree_to_uhwi (len
)
2943 == (unsigned HOST_WIDE_INT
)
2944 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2946 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2947 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2948 if (TREE_CODE (folded
) == INTEGER_CST
)
2950 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2951 int length
= TREE_STRING_LENGTH (string_cst
);
2952 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2954 for (; length
> 0; length
--)
2955 if (ptr
[length
- 1] != ' ')
2964 /* Helper to build a call to memcmp. */
2967 build_memcmp_call (tree s1
, tree s2
, tree n
)
2971 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2972 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2974 s1
= fold_convert (pvoid_type_node
, s1
);
2976 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2977 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2979 s2
= fold_convert (pvoid_type_node
, s2
);
2981 n
= fold_convert (size_type_node
, n
);
2983 tmp
= build_call_expr_loc (input_location
,
2984 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2987 return fold_convert (integer_type_node
, tmp
);
2990 /* Compare two strings. If they are all single characters, the result is the
2991 subtraction of them. Otherwise, we build a library call. */
2994 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2995 enum tree_code code
)
3001 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3002 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3004 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3005 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3007 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3009 /* Deal with single character specially. */
3010 sc1
= fold_convert (integer_type_node
, sc1
);
3011 sc2
= fold_convert (integer_type_node
, sc2
);
3012 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3016 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3018 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3020 /* If one string is a string literal with LEN_TRIM longer
3021 than the length of the second string, the strings
3023 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3024 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3025 return integer_one_node
;
3026 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3027 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3028 return integer_one_node
;
3031 /* We can compare via memcpy if the strings are known to be equal
3032 in length and they are
3034 - kind=4 and the comparison is for (in)equality. */
3036 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3037 && tree_int_cst_equal (len1
, len2
)
3038 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3043 chartype
= gfc_get_char_type (kind
);
3044 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3045 fold_convert (TREE_TYPE(len1
),
3046 TYPE_SIZE_UNIT(chartype
)),
3048 return build_memcmp_call (str1
, str2
, tmp
);
3051 /* Build a call for the comparison. */
3053 fndecl
= gfor_fndecl_compare_string
;
3055 fndecl
= gfor_fndecl_compare_string_char4
;
3059 return build_call_expr_loc (input_location
, fndecl
, 4,
3060 len1
, str1
, len2
, str2
);
3064 /* Return the backend_decl for a procedure pointer component. */
3067 get_proc_ptr_comp (gfc_expr
*e
)
3073 gfc_init_se (&comp_se
, NULL
);
3074 e2
= gfc_copy_expr (e
);
3075 /* We have to restore the expr type later so that gfc_free_expr frees
3076 the exact same thing that was allocated.
3077 TODO: This is ugly. */
3078 old_type
= e2
->expr_type
;
3079 e2
->expr_type
= EXPR_VARIABLE
;
3080 gfc_conv_expr (&comp_se
, e2
);
3081 e2
->expr_type
= old_type
;
3083 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3087 /* Convert a typebound function reference from a class object. */
3089 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3094 if (TREE_CODE (base_object
) != VAR_DECL
)
3096 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3097 gfc_add_modify (&se
->pre
, var
, base_object
);
3099 se
->expr
= gfc_class_vptr_get (base_object
);
3100 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3102 while (ref
&& ref
->next
)
3104 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3105 if (ref
->u
.c
.sym
->attr
.extension
)
3106 conv_parent_component_references (se
, ref
);
3107 gfc_conv_component_ref (se
, ref
);
3108 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3113 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3117 if (gfc_is_proc_ptr_comp (expr
))
3118 tmp
= get_proc_ptr_comp (expr
);
3119 else if (sym
->attr
.dummy
)
3121 tmp
= gfc_get_symbol_decl (sym
);
3122 if (sym
->attr
.proc_pointer
)
3123 tmp
= build_fold_indirect_ref_loc (input_location
,
3125 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3126 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3130 if (!sym
->backend_decl
)
3131 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3133 TREE_USED (sym
->backend_decl
) = 1;
3135 tmp
= sym
->backend_decl
;
3137 if (sym
->attr
.cray_pointee
)
3139 /* TODO - make the cray pointee a pointer to a procedure,
3140 assign the pointer to it and use it for the call. This
3142 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3143 gfc_get_symbol_decl (sym
->cp_pointer
));
3144 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3147 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3149 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3150 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3157 /* Initialize MAPPING. */
3160 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3162 mapping
->syms
= NULL
;
3163 mapping
->charlens
= NULL
;
3167 /* Free all memory held by MAPPING (but not MAPPING itself). */
3170 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3172 gfc_interface_sym_mapping
*sym
;
3173 gfc_interface_sym_mapping
*nextsym
;
3175 gfc_charlen
*nextcl
;
3177 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3179 nextsym
= sym
->next
;
3180 sym
->new_sym
->n
.sym
->formal
= NULL
;
3181 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3182 gfc_free_expr (sym
->expr
);
3183 free (sym
->new_sym
);
3186 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3189 gfc_free_expr (cl
->length
);
3195 /* Return a copy of gfc_charlen CL. Add the returned structure to
3196 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3198 static gfc_charlen
*
3199 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3202 gfc_charlen
*new_charlen
;
3204 new_charlen
= gfc_get_charlen ();
3205 new_charlen
->next
= mapping
->charlens
;
3206 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3208 mapping
->charlens
= new_charlen
;
3213 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3214 array variable that can be used as the actual argument for dummy
3215 argument SYM. Add any initialization code to BLOCK. PACKED is as
3216 for gfc_get_nodesc_array_type and DATA points to the first element
3217 in the passed array. */
3220 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3221 gfc_packed packed
, tree data
)
3226 type
= gfc_typenode_for_spec (&sym
->ts
);
3227 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3228 !sym
->attr
.target
&& !sym
->attr
.pointer
3229 && !sym
->attr
.proc_pointer
);
3231 var
= gfc_create_var (type
, "ifm");
3232 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3238 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3239 and offset of descriptorless array type TYPE given that it has the same
3240 size as DESC. Add any set-up code to BLOCK. */
3243 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3250 offset
= gfc_index_zero_node
;
3251 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3253 dim
= gfc_rank_cst
[n
];
3254 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3255 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3257 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3258 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3259 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3260 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3262 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3264 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3265 gfc_array_index_type
,
3266 gfc_conv_descriptor_ubound_get (desc
, dim
),
3267 gfc_conv_descriptor_lbound_get (desc
, dim
));
3268 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3269 gfc_array_index_type
,
3270 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3271 tmp
= gfc_evaluate_now (tmp
, block
);
3272 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3274 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3275 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3276 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3277 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3278 gfc_array_index_type
, offset
, tmp
);
3280 offset
= gfc_evaluate_now (offset
, block
);
3281 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3285 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3286 in SE. The caller may still use se->expr and se->string_length after
3287 calling this function. */
3290 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3291 gfc_symbol
* sym
, gfc_se
* se
,
3294 gfc_interface_sym_mapping
*sm
;
3298 gfc_symbol
*new_sym
;
3300 gfc_symtree
*new_symtree
;
3302 /* Create a new symbol to represent the actual argument. */
3303 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3304 new_sym
->ts
= sym
->ts
;
3305 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3306 new_sym
->attr
.referenced
= 1;
3307 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3308 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3309 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3310 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3311 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3312 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3313 new_sym
->attr
.function
= sym
->attr
.function
;
3315 /* Ensure that the interface is available and that
3316 descriptors are passed for array actual arguments. */
3317 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3319 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3320 new_sym
->attr
.always_explicit
3321 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3324 /* Create a fake symtree for it. */
3326 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3327 new_symtree
->n
.sym
= new_sym
;
3328 gcc_assert (new_symtree
== root
);
3330 /* Create a dummy->actual mapping. */
3331 sm
= XCNEW (gfc_interface_sym_mapping
);
3332 sm
->next
= mapping
->syms
;
3334 sm
->new_sym
= new_symtree
;
3335 sm
->expr
= gfc_copy_expr (expr
);
3338 /* Stabilize the argument's value. */
3339 if (!sym
->attr
.function
&& se
)
3340 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3342 if (sym
->ts
.type
== BT_CHARACTER
)
3344 /* Create a copy of the dummy argument's length. */
3345 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3346 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3348 /* If the length is specified as "*", record the length that
3349 the caller is passing. We should use the callee's length
3350 in all other cases. */
3351 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3353 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3354 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3361 /* Use the passed value as-is if the argument is a function. */
3362 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3365 /* If the argument is either a string or a pointer to a string,
3366 convert it to a boundless character type. */
3367 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3369 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3370 tmp
= build_pointer_type (tmp
);
3371 if (sym
->attr
.pointer
)
3372 value
= build_fold_indirect_ref_loc (input_location
,
3376 value
= fold_convert (tmp
, value
);
3379 /* If the argument is a scalar, a pointer to an array or an allocatable,
3381 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3382 value
= build_fold_indirect_ref_loc (input_location
,
3385 /* For character(*), use the actual argument's descriptor. */
3386 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3387 value
= build_fold_indirect_ref_loc (input_location
,
3390 /* If the argument is an array descriptor, use it to determine
3391 information about the actual argument's shape. */
3392 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3393 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3395 /* Get the actual argument's descriptor. */
3396 desc
= build_fold_indirect_ref_loc (input_location
,
3399 /* Create the replacement variable. */
3400 tmp
= gfc_conv_descriptor_data_get (desc
);
3401 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3404 /* Use DESC to work out the upper bounds, strides and offset. */
3405 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3408 /* Otherwise we have a packed array. */
3409 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3410 PACKED_FULL
, se
->expr
);
3412 new_sym
->backend_decl
= value
;
3416 /* Called once all dummy argument mappings have been added to MAPPING,
3417 but before the mapping is used to evaluate expressions. Pre-evaluate
3418 the length of each argument, adding any initialization code to PRE and
3419 any finalization code to POST. */
3422 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3423 stmtblock_t
* pre
, stmtblock_t
* post
)
3425 gfc_interface_sym_mapping
*sym
;
3429 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3430 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3431 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3433 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3434 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3435 gfc_init_se (&se
, NULL
);
3436 gfc_conv_expr (&se
, expr
);
3437 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3438 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3439 gfc_add_block_to_block (pre
, &se
.pre
);
3440 gfc_add_block_to_block (post
, &se
.post
);
3442 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3447 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3451 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3452 gfc_constructor_base base
)
3455 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3457 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3460 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3461 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3462 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3468 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3472 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3477 for (; ref
; ref
= ref
->next
)
3481 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3483 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3484 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3485 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3493 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3494 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3500 /* Convert intrinsic function calls into result expressions. */
3503 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3511 arg1
= expr
->value
.function
.actual
->expr
;
3512 if (expr
->value
.function
.actual
->next
)
3513 arg2
= expr
->value
.function
.actual
->next
->expr
;
3517 sym
= arg1
->symtree
->n
.sym
;
3519 if (sym
->attr
.dummy
)
3524 switch (expr
->value
.function
.isym
->id
)
3527 /* TODO figure out why this condition is necessary. */
3528 if (sym
->attr
.function
3529 && (arg1
->ts
.u
.cl
->length
== NULL
3530 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3531 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3534 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3538 if (!sym
->as
|| sym
->as
->rank
== 0)
3541 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3543 dup
= mpz_get_si (arg2
->value
.integer
);
3548 dup
= sym
->as
->rank
;
3552 for (; d
< dup
; d
++)
3556 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3558 gfc_free_expr (new_expr
);
3562 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3563 gfc_get_int_expr (gfc_default_integer_kind
,
3565 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3567 new_expr
= gfc_multiply (new_expr
, tmp
);
3573 case GFC_ISYM_LBOUND
:
3574 case GFC_ISYM_UBOUND
:
3575 /* TODO These implementations of lbound and ubound do not limit if
3576 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3578 if (!sym
->as
|| sym
->as
->rank
== 0)
3581 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3582 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3584 /* TODO: If the need arises, this could produce an array of
3588 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3590 if (sym
->as
->lower
[d
])
3591 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3595 if (sym
->as
->upper
[d
])
3596 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3604 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3608 gfc_replace_expr (expr
, new_expr
);
3614 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3615 gfc_interface_mapping
* mapping
)
3617 gfc_formal_arglist
*f
;
3618 gfc_actual_arglist
*actual
;
3620 actual
= expr
->value
.function
.actual
;
3621 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3623 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3628 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3631 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3636 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3638 for (d
= 0; d
< as
->rank
; d
++)
3640 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3641 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3644 expr
->value
.function
.esym
->as
= as
;
3647 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3649 expr
->value
.function
.esym
->ts
.u
.cl
->length
3650 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3652 gfc_apply_interface_mapping_to_expr (mapping
,
3653 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3658 /* EXPR is a copy of an expression that appeared in the interface
3659 associated with MAPPING. Walk it recursively looking for references to
3660 dummy arguments that MAPPING maps to actual arguments. Replace each such
3661 reference with a reference to the associated actual argument. */
3664 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3667 gfc_interface_sym_mapping
*sym
;
3668 gfc_actual_arglist
*actual
;
3673 /* Copying an expression does not copy its length, so do that here. */
3674 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3676 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3677 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3680 /* Apply the mapping to any references. */
3681 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3683 /* ...and to the expression's symbol, if it has one. */
3684 /* TODO Find out why the condition on expr->symtree had to be moved into
3685 the loop rather than being outside it, as originally. */
3686 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3687 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3689 if (sym
->new_sym
->n
.sym
->backend_decl
)
3690 expr
->symtree
= sym
->new_sym
;
3692 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3693 /* Replace base type for polymorphic arguments. */
3694 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3695 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3696 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3699 /* ...and to subexpressions in expr->value. */
3700 switch (expr
->expr_type
)
3705 case EXPR_SUBSTRING
:
3709 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3710 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3714 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3715 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3717 if (expr
->value
.function
.esym
== NULL
3718 && expr
->value
.function
.isym
!= NULL
3719 && expr
->value
.function
.actual
->expr
->symtree
3720 && gfc_map_intrinsic_function (expr
, mapping
))
3723 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3724 if (sym
->old
== expr
->value
.function
.esym
)
3726 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3727 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3728 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3733 case EXPR_STRUCTURE
:
3734 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3747 /* Evaluate interface expression EXPR using MAPPING. Store the result
3751 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3752 gfc_se
* se
, gfc_expr
* expr
)
3754 expr
= gfc_copy_expr (expr
);
3755 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3756 gfc_conv_expr (se
, expr
);
3757 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3758 gfc_free_expr (expr
);
3762 /* Returns a reference to a temporary array into which a component of
3763 an actual argument derived type array is copied and then returned
3764 after the function call. */
3766 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3767 sym_intent intent
, bool formal_ptr
)
3775 gfc_array_info
*info
;
3785 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3787 gfc_init_se (&lse
, NULL
);
3788 gfc_init_se (&rse
, NULL
);
3790 /* Walk the argument expression. */
3791 rss
= gfc_walk_expr (expr
);
3793 gcc_assert (rss
!= gfc_ss_terminator
);
3795 /* Initialize the scalarizer. */
3796 gfc_init_loopinfo (&loop
);
3797 gfc_add_ss_to_loop (&loop
, rss
);
3799 /* Calculate the bounds of the scalarization. */
3800 gfc_conv_ss_startstride (&loop
);
3802 /* Build an ss for the temporary. */
3803 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3804 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3806 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3807 if (GFC_ARRAY_TYPE_P (base_type
)
3808 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3809 base_type
= gfc_get_element_type (base_type
);
3811 if (expr
->ts
.type
== BT_CLASS
)
3812 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3814 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3815 ? expr
->ts
.u
.cl
->backend_decl
3819 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3821 /* Associate the SS with the loop. */
3822 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3824 /* Setup the scalarizing loops. */
3825 gfc_conv_loop_setup (&loop
, &expr
->where
);
3827 /* Pass the temporary descriptor back to the caller. */
3828 info
= &loop
.temp_ss
->info
->data
.array
;
3829 parmse
->expr
= info
->descriptor
;
3831 /* Setup the gfc_se structures. */
3832 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3833 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3836 lse
.ss
= loop
.temp_ss
;
3837 gfc_mark_ss_chain_used (rss
, 1);
3838 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3840 /* Start the scalarized loop body. */
3841 gfc_start_scalarized_body (&loop
, &body
);
3843 /* Translate the expression. */
3844 gfc_conv_expr (&rse
, expr
);
3846 gfc_conv_tmp_array_ref (&lse
);
3848 if (intent
!= INTENT_OUT
)
3850 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3851 gfc_add_expr_to_block (&body
, tmp
);
3852 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3853 gfc_trans_scalarizing_loops (&loop
, &body
);
3857 /* Make sure that the temporary declaration survives by merging
3858 all the loop declarations into the current context. */
3859 for (n
= 0; n
< loop
.dimen
; n
++)
3861 gfc_merge_block_scope (&body
);
3862 body
= loop
.code
[loop
.order
[n
]];
3864 gfc_merge_block_scope (&body
);
3867 /* Add the post block after the second loop, so that any
3868 freeing of allocated memory is done at the right time. */
3869 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3871 /**********Copy the temporary back again.*********/
3873 gfc_init_se (&lse
, NULL
);
3874 gfc_init_se (&rse
, NULL
);
3876 /* Walk the argument expression. */
3877 lss
= gfc_walk_expr (expr
);
3878 rse
.ss
= loop
.temp_ss
;
3881 /* Initialize the scalarizer. */
3882 gfc_init_loopinfo (&loop2
);
3883 gfc_add_ss_to_loop (&loop2
, lss
);
3885 /* Calculate the bounds of the scalarization. */
3886 gfc_conv_ss_startstride (&loop2
);
3888 /* Setup the scalarizing loops. */
3889 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3891 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3892 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3894 gfc_mark_ss_chain_used (lss
, 1);
3895 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3897 /* Declare the variable to hold the temporary offset and start the
3898 scalarized loop body. */
3899 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3900 gfc_start_scalarized_body (&loop2
, &body
);
3902 /* Build the offsets for the temporary from the loop variables. The
3903 temporary array has lbounds of zero and strides of one in all
3904 dimensions, so this is very simple. The offset is only computed
3905 outside the innermost loop, so the overall transfer could be
3906 optimized further. */
3907 info
= &rse
.ss
->info
->data
.array
;
3908 dimen
= rse
.ss
->dimen
;
3910 tmp_index
= gfc_index_zero_node
;
3911 for (n
= dimen
- 1; n
> 0; n
--)
3914 tmp
= rse
.loop
->loopvar
[n
];
3915 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3916 tmp
, rse
.loop
->from
[n
]);
3917 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3920 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3921 gfc_array_index_type
,
3922 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3923 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3924 gfc_array_index_type
,
3925 tmp_str
, gfc_index_one_node
);
3927 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3928 gfc_array_index_type
, tmp
, tmp_str
);
3931 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3932 gfc_array_index_type
,
3933 tmp_index
, rse
.loop
->from
[0]);
3934 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3936 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3937 gfc_array_index_type
,
3938 rse
.loop
->loopvar
[0], offset
);
3940 /* Now use the offset for the reference. */
3941 tmp
= build_fold_indirect_ref_loc (input_location
,
3943 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3945 if (expr
->ts
.type
== BT_CHARACTER
)
3946 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3948 gfc_conv_expr (&lse
, expr
);
3950 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3952 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3953 gfc_add_expr_to_block (&body
, tmp
);
3955 /* Generate the copying loops. */
3956 gfc_trans_scalarizing_loops (&loop2
, &body
);
3958 /* Wrap the whole thing up by adding the second loop to the post-block
3959 and following it by the post-block of the first loop. In this way,
3960 if the temporary needs freeing, it is done after use! */
3961 if (intent
!= INTENT_IN
)
3963 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3964 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3967 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3969 gfc_cleanup_loop (&loop
);
3970 gfc_cleanup_loop (&loop2
);
3972 /* Pass the string length to the argument expression. */
3973 if (expr
->ts
.type
== BT_CHARACTER
)
3974 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3976 /* Determine the offset for pointer formal arguments and set the
3980 size
= gfc_index_one_node
;
3981 offset
= gfc_index_zero_node
;
3982 for (n
= 0; n
< dimen
; n
++)
3984 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3986 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3987 gfc_array_index_type
, tmp
,
3988 gfc_index_one_node
);
3989 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3993 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3996 gfc_index_one_node
);
3997 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3998 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3999 gfc_array_index_type
,
4001 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4002 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4003 gfc_array_index_type
,
4004 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4005 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4006 gfc_array_index_type
,
4007 tmp
, gfc_index_one_node
);
4008 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4009 gfc_array_index_type
, size
, tmp
);
4012 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4016 /* We want either the address for the data or the address of the descriptor,
4017 depending on the mode of passing array arguments. */
4019 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4021 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4027 /* Generate the code for argument list functions. */
4030 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4032 /* Pass by value for g77 %VAL(arg), pass the address
4033 indirectly for %LOC, else by reference. Thus %REF
4034 is a "do-nothing" and %LOC is the same as an F95
4036 if (strncmp (name
, "%VAL", 4) == 0)
4037 gfc_conv_expr (se
, expr
);
4038 else if (strncmp (name
, "%LOC", 4) == 0)
4040 gfc_conv_expr_reference (se
, expr
);
4041 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4043 else if (strncmp (name
, "%REF", 4) == 0)
4044 gfc_conv_expr_reference (se
, expr
);
4046 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4050 /* Generate code for a procedure call. Note can return se->post != NULL.
4051 If se->direct_byref is set then se->expr contains the return parameter.
4052 Return nonzero, if the call has alternate specifiers.
4053 'expr' is only needed for procedure pointer components. */
4056 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4057 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4058 vec
<tree
, va_gc
> *append_args
)
4060 gfc_interface_mapping mapping
;
4061 vec
<tree
, va_gc
> *arglist
;
4062 vec
<tree
, va_gc
> *retargs
;
4066 gfc_array_info
*info
;
4073 vec
<tree
, va_gc
> *stringargs
;
4074 vec
<tree
, va_gc
> *optionalargs
;
4076 gfc_formal_arglist
*formal
;
4077 gfc_actual_arglist
*arg
;
4078 int has_alternate_specifier
= 0;
4079 bool need_interface_mapping
;
4086 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4087 gfc_component
*comp
= NULL
;
4093 optionalargs
= NULL
;
4098 comp
= gfc_get_proc_ptr_comp (expr
);
4102 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4104 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4105 if (se
->ss
->info
->useflags
)
4107 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4108 && sym
->result
->attr
.dimension
)
4109 || (comp
&& comp
->attr
.dimension
));
4110 gcc_assert (se
->loop
!= NULL
);
4112 /* Access the previously obtained result. */
4113 gfc_conv_tmp_array_ref (se
);
4117 info
= &se
->ss
->info
->data
.array
;
4122 gfc_init_block (&post
);
4123 gfc_init_interface_mapping (&mapping
);
4126 formal
= gfc_sym_get_dummy_args (sym
);
4127 need_interface_mapping
= sym
->attr
.dimension
||
4128 (sym
->ts
.type
== BT_CHARACTER
4129 && sym
->ts
.u
.cl
->length
4130 && sym
->ts
.u
.cl
->length
->expr_type
4135 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4136 need_interface_mapping
= comp
->attr
.dimension
||
4137 (comp
->ts
.type
== BT_CHARACTER
4138 && comp
->ts
.u
.cl
->length
4139 && comp
->ts
.u
.cl
->length
->expr_type
4143 base_object
= NULL_TREE
;
4145 /* Evaluate the arguments. */
4146 for (arg
= args
; arg
!= NULL
;
4147 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4150 fsym
= formal
? formal
->sym
: NULL
;
4151 parm_kind
= MISSING
;
4153 /* Class array expressions are sometimes coming completely unadorned
4154 with either arrayspec or _data component. Correct that here.
4155 OOP-TODO: Move this to the frontend. */
4156 if (e
&& e
->expr_type
== EXPR_VARIABLE
4158 && e
->ts
.type
== BT_CLASS
4159 && (CLASS_DATA (e
)->attr
.codimension
4160 || CLASS_DATA (e
)->attr
.dimension
))
4162 gfc_typespec temp_ts
= e
->ts
;
4163 gfc_add_class_array_ref (e
);
4169 if (se
->ignore_optional
)
4171 /* Some intrinsics have already been resolved to the correct
4175 else if (arg
->label
)
4177 has_alternate_specifier
= 1;
4182 gfc_init_se (&parmse
, NULL
);
4184 /* For scalar arguments with VALUE attribute which are passed by
4185 value, pass "0" and a hidden argument gives the optional
4187 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4188 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4189 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4191 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4193 vec_safe_push (optionalargs
, boolean_false_node
);
4197 /* Pass a NULL pointer for an absent arg. */
4198 parmse
.expr
= null_pointer_node
;
4199 if (arg
->missing_arg_type
== BT_CHARACTER
)
4200 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4205 else if (arg
->expr
->expr_type
== EXPR_NULL
4206 && fsym
&& !fsym
->attr
.pointer
4207 && (fsym
->ts
.type
!= BT_CLASS
4208 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4210 /* Pass a NULL pointer to denote an absent arg. */
4211 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4212 && (fsym
->ts
.type
!= BT_CLASS
4213 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4214 gfc_init_se (&parmse
, NULL
);
4215 parmse
.expr
= null_pointer_node
;
4216 if (arg
->missing_arg_type
== BT_CHARACTER
)
4217 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4219 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4220 && e
->ts
.type
== BT_DERIVED
)
4222 /* The derived type needs to be converted to a temporary
4224 gfc_init_se (&parmse
, se
);
4225 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4227 && e
->expr_type
== EXPR_VARIABLE
4228 && e
->symtree
->n
.sym
->attr
.optional
,
4229 CLASS_DATA (fsym
)->attr
.class_pointer
4230 || CLASS_DATA (fsym
)->attr
.allocatable
);
4232 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4234 /* The intrinsic type needs to be converted to a temporary
4235 CLASS object for the unlimited polymorphic formal. */
4236 gfc_init_se (&parmse
, se
);
4237 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4239 else if (se
->ss
&& se
->ss
->info
->useflags
)
4245 /* An elemental function inside a scalarized loop. */
4246 gfc_init_se (&parmse
, se
);
4247 parm_kind
= ELEMENTAL
;
4249 if (fsym
&& fsym
->attr
.value
)
4250 gfc_conv_expr (&parmse
, e
);
4252 gfc_conv_expr_reference (&parmse
, e
);
4254 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4255 && e
->expr_type
== EXPR_FUNCTION
)
4256 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4259 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4260 && gfc_is_class_container_ref (e
))
4262 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4264 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4265 && e
->symtree
->n
.sym
->attr
.optional
)
4267 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4268 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4269 TREE_TYPE (parmse
.expr
),
4271 fold_convert (TREE_TYPE (parmse
.expr
),
4272 null_pointer_node
));
4276 /* If we are passing an absent array as optional dummy to an
4277 elemental procedure, make sure that we pass NULL when the data
4278 pointer is NULL. We need this extra conditional because of
4279 scalarization which passes arrays elements to the procedure,
4280 ignoring the fact that the array can be absent/unallocated/... */
4281 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4283 tree descriptor_data
;
4285 descriptor_data
= ss
->info
->data
.array
.data
;
4286 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4288 fold_convert (TREE_TYPE (descriptor_data
),
4289 null_pointer_node
));
4291 = fold_build3_loc (input_location
, COND_EXPR
,
4292 TREE_TYPE (parmse
.expr
),
4293 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4294 fold_convert (TREE_TYPE (parmse
.expr
),
4299 /* The scalarizer does not repackage the reference to a class
4300 array - instead it returns a pointer to the data element. */
4301 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4302 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4303 fsym
->attr
.intent
!= INTENT_IN
4304 && (CLASS_DATA (fsym
)->attr
.class_pointer
4305 || CLASS_DATA (fsym
)->attr
.allocatable
),
4307 && e
->expr_type
== EXPR_VARIABLE
4308 && e
->symtree
->n
.sym
->attr
.optional
,
4309 CLASS_DATA (fsym
)->attr
.class_pointer
4310 || CLASS_DATA (fsym
)->attr
.allocatable
);
4317 gfc_init_se (&parmse
, NULL
);
4319 /* Check whether the expression is a scalar or not; we cannot use
4320 e->rank as it can be nonzero for functions arguments. */
4321 argss
= gfc_walk_expr (e
);
4322 scalar
= argss
== gfc_ss_terminator
;
4324 gfc_free_ss_chain (argss
);
4326 /* Special handling for passing scalar polymorphic coarrays;
4327 otherwise one passes "class->_data.data" instead of "&class". */
4328 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4329 && fsym
&& fsym
->ts
.type
== BT_CLASS
4330 && CLASS_DATA (fsym
)->attr
.codimension
4331 && !CLASS_DATA (fsym
)->attr
.dimension
)
4333 gfc_add_class_array_ref (e
);
4334 parmse
.want_coarray
= 1;
4338 /* A scalar or transformational function. */
4341 if (e
->expr_type
== EXPR_VARIABLE
4342 && e
->symtree
->n
.sym
->attr
.cray_pointee
4343 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4345 /* The Cray pointer needs to be converted to a pointer to
4346 a type given by the expression. */
4347 gfc_conv_expr (&parmse
, e
);
4348 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4349 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4350 parmse
.expr
= convert (type
, tmp
);
4352 else if (fsym
&& fsym
->attr
.value
)
4354 if (fsym
->ts
.type
== BT_CHARACTER
4355 && fsym
->ts
.is_c_interop
4356 && fsym
->ns
->proc_name
!= NULL
4357 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4360 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4361 if (parmse
.expr
== NULL
)
4362 gfc_conv_expr (&parmse
, e
);
4366 gfc_conv_expr (&parmse
, e
);
4367 if (fsym
->attr
.optional
4368 && fsym
->ts
.type
!= BT_CLASS
4369 && fsym
->ts
.type
!= BT_DERIVED
)
4371 if (e
->expr_type
!= EXPR_VARIABLE
4372 || !e
->symtree
->n
.sym
->attr
.optional
4374 vec_safe_push (optionalargs
, boolean_true_node
);
4377 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4378 if (!e
->symtree
->n
.sym
->attr
.value
)
4380 = fold_build3_loc (input_location
, COND_EXPR
,
4381 TREE_TYPE (parmse
.expr
),
4383 fold_convert (TREE_TYPE (parmse
.expr
),
4384 integer_zero_node
));
4386 vec_safe_push (optionalargs
, tmp
);
4391 else if (arg
->name
&& arg
->name
[0] == '%')
4392 /* Argument list functions %VAL, %LOC and %REF are signalled
4393 through arg->name. */
4394 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4395 else if ((e
->expr_type
== EXPR_FUNCTION
)
4396 && ((e
->value
.function
.esym
4397 && e
->value
.function
.esym
->result
->attr
.pointer
)
4398 || (!e
->value
.function
.esym
4399 && e
->symtree
->n
.sym
->attr
.pointer
))
4400 && fsym
&& fsym
->attr
.target
)
4402 gfc_conv_expr (&parmse
, e
);
4403 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4405 else if (e
->expr_type
== EXPR_FUNCTION
4406 && e
->symtree
->n
.sym
->result
4407 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4408 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4410 /* Functions returning procedure pointers. */
4411 gfc_conv_expr (&parmse
, e
);
4412 if (fsym
&& fsym
->attr
.proc_pointer
)
4413 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4417 if (e
->ts
.type
== BT_CLASS
&& fsym
4418 && fsym
->ts
.type
== BT_CLASS
4419 && (!CLASS_DATA (fsym
)->as
4420 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4421 && CLASS_DATA (e
)->attr
.codimension
)
4423 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4424 gcc_assert (!CLASS_DATA (fsym
)->as
);
4425 gfc_add_class_array_ref (e
);
4426 parmse
.want_coarray
= 1;
4427 gfc_conv_expr_reference (&parmse
, e
);
4428 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4430 && e
->expr_type
== EXPR_VARIABLE
);
4432 else if (e
->ts
.type
== BT_CLASS
&& fsym
4433 && fsym
->ts
.type
== BT_CLASS
4434 && !CLASS_DATA (fsym
)->as
4435 && !CLASS_DATA (e
)->as
4436 && (CLASS_DATA (fsym
)->attr
.class_pointer
4437 != CLASS_DATA (e
)->attr
.class_pointer
4438 || CLASS_DATA (fsym
)->attr
.allocatable
4439 != CLASS_DATA (e
)->attr
.allocatable
))
4441 type
= gfc_typenode_for_spec (&fsym
->ts
);
4442 var
= gfc_create_var (type
, fsym
->name
);
4443 gfc_conv_expr (&parmse
, e
);
4444 if (fsym
->attr
.optional
4445 && e
->expr_type
== EXPR_VARIABLE
4446 && e
->symtree
->n
.sym
->attr
.optional
)
4450 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4451 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4452 boolean_type_node
, tmp
,
4453 fold_convert (TREE_TYPE (tmp
),
4454 null_pointer_node
));
4455 gfc_start_block (&block
);
4456 gfc_add_modify (&block
, var
,
4457 fold_build1_loc (input_location
,
4459 type
, parmse
.expr
));
4460 gfc_add_expr_to_block (&parmse
.pre
,
4461 fold_build3_loc (input_location
,
4462 COND_EXPR
, void_type_node
,
4463 cond
, gfc_finish_block (&block
),
4464 build_empty_stmt (input_location
)));
4465 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4466 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4467 TREE_TYPE (parmse
.expr
),
4469 fold_convert (TREE_TYPE (parmse
.expr
),
4470 null_pointer_node
));
4474 gfc_add_modify (&parmse
.pre
, var
,
4475 fold_build1_loc (input_location
,
4477 type
, parmse
.expr
));
4478 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4482 gfc_conv_expr_reference (&parmse
, e
);
4484 /* Catch base objects that are not variables. */
4485 if (e
->ts
.type
== BT_CLASS
4486 && e
->expr_type
!= EXPR_VARIABLE
4487 && expr
&& e
== expr
->base_expr
)
4488 base_object
= build_fold_indirect_ref_loc (input_location
,
4491 /* A class array element needs converting back to be a
4492 class object, if the formal argument is a class object. */
4493 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4494 && e
->ts
.type
== BT_CLASS
4495 && ((CLASS_DATA (fsym
)->as
4496 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4497 || CLASS_DATA (e
)->attr
.dimension
))
4498 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4499 fsym
->attr
.intent
!= INTENT_IN
4500 && (CLASS_DATA (fsym
)->attr
.class_pointer
4501 || CLASS_DATA (fsym
)->attr
.allocatable
),
4503 && e
->expr_type
== EXPR_VARIABLE
4504 && e
->symtree
->n
.sym
->attr
.optional
,
4505 CLASS_DATA (fsym
)->attr
.class_pointer
4506 || CLASS_DATA (fsym
)->attr
.allocatable
);
4508 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4509 allocated on entry, it must be deallocated. */
4510 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4511 && (fsym
->attr
.allocatable
4512 || (fsym
->ts
.type
== BT_CLASS
4513 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4518 gfc_init_block (&block
);
4520 if (e
->ts
.type
== BT_CLASS
)
4521 ptr
= gfc_class_data_get (ptr
);
4523 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4525 gfc_add_expr_to_block (&block
, tmp
);
4526 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4527 void_type_node
, ptr
,
4529 gfc_add_expr_to_block (&block
, tmp
);
4531 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4533 gfc_add_modify (&block
, ptr
,
4534 fold_convert (TREE_TYPE (ptr
),
4535 null_pointer_node
));
4536 gfc_add_expr_to_block (&block
, tmp
);
4538 else if (fsym
->ts
.type
== BT_CLASS
)
4541 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4542 tmp
= gfc_get_symbol_decl (vtab
);
4543 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4544 ptr
= gfc_class_vptr_get (parmse
.expr
);
4545 gfc_add_modify (&block
, ptr
,
4546 fold_convert (TREE_TYPE (ptr
), tmp
));
4547 gfc_add_expr_to_block (&block
, tmp
);
4550 if (fsym
->attr
.optional
4551 && e
->expr_type
== EXPR_VARIABLE
4552 && e
->symtree
->n
.sym
->attr
.optional
)
4554 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4556 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4557 gfc_finish_block (&block
),
4558 build_empty_stmt (input_location
));
4561 tmp
= gfc_finish_block (&block
);
4563 gfc_add_expr_to_block (&se
->pre
, tmp
);
4566 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4567 || fsym
->ts
.type
== BT_ASSUMED
)
4568 && e
->ts
.type
== BT_CLASS
4569 && !CLASS_DATA (e
)->attr
.dimension
4570 && !CLASS_DATA (e
)->attr
.codimension
)
4571 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4573 /* Wrap scalar variable in a descriptor. We need to convert
4574 the address of a pointer back to the pointer itself before,
4575 we can assign it to the data field. */
4577 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4578 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4581 if (TREE_CODE (tmp
) == ADDR_EXPR
4582 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4583 tmp
= TREE_OPERAND (tmp
, 0);
4584 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4586 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4589 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4590 && ((fsym
->attr
.pointer
4591 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4592 || (fsym
->attr
.proc_pointer
4593 && !(e
->expr_type
== EXPR_VARIABLE
4594 && e
->symtree
->n
.sym
->attr
.dummy
))
4595 || (fsym
->attr
.proc_pointer
4596 && e
->expr_type
== EXPR_VARIABLE
4597 && gfc_is_proc_ptr_comp (e
))
4598 || (fsym
->attr
.allocatable
4599 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4601 /* Scalar pointer dummy args require an extra level of
4602 indirection. The null pointer already contains
4603 this level of indirection. */
4604 parm_kind
= SCALAR_POINTER
;
4605 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4609 else if (e
->ts
.type
== BT_CLASS
4610 && fsym
&& fsym
->ts
.type
== BT_CLASS
4611 && (CLASS_DATA (fsym
)->attr
.dimension
4612 || CLASS_DATA (fsym
)->attr
.codimension
))
4614 /* Pass a class array. */
4615 parmse
.use_offset
= 1;
4616 gfc_conv_expr_descriptor (&parmse
, e
);
4618 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4619 allocated on entry, it must be deallocated. */
4620 if (fsym
->attr
.intent
== INTENT_OUT
4621 && CLASS_DATA (fsym
)->attr
.allocatable
)
4626 gfc_init_block (&block
);
4628 ptr
= gfc_class_data_get (ptr
);
4630 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4631 NULL_TREE
, NULL_TREE
,
4634 gfc_add_expr_to_block (&block
, tmp
);
4635 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4636 void_type_node
, ptr
,
4638 gfc_add_expr_to_block (&block
, tmp
);
4639 gfc_reset_vptr (&block
, e
);
4641 if (fsym
->attr
.optional
4642 && e
->expr_type
== EXPR_VARIABLE
4644 || (e
->ref
->type
== REF_ARRAY
4645 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4646 && e
->symtree
->n
.sym
->attr
.optional
)
4648 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4650 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4651 gfc_finish_block (&block
),
4652 build_empty_stmt (input_location
));
4655 tmp
= gfc_finish_block (&block
);
4657 gfc_add_expr_to_block (&se
->pre
, tmp
);
4660 /* The conversion does not repackage the reference to a class
4661 array - _data descriptor. */
4662 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4663 fsym
->attr
.intent
!= INTENT_IN
4664 && (CLASS_DATA (fsym
)->attr
.class_pointer
4665 || CLASS_DATA (fsym
)->attr
.allocatable
),
4667 && e
->expr_type
== EXPR_VARIABLE
4668 && e
->symtree
->n
.sym
->attr
.optional
,
4669 CLASS_DATA (fsym
)->attr
.class_pointer
4670 || CLASS_DATA (fsym
)->attr
.allocatable
);
4674 /* If the procedure requires an explicit interface, the actual
4675 argument is passed according to the corresponding formal
4676 argument. If the corresponding formal argument is a POINTER,
4677 ALLOCATABLE or assumed shape, we do not use g77's calling
4678 convention, and pass the address of the array descriptor
4679 instead. Otherwise we use g77's calling convention. */
4682 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4683 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4684 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4686 f
= f
|| !comp
->attr
.always_explicit
;
4688 f
= f
|| !sym
->attr
.always_explicit
;
4690 /* If the argument is a function call that may not create
4691 a temporary for the result, we have to check that we
4692 can do it, i.e. that there is no alias between this
4693 argument and another one. */
4694 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4700 intent
= fsym
->attr
.intent
;
4702 intent
= INTENT_UNKNOWN
;
4704 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4706 parmse
.force_tmp
= 1;
4708 iarg
= e
->value
.function
.actual
->expr
;
4710 /* Temporary needed if aliasing due to host association. */
4711 if (sym
->attr
.contained
4713 && !sym
->attr
.implicit_pure
4714 && !sym
->attr
.use_assoc
4715 && iarg
->expr_type
== EXPR_VARIABLE
4716 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4717 parmse
.force_tmp
= 1;
4719 /* Ditto within module. */
4720 if (sym
->attr
.use_assoc
4722 && !sym
->attr
.implicit_pure
4723 && iarg
->expr_type
== EXPR_VARIABLE
4724 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4725 parmse
.force_tmp
= 1;
4728 if (e
->expr_type
== EXPR_VARIABLE
4729 && is_subref_array (e
))
4730 /* The actual argument is a component reference to an
4731 array of derived types. In this case, the argument
4732 is converted to a temporary, which is passed and then
4733 written back after the procedure call. */
4734 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4735 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4736 fsym
&& fsym
->attr
.pointer
);
4737 else if (gfc_is_class_array_ref (e
, NULL
)
4738 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4739 /* The actual argument is a component reference to an
4740 array of derived types. In this case, the argument
4741 is converted to a temporary, which is passed and then
4742 written back after the procedure call.
4743 OOP-TODO: Insert code so that if the dynamic type is
4744 the same as the declared type, copy-in/copy-out does
4746 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4747 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4748 fsym
&& fsym
->attr
.pointer
);
4750 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4752 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4753 allocated on entry, it must be deallocated. */
4754 if (fsym
&& fsym
->attr
.allocatable
4755 && fsym
->attr
.intent
== INTENT_OUT
)
4757 tmp
= build_fold_indirect_ref_loc (input_location
,
4759 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4760 if (fsym
->attr
.optional
4761 && e
->expr_type
== EXPR_VARIABLE
4762 && e
->symtree
->n
.sym
->attr
.optional
)
4763 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4765 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4766 tmp
, build_empty_stmt (input_location
));
4767 gfc_add_expr_to_block (&se
->pre
, tmp
);
4772 /* The case with fsym->attr.optional is that of a user subroutine
4773 with an interface indicating an optional argument. When we call
4774 an intrinsic subroutine, however, fsym is NULL, but we might still
4775 have an optional argument, so we proceed to the substitution
4777 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4779 /* If an optional argument is itself an optional dummy argument,
4780 check its presence and substitute a null if absent. This is
4781 only needed when passing an array to an elemental procedure
4782 as then array elements are accessed - or no NULL pointer is
4783 allowed and a "1" or "0" should be passed if not present.
4784 When passing a non-array-descriptor full array to a
4785 non-array-descriptor dummy, no check is needed. For
4786 array-descriptor actual to array-descriptor dummy, see
4787 PR 41911 for why a check has to be inserted.
4788 fsym == NULL is checked as intrinsics required the descriptor
4789 but do not always set fsym. */
4790 if (e
->expr_type
== EXPR_VARIABLE
4791 && e
->symtree
->n
.sym
->attr
.optional
4792 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4793 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4797 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4798 || fsym
->as
->type
== AS_ASSUMED_RANK
4799 || fsym
->as
->type
== AS_DEFERRED
))))))
4800 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4801 e
->representation
.length
);
4806 /* Obtain the character length of an assumed character length
4807 length procedure from the typespec. */
4808 if (fsym
->ts
.type
== BT_CHARACTER
4809 && parmse
.string_length
== NULL_TREE
4810 && e
->ts
.type
== BT_PROCEDURE
4811 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4812 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4813 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4815 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4816 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4820 if (fsym
&& need_interface_mapping
&& e
)
4821 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4823 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4824 gfc_add_block_to_block (&post
, &parmse
.post
);
4826 /* Allocated allocatable components of derived types must be
4827 deallocated for non-variable scalars. Non-variable arrays are
4828 dealt with in trans-array.c(gfc_conv_array_parameter). */
4829 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4830 && e
->ts
.u
.derived
->attr
.alloc_comp
4831 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4832 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4835 tmp
= build_fold_indirect_ref_loc (input_location
,
4837 parm_rank
= e
->rank
;
4845 case (SCALAR_POINTER
):
4846 tmp
= build_fold_indirect_ref_loc (input_location
,
4851 if (e
->expr_type
== EXPR_OP
4852 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4853 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4856 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4857 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4858 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4861 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4863 /* The derived type is passed to gfc_deallocate_alloc_comp.
4864 Therefore, class actuals can handled correctly but derived
4865 types passed to class formals need the _data component. */
4866 tmp
= gfc_class_data_get (tmp
);
4867 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4868 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4871 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4873 gfc_add_expr_to_block (&se
->post
, tmp
);
4876 /* Add argument checking of passing an unallocated/NULL actual to
4877 a nonallocatable/nonpointer dummy. */
4879 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4881 symbol_attribute attr
;
4885 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4886 attr
= gfc_expr_attr (e
);
4888 goto end_pointer_check
;
4890 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4891 allocatable to an optional dummy, cf. 12.5.2.12. */
4892 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4893 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4894 goto end_pointer_check
;
4898 /* If the actual argument is an optional pointer/allocatable and
4899 the formal argument takes an nonpointer optional value,
4900 it is invalid to pass a non-present argument on, even
4901 though there is no technical reason for this in gfortran.
4902 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4903 tree present
, null_ptr
, type
;
4905 if (attr
.allocatable
4906 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4907 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4908 "allocated or not present", e
->symtree
->n
.sym
->name
);
4909 else if (attr
.pointer
4910 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4911 asprintf (&msg
, "Pointer actual argument '%s' is not "
4912 "associated or not present",
4913 e
->symtree
->n
.sym
->name
);
4914 else if (attr
.proc_pointer
4915 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4916 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4917 "associated or not present",
4918 e
->symtree
->n
.sym
->name
);
4920 goto end_pointer_check
;
4922 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4923 type
= TREE_TYPE (present
);
4924 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4925 boolean_type_node
, present
,
4927 null_pointer_node
));
4928 type
= TREE_TYPE (parmse
.expr
);
4929 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4930 boolean_type_node
, parmse
.expr
,
4932 null_pointer_node
));
4933 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4934 boolean_type_node
, present
, null_ptr
);
4938 if (attr
.allocatable
4939 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4940 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4941 "allocated", e
->symtree
->n
.sym
->name
);
4942 else if (attr
.pointer
4943 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4944 asprintf (&msg
, "Pointer actual argument '%s' is not "
4945 "associated", e
->symtree
->n
.sym
->name
);
4946 else if (attr
.proc_pointer
4947 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4948 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4949 "associated", e
->symtree
->n
.sym
->name
);
4951 goto end_pointer_check
;
4955 /* If the argument is passed by value, we need to strip the
4957 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4958 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4960 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4961 boolean_type_node
, tmp
,
4962 fold_convert (TREE_TYPE (tmp
),
4963 null_pointer_node
));
4966 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4972 /* Deferred length dummies pass the character length by reference
4973 so that the value can be returned. */
4974 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4976 tmp
= parmse
.string_length
;
4977 if (TREE_CODE (tmp
) != VAR_DECL
)
4978 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4979 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4982 /* Character strings are passed as two parameters, a length and a
4983 pointer - except for Bind(c) which only passes the pointer.
4984 An unlimited polymorphic formal argument likewise does not
4986 if (parmse
.string_length
!= NULL_TREE
4987 && !sym
->attr
.is_bind_c
4988 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4989 vec_safe_push (stringargs
, parmse
.string_length
);
4991 /* When calling __copy for character expressions to unlimited
4992 polymorphic entities, the dst argument needs a string length. */
4993 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4994 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4995 && arg
->next
&& arg
->next
->expr
4996 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4997 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4998 vec_safe_push (stringargs
, parmse
.string_length
);
5000 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5001 pass the token and the offset as additional arguments. */
5002 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5003 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5004 && !fsym
->attr
.allocatable
)
5005 || (fsym
->ts
.type
== BT_CLASS
5006 && CLASS_DATA (fsym
)->attr
.codimension
5007 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5009 /* Token and offset. */
5010 vec_safe_push (stringargs
, null_pointer_node
);
5011 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5012 gcc_assert (fsym
->attr
.optional
);
5014 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5015 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5016 && !fsym
->attr
.allocatable
)
5017 || (fsym
->ts
.type
== BT_CLASS
5018 && CLASS_DATA (fsym
)->attr
.codimension
5019 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5021 tree caf_decl
, caf_type
;
5024 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5025 caf_type
= TREE_TYPE (caf_decl
);
5027 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5028 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5029 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5030 tmp
= gfc_conv_descriptor_token (caf_decl
);
5031 else if (DECL_LANG_SPECIFIC (caf_decl
)
5032 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5033 tmp
= GFC_DECL_TOKEN (caf_decl
);
5036 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5037 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5038 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5041 vec_safe_push (stringargs
, tmp
);
5043 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5044 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5045 offset
= build_int_cst (gfc_array_index_type
, 0);
5046 else if (DECL_LANG_SPECIFIC (caf_decl
)
5047 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5048 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5049 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5050 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5052 offset
= build_int_cst (gfc_array_index_type
, 0);
5054 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5055 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5058 gcc_assert (POINTER_TYPE_P (caf_type
));
5062 tmp2
= fsym
->ts
.type
== BT_CLASS
5063 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5064 if ((fsym
->ts
.type
!= BT_CLASS
5065 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5066 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5067 || (fsym
->ts
.type
== BT_CLASS
5068 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5069 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5071 if (fsym
->ts
.type
== BT_CLASS
)
5072 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5075 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5076 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5078 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5079 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5081 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5082 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5085 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5088 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5089 gfc_array_index_type
,
5090 fold_convert (gfc_array_index_type
, tmp2
),
5091 fold_convert (gfc_array_index_type
, tmp
));
5092 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5093 gfc_array_index_type
, offset
, tmp
);
5095 vec_safe_push (stringargs
, offset
);
5098 vec_safe_push (arglist
, parmse
.expr
);
5100 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5107 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5108 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5109 else if (ts
.type
== BT_CHARACTER
)
5111 if (ts
.u
.cl
->length
== NULL
)
5113 /* Assumed character length results are not allowed by 5.1.1.5 of the
5114 standard and are trapped in resolve.c; except in the case of SPREAD
5115 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5116 we take the character length of the first argument for the result.
5117 For dummies, we have to look through the formal argument list for
5118 this function and use the character length found there.*/
5120 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5121 else if (!sym
->attr
.dummy
)
5122 cl
.backend_decl
= (*stringargs
)[0];
5125 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5126 for (; formal
; formal
= formal
->next
)
5127 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5128 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5130 len
= cl
.backend_decl
;
5136 /* Calculate the length of the returned string. */
5137 gfc_init_se (&parmse
, NULL
);
5138 if (need_interface_mapping
)
5139 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5141 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5142 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5143 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5145 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5146 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5147 gfc_charlen_type_node
, tmp
,
5148 build_int_cst (gfc_charlen_type_node
, 0));
5149 cl
.backend_decl
= tmp
;
5152 /* Set up a charlen structure for it. */
5157 len
= cl
.backend_decl
;
5160 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5161 || (!comp
&& gfc_return_by_reference (sym
));
5164 if (se
->direct_byref
)
5166 /* Sometimes, too much indirection can be applied; e.g. for
5167 function_result = array_valued_recursive_function. */
5168 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5169 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5170 && GFC_DESCRIPTOR_TYPE_P
5171 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5172 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5175 /* If the lhs of an assignment x = f(..) is allocatable and
5176 f2003 is allowed, we must do the automatic reallocation.
5177 TODO - deal with intrinsics, without using a temporary. */
5178 if (flag_realloc_lhs
5179 && se
->ss
&& se
->ss
->loop_chain
5180 && se
->ss
->loop_chain
->is_alloc_lhs
5181 && !expr
->value
.function
.isym
5182 && sym
->result
->as
!= NULL
)
5184 /* Evaluate the bounds of the result, if known. */
5185 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5188 /* Perform the automatic reallocation. */
5189 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5191 gfc_add_expr_to_block (&se
->pre
, tmp
);
5193 /* Pass the temporary as the first argument. */
5194 result
= info
->descriptor
;
5197 result
= build_fold_indirect_ref_loc (input_location
,
5199 vec_safe_push (retargs
, se
->expr
);
5201 else if (comp
&& comp
->attr
.dimension
)
5203 gcc_assert (se
->loop
&& info
);
5205 /* Set the type of the array. */
5206 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5207 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5209 /* Evaluate the bounds of the result, if known. */
5210 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5212 /* If the lhs of an assignment x = f(..) is allocatable and
5213 f2003 is allowed, we must not generate the function call
5214 here but should just send back the results of the mapping.
5215 This is signalled by the function ss being flagged. */
5216 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5218 gfc_free_interface_mapping (&mapping
);
5219 return has_alternate_specifier
;
5222 /* Create a temporary to store the result. In case the function
5223 returns a pointer, the temporary will be a shallow copy and
5224 mustn't be deallocated. */
5225 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5226 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5227 tmp
, NULL_TREE
, false,
5228 !comp
->attr
.pointer
, callee_alloc
,
5229 &se
->ss
->info
->expr
->where
);
5231 /* Pass the temporary as the first argument. */
5232 result
= info
->descriptor
;
5233 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5234 vec_safe_push (retargs
, tmp
);
5236 else if (!comp
&& sym
->result
->attr
.dimension
)
5238 gcc_assert (se
->loop
&& info
);
5240 /* Set the type of the array. */
5241 tmp
= gfc_typenode_for_spec (&ts
);
5242 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5244 /* Evaluate the bounds of the result, if known. */
5245 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5247 /* If the lhs of an assignment x = f(..) is allocatable and
5248 f2003 is allowed, we must not generate the function call
5249 here but should just send back the results of the mapping.
5250 This is signalled by the function ss being flagged. */
5251 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5253 gfc_free_interface_mapping (&mapping
);
5254 return has_alternate_specifier
;
5257 /* Create a temporary to store the result. In case the function
5258 returns a pointer, the temporary will be a shallow copy and
5259 mustn't be deallocated. */
5260 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5261 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5262 tmp
, NULL_TREE
, false,
5263 !sym
->attr
.pointer
, callee_alloc
,
5264 &se
->ss
->info
->expr
->where
);
5266 /* Pass the temporary as the first argument. */
5267 result
= info
->descriptor
;
5268 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5269 vec_safe_push (retargs
, tmp
);
5271 else if (ts
.type
== BT_CHARACTER
)
5273 /* Pass the string length. */
5274 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5275 type
= build_pointer_type (type
);
5277 /* Return an address to a char[0:len-1]* temporary for
5278 character pointers. */
5279 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5280 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5282 var
= gfc_create_var (type
, "pstr");
5284 if ((!comp
&& sym
->attr
.allocatable
)
5285 || (comp
&& comp
->attr
.allocatable
))
5287 gfc_add_modify (&se
->pre
, var
,
5288 fold_convert (TREE_TYPE (var
),
5289 null_pointer_node
));
5290 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5291 gfc_add_expr_to_block (&se
->post
, tmp
);
5294 /* Provide an address expression for the function arguments. */
5295 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5298 var
= gfc_conv_string_tmp (se
, type
, len
);
5300 vec_safe_push (retargs
, var
);
5304 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5306 type
= gfc_get_complex_type (ts
.kind
);
5307 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5308 vec_safe_push (retargs
, var
);
5311 /* Add the string length to the argument list. */
5312 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5315 if (TREE_CODE (tmp
) != VAR_DECL
)
5316 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5317 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5318 vec_safe_push (retargs
, tmp
);
5320 else if (ts
.type
== BT_CHARACTER
)
5321 vec_safe_push (retargs
, len
);
5323 gfc_free_interface_mapping (&mapping
);
5325 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5326 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5327 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5328 vec_safe_reserve (retargs
, arglen
);
5330 /* Add the return arguments. */
5331 retargs
->splice (arglist
);
5333 /* Add the hidden present status for optional+value to the arguments. */
5334 retargs
->splice (optionalargs
);
5336 /* Add the hidden string length parameters to the arguments. */
5337 retargs
->splice (stringargs
);
5339 /* We may want to append extra arguments here. This is used e.g. for
5340 calls to libgfortran_matmul_??, which need extra information. */
5341 if (!vec_safe_is_empty (append_args
))
5342 retargs
->splice (append_args
);
5345 /* Generate the actual call. */
5346 if (base_object
== NULL_TREE
)
5347 conv_function_val (se
, sym
, expr
);
5349 conv_base_obj_fcn_val (se
, base_object
, expr
);
5351 /* If there are alternate return labels, function type should be
5352 integer. Can't modify the type in place though, since it can be shared
5353 with other functions. For dummy arguments, the typing is done to
5354 this result, even if it has to be repeated for each call. */
5355 if (has_alternate_specifier
5356 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5358 if (!sym
->attr
.dummy
)
5360 TREE_TYPE (sym
->backend_decl
)
5361 = build_function_type (integer_type_node
,
5362 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5363 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5366 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5369 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5370 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5372 /* If we have a pointer function, but we don't want a pointer, e.g.
5375 where f is pointer valued, we have to dereference the result. */
5376 if (!se
->want_pointer
&& !byref
5377 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5378 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5379 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5381 /* f2c calling conventions require a scalar default real function to
5382 return a double precision result. Convert this back to default
5383 real. We only care about the cases that can happen in Fortran 77.
5385 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5386 && sym
->ts
.kind
== gfc_default_real_kind
5387 && !sym
->attr
.always_explicit
)
5388 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5390 /* A pure function may still have side-effects - it may modify its
5392 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5394 if (!sym
->attr
.pure
)
5395 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5400 /* Add the function call to the pre chain. There is no expression. */
5401 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5402 se
->expr
= NULL_TREE
;
5404 if (!se
->direct_byref
)
5406 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5408 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5410 /* Check the data pointer hasn't been modified. This would
5411 happen in a function returning a pointer. */
5412 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5413 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5416 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5419 se
->expr
= info
->descriptor
;
5420 /* Bundle in the string length. */
5421 se
->string_length
= len
;
5423 else if (ts
.type
== BT_CHARACTER
)
5425 /* Dereference for character pointer results. */
5426 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5427 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5428 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5432 se
->string_length
= len
;
5436 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5437 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5442 /* Follow the function call with the argument post block. */
5445 gfc_add_block_to_block (&se
->pre
, &post
);
5447 /* Transformational functions of derived types with allocatable
5448 components must have the result allocatable components copied. */
5449 arg
= expr
->value
.function
.actual
;
5450 if (result
&& arg
&& expr
->rank
5451 && expr
->value
.function
.isym
5452 && expr
->value
.function
.isym
->transformational
5453 && arg
->expr
->ts
.type
== BT_DERIVED
5454 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5457 /* Copy the allocatable components. We have to use a
5458 temporary here to prevent source allocatable components
5459 from being corrupted. */
5460 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5461 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5462 result
, tmp2
, expr
->rank
);
5463 gfc_add_expr_to_block (&se
->pre
, tmp
);
5464 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5466 gfc_add_expr_to_block (&se
->pre
, tmp
);
5468 /* Finally free the temporary's data field. */
5469 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5470 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5471 NULL_TREE
, NULL_TREE
, true,
5473 gfc_add_expr_to_block (&se
->pre
, tmp
);
5477 gfc_add_block_to_block (&se
->post
, &post
);
5479 return has_alternate_specifier
;
5483 /* Fill a character string with spaces. */
5486 fill_with_spaces (tree start
, tree type
, tree size
)
5488 stmtblock_t block
, loop
;
5489 tree i
, el
, exit_label
, cond
, tmp
;
5491 /* For a simple char type, we can call memset(). */
5492 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5493 return build_call_expr_loc (input_location
,
5494 builtin_decl_explicit (BUILT_IN_MEMSET
),
5496 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5497 lang_hooks
.to_target_charset (' ')),
5500 /* Otherwise, we use a loop:
5501 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5505 /* Initialize variables. */
5506 gfc_init_block (&block
);
5507 i
= gfc_create_var (sizetype
, "i");
5508 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5509 el
= gfc_create_var (build_pointer_type (type
), "el");
5510 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5511 exit_label
= gfc_build_label_decl (NULL_TREE
);
5512 TREE_USED (exit_label
) = 1;
5516 gfc_init_block (&loop
);
5518 /* Exit condition. */
5519 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5520 build_zero_cst (sizetype
));
5521 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5522 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5523 build_empty_stmt (input_location
));
5524 gfc_add_expr_to_block (&loop
, tmp
);
5527 gfc_add_modify (&loop
,
5528 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5529 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5531 /* Increment loop variables. */
5532 gfc_add_modify (&loop
, i
,
5533 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5534 TYPE_SIZE_UNIT (type
)));
5535 gfc_add_modify (&loop
, el
,
5536 fold_build_pointer_plus_loc (input_location
,
5537 el
, TYPE_SIZE_UNIT (type
)));
5539 /* Making the loop... actually loop! */
5540 tmp
= gfc_finish_block (&loop
);
5541 tmp
= build1_v (LOOP_EXPR
, tmp
);
5542 gfc_add_expr_to_block (&block
, tmp
);
5544 /* The exit label. */
5545 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5546 gfc_add_expr_to_block (&block
, tmp
);
5549 return gfc_finish_block (&block
);
5553 /* Generate code to copy a string. */
5556 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5557 int dkind
, tree slength
, tree src
, int skind
)
5559 tree tmp
, dlen
, slen
;
5568 stmtblock_t tempblock
;
5570 gcc_assert (dkind
== skind
);
5572 if (slength
!= NULL_TREE
)
5574 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5575 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5579 slen
= build_int_cst (size_type_node
, 1);
5583 if (dlength
!= NULL_TREE
)
5585 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5586 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5590 dlen
= build_int_cst (size_type_node
, 1);
5594 /* Assign directly if the types are compatible. */
5595 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5596 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5598 gfc_add_modify (block
, dsc
, ssc
);
5602 /* Do nothing if the destination length is zero. */
5603 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5604 build_int_cst (size_type_node
, 0));
5606 /* The following code was previously in _gfortran_copy_string:
5608 // The two strings may overlap so we use memmove.
5610 copy_string (GFC_INTEGER_4 destlen, char * dest,
5611 GFC_INTEGER_4 srclen, const char * src)
5613 if (srclen >= destlen)
5615 // This will truncate if too long.
5616 memmove (dest, src, destlen);
5620 memmove (dest, src, srclen);
5622 memset (&dest[srclen], ' ', destlen - srclen);
5626 We're now doing it here for better optimization, but the logic
5629 /* For non-default character kinds, we have to multiply the string
5630 length by the base type size. */
5631 chartype
= gfc_get_char_type (dkind
);
5632 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5633 fold_convert (size_type_node
, slen
),
5634 fold_convert (size_type_node
,
5635 TYPE_SIZE_UNIT (chartype
)));
5636 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5637 fold_convert (size_type_node
, dlen
),
5638 fold_convert (size_type_node
,
5639 TYPE_SIZE_UNIT (chartype
)));
5641 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5642 dest
= fold_convert (pvoid_type_node
, dest
);
5644 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5646 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5647 src
= fold_convert (pvoid_type_node
, src
);
5649 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5651 /* Truncate string if source is too long. */
5652 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5654 tmp2
= build_call_expr_loc (input_location
,
5655 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5656 3, dest
, src
, dlen
);
5658 /* Else copy and pad with spaces. */
5659 tmp3
= build_call_expr_loc (input_location
,
5660 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5661 3, dest
, src
, slen
);
5663 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5664 tmp4
= fill_with_spaces (tmp4
, chartype
,
5665 fold_build2_loc (input_location
, MINUS_EXPR
,
5666 TREE_TYPE(dlen
), dlen
, slen
));
5668 gfc_init_block (&tempblock
);
5669 gfc_add_expr_to_block (&tempblock
, tmp3
);
5670 gfc_add_expr_to_block (&tempblock
, tmp4
);
5671 tmp3
= gfc_finish_block (&tempblock
);
5673 /* The whole copy_string function is there. */
5674 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5676 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5677 build_empty_stmt (input_location
));
5678 gfc_add_expr_to_block (block
, tmp
);
5682 /* Translate a statement function.
5683 The value of a statement function reference is obtained by evaluating the
5684 expression using the values of the actual arguments for the values of the
5685 corresponding dummy arguments. */
5688 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5692 gfc_formal_arglist
*fargs
;
5693 gfc_actual_arglist
*args
;
5696 gfc_saved_var
*saved_vars
;
5702 sym
= expr
->symtree
->n
.sym
;
5703 args
= expr
->value
.function
.actual
;
5704 gfc_init_se (&lse
, NULL
);
5705 gfc_init_se (&rse
, NULL
);
5708 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5710 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5711 temp_vars
= XCNEWVEC (tree
, n
);
5713 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5714 fargs
= fargs
->next
, n
++)
5716 /* Each dummy shall be specified, explicitly or implicitly, to be
5718 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5721 if (fsym
->ts
.type
== BT_CHARACTER
)
5723 /* Copy string arguments. */
5726 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5727 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5729 /* Create a temporary to hold the value. */
5730 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5731 fsym
->ts
.u
.cl
->backend_decl
5732 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5734 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5735 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5737 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5739 gfc_conv_expr (&rse
, args
->expr
);
5740 gfc_conv_string_parameter (&rse
);
5741 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5742 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5744 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5745 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5746 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5747 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5751 /* For everything else, just evaluate the expression. */
5753 /* Create a temporary to hold the value. */
5754 type
= gfc_typenode_for_spec (&fsym
->ts
);
5755 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5757 gfc_conv_expr (&lse
, args
->expr
);
5759 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5760 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5761 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5767 /* Use the temporary variables in place of the real ones. */
5768 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5769 fargs
= fargs
->next
, n
++)
5770 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5772 gfc_conv_expr (se
, sym
->value
);
5774 if (sym
->ts
.type
== BT_CHARACTER
)
5776 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5778 /* Force the expression to the correct length. */
5779 if (!INTEGER_CST_P (se
->string_length
)
5780 || tree_int_cst_lt (se
->string_length
,
5781 sym
->ts
.u
.cl
->backend_decl
))
5783 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5784 tmp
= gfc_create_var (type
, sym
->name
);
5785 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5786 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5787 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5791 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5794 /* Restore the original variables. */
5795 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5796 fargs
= fargs
->next
, n
++)
5797 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5803 /* Translate a function expression. */
5806 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5810 if (expr
->value
.function
.isym
)
5812 gfc_conv_intrinsic_function (se
, expr
);
5816 /* expr.value.function.esym is the resolved (specific) function symbol for
5817 most functions. However this isn't set for dummy procedures. */
5818 sym
= expr
->value
.function
.esym
;
5820 sym
= expr
->symtree
->n
.sym
;
5822 /* The IEEE_ARITHMETIC functions are caught here. */
5823 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
5824 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
5827 /* We distinguish statement functions from general functions to improve
5828 runtime performance. */
5829 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5831 gfc_conv_statement_function (se
, expr
);
5835 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5840 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5843 is_zero_initializer_p (gfc_expr
* expr
)
5845 if (expr
->expr_type
!= EXPR_CONSTANT
)
5848 /* We ignore constants with prescribed memory representations for now. */
5849 if (expr
->representation
.string
)
5852 switch (expr
->ts
.type
)
5855 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5858 return mpfr_zero_p (expr
->value
.real
)
5859 && MPFR_SIGN (expr
->value
.real
) >= 0;
5862 return expr
->value
.logical
== 0;
5865 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5866 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5867 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5868 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5878 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5883 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5884 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5886 gfc_conv_tmp_array_ref (se
);
5890 /* Build a static initializer. EXPR is the expression for the initial value.
5891 The other parameters describe the variable of the component being
5892 initialized. EXPR may be null. */
5895 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5896 bool array
, bool pointer
, bool procptr
)
5900 if (!(expr
|| pointer
|| procptr
))
5903 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5904 (these are the only two iso_c_binding derived types that can be
5905 used as initialization expressions). If so, we need to modify
5906 the 'expr' to be that for a (void *). */
5907 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5908 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5910 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5912 /* The derived symbol has already been converted to a (void *). Use
5914 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5915 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5917 gfc_init_se (&se
, NULL
);
5918 gfc_conv_constant (&se
, expr
);
5919 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5923 if (array
&& !procptr
)
5926 /* Arrays need special handling. */
5928 ctor
= gfc_build_null_descriptor (type
);
5929 /* Special case assigning an array to zero. */
5930 else if (is_zero_initializer_p (expr
))
5931 ctor
= build_constructor (type
, NULL
);
5933 ctor
= gfc_conv_array_initializer (type
, expr
);
5934 TREE_STATIC (ctor
) = 1;
5937 else if (pointer
|| procptr
)
5939 if (ts
->type
== BT_CLASS
&& !procptr
)
5941 gfc_init_se (&se
, NULL
);
5942 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5943 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5944 TREE_STATIC (se
.expr
) = 1;
5947 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5948 return fold_convert (type
, null_pointer_node
);
5951 gfc_init_se (&se
, NULL
);
5952 se
.want_pointer
= 1;
5953 gfc_conv_expr (&se
, expr
);
5954 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5964 gfc_init_se (&se
, NULL
);
5965 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5966 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5968 gfc_conv_structure (&se
, expr
, 1);
5969 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5970 TREE_STATIC (se
.expr
) = 1;
5975 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5976 TREE_STATIC (ctor
) = 1;
5981 gfc_init_se (&se
, NULL
);
5982 gfc_conv_constant (&se
, expr
);
5983 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5990 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5996 gfc_array_info
*lss_array
;
6003 gfc_start_block (&block
);
6005 /* Initialize the scalarizer. */
6006 gfc_init_loopinfo (&loop
);
6008 gfc_init_se (&lse
, NULL
);
6009 gfc_init_se (&rse
, NULL
);
6012 rss
= gfc_walk_expr (expr
);
6013 if (rss
== gfc_ss_terminator
)
6014 /* The rhs is scalar. Add a ss for the expression. */
6015 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6017 /* Create a SS for the destination. */
6018 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6020 lss_array
= &lss
->info
->data
.array
;
6021 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6022 lss_array
->descriptor
= dest
;
6023 lss_array
->data
= gfc_conv_array_data (dest
);
6024 lss_array
->offset
= gfc_conv_array_offset (dest
);
6025 for (n
= 0; n
< cm
->as
->rank
; n
++)
6027 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6028 lss_array
->stride
[n
] = gfc_index_one_node
;
6030 mpz_init (lss_array
->shape
[n
]);
6031 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6032 cm
->as
->lower
[n
]->value
.integer
);
6033 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6036 /* Associate the SS with the loop. */
6037 gfc_add_ss_to_loop (&loop
, lss
);
6038 gfc_add_ss_to_loop (&loop
, rss
);
6040 /* Calculate the bounds of the scalarization. */
6041 gfc_conv_ss_startstride (&loop
);
6043 /* Setup the scalarizing loops. */
6044 gfc_conv_loop_setup (&loop
, &expr
->where
);
6046 /* Setup the gfc_se structures. */
6047 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6048 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6051 gfc_mark_ss_chain_used (rss
, 1);
6053 gfc_mark_ss_chain_used (lss
, 1);
6055 /* Start the scalarized loop body. */
6056 gfc_start_scalarized_body (&loop
, &body
);
6058 gfc_conv_tmp_array_ref (&lse
);
6059 if (cm
->ts
.type
== BT_CHARACTER
)
6060 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6062 gfc_conv_expr (&rse
, expr
);
6064 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6065 gfc_add_expr_to_block (&body
, tmp
);
6067 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6069 /* Generate the copying loops. */
6070 gfc_trans_scalarizing_loops (&loop
, &body
);
6072 /* Wrap the whole thing up. */
6073 gfc_add_block_to_block (&block
, &loop
.pre
);
6074 gfc_add_block_to_block (&block
, &loop
.post
);
6076 gcc_assert (lss_array
->shape
!= NULL
);
6077 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6078 gfc_cleanup_loop (&loop
);
6080 return gfc_finish_block (&block
);
6085 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6095 gfc_expr
*arg
= NULL
;
6097 gfc_start_block (&block
);
6098 gfc_init_se (&se
, NULL
);
6100 /* Get the descriptor for the expressions. */
6101 se
.want_pointer
= 0;
6102 gfc_conv_expr_descriptor (&se
, expr
);
6103 gfc_add_block_to_block (&block
, &se
.pre
);
6104 gfc_add_modify (&block
, dest
, se
.expr
);
6106 /* Deal with arrays of derived types with allocatable components. */
6107 if (cm
->ts
.type
== BT_DERIVED
6108 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6109 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6113 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6114 TREE_TYPE(cm
->backend_decl
),
6117 gfc_add_expr_to_block (&block
, tmp
);
6118 gfc_add_block_to_block (&block
, &se
.post
);
6120 if (expr
->expr_type
!= EXPR_VARIABLE
)
6121 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6124 /* We need to know if the argument of a conversion function is a
6125 variable, so that the correct lower bound can be used. */
6126 if (expr
->expr_type
== EXPR_FUNCTION
6127 && expr
->value
.function
.isym
6128 && expr
->value
.function
.isym
->conversion
6129 && expr
->value
.function
.actual
->expr
6130 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6131 arg
= expr
->value
.function
.actual
->expr
;
6133 /* Obtain the array spec of full array references. */
6135 as
= gfc_get_full_arrayspec_from_expr (arg
);
6137 as
= gfc_get_full_arrayspec_from_expr (expr
);
6139 /* Shift the lbound and ubound of temporaries to being unity,
6140 rather than zero, based. Always calculate the offset. */
6141 offset
= gfc_conv_descriptor_offset_get (dest
);
6142 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6143 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6145 for (n
= 0; n
< expr
->rank
; n
++)
6150 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6151 TODO It looks as if gfc_conv_expr_descriptor should return
6152 the correct bounds and that the following should not be
6153 necessary. This would simplify gfc_conv_intrinsic_bound
6155 if (as
&& as
->lower
[n
])
6158 gfc_init_se (&lbse
, NULL
);
6159 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6160 gfc_add_block_to_block (&block
, &lbse
.pre
);
6161 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6165 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6166 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6170 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6173 lbound
= gfc_index_one_node
;
6175 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6177 /* Shift the bounds and set the offset accordingly. */
6178 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6179 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6180 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6181 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6183 gfc_conv_descriptor_ubound_set (&block
, dest
,
6184 gfc_rank_cst
[n
], tmp
);
6185 gfc_conv_descriptor_lbound_set (&block
, dest
,
6186 gfc_rank_cst
[n
], lbound
);
6188 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6189 gfc_conv_descriptor_lbound_get (dest
,
6191 gfc_conv_descriptor_stride_get (dest
,
6193 gfc_add_modify (&block
, tmp2
, tmp
);
6194 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6196 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6201 /* If a conversion expression has a null data pointer
6202 argument, nullify the allocatable component. */
6206 if (arg
->symtree
->n
.sym
->attr
.allocatable
6207 || arg
->symtree
->n
.sym
->attr
.pointer
)
6209 non_null_expr
= gfc_finish_block (&block
);
6210 gfc_start_block (&block
);
6211 gfc_conv_descriptor_data_set (&block
, dest
,
6213 null_expr
= gfc_finish_block (&block
);
6214 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6215 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6216 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6217 return build3_v (COND_EXPR
, tmp
,
6218 null_expr
, non_null_expr
);
6222 return gfc_finish_block (&block
);
6226 /* Assign a single component of a derived type constructor. */
6229 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6236 gfc_start_block (&block
);
6238 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6240 gfc_init_se (&se
, NULL
);
6241 /* Pointer component. */
6242 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6243 && !cm
->attr
.proc_pointer
)
6245 /* Array pointer. */
6246 if (expr
->expr_type
== EXPR_NULL
)
6247 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6250 se
.direct_byref
= 1;
6252 gfc_conv_expr_descriptor (&se
, expr
);
6253 gfc_add_block_to_block (&block
, &se
.pre
);
6254 gfc_add_block_to_block (&block
, &se
.post
);
6259 /* Scalar pointers. */
6260 se
.want_pointer
= 1;
6261 gfc_conv_expr (&se
, expr
);
6262 gfc_add_block_to_block (&block
, &se
.pre
);
6264 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6265 && expr
->symtree
->n
.sym
->attr
.dummy
)
6266 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6268 gfc_add_modify (&block
, dest
,
6269 fold_convert (TREE_TYPE (dest
), se
.expr
));
6270 gfc_add_block_to_block (&block
, &se
.post
);
6273 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6275 /* NULL initialization for CLASS components. */
6276 tmp
= gfc_trans_structure_assign (dest
,
6277 gfc_class_initializer (&cm
->ts
, expr
));
6278 gfc_add_expr_to_block (&block
, tmp
);
6280 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6281 && !cm
->attr
.proc_pointer
)
6283 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6284 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6285 else if (cm
->attr
.allocatable
)
6287 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6288 gfc_add_expr_to_block (&block
, tmp
);
6292 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6293 gfc_add_expr_to_block (&block
, tmp
);
6296 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6298 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6300 gfc_init_se (&se
, NULL
);
6301 gfc_conv_expr (&se
, expr
);
6302 gfc_add_block_to_block (&block
, &se
.pre
);
6303 gfc_add_modify (&block
, dest
,
6304 fold_convert (TREE_TYPE (dest
), se
.expr
));
6305 gfc_add_block_to_block (&block
, &se
.post
);
6309 /* Nested constructors. */
6310 tmp
= gfc_trans_structure_assign (dest
, expr
);
6311 gfc_add_expr_to_block (&block
, tmp
);
6314 else if (gfc_deferred_strlen (cm
, &tmp
))
6318 gcc_assert (strlen
);
6319 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6321 TREE_OPERAND (dest
, 0),
6324 if (expr
->expr_type
== EXPR_NULL
)
6326 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6327 gfc_add_modify (&block
, dest
, tmp
);
6328 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6329 gfc_add_modify (&block
, strlen
, tmp
);
6334 gfc_init_se (&se
, NULL
);
6335 gfc_conv_expr (&se
, expr
);
6336 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6337 tmp
= build_call_expr_loc (input_location
,
6338 builtin_decl_explicit (BUILT_IN_MALLOC
),
6340 gfc_add_modify (&block
, dest
,
6341 fold_convert (TREE_TYPE (dest
), tmp
));
6342 gfc_add_modify (&block
, strlen
, se
.string_length
);
6343 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6344 gfc_add_expr_to_block (&block
, tmp
);
6347 else if (!cm
->attr
.deferred_parameter
)
6349 /* Scalar component (excluding deferred parameters). */
6350 gfc_init_se (&se
, NULL
);
6351 gfc_init_se (&lse
, NULL
);
6353 gfc_conv_expr (&se
, expr
);
6354 if (cm
->ts
.type
== BT_CHARACTER
)
6355 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6357 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6358 gfc_add_expr_to_block (&block
, tmp
);
6360 return gfc_finish_block (&block
);
6363 /* Assign a derived type constructor to a variable. */
6366 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6374 gfc_start_block (&block
);
6375 cm
= expr
->ts
.u
.derived
->components
;
6377 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6378 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6379 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6383 gcc_assert (cm
->backend_decl
== NULL
);
6384 gfc_init_se (&se
, NULL
);
6385 gfc_init_se (&lse
, NULL
);
6386 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6388 gfc_add_modify (&block
, lse
.expr
,
6389 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6391 return gfc_finish_block (&block
);
6394 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6395 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6397 /* Skip absent members in default initializers. */
6401 field
= cm
->backend_decl
;
6402 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6403 dest
, field
, NULL_TREE
);
6404 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6405 gfc_add_expr_to_block (&block
, tmp
);
6407 return gfc_finish_block (&block
);
6410 /* Build an expression for a constructor. If init is nonzero then
6411 this is part of a static variable initializer. */
6414 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6421 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6423 gcc_assert (se
->ss
== NULL
);
6424 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6425 type
= gfc_typenode_for_spec (&expr
->ts
);
6429 /* Create a temporary variable and fill it in. */
6430 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6431 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6432 gfc_add_expr_to_block (&se
->pre
, tmp
);
6436 cm
= expr
->ts
.u
.derived
->components
;
6438 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6439 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6441 /* Skip absent members in default initializers and allocatable
6442 components. Although the latter have a default initializer
6443 of EXPR_NULL,... by default, the static nullify is not needed
6444 since this is done every time we come into scope. */
6445 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6448 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6449 && strcmp (cm
->name
, "_extends") == 0
6450 && cm
->initializer
->symtree
)
6454 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6455 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6456 vtab
= unshare_expr_without_location (vtab
);
6457 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6459 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6461 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6462 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6463 fold_convert (TREE_TYPE (cm
->backend_decl
),
6468 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6469 TREE_TYPE (cm
->backend_decl
),
6470 cm
->attr
.dimension
, cm
->attr
.pointer
,
6471 cm
->attr
.proc_pointer
);
6472 val
= unshare_expr_without_location (val
);
6474 /* Append it to the constructor list. */
6475 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6478 se
->expr
= build_constructor (type
, v
);
6480 TREE_CONSTANT (se
->expr
) = 1;
6484 /* Translate a substring expression. */
6487 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6493 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6495 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6496 expr
->value
.character
.length
,
6497 expr
->value
.character
.string
);
6499 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6500 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6503 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6507 /* Entry point for expression translation. Evaluates a scalar quantity.
6508 EXPR is the expression to be translated, and SE is the state structure if
6509 called from within the scalarized. */
6512 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6517 if (ss
&& ss
->info
->expr
== expr
6518 && (ss
->info
->type
== GFC_SS_SCALAR
6519 || ss
->info
->type
== GFC_SS_REFERENCE
))
6521 gfc_ss_info
*ss_info
;
6524 /* Substitute a scalar expression evaluated outside the scalarization
6526 se
->expr
= ss_info
->data
.scalar
.value
;
6527 /* If the reference can be NULL, the value field contains the reference,
6528 not the value the reference points to (see gfc_add_loop_ss_code). */
6529 if (ss_info
->can_be_null_ref
)
6530 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6532 se
->string_length
= ss_info
->string_length
;
6533 gfc_advance_se_ss_chain (se
);
6537 /* We need to convert the expressions for the iso_c_binding derived types.
6538 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6539 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6540 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6541 updated to be an integer with a kind equal to the size of a (void *). */
6542 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6544 if (expr
->expr_type
== EXPR_VARIABLE
6545 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6546 || expr
->symtree
->n
.sym
->intmod_sym_id
6547 == ISOCBINDING_NULL_FUNPTR
))
6549 /* Set expr_type to EXPR_NULL, which will result in
6550 null_pointer_node being used below. */
6551 expr
->expr_type
= EXPR_NULL
;
6555 /* Update the type/kind of the expression to be what the new
6556 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6557 expr
->ts
.type
= BT_INTEGER
;
6558 expr
->ts
.f90_type
= BT_VOID
;
6559 expr
->ts
.kind
= gfc_index_integer_kind
;
6563 gfc_fix_class_refs (expr
);
6565 switch (expr
->expr_type
)
6568 gfc_conv_expr_op (se
, expr
);
6572 gfc_conv_function_expr (se
, expr
);
6576 gfc_conv_constant (se
, expr
);
6580 gfc_conv_variable (se
, expr
);
6584 se
->expr
= null_pointer_node
;
6587 case EXPR_SUBSTRING
:
6588 gfc_conv_substring_expr (se
, expr
);
6591 case EXPR_STRUCTURE
:
6592 gfc_conv_structure (se
, expr
, 0);
6596 gfc_conv_array_constructor_expr (se
, expr
);
6605 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6606 of an assignment. */
6608 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6610 gfc_conv_expr (se
, expr
);
6611 /* All numeric lvalues should have empty post chains. If not we need to
6612 figure out a way of rewriting an lvalue so that it has no post chain. */
6613 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6616 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6617 numeric expressions. Used for scalar values where inserting cleanup code
6620 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6624 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6625 gfc_conv_expr (se
, expr
);
6628 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6629 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6631 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6635 /* Helper to translate an expression and convert it to a particular type. */
6637 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6639 gfc_conv_expr_val (se
, expr
);
6640 se
->expr
= convert (type
, se
->expr
);
6644 /* Converts an expression so that it can be passed by reference. Scalar
6648 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6654 if (ss
&& ss
->info
->expr
== expr
6655 && ss
->info
->type
== GFC_SS_REFERENCE
)
6657 /* Returns a reference to the scalar evaluated outside the loop
6659 gfc_conv_expr (se
, expr
);
6661 if (expr
->ts
.type
== BT_CHARACTER
6662 && expr
->expr_type
!= EXPR_FUNCTION
)
6663 gfc_conv_string_parameter (se
);
6665 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6670 if (expr
->ts
.type
== BT_CHARACTER
)
6672 gfc_conv_expr (se
, expr
);
6673 gfc_conv_string_parameter (se
);
6677 if (expr
->expr_type
== EXPR_VARIABLE
)
6679 se
->want_pointer
= 1;
6680 gfc_conv_expr (se
, expr
);
6683 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6684 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6685 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6691 if (expr
->expr_type
== EXPR_FUNCTION
6692 && ((expr
->value
.function
.esym
6693 && expr
->value
.function
.esym
->result
->attr
.pointer
6694 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6695 || (!expr
->value
.function
.esym
&& !expr
->ref
6696 && expr
->symtree
->n
.sym
->attr
.pointer
6697 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6699 se
->want_pointer
= 1;
6700 gfc_conv_expr (se
, expr
);
6701 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6702 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6707 gfc_conv_expr (se
, expr
);
6709 /* Create a temporary var to hold the value. */
6710 if (TREE_CONSTANT (se
->expr
))
6712 tree tmp
= se
->expr
;
6713 STRIP_TYPE_NOPS (tmp
);
6714 var
= build_decl (input_location
,
6715 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6716 DECL_INITIAL (var
) = tmp
;
6717 TREE_STATIC (var
) = 1;
6722 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6723 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6725 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6727 /* Take the address of that value. */
6728 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6729 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6730 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6731 && expr
->ts
.u
.derived
->attr
.alloc_comp
6732 && expr
->expr_type
!= EXPR_VARIABLE
)
6736 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6737 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6739 /* The components shall be deallocated before
6740 their containing entity. */
6741 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6747 gfc_trans_pointer_assign (gfc_code
* code
)
6749 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6753 /* Generate code for a pointer assignment. */
6756 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6758 gfc_expr
*expr1_vptr
= NULL
;
6768 gfc_start_block (&block
);
6770 gfc_init_se (&lse
, NULL
);
6772 /* Check whether the expression is a scalar or not; we cannot use
6773 expr1->rank as it can be nonzero for proc pointers. */
6774 ss
= gfc_walk_expr (expr1
);
6775 scalar
= ss
== gfc_ss_terminator
;
6777 gfc_free_ss_chain (ss
);
6779 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6780 && expr2
->expr_type
!= EXPR_FUNCTION
)
6782 gfc_add_data_component (expr2
);
6783 /* The following is required as gfc_add_data_component doesn't
6784 update ts.type if there is a tailing REF_ARRAY. */
6785 expr2
->ts
.type
= BT_DERIVED
;
6790 /* Scalar pointers. */
6791 lse
.want_pointer
= 1;
6792 gfc_conv_expr (&lse
, expr1
);
6793 gfc_init_se (&rse
, NULL
);
6794 rse
.want_pointer
= 1;
6795 gfc_conv_expr (&rse
, expr2
);
6797 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6798 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6799 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6802 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6803 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6804 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6807 gfc_add_block_to_block (&block
, &lse
.pre
);
6808 gfc_add_block_to_block (&block
, &rse
.pre
);
6810 /* Check character lengths if character expression. The test is only
6811 really added if -fbounds-check is enabled. Exclude deferred
6812 character length lefthand sides. */
6813 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6814 && !expr1
->ts
.deferred
6815 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6816 && !gfc_is_proc_ptr_comp (expr1
))
6818 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6819 gcc_assert (lse
.string_length
&& rse
.string_length
);
6820 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6821 lse
.string_length
, rse
.string_length
,
6825 /* The assignment to an deferred character length sets the string
6826 length to that of the rhs. */
6827 if (expr1
->ts
.deferred
)
6829 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6830 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6831 else if (lse
.string_length
!= NULL
)
6832 gfc_add_modify (&block
, lse
.string_length
,
6833 build_int_cst (gfc_charlen_type_node
, 0));
6836 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6837 rse
.expr
= gfc_class_data_get (rse
.expr
);
6839 gfc_add_modify (&block
, lse
.expr
,
6840 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6842 gfc_add_block_to_block (&block
, &rse
.post
);
6843 gfc_add_block_to_block (&block
, &lse
.post
);
6850 tree strlen_rhs
= NULL_TREE
;
6852 /* Array pointer. Find the last reference on the LHS and if it is an
6853 array section ref, we're dealing with bounds remapping. In this case,
6854 set it to AR_FULL so that gfc_conv_expr_descriptor does
6855 not see it and process the bounds remapping afterwards explicitly. */
6856 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6857 if (!remap
->next
&& remap
->type
== REF_ARRAY
6858 && remap
->u
.ar
.type
== AR_SECTION
)
6860 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6862 gfc_init_se (&lse
, NULL
);
6864 lse
.descriptor_only
= 1;
6865 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6866 && expr1
->ts
.type
== BT_CLASS
)
6867 expr1_vptr
= gfc_copy_expr (expr1
);
6868 gfc_conv_expr_descriptor (&lse
, expr1
);
6869 strlen_lhs
= lse
.string_length
;
6872 if (expr2
->expr_type
== EXPR_NULL
)
6874 /* Just set the data pointer to null. */
6875 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6877 else if (rank_remap
)
6879 /* If we are rank-remapping, just get the RHS's descriptor and
6880 process this later on. */
6881 gfc_init_se (&rse
, NULL
);
6882 rse
.direct_byref
= 1;
6883 rse
.byref_noassign
= 1;
6885 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6887 gfc_conv_function_expr (&rse
, expr2
);
6889 if (expr1
->ts
.type
!= BT_CLASS
)
6890 rse
.expr
= gfc_class_data_get (rse
.expr
);
6893 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6894 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6896 gfc_add_vptr_component (expr1_vptr
);
6897 gfc_init_se (&rse
, NULL
);
6898 rse
.want_pointer
= 1;
6899 gfc_conv_expr (&rse
, expr1_vptr
);
6900 gfc_add_modify (&lse
.pre
, rse
.expr
,
6901 fold_convert (TREE_TYPE (rse
.expr
),
6902 gfc_class_vptr_get (tmp
)));
6903 rse
.expr
= gfc_class_data_get (tmp
);
6906 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6908 tree bound
[GFC_MAX_DIMENSIONS
];
6911 for (i
= 0; i
< expr2
->rank
; i
++)
6912 bound
[i
] = NULL_TREE
;
6913 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6914 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6916 GFC_ARRAY_POINTER_CONT
, false);
6917 tmp
= gfc_create_var (tmp
, "ptrtemp");
6919 lse
.direct_byref
= 1;
6920 gfc_conv_expr_descriptor (&lse
, expr2
);
6921 strlen_rhs
= lse
.string_length
;
6926 gfc_conv_expr_descriptor (&rse
, expr2
);
6927 strlen_rhs
= rse
.string_length
;
6930 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6932 /* Assign directly to the LHS's descriptor. */
6933 lse
.direct_byref
= 1;
6934 gfc_conv_expr_descriptor (&lse
, expr2
);
6935 strlen_rhs
= lse
.string_length
;
6937 /* If this is a subreference array pointer assignment, use the rhs
6938 descriptor element size for the lhs span. */
6939 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6941 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6942 gfc_init_se (&rse
, NULL
);
6943 rse
.descriptor_only
= 1;
6944 gfc_conv_expr (&rse
, expr2
);
6945 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6946 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6947 if (!INTEGER_CST_P (tmp
))
6948 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6949 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6952 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6954 gfc_init_se (&rse
, NULL
);
6955 rse
.want_pointer
= 1;
6956 gfc_conv_function_expr (&rse
, expr2
);
6957 if (expr1
->ts
.type
!= BT_CLASS
)
6959 rse
.expr
= gfc_class_data_get (rse
.expr
);
6960 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6964 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6965 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6967 gfc_add_vptr_component (expr1_vptr
);
6968 gfc_init_se (&rse
, NULL
);
6969 rse
.want_pointer
= 1;
6970 gfc_conv_expr (&rse
, expr1_vptr
);
6971 gfc_add_modify (&lse
.pre
, rse
.expr
,
6972 fold_convert (TREE_TYPE (rse
.expr
),
6973 gfc_class_vptr_get (tmp
)));
6974 rse
.expr
= gfc_class_data_get (tmp
);
6975 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6980 /* Assign to a temporary descriptor and then copy that
6981 temporary to the pointer. */
6982 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6984 lse
.direct_byref
= 1;
6985 gfc_conv_expr_descriptor (&lse
, expr2
);
6986 strlen_rhs
= lse
.string_length
;
6987 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6991 gfc_free_expr (expr1_vptr
);
6993 gfc_add_block_to_block (&block
, &lse
.pre
);
6995 gfc_add_block_to_block (&block
, &rse
.pre
);
6997 /* If we do bounds remapping, update LHS descriptor accordingly. */
7001 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7005 /* Do rank remapping. We already have the RHS's descriptor
7006 converted in rse and now have to build the correct LHS
7007 descriptor for it. */
7011 tree lbound
, ubound
;
7014 dtype
= gfc_conv_descriptor_dtype (desc
);
7015 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7016 gfc_add_modify (&block
, dtype
, tmp
);
7018 /* Copy data pointer. */
7019 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7020 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7022 /* Copy offset but adjust it such that it would correspond
7023 to a lbound of zero. */
7024 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7025 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7027 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7029 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7031 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7032 gfc_array_index_type
, stride
, lbound
);
7033 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7034 gfc_array_index_type
, offs
, tmp
);
7036 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7038 /* Set the bounds as declared for the LHS and calculate strides as
7039 well as another offset update accordingly. */
7040 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7042 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7047 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7049 /* Convert declared bounds. */
7050 gfc_init_se (&lower_se
, NULL
);
7051 gfc_init_se (&upper_se
, NULL
);
7052 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7053 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7055 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7056 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7058 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7059 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7061 lbound
= gfc_evaluate_now (lbound
, &block
);
7062 ubound
= gfc_evaluate_now (ubound
, &block
);
7064 gfc_add_block_to_block (&block
, &lower_se
.post
);
7065 gfc_add_block_to_block (&block
, &upper_se
.post
);
7067 /* Set bounds in descriptor. */
7068 gfc_conv_descriptor_lbound_set (&block
, desc
,
7069 gfc_rank_cst
[dim
], lbound
);
7070 gfc_conv_descriptor_ubound_set (&block
, desc
,
7071 gfc_rank_cst
[dim
], ubound
);
7074 stride
= gfc_evaluate_now (stride
, &block
);
7075 gfc_conv_descriptor_stride_set (&block
, desc
,
7076 gfc_rank_cst
[dim
], stride
);
7078 /* Update offset. */
7079 offs
= gfc_conv_descriptor_offset_get (desc
);
7080 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7081 gfc_array_index_type
, lbound
, stride
);
7082 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7083 gfc_array_index_type
, offs
, tmp
);
7084 offs
= gfc_evaluate_now (offs
, &block
);
7085 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7087 /* Update stride. */
7088 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7089 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7090 gfc_array_index_type
, stride
, tmp
);
7095 /* Bounds remapping. Just shift the lower bounds. */
7097 gcc_assert (expr1
->rank
== expr2
->rank
);
7099 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7103 gcc_assert (remap
->u
.ar
.start
[dim
]);
7104 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7105 gfc_init_se (&lbound_se
, NULL
);
7106 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7108 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7109 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7110 dim
, lbound_se
.expr
);
7111 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7116 /* Check string lengths if applicable. The check is only really added
7117 to the output code if -fbounds-check is enabled. */
7118 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7120 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7121 gcc_assert (strlen_lhs
&& strlen_rhs
);
7122 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7123 strlen_lhs
, strlen_rhs
, &block
);
7126 /* If rank remapping was done, check with -fcheck=bounds that
7127 the target is at least as large as the pointer. */
7128 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7134 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7135 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7137 lsize
= gfc_evaluate_now (lsize
, &block
);
7138 rsize
= gfc_evaluate_now (rsize
, &block
);
7139 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7142 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7143 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7147 gfc_add_block_to_block (&block
, &lse
.post
);
7149 gfc_add_block_to_block (&block
, &rse
.post
);
7152 return gfc_finish_block (&block
);
7156 /* Makes sure se is suitable for passing as a function string parameter. */
7157 /* TODO: Need to check all callers of this function. It may be abused. */
7160 gfc_conv_string_parameter (gfc_se
* se
)
7164 if (TREE_CODE (se
->expr
) == STRING_CST
)
7166 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7167 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7171 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7173 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7175 type
= TREE_TYPE (se
->expr
);
7176 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7180 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7182 type
= build_pointer_type (type
);
7183 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7187 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
7191 /* Generate code for assignment of scalar variables. Includes character
7192 strings and derived types with allocatable components.
7193 If you know that the LHS has no allocations, set dealloc to false.
7195 DEEP_COPY has no effect if the typespec TS is not a derived type with
7196 allocatable components. Otherwise, if it is set, an explicit copy of each
7197 allocatable component is made. This is necessary as a simple copy of the
7198 whole object would copy array descriptors as is, so that the lhs's
7199 allocatable components would point to the rhs's after the assignment.
7200 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7201 necessary if the rhs is a non-pointer function, as the allocatable components
7202 are not accessible by other means than the function's result after the
7203 function has returned. It is even more subtle when temporaries are involved,
7204 as the two following examples show:
7205 1. When we evaluate an array constructor, a temporary is created. Thus
7206 there is theoretically no alias possible. However, no deep copy is
7207 made for this temporary, so that if the constructor is made of one or
7208 more variable with allocatable components, those components still point
7209 to the variable's: DEEP_COPY should be set for the assignment from the
7210 temporary to the lhs in that case.
7211 2. When assigning a scalar to an array, we evaluate the scalar value out
7212 of the loop, store it into a temporary variable, and assign from that.
7213 In that case, deep copying when assigning to the temporary would be a
7214 waste of resources; however deep copies should happen when assigning from
7215 the temporary to each array element: again DEEP_COPY should be set for
7216 the assignment from the temporary to the lhs. */
7219 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7220 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7226 gfc_init_block (&block
);
7228 if (ts
.type
== BT_CHARACTER
)
7233 if (lse
->string_length
!= NULL_TREE
)
7235 gfc_conv_string_parameter (lse
);
7236 gfc_add_block_to_block (&block
, &lse
->pre
);
7237 llen
= lse
->string_length
;
7240 if (rse
->string_length
!= NULL_TREE
)
7242 gcc_assert (rse
->string_length
!= NULL_TREE
);
7243 gfc_conv_string_parameter (rse
);
7244 gfc_add_block_to_block (&block
, &rse
->pre
);
7245 rlen
= rse
->string_length
;
7248 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7249 rse
->expr
, ts
.kind
);
7251 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7253 tree tmp_var
= NULL_TREE
;
7256 /* Are the rhs and the lhs the same? */
7259 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7260 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7261 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7262 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7265 /* Deallocate the lhs allocated components as long as it is not
7266 the same as the rhs. This must be done following the assignment
7267 to prevent deallocating data that could be used in the rhs
7269 if (!l_is_temp
&& dealloc
)
7271 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7272 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7274 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7276 gfc_add_expr_to_block (&lse
->post
, tmp
);
7279 gfc_add_block_to_block (&block
, &rse
->pre
);
7280 gfc_add_block_to_block (&block
, &lse
->pre
);
7282 gfc_add_modify (&block
, lse
->expr
,
7283 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7285 /* Restore pointer address of coarray components. */
7286 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7288 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7289 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7291 gfc_add_expr_to_block (&block
, tmp
);
7294 /* Do a deep copy if the rhs is a variable, if it is not the
7298 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7299 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7301 gfc_add_expr_to_block (&block
, tmp
);
7304 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7306 gfc_add_block_to_block (&block
, &lse
->pre
);
7307 gfc_add_block_to_block (&block
, &rse
->pre
);
7308 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7309 TREE_TYPE (lse
->expr
), rse
->expr
);
7310 gfc_add_modify (&block
, lse
->expr
, tmp
);
7314 gfc_add_block_to_block (&block
, &lse
->pre
);
7315 gfc_add_block_to_block (&block
, &rse
->pre
);
7317 gfc_add_modify (&block
, lse
->expr
,
7318 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7321 gfc_add_block_to_block (&block
, &lse
->post
);
7322 gfc_add_block_to_block (&block
, &rse
->post
);
7324 return gfc_finish_block (&block
);
7328 /* There are quite a lot of restrictions on the optimisation in using an
7329 array function assign without a temporary. */
7332 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7335 bool seen_array_ref
;
7337 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7339 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7340 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7343 /* Elemental functions are scalarized so that they don't need a
7344 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7345 they would need special treatment in gfc_trans_arrayfunc_assign. */
7346 if (expr2
->value
.function
.esym
!= NULL
7347 && expr2
->value
.function
.esym
->attr
.elemental
)
7350 /* Need a temporary if rhs is not FULL or a contiguous section. */
7351 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7354 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7355 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7358 /* Functions returning pointers or allocatables need temporaries. */
7359 c
= expr2
->value
.function
.esym
7360 ? (expr2
->value
.function
.esym
->attr
.pointer
7361 || expr2
->value
.function
.esym
->attr
.allocatable
)
7362 : (expr2
->symtree
->n
.sym
->attr
.pointer
7363 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7367 /* Character array functions need temporaries unless the
7368 character lengths are the same. */
7369 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7371 if (expr1
->ts
.u
.cl
->length
== NULL
7372 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7375 if (expr2
->ts
.u
.cl
->length
== NULL
7376 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7379 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7380 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7384 /* Check that no LHS component references appear during an array
7385 reference. This is needed because we do not have the means to
7386 span any arbitrary stride with an array descriptor. This check
7387 is not needed for the rhs because the function result has to be
7389 seen_array_ref
= false;
7390 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7392 if (ref
->type
== REF_ARRAY
)
7393 seen_array_ref
= true;
7394 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7398 /* Check for a dependency. */
7399 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7400 expr2
->value
.function
.esym
,
7401 expr2
->value
.function
.actual
,
7405 /* If we have reached here with an intrinsic function, we do not
7406 need a temporary except in the particular case that reallocation
7407 on assignment is active and the lhs is allocatable and a target. */
7408 if (expr2
->value
.function
.isym
)
7409 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
7411 /* If the LHS is a dummy, we need a temporary if it is not
7413 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7416 /* If the lhs has been host_associated, is in common, a pointer or is
7417 a target and the function is not using a RESULT variable, aliasing
7418 can occur and a temporary is needed. */
7419 if ((sym
->attr
.host_assoc
7420 || sym
->attr
.in_common
7421 || sym
->attr
.pointer
7422 || sym
->attr
.cray_pointee
7423 || sym
->attr
.target
)
7424 && expr2
->symtree
!= NULL
7425 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7428 /* A PURE function can unconditionally be called without a temporary. */
7429 if (expr2
->value
.function
.esym
!= NULL
7430 && expr2
->value
.function
.esym
->attr
.pure
)
7433 /* Implicit_pure functions are those which could legally be declared
7435 if (expr2
->value
.function
.esym
!= NULL
7436 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7439 if (!sym
->attr
.use_assoc
7440 && !sym
->attr
.in_common
7441 && !sym
->attr
.pointer
7442 && !sym
->attr
.target
7443 && !sym
->attr
.cray_pointee
7444 && expr2
->value
.function
.esym
)
7446 /* A temporary is not needed if the function is not contained and
7447 the variable is local or host associated and not a pointer or
7449 if (!expr2
->value
.function
.esym
->attr
.contained
)
7452 /* A temporary is not needed if the lhs has never been host
7453 associated and the procedure is contained. */
7454 else if (!sym
->attr
.host_assoc
)
7457 /* A temporary is not needed if the variable is local and not
7458 a pointer, a target or a result. */
7460 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7464 /* Default to temporary use. */
7469 /* Provide the loop info so that the lhs descriptor can be built for
7470 reallocatable assignments from extrinsic function calls. */
7473 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7476 /* Signal that the function call should not be made by
7477 gfc_conv_loop_setup. */
7478 se
->ss
->is_alloc_lhs
= 1;
7479 gfc_init_loopinfo (loop
);
7480 gfc_add_ss_to_loop (loop
, *ss
);
7481 gfc_add_ss_to_loop (loop
, se
->ss
);
7482 gfc_conv_ss_startstride (loop
);
7483 gfc_conv_loop_setup (loop
, where
);
7484 gfc_copy_loopinfo_to_se (se
, loop
);
7485 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7486 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7487 se
->ss
->is_alloc_lhs
= 0;
7491 /* For assignment to a reallocatable lhs from intrinsic functions,
7492 replace the se.expr (ie. the result) with a temporary descriptor.
7493 Null the data field so that the library allocates space for the
7494 result. Free the data of the original descriptor after the function,
7495 in case it appears in an argument expression and transfer the
7496 result to the original descriptor. */
7499 fcncall_realloc_result (gfc_se
*se
, int rank
)
7508 /* Use the allocation done by the library. Substitute the lhs
7509 descriptor with a copy, whose data field is nulled.*/
7510 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7511 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7512 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7514 /* Unallocated, the descriptor does not have a dtype. */
7515 tmp
= gfc_conv_descriptor_dtype (desc
);
7516 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7518 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7519 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7520 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7522 /* Free the lhs after the function call and copy the result data to
7523 the lhs descriptor. */
7524 tmp
= gfc_conv_descriptor_data_get (desc
);
7525 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7526 boolean_type_node
, tmp
,
7527 build_int_cst (TREE_TYPE (tmp
), 0));
7528 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7529 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7530 gfc_add_expr_to_block (&se
->post
, tmp
);
7532 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7533 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7535 /* Check that the shapes are the same between lhs and expression. */
7536 for (n
= 0 ; n
< rank
; n
++)
7539 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7540 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7541 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7542 gfc_array_index_type
, tmp
, tmp1
);
7543 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7544 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7545 gfc_array_index_type
, tmp
, tmp1
);
7546 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7547 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7548 gfc_array_index_type
, tmp
, tmp1
);
7549 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7550 boolean_type_node
, tmp
,
7551 gfc_index_zero_node
);
7552 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7553 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7554 boolean_type_node
, tmp
,
7558 /* 'zero_cond' being true is equal to lhs not being allocated or the
7559 shapes being different. */
7560 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7562 /* Now reset the bounds returned from the function call to bounds based
7563 on the lhs lbounds, except where the lhs is not allocated or the shapes
7564 of 'variable and 'expr' are different. Set the offset accordingly. */
7565 offset
= gfc_index_zero_node
;
7566 for (n
= 0 ; n
< rank
; n
++)
7570 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7571 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7572 gfc_array_index_type
, zero_cond
,
7573 gfc_index_one_node
, lbound
);
7574 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7576 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7577 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7578 gfc_array_index_type
, tmp
, lbound
);
7579 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7580 gfc_rank_cst
[n
], lbound
);
7581 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7582 gfc_rank_cst
[n
], tmp
);
7584 /* Set stride and accumulate the offset. */
7585 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7586 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7587 gfc_rank_cst
[n
], tmp
);
7588 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7589 gfc_array_index_type
, lbound
, tmp
);
7590 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7591 gfc_array_index_type
, offset
, tmp
);
7592 offset
= gfc_evaluate_now (offset
, &se
->post
);
7595 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7600 /* Try to translate array(:) = func (...), where func is a transformational
7601 array function, without using a temporary. Returns NULL if this isn't the
7605 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7609 gfc_component
*comp
= NULL
;
7612 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7615 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7617 comp
= gfc_get_proc_ptr_comp (expr2
);
7618 gcc_assert (expr2
->value
.function
.isym
7619 || (comp
&& comp
->attr
.dimension
)
7620 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7621 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7623 gfc_init_se (&se
, NULL
);
7624 gfc_start_block (&se
.pre
);
7625 se
.want_pointer
= 1;
7627 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7629 if (expr1
->ts
.type
== BT_DERIVED
7630 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7633 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7635 gfc_add_expr_to_block (&se
.pre
, tmp
);
7638 se
.direct_byref
= 1;
7639 se
.ss
= gfc_walk_expr (expr2
);
7640 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7642 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7643 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7644 Clearly, this cannot be done for an allocatable function result, since
7645 the shape of the result is unknown and, in any case, the function must
7646 correctly take care of the reallocation internally. For intrinsic
7647 calls, the array data is freed and the library takes care of allocation.
7648 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7650 if (flag_realloc_lhs
7651 && gfc_is_reallocatable_lhs (expr1
)
7652 && !gfc_expr_attr (expr1
).codimension
7653 && !gfc_is_coindexed (expr1
)
7654 && !(expr2
->value
.function
.esym
7655 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7657 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7659 if (!expr2
->value
.function
.isym
)
7661 ss
= gfc_walk_expr (expr1
);
7662 gcc_assert (ss
!= gfc_ss_terminator
);
7664 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7665 ss
->is_alloc_lhs
= 1;
7668 fcncall_realloc_result (&se
, expr1
->rank
);
7671 gfc_conv_function_expr (&se
, expr2
);
7672 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7675 gfc_cleanup_loop (&loop
);
7677 gfc_free_ss_chain (se
.ss
);
7679 return gfc_finish_block (&se
.pre
);
7683 /* Try to efficiently translate array(:) = 0. Return NULL if this
7687 gfc_trans_zero_assign (gfc_expr
* expr
)
7689 tree dest
, len
, type
;
7693 sym
= expr
->symtree
->n
.sym
;
7694 dest
= gfc_get_symbol_decl (sym
);
7696 type
= TREE_TYPE (dest
);
7697 if (POINTER_TYPE_P (type
))
7698 type
= TREE_TYPE (type
);
7699 if (!GFC_ARRAY_TYPE_P (type
))
7702 /* Determine the length of the array. */
7703 len
= GFC_TYPE_ARRAY_SIZE (type
);
7704 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7707 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7708 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7709 fold_convert (gfc_array_index_type
, tmp
));
7711 /* If we are zeroing a local array avoid taking its address by emitting
7713 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7714 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7715 dest
, build_constructor (TREE_TYPE (dest
),
7718 /* Convert arguments to the correct types. */
7719 dest
= fold_convert (pvoid_type_node
, dest
);
7720 len
= fold_convert (size_type_node
, len
);
7722 /* Construct call to __builtin_memset. */
7723 tmp
= build_call_expr_loc (input_location
,
7724 builtin_decl_explicit (BUILT_IN_MEMSET
),
7725 3, dest
, integer_zero_node
, len
);
7726 return fold_convert (void_type_node
, tmp
);
7730 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7731 that constructs the call to __builtin_memcpy. */
7734 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7738 /* Convert arguments to the correct types. */
7739 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7740 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7742 dst
= fold_convert (pvoid_type_node
, dst
);
7744 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7745 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7747 src
= fold_convert (pvoid_type_node
, src
);
7749 len
= fold_convert (size_type_node
, len
);
7751 /* Construct call to __builtin_memcpy. */
7752 tmp
= build_call_expr_loc (input_location
,
7753 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7755 return fold_convert (void_type_node
, tmp
);
7759 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7760 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7761 source/rhs, both are gfc_full_array_ref_p which have been checked for
7765 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7767 tree dst
, dlen
, dtype
;
7768 tree src
, slen
, stype
;
7771 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7772 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7774 dtype
= TREE_TYPE (dst
);
7775 if (POINTER_TYPE_P (dtype
))
7776 dtype
= TREE_TYPE (dtype
);
7777 stype
= TREE_TYPE (src
);
7778 if (POINTER_TYPE_P (stype
))
7779 stype
= TREE_TYPE (stype
);
7781 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7784 /* Determine the lengths of the arrays. */
7785 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7786 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7788 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7789 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7790 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7792 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7793 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7795 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7796 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7797 slen
, fold_convert (gfc_array_index_type
, tmp
));
7799 /* Sanity check that they are the same. This should always be
7800 the case, as we should already have checked for conformance. */
7801 if (!tree_int_cst_equal (slen
, dlen
))
7804 return gfc_build_memcpy_call (dst
, src
, dlen
);
7808 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7809 this can't be done. EXPR1 is the destination/lhs for which
7810 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7813 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7815 unsigned HOST_WIDE_INT nelem
;
7821 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7825 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7826 dtype
= TREE_TYPE (dst
);
7827 if (POINTER_TYPE_P (dtype
))
7828 dtype
= TREE_TYPE (dtype
);
7829 if (!GFC_ARRAY_TYPE_P (dtype
))
7832 /* Determine the lengths of the array. */
7833 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7834 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7837 /* Confirm that the constructor is the same size. */
7838 if (compare_tree_int (len
, nelem
) != 0)
7841 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7842 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7843 fold_convert (gfc_array_index_type
, tmp
));
7845 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7846 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7848 stype
= TREE_TYPE (src
);
7849 if (POINTER_TYPE_P (stype
))
7850 stype
= TREE_TYPE (stype
);
7852 return gfc_build_memcpy_call (dst
, src
, len
);
7856 /* Tells whether the expression is to be treated as a variable reference. */
7859 expr_is_variable (gfc_expr
*expr
)
7862 gfc_component
*comp
;
7863 gfc_symbol
*func_ifc
;
7865 if (expr
->expr_type
== EXPR_VARIABLE
)
7868 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7871 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7872 return expr_is_variable (arg
);
7875 /* A data-pointer-returning function should be considered as a variable
7877 if (expr
->expr_type
== EXPR_FUNCTION
7878 && expr
->ref
== NULL
)
7880 if (expr
->value
.function
.isym
!= NULL
)
7883 if (expr
->value
.function
.esym
!= NULL
)
7885 func_ifc
= expr
->value
.function
.esym
;
7890 gcc_assert (expr
->symtree
);
7891 func_ifc
= expr
->symtree
->n
.sym
;
7898 comp
= gfc_get_proc_ptr_comp (expr
);
7899 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7902 func_ifc
= comp
->ts
.interface
;
7906 if (expr
->expr_type
== EXPR_COMPCALL
)
7908 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7909 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7916 gcc_assert (func_ifc
->attr
.function
7917 && func_ifc
->result
!= NULL
);
7918 return func_ifc
->result
->attr
.pointer
;
7922 /* Is the lhs OK for automatic reallocation? */
7925 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7929 /* An allocatable variable with no reference. */
7930 if (expr
->symtree
->n
.sym
->attr
.allocatable
7934 /* All that can be left are allocatable components. */
7935 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7936 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7937 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7940 /* Find an allocatable component ref last. */
7941 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7942 if (ref
->type
== REF_COMPONENT
7944 && ref
->u
.c
.component
->attr
.allocatable
)
7951 /* Allocate or reallocate scalar lhs, as necessary. */
7954 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7968 if (!expr1
|| expr1
->rank
)
7971 if (!expr2
|| expr2
->rank
)
7974 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7976 /* Since this is a scalar lhs, we can afford to do this. That is,
7977 there is no risk of side effects being repeated. */
7978 gfc_init_se (&lse
, NULL
);
7979 lse
.want_pointer
= 1;
7980 gfc_conv_expr (&lse
, expr1
);
7982 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7983 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7985 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7986 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7987 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7989 tmp
= build3_v (COND_EXPR
, cond
,
7990 build1_v (GOTO_EXPR
, jump_label1
),
7991 build_empty_stmt (input_location
));
7992 gfc_add_expr_to_block (block
, tmp
);
7994 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7996 /* Use the rhs string length and the lhs element size. */
7997 size
= string_length
;
7998 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7999 tmp
= TYPE_SIZE_UNIT (tmp
);
8000 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8001 TREE_TYPE (tmp
), tmp
,
8002 fold_convert (TREE_TYPE (tmp
), size
));
8006 /* Otherwise use the length in bytes of the rhs. */
8007 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8008 size_in_bytes
= size
;
8011 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8012 size_in_bytes
, size_one_node
);
8014 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8016 tmp
= build_call_expr_loc (input_location
,
8017 builtin_decl_explicit (BUILT_IN_CALLOC
),
8018 2, build_one_cst (size_type_node
),
8020 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8021 gfc_add_modify (block
, lse
.expr
, tmp
);
8025 tmp
= build_call_expr_loc (input_location
,
8026 builtin_decl_explicit (BUILT_IN_MALLOC
),
8028 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8029 gfc_add_modify (block
, lse
.expr
, tmp
);
8032 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8034 /* Deferred characters need checking for lhs and rhs string
8035 length. Other deferred parameter variables will have to
8037 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8038 gfc_add_expr_to_block (block
, tmp
);
8040 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8041 gfc_add_expr_to_block (block
, tmp
);
8043 /* For a deferred length character, reallocate if lengths of lhs and
8044 rhs are different. */
8045 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8047 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8048 expr1
->ts
.u
.cl
->backend_decl
, size
);
8049 /* Jump past the realloc if the lengths are the same. */
8050 tmp
= build3_v (COND_EXPR
, cond
,
8051 build1_v (GOTO_EXPR
, jump_label2
),
8052 build_empty_stmt (input_location
));
8053 gfc_add_expr_to_block (block
, tmp
);
8054 tmp
= build_call_expr_loc (input_location
,
8055 builtin_decl_explicit (BUILT_IN_REALLOC
),
8056 2, fold_convert (pvoid_type_node
, lse
.expr
),
8058 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8059 gfc_add_modify (block
, lse
.expr
, tmp
);
8060 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8061 gfc_add_expr_to_block (block
, tmp
);
8063 /* Update the lhs character length. */
8064 size
= string_length
;
8065 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8066 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
8068 gfc_add_modify (block
, lse
.string_length
, size
);
8072 /* Check for assignments of the type
8076 to make sure we do not check for reallocation unneccessarily. */
8080 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8082 gfc_actual_arglist
*a
;
8085 switch (expr2
->expr_type
)
8088 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8091 if (expr2
->value
.function
.esym
8092 && expr2
->value
.function
.esym
->attr
.elemental
)
8094 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8097 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8102 else if (expr2
->value
.function
.isym
8103 && expr2
->value
.function
.isym
->elemental
)
8105 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8108 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8117 switch (expr2
->value
.op
.op
)
8120 case INTRINSIC_UPLUS
:
8121 case INTRINSIC_UMINUS
:
8122 case INTRINSIC_PARENTHESES
:
8123 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8125 case INTRINSIC_PLUS
:
8126 case INTRINSIC_MINUS
:
8127 case INTRINSIC_TIMES
:
8128 case INTRINSIC_DIVIDE
:
8129 case INTRINSIC_POWER
:
8133 case INTRINSIC_NEQV
:
8140 case INTRINSIC_EQ_OS
:
8141 case INTRINSIC_NE_OS
:
8142 case INTRINSIC_GT_OS
:
8143 case INTRINSIC_GE_OS
:
8144 case INTRINSIC_LT_OS
:
8145 case INTRINSIC_LE_OS
:
8147 e1
= expr2
->value
.op
.op1
;
8148 e2
= expr2
->value
.op
.op2
;
8150 if (e1
->rank
== 0 && e2
->rank
> 0)
8151 return is_runtime_conformable (expr1
, e2
);
8152 else if (e1
->rank
> 0 && e2
->rank
== 0)
8153 return is_runtime_conformable (expr1
, e1
);
8154 else if (e1
->rank
> 0 && e2
->rank
> 0)
8155 return is_runtime_conformable (expr1
, e1
)
8156 && is_runtime_conformable (expr1
, e2
);
8172 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8173 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8174 init_flag indicates initialization expressions and dealloc that no
8175 deallocate prior assignment is needed (if in doubt, set true). */
8178 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8184 gfc_ss
*lss_section
;
8191 bool scalar_to_array
;
8195 /* Assignment of the form lhs = rhs. */
8196 gfc_start_block (&block
);
8198 gfc_init_se (&lse
, NULL
);
8199 gfc_init_se (&rse
, NULL
);
8202 lss
= gfc_walk_expr (expr1
);
8203 if (gfc_is_reallocatable_lhs (expr1
)
8204 && !(expr2
->expr_type
== EXPR_FUNCTION
8205 && expr2
->value
.function
.isym
!= NULL
))
8206 lss
->is_alloc_lhs
= 1;
8208 if (lss
!= gfc_ss_terminator
)
8210 /* The assignment needs scalarization. */
8213 /* Find a non-scalar SS from the lhs. */
8214 while (lss_section
!= gfc_ss_terminator
8215 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8216 lss_section
= lss_section
->next
;
8218 gcc_assert (lss_section
!= gfc_ss_terminator
);
8220 /* Initialize the scalarizer. */
8221 gfc_init_loopinfo (&loop
);
8224 rss
= gfc_walk_expr (expr2
);
8225 if (rss
== gfc_ss_terminator
)
8226 /* The rhs is scalar. Add a ss for the expression. */
8227 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8229 /* Associate the SS with the loop. */
8230 gfc_add_ss_to_loop (&loop
, lss
);
8231 gfc_add_ss_to_loop (&loop
, rss
);
8233 /* Calculate the bounds of the scalarization. */
8234 gfc_conv_ss_startstride (&loop
);
8235 /* Enable loop reversal. */
8236 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8237 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8238 /* Resolve any data dependencies in the statement. */
8239 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8240 /* Setup the scalarizing loops. */
8241 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8243 /* Setup the gfc_se structures. */
8244 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8245 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8248 gfc_mark_ss_chain_used (rss
, 1);
8249 if (loop
.temp_ss
== NULL
)
8252 gfc_mark_ss_chain_used (lss
, 1);
8256 lse
.ss
= loop
.temp_ss
;
8257 gfc_mark_ss_chain_used (lss
, 3);
8258 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8261 /* Allow the scalarizer to workshare array assignments. */
8262 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8263 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8265 /* Start the scalarized loop body. */
8266 gfc_start_scalarized_body (&loop
, &body
);
8269 gfc_init_block (&body
);
8271 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8273 /* Translate the expression. */
8274 gfc_conv_expr (&rse
, expr2
);
8276 /* Stabilize a string length for temporaries. */
8277 if (expr2
->ts
.type
== BT_CHARACTER
)
8278 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8280 string_length
= NULL_TREE
;
8284 gfc_conv_tmp_array_ref (&lse
);
8285 if (expr2
->ts
.type
== BT_CHARACTER
)
8286 lse
.string_length
= string_length
;
8289 gfc_conv_expr (&lse
, expr1
);
8291 /* Assignments of scalar derived types with allocatable components
8292 to arrays must be done with a deep copy and the rhs temporary
8293 must have its components deallocated afterwards. */
8294 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8295 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8296 && !expr_is_variable (expr2
)
8297 && !gfc_is_constant_expr (expr2
)
8298 && expr1
->rank
&& !expr2
->rank
);
8299 if (scalar_to_array
&& dealloc
)
8301 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8302 gfc_add_expr_to_block (&loop
.post
, tmp
);
8305 /* When assigning a character function result to a deferred-length variable,
8306 the function call must happen before the (re)allocation of the lhs -
8307 otherwise the character length of the result is not known.
8308 NOTE: This relies on having the exact dependence of the length type
8309 parameter available to the caller; gfortran saves it in the .mod files. */
8310 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8311 gfc_add_block_to_block (&block
, &rse
.pre
);
8313 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8314 l_is_temp
|| init_flag
,
8315 expr_is_variable (expr2
) || scalar_to_array
8316 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8317 gfc_add_expr_to_block (&body
, tmp
);
8319 if (lss
== gfc_ss_terminator
)
8321 /* F2003: Add the code for reallocation on assignment. */
8322 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
8323 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8326 /* Use the scalar assignment as is. */
8327 gfc_add_block_to_block (&block
, &body
);
8331 gcc_assert (lse
.ss
== gfc_ss_terminator
8332 && rse
.ss
== gfc_ss_terminator
);
8336 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8338 /* We need to copy the temporary to the actual lhs. */
8339 gfc_init_se (&lse
, NULL
);
8340 gfc_init_se (&rse
, NULL
);
8341 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8342 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8344 rse
.ss
= loop
.temp_ss
;
8347 gfc_conv_tmp_array_ref (&rse
);
8348 gfc_conv_expr (&lse
, expr1
);
8350 gcc_assert (lse
.ss
== gfc_ss_terminator
8351 && rse
.ss
== gfc_ss_terminator
);
8353 if (expr2
->ts
.type
== BT_CHARACTER
)
8354 rse
.string_length
= string_length
;
8356 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8357 false, false, dealloc
);
8358 gfc_add_expr_to_block (&body
, tmp
);
8361 /* F2003: Allocate or reallocate lhs of allocatable array. */
8362 if (flag_realloc_lhs
8363 && gfc_is_reallocatable_lhs (expr1
)
8364 && !gfc_expr_attr (expr1
).codimension
8365 && !gfc_is_coindexed (expr1
)
8367 && !is_runtime_conformable (expr1
, expr2
))
8369 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8370 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8371 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8372 if (tmp
!= NULL_TREE
)
8373 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8376 /* Generate the copying loops. */
8377 gfc_trans_scalarizing_loops (&loop
, &body
);
8379 /* Wrap the whole thing up. */
8380 gfc_add_block_to_block (&block
, &loop
.pre
);
8381 gfc_add_block_to_block (&block
, &loop
.post
);
8383 gfc_cleanup_loop (&loop
);
8386 return gfc_finish_block (&block
);
8390 /* Check whether EXPR is a copyable array. */
8393 copyable_array_p (gfc_expr
* expr
)
8395 if (expr
->expr_type
!= EXPR_VARIABLE
)
8398 /* First check it's an array. */
8399 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8402 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8405 /* Next check that it's of a simple enough type. */
8406 switch (expr
->ts
.type
)
8418 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8427 /* Translate an assignment. */
8430 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8435 /* Special case a single function returning an array. */
8436 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8438 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8443 /* Special case assigning an array to zero. */
8444 if (copyable_array_p (expr1
)
8445 && is_zero_initializer_p (expr2
))
8447 tmp
= gfc_trans_zero_assign (expr1
);
8452 /* Special case copying one array to another. */
8453 if (copyable_array_p (expr1
)
8454 && copyable_array_p (expr2
)
8455 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8456 && !gfc_check_dependency (expr1
, expr2
, 0))
8458 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8463 /* Special case initializing an array from a constant array constructor. */
8464 if (copyable_array_p (expr1
)
8465 && expr2
->expr_type
== EXPR_ARRAY
8466 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8468 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8473 /* Fallback to the scalarizer to generate explicit loops. */
8474 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8478 gfc_trans_init_assign (gfc_code
* code
)
8480 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8484 gfc_trans_assign (gfc_code
* code
)
8486 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);