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
);
936 if (UNLIMITED_POLY(obj
))
938 /* Check if rhs is non-NULL. */
940 gfc_init_se (&src
, NULL
);
941 gfc_conv_expr (&src
, rhs
);
942 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
943 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
944 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
946 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
947 build_empty_stmt (input_location
));
953 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
954 A MEMCPY is needed to copy the full data from the default initializer
955 of the dynamic type. */
958 gfc_trans_class_init_assign (gfc_code
*code
)
962 gfc_se dst
,src
,memsz
;
963 gfc_expr
*lhs
, *rhs
, *sz
;
965 gfc_start_block (&block
);
967 lhs
= gfc_copy_expr (code
->expr1
);
968 gfc_add_data_component (lhs
);
970 rhs
= gfc_copy_expr (code
->expr1
);
971 gfc_add_vptr_component (rhs
);
973 /* Make sure that the component backend_decls have been built, which
974 will not have happened if the derived types concerned have not
976 gfc_get_derived_type (rhs
->ts
.u
.derived
);
977 gfc_add_def_init_component (rhs
);
979 if (code
->expr1
->ts
.type
== BT_CLASS
980 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
981 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
984 sz
= gfc_copy_expr (code
->expr1
);
985 gfc_add_vptr_component (sz
);
986 gfc_add_size_component (sz
);
988 gfc_init_se (&dst
, NULL
);
989 gfc_init_se (&src
, NULL
);
990 gfc_init_se (&memsz
, NULL
);
991 gfc_conv_expr (&dst
, lhs
);
992 gfc_conv_expr (&src
, rhs
);
993 gfc_conv_expr (&memsz
, sz
);
994 gfc_add_block_to_block (&block
, &src
.pre
);
995 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
997 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
999 if (UNLIMITED_POLY(code
->expr1
))
1001 /* Check if _def_init is non-NULL. */
1002 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1003 boolean_type_node
, src
.expr
,
1004 fold_convert (TREE_TYPE (src
.expr
),
1005 null_pointer_node
));
1006 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1007 tmp
, build_empty_stmt (input_location
));
1011 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1012 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1014 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1015 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1017 build_empty_stmt (input_location
));
1020 gfc_add_expr_to_block (&block
, tmp
);
1022 return gfc_finish_block (&block
);
1026 /* Translate an assignment to a CLASS object
1027 (pointer or ordinary assignment). */
1030 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1038 gfc_start_block (&block
);
1041 while (ref
&& ref
->next
)
1044 /* Class valued proc_pointer assignments do not need any further
1046 if (ref
&& ref
->type
== REF_COMPONENT
1047 && ref
->u
.c
.component
->attr
.proc_pointer
1048 && expr2
->expr_type
== EXPR_VARIABLE
1049 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1050 && op
== EXEC_POINTER_ASSIGN
)
1053 if (expr2
->ts
.type
!= BT_CLASS
)
1055 /* Insert an additional assignment which sets the '_vptr' field. */
1056 gfc_symbol
*vtab
= NULL
;
1059 lhs
= gfc_copy_expr (expr1
);
1060 gfc_add_vptr_component (lhs
);
1062 if (UNLIMITED_POLY (expr1
)
1063 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1065 rhs
= gfc_get_null_expr (&expr2
->where
);
1069 if (expr2
->expr_type
== EXPR_NULL
)
1070 vtab
= gfc_find_vtab (&expr1
->ts
);
1072 vtab
= gfc_find_vtab (&expr2
->ts
);
1075 rhs
= gfc_get_expr ();
1076 rhs
->expr_type
= EXPR_VARIABLE
;
1077 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1081 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1082 gfc_add_expr_to_block (&block
, tmp
);
1084 gfc_free_expr (lhs
);
1085 gfc_free_expr (rhs
);
1087 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1089 /* F2003:C717 only sequence and bind-C types can come here. */
1090 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1091 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1092 gfc_add_data_component (expr2
);
1095 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1097 /* Insert an additional assignment which sets the '_vptr' field. */
1098 lhs
= gfc_copy_expr (expr1
);
1099 gfc_add_vptr_component (lhs
);
1101 rhs
= gfc_copy_expr (expr2
);
1102 gfc_add_vptr_component (rhs
);
1104 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1105 gfc_add_expr_to_block (&block
, tmp
);
1107 gfc_free_expr (lhs
);
1108 gfc_free_expr (rhs
);
1111 /* Do the actual CLASS assignment. */
1112 if (expr2
->ts
.type
== BT_CLASS
1113 && !CLASS_DATA (expr2
)->attr
.dimension
)
1115 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1116 || !CLASS_DATA (expr2
)->attr
.dimension
)
1117 gfc_add_data_component (expr1
);
1121 if (op
== EXEC_ASSIGN
)
1122 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1123 else if (op
== EXEC_POINTER_ASSIGN
)
1124 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1128 gfc_add_expr_to_block (&block
, tmp
);
1130 return gfc_finish_block (&block
);
1134 /* End of prototype trans-class.c */
1138 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1140 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1141 gfc_warning (OPT_Wrealloc_lhs
,
1142 "Code for reallocating the allocatable array at %L will "
1144 else if (warn_realloc_lhs_all
)
1145 gfc_warning (OPT_Wrealloc_lhs_all
,
1146 "Code for reallocating the allocatable variable at %L "
1147 "will be added", where
);
1151 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1152 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1155 /* Copy the scalarization loop variables. */
1158 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1161 dest
->loop
= src
->loop
;
1165 /* Initialize a simple expression holder.
1167 Care must be taken when multiple se are created with the same parent.
1168 The child se must be kept in sync. The easiest way is to delay creation
1169 of a child se until after after the previous se has been translated. */
1172 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1174 memset (se
, 0, sizeof (gfc_se
));
1175 gfc_init_block (&se
->pre
);
1176 gfc_init_block (&se
->post
);
1178 se
->parent
= parent
;
1181 gfc_copy_se_loopvars (se
, parent
);
1185 /* Advances to the next SS in the chain. Use this rather than setting
1186 se->ss = se->ss->next because all the parents needs to be kept in sync.
1190 gfc_advance_se_ss_chain (gfc_se
* se
)
1195 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1198 /* Walk down the parent chain. */
1201 /* Simple consistency check. */
1202 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1203 || p
->parent
->ss
->nested_ss
== p
->ss
);
1205 /* If we were in a nested loop, the next scalarized expression can be
1206 on the parent ss' next pointer. Thus we should not take the next
1207 pointer blindly, but rather go up one nest level as long as next
1208 is the end of chain. */
1210 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1220 /* Ensures the result of the expression as either a temporary variable
1221 or a constant so that it can be used repeatedly. */
1224 gfc_make_safe_expr (gfc_se
* se
)
1228 if (CONSTANT_CLASS_P (se
->expr
))
1231 /* We need a temporary for this result. */
1232 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1233 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1238 /* Return an expression which determines if a dummy parameter is present.
1239 Also used for arguments to procedures with multiple entry points. */
1242 gfc_conv_expr_present (gfc_symbol
* sym
)
1246 gcc_assert (sym
->attr
.dummy
);
1247 decl
= gfc_get_symbol_decl (sym
);
1249 /* Intrinsic scalars with VALUE attribute which are passed by value
1250 use a hidden argument to denote the present status. */
1251 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1252 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1253 && !sym
->attr
.dimension
)
1255 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1258 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1260 strcpy (&name
[1], sym
->name
);
1261 tree_name
= get_identifier (name
);
1263 /* Walk function argument list to find hidden arg. */
1264 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1265 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1266 if (DECL_NAME (cond
) == tree_name
)
1273 if (TREE_CODE (decl
) != PARM_DECL
)
1275 /* Array parameters use a temporary descriptor, we want the real
1277 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1278 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1279 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1282 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1283 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1285 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1286 as actual argument to denote absent dummies. For array descriptors,
1287 we thus also need to check the array descriptor. For BT_CLASS, it
1288 can also occur for scalars and F2003 due to type->class wrapping and
1289 class->class wrapping. Note further that BT_CLASS always uses an
1290 array descriptor for arrays, also for explicit-shape/assumed-size. */
1292 if (!sym
->attr
.allocatable
1293 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1294 || (sym
->ts
.type
== BT_CLASS
1295 && !CLASS_DATA (sym
)->attr
.allocatable
1296 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1297 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1298 || sym
->ts
.type
== BT_CLASS
))
1302 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1303 || sym
->as
->type
== AS_ASSUMED_RANK
1304 || sym
->attr
.codimension
))
1305 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1307 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1308 if (sym
->ts
.type
== BT_CLASS
)
1309 tmp
= gfc_class_data_get (tmp
);
1310 tmp
= gfc_conv_array_data (tmp
);
1312 else if (sym
->ts
.type
== BT_CLASS
)
1313 tmp
= gfc_class_data_get (decl
);
1317 if (tmp
!= NULL_TREE
)
1319 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1320 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1321 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1322 boolean_type_node
, cond
, tmp
);
1330 /* Converts a missing, dummy argument into a null or zero. */
1333 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1338 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1342 /* Create a temporary and convert it to the correct type. */
1343 tmp
= gfc_get_int_type (kind
);
1344 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1347 /* Test for a NULL value. */
1348 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1349 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1350 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1351 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1355 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1357 build_zero_cst (TREE_TYPE (se
->expr
)));
1358 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1362 if (ts
.type
== BT_CHARACTER
)
1364 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1365 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1366 present
, se
->string_length
, tmp
);
1367 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1368 se
->string_length
= tmp
;
1374 /* Get the character length of an expression, looking through gfc_refs
1378 gfc_get_expr_charlen (gfc_expr
*e
)
1383 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1384 && e
->ts
.type
== BT_CHARACTER
);
1386 length
= NULL
; /* To silence compiler warning. */
1388 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1391 gfc_init_se (&tmpse
, NULL
);
1392 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1393 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1397 /* First candidate: if the variable is of type CHARACTER, the
1398 expression's length could be the length of the character
1400 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1401 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1403 /* Look through the reference chain for component references. */
1404 for (r
= e
->ref
; r
; r
= r
->next
)
1409 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1410 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1418 /* We should never got substring references here. These will be
1419 broken down by the scalarizer. */
1425 gcc_assert (length
!= NULL
);
1430 /* Return for an expression the backend decl of the coarray. */
1433 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1439 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1441 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1442 gcc_assert (caf_decl
);
1443 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1444 caf_decl
= gfc_class_data_get (caf_decl
);
1445 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1448 /* The following code assumes that the coarray is a component reachable via
1449 only scalar components/variables; the Fortran standard guarantees this. */
1451 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1452 if (ref
->type
== REF_COMPONENT
)
1454 gfc_component
*comp
= ref
->u
.c
.component
;
1456 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1457 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1458 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1459 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1460 comp
->backend_decl
, NULL_TREE
);
1461 if (comp
->ts
.type
== BT_CLASS
)
1462 caf_decl
= gfc_class_data_get (caf_decl
);
1463 if (comp
->attr
.codimension
)
1469 gcc_assert (found
&& caf_decl
);
1474 /* Obtain the Coarray token - and optionally also the offset. */
1477 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1482 /* Coarray token. */
1483 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1485 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1486 == GFC_ARRAY_ALLOCATABLE
1487 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1488 *token
= gfc_conv_descriptor_token (caf_decl
);
1490 else if (DECL_LANG_SPECIFIC (caf_decl
)
1491 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1492 *token
= GFC_DECL_TOKEN (caf_decl
);
1495 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1496 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1497 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1503 /* Offset between the coarray base address and the address wanted. */
1504 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1505 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1506 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1507 *offset
= build_int_cst (gfc_array_index_type
, 0);
1508 else if (DECL_LANG_SPECIFIC (caf_decl
)
1509 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1510 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1511 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1512 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1514 *offset
= build_int_cst (gfc_array_index_type
, 0);
1516 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1517 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1519 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1520 tmp
= gfc_conv_descriptor_data_get (tmp
);
1522 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1523 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1526 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1530 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1531 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1533 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1534 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1537 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1541 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1542 fold_convert (gfc_array_index_type
, *offset
),
1543 fold_convert (gfc_array_index_type
, tmp
));
1547 /* Convert the coindex of a coarray into an image index; the result is
1548 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1549 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1552 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1555 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1559 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1560 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1562 gcc_assert (ref
!= NULL
);
1564 img_idx
= integer_zero_node
;
1565 extent
= integer_one_node
;
1566 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1567 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1569 gfc_init_se (&se
, NULL
);
1570 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1571 gfc_add_block_to_block (block
, &se
.pre
);
1572 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1573 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1574 integer_type_node
, se
.expr
,
1575 fold_convert(integer_type_node
, lbound
));
1576 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1578 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1580 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1582 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1583 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1584 tmp
= fold_convert (integer_type_node
, tmp
);
1585 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1586 integer_type_node
, extent
, tmp
);
1590 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1592 gfc_init_se (&se
, NULL
);
1593 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1594 gfc_add_block_to_block (block
, &se
.pre
);
1595 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1596 lbound
= fold_convert (integer_type_node
, lbound
);
1597 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1598 integer_type_node
, se
.expr
, lbound
);
1599 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1601 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1603 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1605 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1606 ubound
= fold_convert (integer_type_node
, ubound
);
1607 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1608 integer_type_node
, ubound
, lbound
);
1609 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1610 tmp
, integer_one_node
);
1611 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1612 integer_type_node
, extent
, tmp
);
1615 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1616 img_idx
, integer_one_node
);
1621 /* For each character array constructor subexpression without a ts.u.cl->length,
1622 replace it by its first element (if there aren't any elements, the length
1623 should already be set to zero). */
1626 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1628 gfc_actual_arglist
* arg
;
1634 switch (e
->expr_type
)
1638 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1639 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1643 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1647 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1648 flatten_array_ctors_without_strlen (arg
->expr
);
1653 /* We've found what we're looking for. */
1654 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1659 gcc_assert (e
->value
.constructor
);
1661 c
= gfc_constructor_first (e
->value
.constructor
);
1665 flatten_array_ctors_without_strlen (new_expr
);
1666 gfc_replace_expr (e
, new_expr
);
1670 /* Otherwise, fall through to handle constructor elements. */
1671 case EXPR_STRUCTURE
:
1672 for (c
= gfc_constructor_first (e
->value
.constructor
);
1673 c
; c
= gfc_constructor_next (c
))
1674 flatten_array_ctors_without_strlen (c
->expr
);
1684 /* Generate code to initialize a string length variable. Returns the
1685 value. For array constructors, cl->length might be NULL and in this case,
1686 the first element of the constructor is needed. expr is the original
1687 expression so we can access it but can be NULL if this is not needed. */
1690 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1694 gfc_init_se (&se
, NULL
);
1698 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1701 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1702 "flatten" array constructors by taking their first element; all elements
1703 should be the same length or a cl->length should be present. */
1706 gfc_expr
* expr_flat
;
1708 expr_flat
= gfc_copy_expr (expr
);
1709 flatten_array_ctors_without_strlen (expr_flat
);
1710 gfc_resolve_expr (expr_flat
);
1712 gfc_conv_expr (&se
, expr_flat
);
1713 gfc_add_block_to_block (pblock
, &se
.pre
);
1714 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1716 gfc_free_expr (expr_flat
);
1720 /* Convert cl->length. */
1722 gcc_assert (cl
->length
);
1724 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1725 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1726 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1727 gfc_add_block_to_block (pblock
, &se
.pre
);
1729 if (cl
->backend_decl
)
1730 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1732 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1737 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1738 const char *name
, locus
*where
)
1748 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1749 type
= build_pointer_type (type
);
1751 gfc_init_se (&start
, se
);
1752 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1753 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1755 if (integer_onep (start
.expr
))
1756 gfc_conv_string_parameter (se
);
1761 /* Avoid multiple evaluation of substring start. */
1762 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1763 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1765 /* Change the start of the string. */
1766 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1769 tmp
= build_fold_indirect_ref_loc (input_location
,
1771 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1772 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1775 /* Length = end + 1 - start. */
1776 gfc_init_se (&end
, se
);
1777 if (ref
->u
.ss
.end
== NULL
)
1778 end
.expr
= se
->string_length
;
1781 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1782 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1786 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1787 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1789 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1791 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1792 boolean_type_node
, start
.expr
,
1795 /* Check lower bound. */
1796 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1798 build_int_cst (gfc_charlen_type_node
, 1));
1799 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1800 boolean_type_node
, nonempty
, fault
);
1802 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
1803 "is less than one", name
);
1805 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
1806 "is less than one");
1807 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1808 fold_convert (long_integer_type_node
,
1812 /* Check upper bound. */
1813 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1814 end
.expr
, se
->string_length
);
1815 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1816 boolean_type_node
, nonempty
, fault
);
1818 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
1819 "exceeds string length (%%ld)", name
);
1821 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
1822 "exceeds string length (%%ld)");
1823 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1824 fold_convert (long_integer_type_node
, end
.expr
),
1825 fold_convert (long_integer_type_node
,
1826 se
->string_length
));
1830 /* Try to calculate the length from the start and end expressions. */
1832 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1836 i_len
= mpz_get_si (length
) + 1;
1840 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1841 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1845 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1846 end
.expr
, start
.expr
);
1847 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1848 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1849 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1850 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1853 se
->string_length
= tmp
;
1857 /* Convert a derived type component reference. */
1860 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1867 c
= ref
->u
.c
.component
;
1869 gcc_assert (c
->backend_decl
);
1871 field
= c
->backend_decl
;
1872 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1875 /* Components can correspond to fields of different containing
1876 types, as components are created without context, whereas
1877 a concrete use of a component has the type of decl as context.
1878 So, if the type doesn't match, we search the corresponding
1879 FIELD_DECL in the parent type. To not waste too much time
1880 we cache this result in norestrict_decl. */
1882 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1884 tree f2
= c
->norestrict_decl
;
1885 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1886 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1887 if (TREE_CODE (f2
) == FIELD_DECL
1888 && DECL_NAME (f2
) == DECL_NAME (field
))
1891 c
->norestrict_decl
= f2
;
1895 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1896 decl
, field
, NULL_TREE
);
1900 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1902 tmp
= c
->ts
.u
.cl
->backend_decl
;
1903 /* Components must always be constant length. */
1904 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1905 se
->string_length
= tmp
;
1908 if (gfc_deferred_strlen (c
, &field
))
1910 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1912 decl
, field
, NULL_TREE
);
1913 se
->string_length
= tmp
;
1916 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1917 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1918 && c
->ts
.type
!= BT_CHARACTER
)
1919 || c
->attr
.proc_pointer
)
1920 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1925 /* This function deals with component references to components of the
1926 parent type for derived type extensions. */
1928 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1936 c
= ref
->u
.c
.component
;
1938 /* Return if the component is in the parent type. */
1939 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1940 if (strcmp (c
->name
, cmp
->name
) == 0)
1943 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1944 parent
.type
= REF_COMPONENT
;
1946 parent
.u
.c
.sym
= dt
;
1947 parent
.u
.c
.component
= dt
->components
;
1949 if (dt
->backend_decl
== NULL
)
1950 gfc_get_derived_type (dt
);
1952 /* Build the reference and call self. */
1953 gfc_conv_component_ref (se
, &parent
);
1954 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1955 parent
.u
.c
.component
= c
;
1956 conv_parent_component_references (se
, &parent
);
1959 /* Return the contents of a variable. Also handles reference/pointer
1960 variables (all Fortran pointer references are implicit). */
1963 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1968 tree parent_decl
= NULL_TREE
;
1971 bool alternate_entry
;
1974 sym
= expr
->symtree
->n
.sym
;
1978 gfc_ss_info
*ss_info
= ss
->info
;
1980 /* Check that something hasn't gone horribly wrong. */
1981 gcc_assert (ss
!= gfc_ss_terminator
);
1982 gcc_assert (ss_info
->expr
== expr
);
1984 /* A scalarized term. We already know the descriptor. */
1985 se
->expr
= ss_info
->data
.array
.descriptor
;
1986 se
->string_length
= ss_info
->string_length
;
1987 ref
= ss_info
->data
.array
.ref
;
1989 gcc_assert (ref
->type
== REF_ARRAY
1990 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1992 gfc_conv_tmp_array_ref (se
);
1996 tree se_expr
= NULL_TREE
;
1998 se
->expr
= gfc_get_symbol_decl (sym
);
2000 /* Deal with references to a parent results or entries by storing
2001 the current_function_decl and moving to the parent_decl. */
2002 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2003 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2004 && sym
->result
== sym
;
2005 entry_master
= sym
->attr
.result
2006 && sym
->ns
->proc_name
->attr
.entry_master
2007 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2008 if (current_function_decl
)
2009 parent_decl
= DECL_CONTEXT (current_function_decl
);
2011 if ((se
->expr
== parent_decl
&& return_value
)
2012 || (sym
->ns
&& sym
->ns
->proc_name
2014 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2015 && (alternate_entry
|| entry_master
)))
2020 /* Special case for assigning the return value of a function.
2021 Self recursive functions must have an explicit return value. */
2022 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2023 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2025 /* Similarly for alternate entry points. */
2026 else if (alternate_entry
2027 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2030 gfc_entry_list
*el
= NULL
;
2032 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2035 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2040 else if (entry_master
2041 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2043 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2048 /* Procedure actual arguments. */
2049 else if (sym
->attr
.flavor
== FL_PROCEDURE
2050 && se
->expr
!= current_function_decl
)
2052 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2054 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2055 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2061 /* Dereference the expression, where needed. Since characters
2062 are entirely different from other types, they are treated
2064 if (sym
->ts
.type
== BT_CHARACTER
)
2066 /* Dereference character pointer dummy arguments
2068 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2070 || sym
->attr
.function
2071 || sym
->attr
.result
))
2072 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2076 else if (!sym
->attr
.value
)
2078 /* Dereference non-character scalar dummy arguments. */
2079 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2080 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
2081 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2084 /* Dereference scalar hidden result. */
2085 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2086 && (sym
->attr
.function
|| sym
->attr
.result
)
2087 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2088 && !sym
->attr
.always_explicit
)
2089 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2092 /* Dereference non-character pointer variables.
2093 These must be dummies, results, or scalars. */
2094 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2095 || gfc_is_associate_pointer (sym
)
2096 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2098 || sym
->attr
.function
2100 || (!sym
->attr
.dimension
2101 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2102 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2109 /* For character variables, also get the length. */
2110 if (sym
->ts
.type
== BT_CHARACTER
)
2112 /* If the character length of an entry isn't set, get the length from
2113 the master function instead. */
2114 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2115 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2117 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2118 gcc_assert (se
->string_length
);
2126 /* Return the descriptor if that's what we want and this is an array
2127 section reference. */
2128 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2130 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2131 /* Return the descriptor for array pointers and allocations. */
2132 if (se
->want_pointer
2133 && ref
->next
== NULL
&& (se
->descriptor_only
))
2136 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2137 /* Return a pointer to an element. */
2141 if (ref
->u
.c
.sym
->attr
.extension
)
2142 conv_parent_component_references (se
, ref
);
2144 gfc_conv_component_ref (se
, ref
);
2145 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2146 && se
->want_pointer
&& se
->descriptor_only
)
2152 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2153 expr
->symtree
->name
, &expr
->where
);
2162 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2164 if (se
->want_pointer
)
2166 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2167 gfc_conv_string_parameter (se
);
2169 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2174 /* Unary ops are easy... Or they would be if ! was a valid op. */
2177 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2182 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2183 /* Initialize the operand. */
2184 gfc_init_se (&operand
, se
);
2185 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2186 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2188 type
= gfc_typenode_for_spec (&expr
->ts
);
2190 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2191 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2192 All other unary operators have an equivalent GIMPLE unary operator. */
2193 if (code
== TRUTH_NOT_EXPR
)
2194 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2195 build_int_cst (type
, 0));
2197 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2201 /* Expand power operator to optimal multiplications when a value is raised
2202 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2203 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2204 Programming", 3rd Edition, 1998. */
2206 /* This code is mostly duplicated from expand_powi in the backend.
2207 We establish the "optimal power tree" lookup table with the defined size.
2208 The items in the table are the exponents used to calculate the index
2209 exponents. Any integer n less than the value can get an "addition chain",
2210 with the first node being one. */
2211 #define POWI_TABLE_SIZE 256
2213 /* The table is from builtins.c. */
2214 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2216 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2217 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2218 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2219 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2220 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2221 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2222 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2223 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2224 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2225 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2226 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2227 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2228 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2229 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2230 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2231 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2232 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2233 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2234 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2235 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2236 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2237 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2238 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2239 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2240 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2241 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2242 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2243 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2244 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2245 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2246 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2247 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2250 /* If n is larger than lookup table's max index, we use the "window
2252 #define POWI_WINDOW_SIZE 3
2254 /* Recursive function to expand the power operator. The temporary
2255 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2257 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2264 if (n
< POWI_TABLE_SIZE
)
2269 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2270 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2274 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2275 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2276 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2280 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2284 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2285 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2287 if (n
< POWI_TABLE_SIZE
)
2294 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2295 return 1. Else return 0 and a call to runtime library functions
2296 will have to be built. */
2298 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2303 tree vartmp
[POWI_TABLE_SIZE
];
2305 unsigned HOST_WIDE_INT n
;
2307 wide_int wrhs
= rhs
;
2309 /* If exponent is too large, we won't expand it anyway, so don't bother
2310 with large integer values. */
2311 if (!wi::fits_shwi_p (wrhs
))
2314 m
= wrhs
.to_shwi ();
2315 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2316 of the asymmetric range of the integer type. */
2317 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2319 type
= TREE_TYPE (lhs
);
2320 sgn
= tree_int_cst_sgn (rhs
);
2322 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2323 || optimize_size
) && (m
> 2 || m
< -1))
2329 se
->expr
= gfc_build_const (type
, integer_one_node
);
2333 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2334 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2336 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2337 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2338 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2339 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2342 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2345 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2346 boolean_type_node
, tmp
, cond
);
2347 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2348 tmp
, build_int_cst (type
, 1),
2349 build_int_cst (type
, 0));
2353 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2354 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2355 build_int_cst (type
, -1),
2356 build_int_cst (type
, 0));
2357 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2358 cond
, build_int_cst (type
, 1), tmp
);
2362 memset (vartmp
, 0, sizeof (vartmp
));
2366 tmp
= gfc_build_const (type
, integer_one_node
);
2367 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2371 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2377 /* Power op (**). Constant integer exponent has special handling. */
2380 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2382 tree gfc_int4_type_node
;
2385 int res_ikind_1
, res_ikind_2
;
2390 gfc_init_se (&lse
, se
);
2391 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2392 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2393 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2395 gfc_init_se (&rse
, se
);
2396 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2397 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2399 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2400 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2401 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2404 gfc_int4_type_node
= gfc_get_int_type (4);
2406 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2407 library routine. But in the end, we have to convert the result back
2408 if this case applies -- with res_ikind_K, we keep track whether operand K
2409 falls into this case. */
2413 kind
= expr
->value
.op
.op1
->ts
.kind
;
2414 switch (expr
->value
.op
.op2
->ts
.type
)
2417 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2422 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2423 res_ikind_2
= ikind
;
2445 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2447 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2474 switch (expr
->value
.op
.op1
->ts
.type
)
2477 if (kind
== 3) /* Case 16 was not handled properly above. */
2479 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2483 /* Use builtins for real ** int4. */
2489 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2493 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2497 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2501 /* Use the __builtin_powil() only if real(kind=16) is
2502 actually the C long double type. */
2503 if (!gfc_real16_is_float128
)
2504 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2512 /* If we don't have a good builtin for this, go for the
2513 library function. */
2515 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2519 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2528 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2532 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2540 se
->expr
= build_call_expr_loc (input_location
,
2541 fndecl
, 2, lse
.expr
, rse
.expr
);
2543 /* Convert the result back if it is of wrong integer kind. */
2544 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2546 /* We want the maximum of both operand kinds as result. */
2547 if (res_ikind_1
< res_ikind_2
)
2548 res_ikind_1
= res_ikind_2
;
2549 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2554 /* Generate code to allocate a string temporary. */
2557 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2562 if (gfc_can_put_var_on_stack (len
))
2564 /* Create a temporary variable to hold the result. */
2565 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2566 gfc_charlen_type_node
, len
,
2567 build_int_cst (gfc_charlen_type_node
, 1));
2568 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2570 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2571 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2573 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2575 var
= gfc_create_var (tmp
, "str");
2576 var
= gfc_build_addr_expr (type
, var
);
2580 /* Allocate a temporary to hold the result. */
2581 var
= gfc_create_var (type
, "pstr");
2582 gcc_assert (POINTER_TYPE_P (type
));
2583 tmp
= TREE_TYPE (type
);
2584 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2585 tmp
= TREE_TYPE (tmp
);
2586 tmp
= TYPE_SIZE_UNIT (tmp
);
2587 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2588 fold_convert (size_type_node
, len
),
2589 fold_convert (size_type_node
, tmp
));
2590 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2591 gfc_add_modify (&se
->pre
, var
, tmp
);
2593 /* Free the temporary afterwards. */
2594 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2595 gfc_add_expr_to_block (&se
->post
, tmp
);
2602 /* Handle a string concatenation operation. A temporary will be allocated to
2606 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2609 tree len
, type
, var
, tmp
, fndecl
;
2611 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2612 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2613 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2615 gfc_init_se (&lse
, se
);
2616 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2617 gfc_conv_string_parameter (&lse
);
2618 gfc_init_se (&rse
, se
);
2619 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2620 gfc_conv_string_parameter (&rse
);
2622 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2623 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2625 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2626 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2627 if (len
== NULL_TREE
)
2629 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2630 TREE_TYPE (lse
.string_length
),
2631 lse
.string_length
, rse
.string_length
);
2634 type
= build_pointer_type (type
);
2636 var
= gfc_conv_string_tmp (se
, type
, len
);
2638 /* Do the actual concatenation. */
2639 if (expr
->ts
.kind
== 1)
2640 fndecl
= gfor_fndecl_concat_string
;
2641 else if (expr
->ts
.kind
== 4)
2642 fndecl
= gfor_fndecl_concat_string_char4
;
2646 tmp
= build_call_expr_loc (input_location
,
2647 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2648 rse
.string_length
, rse
.expr
);
2649 gfc_add_expr_to_block (&se
->pre
, tmp
);
2651 /* Add the cleanup for the operands. */
2652 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2653 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2656 se
->string_length
= len
;
2659 /* Translates an op expression. Common (binary) cases are handled by this
2660 function, others are passed on. Recursion is used in either case.
2661 We use the fact that (op1.ts == op2.ts) (except for the power
2663 Operators need no special handling for scalarized expressions as long as
2664 they call gfc_conv_simple_val to get their operands.
2665 Character strings get special handling. */
2668 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2670 enum tree_code code
;
2679 switch (expr
->value
.op
.op
)
2681 case INTRINSIC_PARENTHESES
:
2682 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
2683 && flag_protect_parens
)
2685 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2686 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2691 case INTRINSIC_UPLUS
:
2692 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2695 case INTRINSIC_UMINUS
:
2696 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2700 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2703 case INTRINSIC_PLUS
:
2707 case INTRINSIC_MINUS
:
2711 case INTRINSIC_TIMES
:
2715 case INTRINSIC_DIVIDE
:
2716 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2717 an integer, we must round towards zero, so we use a
2719 if (expr
->ts
.type
== BT_INTEGER
)
2720 code
= TRUNC_DIV_EXPR
;
2725 case INTRINSIC_POWER
:
2726 gfc_conv_power_op (se
, expr
);
2729 case INTRINSIC_CONCAT
:
2730 gfc_conv_concat_op (se
, expr
);
2734 code
= TRUTH_ANDIF_EXPR
;
2739 code
= TRUTH_ORIF_EXPR
;
2743 /* EQV and NEQV only work on logicals, but since we represent them
2744 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2746 case INTRINSIC_EQ_OS
:
2754 case INTRINSIC_NE_OS
:
2755 case INTRINSIC_NEQV
:
2762 case INTRINSIC_GT_OS
:
2769 case INTRINSIC_GE_OS
:
2776 case INTRINSIC_LT_OS
:
2783 case INTRINSIC_LE_OS
:
2789 case INTRINSIC_USER
:
2790 case INTRINSIC_ASSIGN
:
2791 /* These should be converted into function calls by the frontend. */
2795 fatal_error ("Unknown intrinsic op");
2799 /* The only exception to this is **, which is handled separately anyway. */
2800 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2802 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2806 gfc_init_se (&lse
, se
);
2807 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2808 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2811 gfc_init_se (&rse
, se
);
2812 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2813 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2817 gfc_conv_string_parameter (&lse
);
2818 gfc_conv_string_parameter (&rse
);
2820 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2821 rse
.string_length
, rse
.expr
,
2822 expr
->value
.op
.op1
->ts
.kind
,
2824 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2825 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2828 type
= gfc_typenode_for_spec (&expr
->ts
);
2832 /* The result of logical ops is always boolean_type_node. */
2833 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2834 lse
.expr
, rse
.expr
);
2835 se
->expr
= convert (type
, tmp
);
2838 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2840 /* Add the post blocks. */
2841 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2842 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2845 /* If a string's length is one, we convert it to a single character. */
2848 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2852 || !tree_fits_uhwi_p (len
)
2853 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2856 if (TREE_INT_CST_LOW (len
) == 1)
2858 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2859 return build_fold_indirect_ref_loc (input_location
, str
);
2863 && TREE_CODE (str
) == ADDR_EXPR
2864 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2865 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2866 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2867 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2868 && TREE_INT_CST_LOW (len
) > 1
2869 && TREE_INT_CST_LOW (len
)
2870 == (unsigned HOST_WIDE_INT
)
2871 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2873 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2874 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2875 if (TREE_CODE (ret
) == INTEGER_CST
)
2877 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2878 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2879 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2881 for (i
= 1; i
< length
; i
++)
2894 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2897 if (sym
->backend_decl
)
2899 /* This becomes the nominal_type in
2900 function.c:assign_parm_find_data_types. */
2901 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2902 /* This becomes the passed_type in
2903 function.c:assign_parm_find_data_types. C promotes char to
2904 integer for argument passing. */
2905 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2907 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2912 /* If we have a constant character expression, make it into an
2914 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2919 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2920 (int)(*expr
)->value
.character
.string
[0]);
2921 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2923 /* The expr needs to be compatible with a C int. If the
2924 conversion fails, then the 2 causes an ICE. */
2925 ts
.type
= BT_INTEGER
;
2926 ts
.kind
= gfc_c_int_kind
;
2927 gfc_convert_type (*expr
, &ts
, 2);
2930 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2932 if ((*expr
)->ref
== NULL
)
2934 se
->expr
= gfc_string_to_single_character
2935 (build_int_cst (integer_type_node
, 1),
2936 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2938 ((*expr
)->symtree
->n
.sym
)),
2943 gfc_conv_variable (se
, *expr
);
2944 se
->expr
= gfc_string_to_single_character
2945 (build_int_cst (integer_type_node
, 1),
2946 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2954 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2955 if STR is a string literal, otherwise return -1. */
2958 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2961 && TREE_CODE (str
) == ADDR_EXPR
2962 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2963 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2964 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2965 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2966 && tree_fits_uhwi_p (len
)
2967 && tree_to_uhwi (len
) >= 1
2968 && tree_to_uhwi (len
)
2969 == (unsigned HOST_WIDE_INT
)
2970 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2972 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2973 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2974 if (TREE_CODE (folded
) == INTEGER_CST
)
2976 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2977 int length
= TREE_STRING_LENGTH (string_cst
);
2978 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2980 for (; length
> 0; length
--)
2981 if (ptr
[length
- 1] != ' ')
2990 /* Helper to build a call to memcmp. */
2993 build_memcmp_call (tree s1
, tree s2
, tree n
)
2997 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2998 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3000 s1
= fold_convert (pvoid_type_node
, s1
);
3002 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3003 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3005 s2
= fold_convert (pvoid_type_node
, s2
);
3007 n
= fold_convert (size_type_node
, n
);
3009 tmp
= build_call_expr_loc (input_location
,
3010 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3013 return fold_convert (integer_type_node
, tmp
);
3016 /* Compare two strings. If they are all single characters, the result is the
3017 subtraction of them. Otherwise, we build a library call. */
3020 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3021 enum tree_code code
)
3027 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3028 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3030 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3031 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3033 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3035 /* Deal with single character specially. */
3036 sc1
= fold_convert (integer_type_node
, sc1
);
3037 sc2
= fold_convert (integer_type_node
, sc2
);
3038 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3042 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3044 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3046 /* If one string is a string literal with LEN_TRIM longer
3047 than the length of the second string, the strings
3049 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3050 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3051 return integer_one_node
;
3052 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3053 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3054 return integer_one_node
;
3057 /* We can compare via memcpy if the strings are known to be equal
3058 in length and they are
3060 - kind=4 and the comparison is for (in)equality. */
3062 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3063 && tree_int_cst_equal (len1
, len2
)
3064 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3069 chartype
= gfc_get_char_type (kind
);
3070 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3071 fold_convert (TREE_TYPE(len1
),
3072 TYPE_SIZE_UNIT(chartype
)),
3074 return build_memcmp_call (str1
, str2
, tmp
);
3077 /* Build a call for the comparison. */
3079 fndecl
= gfor_fndecl_compare_string
;
3081 fndecl
= gfor_fndecl_compare_string_char4
;
3085 return build_call_expr_loc (input_location
, fndecl
, 4,
3086 len1
, str1
, len2
, str2
);
3090 /* Return the backend_decl for a procedure pointer component. */
3093 get_proc_ptr_comp (gfc_expr
*e
)
3099 gfc_init_se (&comp_se
, NULL
);
3100 e2
= gfc_copy_expr (e
);
3101 /* We have to restore the expr type later so that gfc_free_expr frees
3102 the exact same thing that was allocated.
3103 TODO: This is ugly. */
3104 old_type
= e2
->expr_type
;
3105 e2
->expr_type
= EXPR_VARIABLE
;
3106 gfc_conv_expr (&comp_se
, e2
);
3107 e2
->expr_type
= old_type
;
3109 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3113 /* Convert a typebound function reference from a class object. */
3115 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3120 if (TREE_CODE (base_object
) != VAR_DECL
)
3122 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3123 gfc_add_modify (&se
->pre
, var
, base_object
);
3125 se
->expr
= gfc_class_vptr_get (base_object
);
3126 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3128 while (ref
&& ref
->next
)
3130 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3131 if (ref
->u
.c
.sym
->attr
.extension
)
3132 conv_parent_component_references (se
, ref
);
3133 gfc_conv_component_ref (se
, ref
);
3134 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3139 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3143 if (gfc_is_proc_ptr_comp (expr
))
3144 tmp
= get_proc_ptr_comp (expr
);
3145 else if (sym
->attr
.dummy
)
3147 tmp
= gfc_get_symbol_decl (sym
);
3148 if (sym
->attr
.proc_pointer
)
3149 tmp
= build_fold_indirect_ref_loc (input_location
,
3151 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3152 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3156 if (!sym
->backend_decl
)
3157 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3159 TREE_USED (sym
->backend_decl
) = 1;
3161 tmp
= sym
->backend_decl
;
3163 if (sym
->attr
.cray_pointee
)
3165 /* TODO - make the cray pointee a pointer to a procedure,
3166 assign the pointer to it and use it for the call. This
3168 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3169 gfc_get_symbol_decl (sym
->cp_pointer
));
3170 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3173 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3175 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3176 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3183 /* Initialize MAPPING. */
3186 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3188 mapping
->syms
= NULL
;
3189 mapping
->charlens
= NULL
;
3193 /* Free all memory held by MAPPING (but not MAPPING itself). */
3196 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3198 gfc_interface_sym_mapping
*sym
;
3199 gfc_interface_sym_mapping
*nextsym
;
3201 gfc_charlen
*nextcl
;
3203 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3205 nextsym
= sym
->next
;
3206 sym
->new_sym
->n
.sym
->formal
= NULL
;
3207 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3208 gfc_free_expr (sym
->expr
);
3209 free (sym
->new_sym
);
3212 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3215 gfc_free_expr (cl
->length
);
3221 /* Return a copy of gfc_charlen CL. Add the returned structure to
3222 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3224 static gfc_charlen
*
3225 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3228 gfc_charlen
*new_charlen
;
3230 new_charlen
= gfc_get_charlen ();
3231 new_charlen
->next
= mapping
->charlens
;
3232 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3234 mapping
->charlens
= new_charlen
;
3239 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3240 array variable that can be used as the actual argument for dummy
3241 argument SYM. Add any initialization code to BLOCK. PACKED is as
3242 for gfc_get_nodesc_array_type and DATA points to the first element
3243 in the passed array. */
3246 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3247 gfc_packed packed
, tree data
)
3252 type
= gfc_typenode_for_spec (&sym
->ts
);
3253 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3254 !sym
->attr
.target
&& !sym
->attr
.pointer
3255 && !sym
->attr
.proc_pointer
);
3257 var
= gfc_create_var (type
, "ifm");
3258 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3264 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3265 and offset of descriptorless array type TYPE given that it has the same
3266 size as DESC. Add any set-up code to BLOCK. */
3269 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3276 offset
= gfc_index_zero_node
;
3277 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3279 dim
= gfc_rank_cst
[n
];
3280 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3281 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3283 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3284 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3285 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3286 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3288 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3290 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3291 gfc_array_index_type
,
3292 gfc_conv_descriptor_ubound_get (desc
, dim
),
3293 gfc_conv_descriptor_lbound_get (desc
, dim
));
3294 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3295 gfc_array_index_type
,
3296 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3297 tmp
= gfc_evaluate_now (tmp
, block
);
3298 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3300 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3301 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3302 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3303 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3304 gfc_array_index_type
, offset
, tmp
);
3306 offset
= gfc_evaluate_now (offset
, block
);
3307 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3311 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3312 in SE. The caller may still use se->expr and se->string_length after
3313 calling this function. */
3316 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3317 gfc_symbol
* sym
, gfc_se
* se
,
3320 gfc_interface_sym_mapping
*sm
;
3324 gfc_symbol
*new_sym
;
3326 gfc_symtree
*new_symtree
;
3328 /* Create a new symbol to represent the actual argument. */
3329 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3330 new_sym
->ts
= sym
->ts
;
3331 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3332 new_sym
->attr
.referenced
= 1;
3333 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3334 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3335 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3336 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3337 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3338 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3339 new_sym
->attr
.function
= sym
->attr
.function
;
3341 /* Ensure that the interface is available and that
3342 descriptors are passed for array actual arguments. */
3343 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3345 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3346 new_sym
->attr
.always_explicit
3347 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3350 /* Create a fake symtree for it. */
3352 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3353 new_symtree
->n
.sym
= new_sym
;
3354 gcc_assert (new_symtree
== root
);
3356 /* Create a dummy->actual mapping. */
3357 sm
= XCNEW (gfc_interface_sym_mapping
);
3358 sm
->next
= mapping
->syms
;
3360 sm
->new_sym
= new_symtree
;
3361 sm
->expr
= gfc_copy_expr (expr
);
3364 /* Stabilize the argument's value. */
3365 if (!sym
->attr
.function
&& se
)
3366 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3368 if (sym
->ts
.type
== BT_CHARACTER
)
3370 /* Create a copy of the dummy argument's length. */
3371 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3372 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3374 /* If the length is specified as "*", record the length that
3375 the caller is passing. We should use the callee's length
3376 in all other cases. */
3377 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3379 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3380 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3387 /* Use the passed value as-is if the argument is a function. */
3388 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3391 /* If the argument is either a string or a pointer to a string,
3392 convert it to a boundless character type. */
3393 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3395 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3396 tmp
= build_pointer_type (tmp
);
3397 if (sym
->attr
.pointer
)
3398 value
= build_fold_indirect_ref_loc (input_location
,
3402 value
= fold_convert (tmp
, value
);
3405 /* If the argument is a scalar, a pointer to an array or an allocatable,
3407 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3408 value
= build_fold_indirect_ref_loc (input_location
,
3411 /* For character(*), use the actual argument's descriptor. */
3412 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3413 value
= build_fold_indirect_ref_loc (input_location
,
3416 /* If the argument is an array descriptor, use it to determine
3417 information about the actual argument's shape. */
3418 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3419 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3421 /* Get the actual argument's descriptor. */
3422 desc
= build_fold_indirect_ref_loc (input_location
,
3425 /* Create the replacement variable. */
3426 tmp
= gfc_conv_descriptor_data_get (desc
);
3427 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3430 /* Use DESC to work out the upper bounds, strides and offset. */
3431 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3434 /* Otherwise we have a packed array. */
3435 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3436 PACKED_FULL
, se
->expr
);
3438 new_sym
->backend_decl
= value
;
3442 /* Called once all dummy argument mappings have been added to MAPPING,
3443 but before the mapping is used to evaluate expressions. Pre-evaluate
3444 the length of each argument, adding any initialization code to PRE and
3445 any finalization code to POST. */
3448 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3449 stmtblock_t
* pre
, stmtblock_t
* post
)
3451 gfc_interface_sym_mapping
*sym
;
3455 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3456 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3457 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3459 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3460 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3461 gfc_init_se (&se
, NULL
);
3462 gfc_conv_expr (&se
, expr
);
3463 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3464 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3465 gfc_add_block_to_block (pre
, &se
.pre
);
3466 gfc_add_block_to_block (post
, &se
.post
);
3468 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3473 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3477 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3478 gfc_constructor_base base
)
3481 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3483 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3486 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3487 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3488 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3494 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3498 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3503 for (; ref
; ref
= ref
->next
)
3507 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3509 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3510 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3511 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3519 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3520 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3526 /* Convert intrinsic function calls into result expressions. */
3529 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3537 arg1
= expr
->value
.function
.actual
->expr
;
3538 if (expr
->value
.function
.actual
->next
)
3539 arg2
= expr
->value
.function
.actual
->next
->expr
;
3543 sym
= arg1
->symtree
->n
.sym
;
3545 if (sym
->attr
.dummy
)
3550 switch (expr
->value
.function
.isym
->id
)
3553 /* TODO figure out why this condition is necessary. */
3554 if (sym
->attr
.function
3555 && (arg1
->ts
.u
.cl
->length
== NULL
3556 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3557 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3560 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3564 if (!sym
->as
|| sym
->as
->rank
== 0)
3567 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3569 dup
= mpz_get_si (arg2
->value
.integer
);
3574 dup
= sym
->as
->rank
;
3578 for (; d
< dup
; d
++)
3582 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3584 gfc_free_expr (new_expr
);
3588 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3589 gfc_get_int_expr (gfc_default_integer_kind
,
3591 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3593 new_expr
= gfc_multiply (new_expr
, tmp
);
3599 case GFC_ISYM_LBOUND
:
3600 case GFC_ISYM_UBOUND
:
3601 /* TODO These implementations of lbound and ubound do not limit if
3602 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3604 if (!sym
->as
|| sym
->as
->rank
== 0)
3607 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3608 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3610 /* TODO: If the need arises, this could produce an array of
3614 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3616 if (sym
->as
->lower
[d
])
3617 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3621 if (sym
->as
->upper
[d
])
3622 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3630 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3634 gfc_replace_expr (expr
, new_expr
);
3640 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3641 gfc_interface_mapping
* mapping
)
3643 gfc_formal_arglist
*f
;
3644 gfc_actual_arglist
*actual
;
3646 actual
= expr
->value
.function
.actual
;
3647 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3649 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3654 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3657 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3662 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3664 for (d
= 0; d
< as
->rank
; d
++)
3666 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3667 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3670 expr
->value
.function
.esym
->as
= as
;
3673 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3675 expr
->value
.function
.esym
->ts
.u
.cl
->length
3676 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3678 gfc_apply_interface_mapping_to_expr (mapping
,
3679 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3684 /* EXPR is a copy of an expression that appeared in the interface
3685 associated with MAPPING. Walk it recursively looking for references to
3686 dummy arguments that MAPPING maps to actual arguments. Replace each such
3687 reference with a reference to the associated actual argument. */
3690 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3693 gfc_interface_sym_mapping
*sym
;
3694 gfc_actual_arglist
*actual
;
3699 /* Copying an expression does not copy its length, so do that here. */
3700 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3702 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3703 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3706 /* Apply the mapping to any references. */
3707 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3709 /* ...and to the expression's symbol, if it has one. */
3710 /* TODO Find out why the condition on expr->symtree had to be moved into
3711 the loop rather than being outside it, as originally. */
3712 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3713 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3715 if (sym
->new_sym
->n
.sym
->backend_decl
)
3716 expr
->symtree
= sym
->new_sym
;
3718 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3719 /* Replace base type for polymorphic arguments. */
3720 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3721 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3722 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3725 /* ...and to subexpressions in expr->value. */
3726 switch (expr
->expr_type
)
3731 case EXPR_SUBSTRING
:
3735 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3736 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3740 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3741 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3743 if (expr
->value
.function
.esym
== NULL
3744 && expr
->value
.function
.isym
!= NULL
3745 && expr
->value
.function
.actual
->expr
->symtree
3746 && gfc_map_intrinsic_function (expr
, mapping
))
3749 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3750 if (sym
->old
== expr
->value
.function
.esym
)
3752 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3753 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3754 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3759 case EXPR_STRUCTURE
:
3760 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3773 /* Evaluate interface expression EXPR using MAPPING. Store the result
3777 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3778 gfc_se
* se
, gfc_expr
* expr
)
3780 expr
= gfc_copy_expr (expr
);
3781 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3782 gfc_conv_expr (se
, expr
);
3783 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3784 gfc_free_expr (expr
);
3788 /* Returns a reference to a temporary array into which a component of
3789 an actual argument derived type array is copied and then returned
3790 after the function call. */
3792 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3793 sym_intent intent
, bool formal_ptr
)
3801 gfc_array_info
*info
;
3811 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3813 gfc_init_se (&lse
, NULL
);
3814 gfc_init_se (&rse
, NULL
);
3816 /* Walk the argument expression. */
3817 rss
= gfc_walk_expr (expr
);
3819 gcc_assert (rss
!= gfc_ss_terminator
);
3821 /* Initialize the scalarizer. */
3822 gfc_init_loopinfo (&loop
);
3823 gfc_add_ss_to_loop (&loop
, rss
);
3825 /* Calculate the bounds of the scalarization. */
3826 gfc_conv_ss_startstride (&loop
);
3828 /* Build an ss for the temporary. */
3829 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3830 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3832 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3833 if (GFC_ARRAY_TYPE_P (base_type
)
3834 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3835 base_type
= gfc_get_element_type (base_type
);
3837 if (expr
->ts
.type
== BT_CLASS
)
3838 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3840 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3841 ? expr
->ts
.u
.cl
->backend_decl
3845 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3847 /* Associate the SS with the loop. */
3848 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3850 /* Setup the scalarizing loops. */
3851 gfc_conv_loop_setup (&loop
, &expr
->where
);
3853 /* Pass the temporary descriptor back to the caller. */
3854 info
= &loop
.temp_ss
->info
->data
.array
;
3855 parmse
->expr
= info
->descriptor
;
3857 /* Setup the gfc_se structures. */
3858 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3859 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3862 lse
.ss
= loop
.temp_ss
;
3863 gfc_mark_ss_chain_used (rss
, 1);
3864 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3866 /* Start the scalarized loop body. */
3867 gfc_start_scalarized_body (&loop
, &body
);
3869 /* Translate the expression. */
3870 gfc_conv_expr (&rse
, expr
);
3872 gfc_conv_tmp_array_ref (&lse
);
3874 if (intent
!= INTENT_OUT
)
3876 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3877 gfc_add_expr_to_block (&body
, tmp
);
3878 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3879 gfc_trans_scalarizing_loops (&loop
, &body
);
3883 /* Make sure that the temporary declaration survives by merging
3884 all the loop declarations into the current context. */
3885 for (n
= 0; n
< loop
.dimen
; n
++)
3887 gfc_merge_block_scope (&body
);
3888 body
= loop
.code
[loop
.order
[n
]];
3890 gfc_merge_block_scope (&body
);
3893 /* Add the post block after the second loop, so that any
3894 freeing of allocated memory is done at the right time. */
3895 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3897 /**********Copy the temporary back again.*********/
3899 gfc_init_se (&lse
, NULL
);
3900 gfc_init_se (&rse
, NULL
);
3902 /* Walk the argument expression. */
3903 lss
= gfc_walk_expr (expr
);
3904 rse
.ss
= loop
.temp_ss
;
3907 /* Initialize the scalarizer. */
3908 gfc_init_loopinfo (&loop2
);
3909 gfc_add_ss_to_loop (&loop2
, lss
);
3911 /* Calculate the bounds of the scalarization. */
3912 gfc_conv_ss_startstride (&loop2
);
3914 /* Setup the scalarizing loops. */
3915 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3917 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3918 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3920 gfc_mark_ss_chain_used (lss
, 1);
3921 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3923 /* Declare the variable to hold the temporary offset and start the
3924 scalarized loop body. */
3925 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3926 gfc_start_scalarized_body (&loop2
, &body
);
3928 /* Build the offsets for the temporary from the loop variables. The
3929 temporary array has lbounds of zero and strides of one in all
3930 dimensions, so this is very simple. The offset is only computed
3931 outside the innermost loop, so the overall transfer could be
3932 optimized further. */
3933 info
= &rse
.ss
->info
->data
.array
;
3934 dimen
= rse
.ss
->dimen
;
3936 tmp_index
= gfc_index_zero_node
;
3937 for (n
= dimen
- 1; n
> 0; n
--)
3940 tmp
= rse
.loop
->loopvar
[n
];
3941 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3942 tmp
, rse
.loop
->from
[n
]);
3943 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3946 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3947 gfc_array_index_type
,
3948 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3949 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3950 gfc_array_index_type
,
3951 tmp_str
, gfc_index_one_node
);
3953 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3954 gfc_array_index_type
, tmp
, tmp_str
);
3957 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3958 gfc_array_index_type
,
3959 tmp_index
, rse
.loop
->from
[0]);
3960 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3962 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3963 gfc_array_index_type
,
3964 rse
.loop
->loopvar
[0], offset
);
3966 /* Now use the offset for the reference. */
3967 tmp
= build_fold_indirect_ref_loc (input_location
,
3969 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3971 if (expr
->ts
.type
== BT_CHARACTER
)
3972 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3974 gfc_conv_expr (&lse
, expr
);
3976 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3978 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3979 gfc_add_expr_to_block (&body
, tmp
);
3981 /* Generate the copying loops. */
3982 gfc_trans_scalarizing_loops (&loop2
, &body
);
3984 /* Wrap the whole thing up by adding the second loop to the post-block
3985 and following it by the post-block of the first loop. In this way,
3986 if the temporary needs freeing, it is done after use! */
3987 if (intent
!= INTENT_IN
)
3989 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3990 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3993 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3995 gfc_cleanup_loop (&loop
);
3996 gfc_cleanup_loop (&loop2
);
3998 /* Pass the string length to the argument expression. */
3999 if (expr
->ts
.type
== BT_CHARACTER
)
4000 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4002 /* Determine the offset for pointer formal arguments and set the
4006 size
= gfc_index_one_node
;
4007 offset
= gfc_index_zero_node
;
4008 for (n
= 0; n
< dimen
; n
++)
4010 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4012 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4013 gfc_array_index_type
, tmp
,
4014 gfc_index_one_node
);
4015 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4019 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4022 gfc_index_one_node
);
4023 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4024 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4025 gfc_array_index_type
,
4027 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4028 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4029 gfc_array_index_type
,
4030 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4031 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4032 gfc_array_index_type
,
4033 tmp
, gfc_index_one_node
);
4034 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4035 gfc_array_index_type
, size
, tmp
);
4038 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4042 /* We want either the address for the data or the address of the descriptor,
4043 depending on the mode of passing array arguments. */
4045 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4047 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4053 /* Generate the code for argument list functions. */
4056 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4058 /* Pass by value for g77 %VAL(arg), pass the address
4059 indirectly for %LOC, else by reference. Thus %REF
4060 is a "do-nothing" and %LOC is the same as an F95
4062 if (strncmp (name
, "%VAL", 4) == 0)
4063 gfc_conv_expr (se
, expr
);
4064 else if (strncmp (name
, "%LOC", 4) == 0)
4066 gfc_conv_expr_reference (se
, expr
);
4067 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4069 else if (strncmp (name
, "%REF", 4) == 0)
4070 gfc_conv_expr_reference (se
, expr
);
4072 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4076 /* Generate code for a procedure call. Note can return se->post != NULL.
4077 If se->direct_byref is set then se->expr contains the return parameter.
4078 Return nonzero, if the call has alternate specifiers.
4079 'expr' is only needed for procedure pointer components. */
4082 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4083 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4084 vec
<tree
, va_gc
> *append_args
)
4086 gfc_interface_mapping mapping
;
4087 vec
<tree
, va_gc
> *arglist
;
4088 vec
<tree
, va_gc
> *retargs
;
4092 gfc_array_info
*info
;
4099 vec
<tree
, va_gc
> *stringargs
;
4100 vec
<tree
, va_gc
> *optionalargs
;
4102 gfc_formal_arglist
*formal
;
4103 gfc_actual_arglist
*arg
;
4104 int has_alternate_specifier
= 0;
4105 bool need_interface_mapping
;
4112 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4113 gfc_component
*comp
= NULL
;
4119 optionalargs
= NULL
;
4124 comp
= gfc_get_proc_ptr_comp (expr
);
4128 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4130 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4131 if (se
->ss
->info
->useflags
)
4133 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4134 && sym
->result
->attr
.dimension
)
4135 || (comp
&& comp
->attr
.dimension
));
4136 gcc_assert (se
->loop
!= NULL
);
4138 /* Access the previously obtained result. */
4139 gfc_conv_tmp_array_ref (se
);
4143 info
= &se
->ss
->info
->data
.array
;
4148 gfc_init_block (&post
);
4149 gfc_init_interface_mapping (&mapping
);
4152 formal
= gfc_sym_get_dummy_args (sym
);
4153 need_interface_mapping
= sym
->attr
.dimension
||
4154 (sym
->ts
.type
== BT_CHARACTER
4155 && sym
->ts
.u
.cl
->length
4156 && sym
->ts
.u
.cl
->length
->expr_type
4161 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4162 need_interface_mapping
= comp
->attr
.dimension
||
4163 (comp
->ts
.type
== BT_CHARACTER
4164 && comp
->ts
.u
.cl
->length
4165 && comp
->ts
.u
.cl
->length
->expr_type
4169 base_object
= NULL_TREE
;
4171 /* Evaluate the arguments. */
4172 for (arg
= args
; arg
!= NULL
;
4173 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4176 fsym
= formal
? formal
->sym
: NULL
;
4177 parm_kind
= MISSING
;
4179 /* Class array expressions are sometimes coming completely unadorned
4180 with either arrayspec or _data component. Correct that here.
4181 OOP-TODO: Move this to the frontend. */
4182 if (e
&& e
->expr_type
== EXPR_VARIABLE
4184 && e
->ts
.type
== BT_CLASS
4185 && (CLASS_DATA (e
)->attr
.codimension
4186 || CLASS_DATA (e
)->attr
.dimension
))
4188 gfc_typespec temp_ts
= e
->ts
;
4189 gfc_add_class_array_ref (e
);
4195 if (se
->ignore_optional
)
4197 /* Some intrinsics have already been resolved to the correct
4201 else if (arg
->label
)
4203 has_alternate_specifier
= 1;
4208 gfc_init_se (&parmse
, NULL
);
4210 /* For scalar arguments with VALUE attribute which are passed by
4211 value, pass "0" and a hidden argument gives the optional
4213 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4214 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4215 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4217 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4219 vec_safe_push (optionalargs
, boolean_false_node
);
4223 /* Pass a NULL pointer for an absent arg. */
4224 parmse
.expr
= null_pointer_node
;
4225 if (arg
->missing_arg_type
== BT_CHARACTER
)
4226 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4231 else if (arg
->expr
->expr_type
== EXPR_NULL
4232 && fsym
&& !fsym
->attr
.pointer
4233 && (fsym
->ts
.type
!= BT_CLASS
4234 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4236 /* Pass a NULL pointer to denote an absent arg. */
4237 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4238 && (fsym
->ts
.type
!= BT_CLASS
4239 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4240 gfc_init_se (&parmse
, NULL
);
4241 parmse
.expr
= null_pointer_node
;
4242 if (arg
->missing_arg_type
== BT_CHARACTER
)
4243 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4245 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4246 && e
->ts
.type
== BT_DERIVED
)
4248 /* The derived type needs to be converted to a temporary
4250 gfc_init_se (&parmse
, se
);
4251 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4253 && e
->expr_type
== EXPR_VARIABLE
4254 && e
->symtree
->n
.sym
->attr
.optional
,
4255 CLASS_DATA (fsym
)->attr
.class_pointer
4256 || CLASS_DATA (fsym
)->attr
.allocatable
);
4258 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4260 /* The intrinsic type needs to be converted to a temporary
4261 CLASS object for the unlimited polymorphic formal. */
4262 gfc_init_se (&parmse
, se
);
4263 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4265 else if (se
->ss
&& se
->ss
->info
->useflags
)
4271 /* An elemental function inside a scalarized loop. */
4272 gfc_init_se (&parmse
, se
);
4273 parm_kind
= ELEMENTAL
;
4275 if (fsym
&& fsym
->attr
.value
)
4276 gfc_conv_expr (&parmse
, e
);
4278 gfc_conv_expr_reference (&parmse
, e
);
4280 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4281 && e
->expr_type
== EXPR_FUNCTION
)
4282 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4285 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4286 && gfc_is_class_container_ref (e
))
4288 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4290 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4291 && e
->symtree
->n
.sym
->attr
.optional
)
4293 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4294 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4295 TREE_TYPE (parmse
.expr
),
4297 fold_convert (TREE_TYPE (parmse
.expr
),
4298 null_pointer_node
));
4302 /* If we are passing an absent array as optional dummy to an
4303 elemental procedure, make sure that we pass NULL when the data
4304 pointer is NULL. We need this extra conditional because of
4305 scalarization which passes arrays elements to the procedure,
4306 ignoring the fact that the array can be absent/unallocated/... */
4307 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4309 tree descriptor_data
;
4311 descriptor_data
= ss
->info
->data
.array
.data
;
4312 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4314 fold_convert (TREE_TYPE (descriptor_data
),
4315 null_pointer_node
));
4317 = fold_build3_loc (input_location
, COND_EXPR
,
4318 TREE_TYPE (parmse
.expr
),
4319 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4320 fold_convert (TREE_TYPE (parmse
.expr
),
4325 /* The scalarizer does not repackage the reference to a class
4326 array - instead it returns a pointer to the data element. */
4327 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4328 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4329 fsym
->attr
.intent
!= INTENT_IN
4330 && (CLASS_DATA (fsym
)->attr
.class_pointer
4331 || CLASS_DATA (fsym
)->attr
.allocatable
),
4333 && e
->expr_type
== EXPR_VARIABLE
4334 && e
->symtree
->n
.sym
->attr
.optional
,
4335 CLASS_DATA (fsym
)->attr
.class_pointer
4336 || CLASS_DATA (fsym
)->attr
.allocatable
);
4343 gfc_init_se (&parmse
, NULL
);
4345 /* Check whether the expression is a scalar or not; we cannot use
4346 e->rank as it can be nonzero for functions arguments. */
4347 argss
= gfc_walk_expr (e
);
4348 scalar
= argss
== gfc_ss_terminator
;
4350 gfc_free_ss_chain (argss
);
4352 /* Special handling for passing scalar polymorphic coarrays;
4353 otherwise one passes "class->_data.data" instead of "&class". */
4354 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4355 && fsym
&& fsym
->ts
.type
== BT_CLASS
4356 && CLASS_DATA (fsym
)->attr
.codimension
4357 && !CLASS_DATA (fsym
)->attr
.dimension
)
4359 gfc_add_class_array_ref (e
);
4360 parmse
.want_coarray
= 1;
4364 /* A scalar or transformational function. */
4367 if (e
->expr_type
== EXPR_VARIABLE
4368 && e
->symtree
->n
.sym
->attr
.cray_pointee
4369 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4371 /* The Cray pointer needs to be converted to a pointer to
4372 a type given by the expression. */
4373 gfc_conv_expr (&parmse
, e
);
4374 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4375 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4376 parmse
.expr
= convert (type
, tmp
);
4378 else if (fsym
&& fsym
->attr
.value
)
4380 if (fsym
->ts
.type
== BT_CHARACTER
4381 && fsym
->ts
.is_c_interop
4382 && fsym
->ns
->proc_name
!= NULL
4383 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4386 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4387 if (parmse
.expr
== NULL
)
4388 gfc_conv_expr (&parmse
, e
);
4392 gfc_conv_expr (&parmse
, e
);
4393 if (fsym
->attr
.optional
4394 && fsym
->ts
.type
!= BT_CLASS
4395 && fsym
->ts
.type
!= BT_DERIVED
)
4397 if (e
->expr_type
!= EXPR_VARIABLE
4398 || !e
->symtree
->n
.sym
->attr
.optional
4400 vec_safe_push (optionalargs
, boolean_true_node
);
4403 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4404 if (!e
->symtree
->n
.sym
->attr
.value
)
4406 = fold_build3_loc (input_location
, COND_EXPR
,
4407 TREE_TYPE (parmse
.expr
),
4409 fold_convert (TREE_TYPE (parmse
.expr
),
4410 integer_zero_node
));
4412 vec_safe_push (optionalargs
, tmp
);
4417 else if (arg
->name
&& arg
->name
[0] == '%')
4418 /* Argument list functions %VAL, %LOC and %REF are signalled
4419 through arg->name. */
4420 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4421 else if ((e
->expr_type
== EXPR_FUNCTION
)
4422 && ((e
->value
.function
.esym
4423 && e
->value
.function
.esym
->result
->attr
.pointer
)
4424 || (!e
->value
.function
.esym
4425 && e
->symtree
->n
.sym
->attr
.pointer
))
4426 && fsym
&& fsym
->attr
.target
)
4428 gfc_conv_expr (&parmse
, e
);
4429 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4431 else if (e
->expr_type
== EXPR_FUNCTION
4432 && e
->symtree
->n
.sym
->result
4433 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4434 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4436 /* Functions returning procedure pointers. */
4437 gfc_conv_expr (&parmse
, e
);
4438 if (fsym
&& fsym
->attr
.proc_pointer
)
4439 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4443 if (e
->ts
.type
== BT_CLASS
&& fsym
4444 && fsym
->ts
.type
== BT_CLASS
4445 && (!CLASS_DATA (fsym
)->as
4446 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4447 && CLASS_DATA (e
)->attr
.codimension
)
4449 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4450 gcc_assert (!CLASS_DATA (fsym
)->as
);
4451 gfc_add_class_array_ref (e
);
4452 parmse
.want_coarray
= 1;
4453 gfc_conv_expr_reference (&parmse
, e
);
4454 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4456 && e
->expr_type
== EXPR_VARIABLE
);
4458 else if (e
->ts
.type
== BT_CLASS
&& fsym
4459 && fsym
->ts
.type
== BT_CLASS
4460 && !CLASS_DATA (fsym
)->as
4461 && !CLASS_DATA (e
)->as
4462 && (CLASS_DATA (fsym
)->attr
.class_pointer
4463 != CLASS_DATA (e
)->attr
.class_pointer
4464 || CLASS_DATA (fsym
)->attr
.allocatable
4465 != CLASS_DATA (e
)->attr
.allocatable
))
4467 type
= gfc_typenode_for_spec (&fsym
->ts
);
4468 var
= gfc_create_var (type
, fsym
->name
);
4469 gfc_conv_expr (&parmse
, e
);
4470 if (fsym
->attr
.optional
4471 && e
->expr_type
== EXPR_VARIABLE
4472 && e
->symtree
->n
.sym
->attr
.optional
)
4476 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4477 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4478 boolean_type_node
, tmp
,
4479 fold_convert (TREE_TYPE (tmp
),
4480 null_pointer_node
));
4481 gfc_start_block (&block
);
4482 gfc_add_modify (&block
, var
,
4483 fold_build1_loc (input_location
,
4485 type
, parmse
.expr
));
4486 gfc_add_expr_to_block (&parmse
.pre
,
4487 fold_build3_loc (input_location
,
4488 COND_EXPR
, void_type_node
,
4489 cond
, gfc_finish_block (&block
),
4490 build_empty_stmt (input_location
)));
4491 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4492 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4493 TREE_TYPE (parmse
.expr
),
4495 fold_convert (TREE_TYPE (parmse
.expr
),
4496 null_pointer_node
));
4500 gfc_add_modify (&parmse
.pre
, var
,
4501 fold_build1_loc (input_location
,
4503 type
, parmse
.expr
));
4504 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4508 gfc_conv_expr_reference (&parmse
, e
);
4510 /* Catch base objects that are not variables. */
4511 if (e
->ts
.type
== BT_CLASS
4512 && e
->expr_type
!= EXPR_VARIABLE
4513 && expr
&& e
== expr
->base_expr
)
4514 base_object
= build_fold_indirect_ref_loc (input_location
,
4517 /* A class array element needs converting back to be a
4518 class object, if the formal argument is a class object. */
4519 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4520 && e
->ts
.type
== BT_CLASS
4521 && ((CLASS_DATA (fsym
)->as
4522 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4523 || CLASS_DATA (e
)->attr
.dimension
))
4524 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4525 fsym
->attr
.intent
!= INTENT_IN
4526 && (CLASS_DATA (fsym
)->attr
.class_pointer
4527 || CLASS_DATA (fsym
)->attr
.allocatable
),
4529 && e
->expr_type
== EXPR_VARIABLE
4530 && e
->symtree
->n
.sym
->attr
.optional
,
4531 CLASS_DATA (fsym
)->attr
.class_pointer
4532 || CLASS_DATA (fsym
)->attr
.allocatable
);
4534 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4535 allocated on entry, it must be deallocated. */
4536 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4537 && (fsym
->attr
.allocatable
4538 || (fsym
->ts
.type
== BT_CLASS
4539 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4544 gfc_init_block (&block
);
4546 if (e
->ts
.type
== BT_CLASS
)
4547 ptr
= gfc_class_data_get (ptr
);
4549 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4551 gfc_add_expr_to_block (&block
, tmp
);
4552 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4553 void_type_node
, ptr
,
4555 gfc_add_expr_to_block (&block
, tmp
);
4557 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4559 gfc_add_modify (&block
, ptr
,
4560 fold_convert (TREE_TYPE (ptr
),
4561 null_pointer_node
));
4562 gfc_add_expr_to_block (&block
, tmp
);
4564 else if (fsym
->ts
.type
== BT_CLASS
)
4567 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4568 tmp
= gfc_get_symbol_decl (vtab
);
4569 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4570 ptr
= gfc_class_vptr_get (parmse
.expr
);
4571 gfc_add_modify (&block
, ptr
,
4572 fold_convert (TREE_TYPE (ptr
), tmp
));
4573 gfc_add_expr_to_block (&block
, tmp
);
4576 if (fsym
->attr
.optional
4577 && e
->expr_type
== EXPR_VARIABLE
4578 && e
->symtree
->n
.sym
->attr
.optional
)
4580 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4582 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4583 gfc_finish_block (&block
),
4584 build_empty_stmt (input_location
));
4587 tmp
= gfc_finish_block (&block
);
4589 gfc_add_expr_to_block (&se
->pre
, tmp
);
4592 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4593 || fsym
->ts
.type
== BT_ASSUMED
)
4594 && e
->ts
.type
== BT_CLASS
4595 && !CLASS_DATA (e
)->attr
.dimension
4596 && !CLASS_DATA (e
)->attr
.codimension
)
4597 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4599 /* Wrap scalar variable in a descriptor. We need to convert
4600 the address of a pointer back to the pointer itself before,
4601 we can assign it to the data field. */
4603 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4604 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4607 if (TREE_CODE (tmp
) == ADDR_EXPR
4608 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4609 tmp
= TREE_OPERAND (tmp
, 0);
4610 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4612 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4615 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4616 && ((fsym
->attr
.pointer
4617 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4618 || (fsym
->attr
.proc_pointer
4619 && !(e
->expr_type
== EXPR_VARIABLE
4620 && e
->symtree
->n
.sym
->attr
.dummy
))
4621 || (fsym
->attr
.proc_pointer
4622 && e
->expr_type
== EXPR_VARIABLE
4623 && gfc_is_proc_ptr_comp (e
))
4624 || (fsym
->attr
.allocatable
4625 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4627 /* Scalar pointer dummy args require an extra level of
4628 indirection. The null pointer already contains
4629 this level of indirection. */
4630 parm_kind
= SCALAR_POINTER
;
4631 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4635 else if (e
->ts
.type
== BT_CLASS
4636 && fsym
&& fsym
->ts
.type
== BT_CLASS
4637 && (CLASS_DATA (fsym
)->attr
.dimension
4638 || CLASS_DATA (fsym
)->attr
.codimension
))
4640 /* Pass a class array. */
4641 parmse
.use_offset
= 1;
4642 gfc_conv_expr_descriptor (&parmse
, e
);
4644 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4645 allocated on entry, it must be deallocated. */
4646 if (fsym
->attr
.intent
== INTENT_OUT
4647 && CLASS_DATA (fsym
)->attr
.allocatable
)
4652 gfc_init_block (&block
);
4654 ptr
= gfc_class_data_get (ptr
);
4656 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4657 NULL_TREE
, NULL_TREE
,
4660 gfc_add_expr_to_block (&block
, tmp
);
4661 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4662 void_type_node
, ptr
,
4664 gfc_add_expr_to_block (&block
, tmp
);
4665 gfc_reset_vptr (&block
, e
);
4667 if (fsym
->attr
.optional
4668 && e
->expr_type
== EXPR_VARIABLE
4670 || (e
->ref
->type
== REF_ARRAY
4671 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4672 && e
->symtree
->n
.sym
->attr
.optional
)
4674 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4676 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4677 gfc_finish_block (&block
),
4678 build_empty_stmt (input_location
));
4681 tmp
= gfc_finish_block (&block
);
4683 gfc_add_expr_to_block (&se
->pre
, tmp
);
4686 /* The conversion does not repackage the reference to a class
4687 array - _data descriptor. */
4688 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4689 fsym
->attr
.intent
!= INTENT_IN
4690 && (CLASS_DATA (fsym
)->attr
.class_pointer
4691 || CLASS_DATA (fsym
)->attr
.allocatable
),
4693 && e
->expr_type
== EXPR_VARIABLE
4694 && e
->symtree
->n
.sym
->attr
.optional
,
4695 CLASS_DATA (fsym
)->attr
.class_pointer
4696 || CLASS_DATA (fsym
)->attr
.allocatable
);
4700 /* If the procedure requires an explicit interface, the actual
4701 argument is passed according to the corresponding formal
4702 argument. If the corresponding formal argument is a POINTER,
4703 ALLOCATABLE or assumed shape, we do not use g77's calling
4704 convention, and pass the address of the array descriptor
4705 instead. Otherwise we use g77's calling convention. */
4708 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4709 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4710 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4712 f
= f
|| !comp
->attr
.always_explicit
;
4714 f
= f
|| !sym
->attr
.always_explicit
;
4716 /* If the argument is a function call that may not create
4717 a temporary for the result, we have to check that we
4718 can do it, i.e. that there is no alias between this
4719 argument and another one. */
4720 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4726 intent
= fsym
->attr
.intent
;
4728 intent
= INTENT_UNKNOWN
;
4730 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4732 parmse
.force_tmp
= 1;
4734 iarg
= e
->value
.function
.actual
->expr
;
4736 /* Temporary needed if aliasing due to host association. */
4737 if (sym
->attr
.contained
4739 && !sym
->attr
.implicit_pure
4740 && !sym
->attr
.use_assoc
4741 && iarg
->expr_type
== EXPR_VARIABLE
4742 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4743 parmse
.force_tmp
= 1;
4745 /* Ditto within module. */
4746 if (sym
->attr
.use_assoc
4748 && !sym
->attr
.implicit_pure
4749 && iarg
->expr_type
== EXPR_VARIABLE
4750 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4751 parmse
.force_tmp
= 1;
4754 if (e
->expr_type
== EXPR_VARIABLE
4755 && is_subref_array (e
))
4756 /* The actual argument is a component reference to an
4757 array of derived types. In this case, the argument
4758 is converted to a temporary, which is passed and then
4759 written back after the procedure call. */
4760 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4761 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4762 fsym
&& fsym
->attr
.pointer
);
4763 else if (gfc_is_class_array_ref (e
, NULL
)
4764 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4765 /* The actual argument is a component reference to an
4766 array of derived types. In this case, the argument
4767 is converted to a temporary, which is passed and then
4768 written back after the procedure call.
4769 OOP-TODO: Insert code so that if the dynamic type is
4770 the same as the declared type, copy-in/copy-out does
4772 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4773 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4774 fsym
&& fsym
->attr
.pointer
);
4776 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4778 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4779 allocated on entry, it must be deallocated. */
4780 if (fsym
&& fsym
->attr
.allocatable
4781 && fsym
->attr
.intent
== INTENT_OUT
)
4783 tmp
= build_fold_indirect_ref_loc (input_location
,
4785 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4786 if (fsym
->attr
.optional
4787 && e
->expr_type
== EXPR_VARIABLE
4788 && e
->symtree
->n
.sym
->attr
.optional
)
4789 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4791 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4792 tmp
, build_empty_stmt (input_location
));
4793 gfc_add_expr_to_block (&se
->pre
, tmp
);
4798 /* The case with fsym->attr.optional is that of a user subroutine
4799 with an interface indicating an optional argument. When we call
4800 an intrinsic subroutine, however, fsym is NULL, but we might still
4801 have an optional argument, so we proceed to the substitution
4803 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4805 /* If an optional argument is itself an optional dummy argument,
4806 check its presence and substitute a null if absent. This is
4807 only needed when passing an array to an elemental procedure
4808 as then array elements are accessed - or no NULL pointer is
4809 allowed and a "1" or "0" should be passed if not present.
4810 When passing a non-array-descriptor full array to a
4811 non-array-descriptor dummy, no check is needed. For
4812 array-descriptor actual to array-descriptor dummy, see
4813 PR 41911 for why a check has to be inserted.
4814 fsym == NULL is checked as intrinsics required the descriptor
4815 but do not always set fsym. */
4816 if (e
->expr_type
== EXPR_VARIABLE
4817 && e
->symtree
->n
.sym
->attr
.optional
4818 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4819 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4823 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4824 || fsym
->as
->type
== AS_ASSUMED_RANK
4825 || fsym
->as
->type
== AS_DEFERRED
))))))
4826 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4827 e
->representation
.length
);
4832 /* Obtain the character length of an assumed character length
4833 length procedure from the typespec. */
4834 if (fsym
->ts
.type
== BT_CHARACTER
4835 && parmse
.string_length
== NULL_TREE
4836 && e
->ts
.type
== BT_PROCEDURE
4837 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4838 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4839 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4841 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4842 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4846 if (fsym
&& need_interface_mapping
&& e
)
4847 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4849 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4850 gfc_add_block_to_block (&post
, &parmse
.post
);
4852 /* Allocated allocatable components of derived types must be
4853 deallocated for non-variable scalars. Non-variable arrays are
4854 dealt with in trans-array.c(gfc_conv_array_parameter). */
4855 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4856 && e
->ts
.u
.derived
->attr
.alloc_comp
4857 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4858 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4861 tmp
= build_fold_indirect_ref_loc (input_location
,
4863 parm_rank
= e
->rank
;
4871 case (SCALAR_POINTER
):
4872 tmp
= build_fold_indirect_ref_loc (input_location
,
4877 if (e
->expr_type
== EXPR_OP
4878 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4879 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4882 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4883 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4884 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4887 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4889 /* The derived type is passed to gfc_deallocate_alloc_comp.
4890 Therefore, class actuals can handled correctly but derived
4891 types passed to class formals need the _data component. */
4892 tmp
= gfc_class_data_get (tmp
);
4893 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4894 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4897 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4899 gfc_add_expr_to_block (&se
->post
, tmp
);
4902 /* Add argument checking of passing an unallocated/NULL actual to
4903 a nonallocatable/nonpointer dummy. */
4905 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4907 symbol_attribute attr
;
4911 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4912 attr
= gfc_expr_attr (e
);
4914 goto end_pointer_check
;
4916 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4917 allocatable to an optional dummy, cf. 12.5.2.12. */
4918 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4919 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4920 goto end_pointer_check
;
4924 /* If the actual argument is an optional pointer/allocatable and
4925 the formal argument takes an nonpointer optional value,
4926 it is invalid to pass a non-present argument on, even
4927 though there is no technical reason for this in gfortran.
4928 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4929 tree present
, null_ptr
, type
;
4931 if (attr
.allocatable
4932 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4933 msg
= xasprintf ("Allocatable actual argument '%s' is not "
4934 "allocated or not present",
4935 e
->symtree
->n
.sym
->name
);
4936 else if (attr
.pointer
4937 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4938 msg
= xasprintf ("Pointer actual argument '%s' is not "
4939 "associated or not present",
4940 e
->symtree
->n
.sym
->name
);
4941 else if (attr
.proc_pointer
4942 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4943 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
4944 "associated or not present",
4945 e
->symtree
->n
.sym
->name
);
4947 goto end_pointer_check
;
4949 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4950 type
= TREE_TYPE (present
);
4951 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4952 boolean_type_node
, present
,
4954 null_pointer_node
));
4955 type
= TREE_TYPE (parmse
.expr
);
4956 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4957 boolean_type_node
, parmse
.expr
,
4959 null_pointer_node
));
4960 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4961 boolean_type_node
, present
, null_ptr
);
4965 if (attr
.allocatable
4966 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4967 msg
= xasprintf ("Allocatable actual argument '%s' is not "
4968 "allocated", e
->symtree
->n
.sym
->name
);
4969 else if (attr
.pointer
4970 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4971 msg
= xasprintf ("Pointer actual argument '%s' is not "
4972 "associated", e
->symtree
->n
.sym
->name
);
4973 else if (attr
.proc_pointer
4974 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4975 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
4976 "associated", e
->symtree
->n
.sym
->name
);
4978 goto end_pointer_check
;
4982 /* If the argument is passed by value, we need to strip the
4984 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4985 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4987 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4988 boolean_type_node
, tmp
,
4989 fold_convert (TREE_TYPE (tmp
),
4990 null_pointer_node
));
4993 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4999 /* Deferred length dummies pass the character length by reference
5000 so that the value can be returned. */
5001 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5003 tmp
= parmse
.string_length
;
5004 if (TREE_CODE (tmp
) != VAR_DECL
)
5005 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5006 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5009 /* Character strings are passed as two parameters, a length and a
5010 pointer - except for Bind(c) which only passes the pointer.
5011 An unlimited polymorphic formal argument likewise does not
5013 if (parmse
.string_length
!= NULL_TREE
5014 && !sym
->attr
.is_bind_c
5015 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5016 vec_safe_push (stringargs
, parmse
.string_length
);
5018 /* When calling __copy for character expressions to unlimited
5019 polymorphic entities, the dst argument needs a string length. */
5020 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5021 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5022 && arg
->next
&& arg
->next
->expr
5023 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5024 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5025 vec_safe_push (stringargs
, parmse
.string_length
);
5027 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5028 pass the token and the offset as additional arguments. */
5029 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5030 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5031 && !fsym
->attr
.allocatable
)
5032 || (fsym
->ts
.type
== BT_CLASS
5033 && CLASS_DATA (fsym
)->attr
.codimension
5034 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5036 /* Token and offset. */
5037 vec_safe_push (stringargs
, null_pointer_node
);
5038 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5039 gcc_assert (fsym
->attr
.optional
);
5041 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5042 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5043 && !fsym
->attr
.allocatable
)
5044 || (fsym
->ts
.type
== BT_CLASS
5045 && CLASS_DATA (fsym
)->attr
.codimension
5046 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5048 tree caf_decl
, caf_type
;
5051 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5052 caf_type
= TREE_TYPE (caf_decl
);
5054 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5055 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5056 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5057 tmp
= gfc_conv_descriptor_token (caf_decl
);
5058 else if (DECL_LANG_SPECIFIC (caf_decl
)
5059 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5060 tmp
= GFC_DECL_TOKEN (caf_decl
);
5063 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5064 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5065 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5068 vec_safe_push (stringargs
, tmp
);
5070 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5071 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5072 offset
= build_int_cst (gfc_array_index_type
, 0);
5073 else if (DECL_LANG_SPECIFIC (caf_decl
)
5074 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5075 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5076 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5077 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5079 offset
= build_int_cst (gfc_array_index_type
, 0);
5081 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5082 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5085 gcc_assert (POINTER_TYPE_P (caf_type
));
5089 tmp2
= fsym
->ts
.type
== BT_CLASS
5090 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5091 if ((fsym
->ts
.type
!= BT_CLASS
5092 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5093 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5094 || (fsym
->ts
.type
== BT_CLASS
5095 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5096 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5098 if (fsym
->ts
.type
== BT_CLASS
)
5099 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5102 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5103 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5105 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5106 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5108 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5109 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5112 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5115 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5116 gfc_array_index_type
,
5117 fold_convert (gfc_array_index_type
, tmp2
),
5118 fold_convert (gfc_array_index_type
, tmp
));
5119 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5120 gfc_array_index_type
, offset
, tmp
);
5122 vec_safe_push (stringargs
, offset
);
5125 vec_safe_push (arglist
, parmse
.expr
);
5127 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5134 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5135 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5136 else if (ts
.type
== BT_CHARACTER
)
5138 if (ts
.u
.cl
->length
== NULL
)
5140 /* Assumed character length results are not allowed by 5.1.1.5 of the
5141 standard and are trapped in resolve.c; except in the case of SPREAD
5142 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5143 we take the character length of the first argument for the result.
5144 For dummies, we have to look through the formal argument list for
5145 this function and use the character length found there.*/
5147 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5148 else if (!sym
->attr
.dummy
)
5149 cl
.backend_decl
= (*stringargs
)[0];
5152 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5153 for (; formal
; formal
= formal
->next
)
5154 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5155 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5157 len
= cl
.backend_decl
;
5163 /* Calculate the length of the returned string. */
5164 gfc_init_se (&parmse
, NULL
);
5165 if (need_interface_mapping
)
5166 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5168 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5169 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5170 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5172 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5173 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5174 gfc_charlen_type_node
, tmp
,
5175 build_int_cst (gfc_charlen_type_node
, 0));
5176 cl
.backend_decl
= tmp
;
5179 /* Set up a charlen structure for it. */
5184 len
= cl
.backend_decl
;
5187 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5188 || (!comp
&& gfc_return_by_reference (sym
));
5191 if (se
->direct_byref
)
5193 /* Sometimes, too much indirection can be applied; e.g. for
5194 function_result = array_valued_recursive_function. */
5195 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5196 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5197 && GFC_DESCRIPTOR_TYPE_P
5198 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5199 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5202 /* If the lhs of an assignment x = f(..) is allocatable and
5203 f2003 is allowed, we must do the automatic reallocation.
5204 TODO - deal with intrinsics, without using a temporary. */
5205 if (flag_realloc_lhs
5206 && se
->ss
&& se
->ss
->loop_chain
5207 && se
->ss
->loop_chain
->is_alloc_lhs
5208 && !expr
->value
.function
.isym
5209 && sym
->result
->as
!= NULL
)
5211 /* Evaluate the bounds of the result, if known. */
5212 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5215 /* Perform the automatic reallocation. */
5216 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5218 gfc_add_expr_to_block (&se
->pre
, tmp
);
5220 /* Pass the temporary as the first argument. */
5221 result
= info
->descriptor
;
5224 result
= build_fold_indirect_ref_loc (input_location
,
5226 vec_safe_push (retargs
, se
->expr
);
5228 else if (comp
&& comp
->attr
.dimension
)
5230 gcc_assert (se
->loop
&& info
);
5232 /* Set the type of the array. */
5233 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5234 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5236 /* Evaluate the bounds of the result, if known. */
5237 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5239 /* If the lhs of an assignment x = f(..) is allocatable and
5240 f2003 is allowed, we must not generate the function call
5241 here but should just send back the results of the mapping.
5242 This is signalled by the function ss being flagged. */
5243 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5245 gfc_free_interface_mapping (&mapping
);
5246 return has_alternate_specifier
;
5249 /* Create a temporary to store the result. In case the function
5250 returns a pointer, the temporary will be a shallow copy and
5251 mustn't be deallocated. */
5252 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5253 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5254 tmp
, NULL_TREE
, false,
5255 !comp
->attr
.pointer
, callee_alloc
,
5256 &se
->ss
->info
->expr
->where
);
5258 /* Pass the temporary as the first argument. */
5259 result
= info
->descriptor
;
5260 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5261 vec_safe_push (retargs
, tmp
);
5263 else if (!comp
&& sym
->result
->attr
.dimension
)
5265 gcc_assert (se
->loop
&& info
);
5267 /* Set the type of the array. */
5268 tmp
= gfc_typenode_for_spec (&ts
);
5269 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5271 /* Evaluate the bounds of the result, if known. */
5272 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5274 /* If the lhs of an assignment x = f(..) is allocatable and
5275 f2003 is allowed, we must not generate the function call
5276 here but should just send back the results of the mapping.
5277 This is signalled by the function ss being flagged. */
5278 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5280 gfc_free_interface_mapping (&mapping
);
5281 return has_alternate_specifier
;
5284 /* Create a temporary to store the result. In case the function
5285 returns a pointer, the temporary will be a shallow copy and
5286 mustn't be deallocated. */
5287 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5288 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5289 tmp
, NULL_TREE
, false,
5290 !sym
->attr
.pointer
, callee_alloc
,
5291 &se
->ss
->info
->expr
->where
);
5293 /* Pass the temporary as the first argument. */
5294 result
= info
->descriptor
;
5295 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5296 vec_safe_push (retargs
, tmp
);
5298 else if (ts
.type
== BT_CHARACTER
)
5300 /* Pass the string length. */
5301 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5302 type
= build_pointer_type (type
);
5304 /* Return an address to a char[0:len-1]* temporary for
5305 character pointers. */
5306 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5307 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5309 var
= gfc_create_var (type
, "pstr");
5311 if ((!comp
&& sym
->attr
.allocatable
)
5312 || (comp
&& comp
->attr
.allocatable
))
5314 gfc_add_modify (&se
->pre
, var
,
5315 fold_convert (TREE_TYPE (var
),
5316 null_pointer_node
));
5317 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5318 gfc_add_expr_to_block (&se
->post
, tmp
);
5321 /* Provide an address expression for the function arguments. */
5322 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5325 var
= gfc_conv_string_tmp (se
, type
, len
);
5327 vec_safe_push (retargs
, var
);
5331 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5333 type
= gfc_get_complex_type (ts
.kind
);
5334 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5335 vec_safe_push (retargs
, var
);
5338 /* Add the string length to the argument list. */
5339 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5342 if (TREE_CODE (tmp
) != VAR_DECL
)
5343 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5344 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5345 vec_safe_push (retargs
, tmp
);
5347 else if (ts
.type
== BT_CHARACTER
)
5348 vec_safe_push (retargs
, len
);
5350 gfc_free_interface_mapping (&mapping
);
5352 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5353 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5354 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5355 vec_safe_reserve (retargs
, arglen
);
5357 /* Add the return arguments. */
5358 retargs
->splice (arglist
);
5360 /* Add the hidden present status for optional+value to the arguments. */
5361 retargs
->splice (optionalargs
);
5363 /* Add the hidden string length parameters to the arguments. */
5364 retargs
->splice (stringargs
);
5366 /* We may want to append extra arguments here. This is used e.g. for
5367 calls to libgfortran_matmul_??, which need extra information. */
5368 if (!vec_safe_is_empty (append_args
))
5369 retargs
->splice (append_args
);
5372 /* Generate the actual call. */
5373 if (base_object
== NULL_TREE
)
5374 conv_function_val (se
, sym
, expr
);
5376 conv_base_obj_fcn_val (se
, base_object
, expr
);
5378 /* If there are alternate return labels, function type should be
5379 integer. Can't modify the type in place though, since it can be shared
5380 with other functions. For dummy arguments, the typing is done to
5381 this result, even if it has to be repeated for each call. */
5382 if (has_alternate_specifier
5383 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5385 if (!sym
->attr
.dummy
)
5387 TREE_TYPE (sym
->backend_decl
)
5388 = build_function_type (integer_type_node
,
5389 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5390 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5393 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5396 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5397 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5399 /* If we have a pointer function, but we don't want a pointer, e.g.
5402 where f is pointer valued, we have to dereference the result. */
5403 if (!se
->want_pointer
&& !byref
5404 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5405 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5406 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5408 /* f2c calling conventions require a scalar default real function to
5409 return a double precision result. Convert this back to default
5410 real. We only care about the cases that can happen in Fortran 77.
5412 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5413 && sym
->ts
.kind
== gfc_default_real_kind
5414 && !sym
->attr
.always_explicit
)
5415 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5417 /* A pure function may still have side-effects - it may modify its
5419 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5421 if (!sym
->attr
.pure
)
5422 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5427 /* Add the function call to the pre chain. There is no expression. */
5428 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5429 se
->expr
= NULL_TREE
;
5431 if (!se
->direct_byref
)
5433 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5435 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5437 /* Check the data pointer hasn't been modified. This would
5438 happen in a function returning a pointer. */
5439 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5440 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5443 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5446 se
->expr
= info
->descriptor
;
5447 /* Bundle in the string length. */
5448 se
->string_length
= len
;
5450 else if (ts
.type
== BT_CHARACTER
)
5452 /* Dereference for character pointer results. */
5453 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5454 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5455 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5459 se
->string_length
= len
;
5463 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5464 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5469 /* Follow the function call with the argument post block. */
5472 gfc_add_block_to_block (&se
->pre
, &post
);
5474 /* Transformational functions of derived types with allocatable
5475 components must have the result allocatable components copied. */
5476 arg
= expr
->value
.function
.actual
;
5477 if (result
&& arg
&& expr
->rank
5478 && expr
->value
.function
.isym
5479 && expr
->value
.function
.isym
->transformational
5480 && arg
->expr
->ts
.type
== BT_DERIVED
5481 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5484 /* Copy the allocatable components. We have to use a
5485 temporary here to prevent source allocatable components
5486 from being corrupted. */
5487 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5488 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5489 result
, tmp2
, expr
->rank
);
5490 gfc_add_expr_to_block (&se
->pre
, tmp
);
5491 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5493 gfc_add_expr_to_block (&se
->pre
, tmp
);
5495 /* Finally free the temporary's data field. */
5496 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5497 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5498 NULL_TREE
, NULL_TREE
, true,
5500 gfc_add_expr_to_block (&se
->pre
, tmp
);
5504 gfc_add_block_to_block (&se
->post
, &post
);
5506 return has_alternate_specifier
;
5510 /* Fill a character string with spaces. */
5513 fill_with_spaces (tree start
, tree type
, tree size
)
5515 stmtblock_t block
, loop
;
5516 tree i
, el
, exit_label
, cond
, tmp
;
5518 /* For a simple char type, we can call memset(). */
5519 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5520 return build_call_expr_loc (input_location
,
5521 builtin_decl_explicit (BUILT_IN_MEMSET
),
5523 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5524 lang_hooks
.to_target_charset (' ')),
5527 /* Otherwise, we use a loop:
5528 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5532 /* Initialize variables. */
5533 gfc_init_block (&block
);
5534 i
= gfc_create_var (sizetype
, "i");
5535 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5536 el
= gfc_create_var (build_pointer_type (type
), "el");
5537 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5538 exit_label
= gfc_build_label_decl (NULL_TREE
);
5539 TREE_USED (exit_label
) = 1;
5543 gfc_init_block (&loop
);
5545 /* Exit condition. */
5546 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5547 build_zero_cst (sizetype
));
5548 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5549 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5550 build_empty_stmt (input_location
));
5551 gfc_add_expr_to_block (&loop
, tmp
);
5554 gfc_add_modify (&loop
,
5555 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5556 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5558 /* Increment loop variables. */
5559 gfc_add_modify (&loop
, i
,
5560 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5561 TYPE_SIZE_UNIT (type
)));
5562 gfc_add_modify (&loop
, el
,
5563 fold_build_pointer_plus_loc (input_location
,
5564 el
, TYPE_SIZE_UNIT (type
)));
5566 /* Making the loop... actually loop! */
5567 tmp
= gfc_finish_block (&loop
);
5568 tmp
= build1_v (LOOP_EXPR
, tmp
);
5569 gfc_add_expr_to_block (&block
, tmp
);
5571 /* The exit label. */
5572 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5573 gfc_add_expr_to_block (&block
, tmp
);
5576 return gfc_finish_block (&block
);
5580 /* Generate code to copy a string. */
5583 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5584 int dkind
, tree slength
, tree src
, int skind
)
5586 tree tmp
, dlen
, slen
;
5595 stmtblock_t tempblock
;
5597 gcc_assert (dkind
== skind
);
5599 if (slength
!= NULL_TREE
)
5601 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5602 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5606 slen
= build_int_cst (size_type_node
, 1);
5610 if (dlength
!= NULL_TREE
)
5612 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5613 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5617 dlen
= build_int_cst (size_type_node
, 1);
5621 /* Assign directly if the types are compatible. */
5622 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5623 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5625 gfc_add_modify (block
, dsc
, ssc
);
5629 /* Do nothing if the destination length is zero. */
5630 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5631 build_int_cst (size_type_node
, 0));
5633 /* The following code was previously in _gfortran_copy_string:
5635 // The two strings may overlap so we use memmove.
5637 copy_string (GFC_INTEGER_4 destlen, char * dest,
5638 GFC_INTEGER_4 srclen, const char * src)
5640 if (srclen >= destlen)
5642 // This will truncate if too long.
5643 memmove (dest, src, destlen);
5647 memmove (dest, src, srclen);
5649 memset (&dest[srclen], ' ', destlen - srclen);
5653 We're now doing it here for better optimization, but the logic
5656 /* For non-default character kinds, we have to multiply the string
5657 length by the base type size. */
5658 chartype
= gfc_get_char_type (dkind
);
5659 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5660 fold_convert (size_type_node
, slen
),
5661 fold_convert (size_type_node
,
5662 TYPE_SIZE_UNIT (chartype
)));
5663 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5664 fold_convert (size_type_node
, dlen
),
5665 fold_convert (size_type_node
,
5666 TYPE_SIZE_UNIT (chartype
)));
5668 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5669 dest
= fold_convert (pvoid_type_node
, dest
);
5671 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5673 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5674 src
= fold_convert (pvoid_type_node
, src
);
5676 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5678 /* Truncate string if source is too long. */
5679 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5681 tmp2
= build_call_expr_loc (input_location
,
5682 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5683 3, dest
, src
, dlen
);
5685 /* Else copy and pad with spaces. */
5686 tmp3
= build_call_expr_loc (input_location
,
5687 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5688 3, dest
, src
, slen
);
5690 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5691 tmp4
= fill_with_spaces (tmp4
, chartype
,
5692 fold_build2_loc (input_location
, MINUS_EXPR
,
5693 TREE_TYPE(dlen
), dlen
, slen
));
5695 gfc_init_block (&tempblock
);
5696 gfc_add_expr_to_block (&tempblock
, tmp3
);
5697 gfc_add_expr_to_block (&tempblock
, tmp4
);
5698 tmp3
= gfc_finish_block (&tempblock
);
5700 /* The whole copy_string function is there. */
5701 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5703 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5704 build_empty_stmt (input_location
));
5705 gfc_add_expr_to_block (block
, tmp
);
5709 /* Translate a statement function.
5710 The value of a statement function reference is obtained by evaluating the
5711 expression using the values of the actual arguments for the values of the
5712 corresponding dummy arguments. */
5715 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5719 gfc_formal_arglist
*fargs
;
5720 gfc_actual_arglist
*args
;
5723 gfc_saved_var
*saved_vars
;
5729 sym
= expr
->symtree
->n
.sym
;
5730 args
= expr
->value
.function
.actual
;
5731 gfc_init_se (&lse
, NULL
);
5732 gfc_init_se (&rse
, NULL
);
5735 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5737 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5738 temp_vars
= XCNEWVEC (tree
, n
);
5740 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5741 fargs
= fargs
->next
, n
++)
5743 /* Each dummy shall be specified, explicitly or implicitly, to be
5745 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5748 if (fsym
->ts
.type
== BT_CHARACTER
)
5750 /* Copy string arguments. */
5753 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5754 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5756 /* Create a temporary to hold the value. */
5757 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5758 fsym
->ts
.u
.cl
->backend_decl
5759 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5761 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5762 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5764 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5766 gfc_conv_expr (&rse
, args
->expr
);
5767 gfc_conv_string_parameter (&rse
);
5768 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5769 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5771 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5772 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5773 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5774 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5778 /* For everything else, just evaluate the expression. */
5780 /* Create a temporary to hold the value. */
5781 type
= gfc_typenode_for_spec (&fsym
->ts
);
5782 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5784 gfc_conv_expr (&lse
, args
->expr
);
5786 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5787 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5788 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5794 /* Use the temporary variables in place of the real ones. */
5795 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5796 fargs
= fargs
->next
, n
++)
5797 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5799 gfc_conv_expr (se
, sym
->value
);
5801 if (sym
->ts
.type
== BT_CHARACTER
)
5803 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5805 /* Force the expression to the correct length. */
5806 if (!INTEGER_CST_P (se
->string_length
)
5807 || tree_int_cst_lt (se
->string_length
,
5808 sym
->ts
.u
.cl
->backend_decl
))
5810 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5811 tmp
= gfc_create_var (type
, sym
->name
);
5812 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5813 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5814 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5818 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5821 /* Restore the original variables. */
5822 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5823 fargs
= fargs
->next
, n
++)
5824 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5830 /* Translate a function expression. */
5833 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5837 if (expr
->value
.function
.isym
)
5839 gfc_conv_intrinsic_function (se
, expr
);
5843 /* expr.value.function.esym is the resolved (specific) function symbol for
5844 most functions. However this isn't set for dummy procedures. */
5845 sym
= expr
->value
.function
.esym
;
5847 sym
= expr
->symtree
->n
.sym
;
5849 /* The IEEE_ARITHMETIC functions are caught here. */
5850 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
5851 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
5854 /* We distinguish statement functions from general functions to improve
5855 runtime performance. */
5856 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5858 gfc_conv_statement_function (se
, expr
);
5862 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5867 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5870 is_zero_initializer_p (gfc_expr
* expr
)
5872 if (expr
->expr_type
!= EXPR_CONSTANT
)
5875 /* We ignore constants with prescribed memory representations for now. */
5876 if (expr
->representation
.string
)
5879 switch (expr
->ts
.type
)
5882 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5885 return mpfr_zero_p (expr
->value
.real
)
5886 && MPFR_SIGN (expr
->value
.real
) >= 0;
5889 return expr
->value
.logical
== 0;
5892 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5893 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5894 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5895 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5905 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5910 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5911 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5913 gfc_conv_tmp_array_ref (se
);
5917 /* Build a static initializer. EXPR is the expression for the initial value.
5918 The other parameters describe the variable of the component being
5919 initialized. EXPR may be null. */
5922 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5923 bool array
, bool pointer
, bool procptr
)
5927 if (!(expr
|| pointer
|| procptr
))
5930 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5931 (these are the only two iso_c_binding derived types that can be
5932 used as initialization expressions). If so, we need to modify
5933 the 'expr' to be that for a (void *). */
5934 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5935 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5937 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5939 /* The derived symbol has already been converted to a (void *). Use
5941 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5942 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5944 gfc_init_se (&se
, NULL
);
5945 gfc_conv_constant (&se
, expr
);
5946 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5950 if (array
&& !procptr
)
5953 /* Arrays need special handling. */
5955 ctor
= gfc_build_null_descriptor (type
);
5956 /* Special case assigning an array to zero. */
5957 else if (is_zero_initializer_p (expr
))
5958 ctor
= build_constructor (type
, NULL
);
5960 ctor
= gfc_conv_array_initializer (type
, expr
);
5961 TREE_STATIC (ctor
) = 1;
5964 else if (pointer
|| procptr
)
5966 if (ts
->type
== BT_CLASS
&& !procptr
)
5968 gfc_init_se (&se
, NULL
);
5969 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5970 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5971 TREE_STATIC (se
.expr
) = 1;
5974 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5975 return fold_convert (type
, null_pointer_node
);
5978 gfc_init_se (&se
, NULL
);
5979 se
.want_pointer
= 1;
5980 gfc_conv_expr (&se
, expr
);
5981 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5991 gfc_init_se (&se
, NULL
);
5992 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5993 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5995 gfc_conv_structure (&se
, expr
, 1);
5996 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5997 TREE_STATIC (se
.expr
) = 1;
6002 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6003 TREE_STATIC (ctor
) = 1;
6008 gfc_init_se (&se
, NULL
);
6009 gfc_conv_constant (&se
, expr
);
6010 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6017 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6023 gfc_array_info
*lss_array
;
6030 gfc_start_block (&block
);
6032 /* Initialize the scalarizer. */
6033 gfc_init_loopinfo (&loop
);
6035 gfc_init_se (&lse
, NULL
);
6036 gfc_init_se (&rse
, NULL
);
6039 rss
= gfc_walk_expr (expr
);
6040 if (rss
== gfc_ss_terminator
)
6041 /* The rhs is scalar. Add a ss for the expression. */
6042 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6044 /* Create a SS for the destination. */
6045 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6047 lss_array
= &lss
->info
->data
.array
;
6048 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6049 lss_array
->descriptor
= dest
;
6050 lss_array
->data
= gfc_conv_array_data (dest
);
6051 lss_array
->offset
= gfc_conv_array_offset (dest
);
6052 for (n
= 0; n
< cm
->as
->rank
; n
++)
6054 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6055 lss_array
->stride
[n
] = gfc_index_one_node
;
6057 mpz_init (lss_array
->shape
[n
]);
6058 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6059 cm
->as
->lower
[n
]->value
.integer
);
6060 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6063 /* Associate the SS with the loop. */
6064 gfc_add_ss_to_loop (&loop
, lss
);
6065 gfc_add_ss_to_loop (&loop
, rss
);
6067 /* Calculate the bounds of the scalarization. */
6068 gfc_conv_ss_startstride (&loop
);
6070 /* Setup the scalarizing loops. */
6071 gfc_conv_loop_setup (&loop
, &expr
->where
);
6073 /* Setup the gfc_se structures. */
6074 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6075 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6078 gfc_mark_ss_chain_used (rss
, 1);
6080 gfc_mark_ss_chain_used (lss
, 1);
6082 /* Start the scalarized loop body. */
6083 gfc_start_scalarized_body (&loop
, &body
);
6085 gfc_conv_tmp_array_ref (&lse
);
6086 if (cm
->ts
.type
== BT_CHARACTER
)
6087 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6089 gfc_conv_expr (&rse
, expr
);
6091 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6092 gfc_add_expr_to_block (&body
, tmp
);
6094 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6096 /* Generate the copying loops. */
6097 gfc_trans_scalarizing_loops (&loop
, &body
);
6099 /* Wrap the whole thing up. */
6100 gfc_add_block_to_block (&block
, &loop
.pre
);
6101 gfc_add_block_to_block (&block
, &loop
.post
);
6103 gcc_assert (lss_array
->shape
!= NULL
);
6104 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6105 gfc_cleanup_loop (&loop
);
6107 return gfc_finish_block (&block
);
6112 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6122 gfc_expr
*arg
= NULL
;
6124 gfc_start_block (&block
);
6125 gfc_init_se (&se
, NULL
);
6127 /* Get the descriptor for the expressions. */
6128 se
.want_pointer
= 0;
6129 gfc_conv_expr_descriptor (&se
, expr
);
6130 gfc_add_block_to_block (&block
, &se
.pre
);
6131 gfc_add_modify (&block
, dest
, se
.expr
);
6133 /* Deal with arrays of derived types with allocatable components. */
6134 if (cm
->ts
.type
== BT_DERIVED
6135 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6136 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6140 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6141 TREE_TYPE(cm
->backend_decl
),
6144 gfc_add_expr_to_block (&block
, tmp
);
6145 gfc_add_block_to_block (&block
, &se
.post
);
6147 if (expr
->expr_type
!= EXPR_VARIABLE
)
6148 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6151 /* We need to know if the argument of a conversion function is a
6152 variable, so that the correct lower bound can be used. */
6153 if (expr
->expr_type
== EXPR_FUNCTION
6154 && expr
->value
.function
.isym
6155 && expr
->value
.function
.isym
->conversion
6156 && expr
->value
.function
.actual
->expr
6157 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6158 arg
= expr
->value
.function
.actual
->expr
;
6160 /* Obtain the array spec of full array references. */
6162 as
= gfc_get_full_arrayspec_from_expr (arg
);
6164 as
= gfc_get_full_arrayspec_from_expr (expr
);
6166 /* Shift the lbound and ubound of temporaries to being unity,
6167 rather than zero, based. Always calculate the offset. */
6168 offset
= gfc_conv_descriptor_offset_get (dest
);
6169 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6170 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6172 for (n
= 0; n
< expr
->rank
; n
++)
6177 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6178 TODO It looks as if gfc_conv_expr_descriptor should return
6179 the correct bounds and that the following should not be
6180 necessary. This would simplify gfc_conv_intrinsic_bound
6182 if (as
&& as
->lower
[n
])
6185 gfc_init_se (&lbse
, NULL
);
6186 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6187 gfc_add_block_to_block (&block
, &lbse
.pre
);
6188 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6192 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6193 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6197 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6200 lbound
= gfc_index_one_node
;
6202 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6204 /* Shift the bounds and set the offset accordingly. */
6205 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6206 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6207 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6208 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6210 gfc_conv_descriptor_ubound_set (&block
, dest
,
6211 gfc_rank_cst
[n
], tmp
);
6212 gfc_conv_descriptor_lbound_set (&block
, dest
,
6213 gfc_rank_cst
[n
], lbound
);
6215 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6216 gfc_conv_descriptor_lbound_get (dest
,
6218 gfc_conv_descriptor_stride_get (dest
,
6220 gfc_add_modify (&block
, tmp2
, tmp
);
6221 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6223 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6228 /* If a conversion expression has a null data pointer
6229 argument, nullify the allocatable component. */
6233 if (arg
->symtree
->n
.sym
->attr
.allocatable
6234 || arg
->symtree
->n
.sym
->attr
.pointer
)
6236 non_null_expr
= gfc_finish_block (&block
);
6237 gfc_start_block (&block
);
6238 gfc_conv_descriptor_data_set (&block
, dest
,
6240 null_expr
= gfc_finish_block (&block
);
6241 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6242 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6243 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6244 return build3_v (COND_EXPR
, tmp
,
6245 null_expr
, non_null_expr
);
6249 return gfc_finish_block (&block
);
6253 /* Assign a single component of a derived type constructor. */
6256 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6263 gfc_start_block (&block
);
6265 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6267 gfc_init_se (&se
, NULL
);
6268 /* Pointer component. */
6269 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6270 && !cm
->attr
.proc_pointer
)
6272 /* Array pointer. */
6273 if (expr
->expr_type
== EXPR_NULL
)
6274 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6277 se
.direct_byref
= 1;
6279 gfc_conv_expr_descriptor (&se
, expr
);
6280 gfc_add_block_to_block (&block
, &se
.pre
);
6281 gfc_add_block_to_block (&block
, &se
.post
);
6286 /* Scalar pointers. */
6287 se
.want_pointer
= 1;
6288 gfc_conv_expr (&se
, expr
);
6289 gfc_add_block_to_block (&block
, &se
.pre
);
6291 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6292 && expr
->symtree
->n
.sym
->attr
.dummy
)
6293 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6295 gfc_add_modify (&block
, dest
,
6296 fold_convert (TREE_TYPE (dest
), se
.expr
));
6297 gfc_add_block_to_block (&block
, &se
.post
);
6300 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6302 /* NULL initialization for CLASS components. */
6303 tmp
= gfc_trans_structure_assign (dest
,
6304 gfc_class_initializer (&cm
->ts
, expr
));
6305 gfc_add_expr_to_block (&block
, tmp
);
6307 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6308 && !cm
->attr
.proc_pointer
)
6310 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6311 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6312 else if (cm
->attr
.allocatable
)
6314 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6315 gfc_add_expr_to_block (&block
, tmp
);
6319 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6320 gfc_add_expr_to_block (&block
, tmp
);
6323 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6325 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6327 gfc_init_se (&se
, NULL
);
6328 gfc_conv_expr (&se
, expr
);
6329 gfc_add_block_to_block (&block
, &se
.pre
);
6330 gfc_add_modify (&block
, dest
,
6331 fold_convert (TREE_TYPE (dest
), se
.expr
));
6332 gfc_add_block_to_block (&block
, &se
.post
);
6336 /* Nested constructors. */
6337 tmp
= gfc_trans_structure_assign (dest
, expr
);
6338 gfc_add_expr_to_block (&block
, tmp
);
6341 else if (gfc_deferred_strlen (cm
, &tmp
))
6345 gcc_assert (strlen
);
6346 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6348 TREE_OPERAND (dest
, 0),
6351 if (expr
->expr_type
== EXPR_NULL
)
6353 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6354 gfc_add_modify (&block
, dest
, tmp
);
6355 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6356 gfc_add_modify (&block
, strlen
, tmp
);
6361 gfc_init_se (&se
, NULL
);
6362 gfc_conv_expr (&se
, expr
);
6363 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6364 tmp
= build_call_expr_loc (input_location
,
6365 builtin_decl_explicit (BUILT_IN_MALLOC
),
6367 gfc_add_modify (&block
, dest
,
6368 fold_convert (TREE_TYPE (dest
), tmp
));
6369 gfc_add_modify (&block
, strlen
, se
.string_length
);
6370 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6371 gfc_add_expr_to_block (&block
, tmp
);
6374 else if (!cm
->attr
.deferred_parameter
)
6376 /* Scalar component (excluding deferred parameters). */
6377 gfc_init_se (&se
, NULL
);
6378 gfc_init_se (&lse
, NULL
);
6380 gfc_conv_expr (&se
, expr
);
6381 if (cm
->ts
.type
== BT_CHARACTER
)
6382 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6384 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6385 gfc_add_expr_to_block (&block
, tmp
);
6387 return gfc_finish_block (&block
);
6390 /* Assign a derived type constructor to a variable. */
6393 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6401 gfc_start_block (&block
);
6402 cm
= expr
->ts
.u
.derived
->components
;
6404 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6405 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6406 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6410 gcc_assert (cm
->backend_decl
== NULL
);
6411 gfc_init_se (&se
, NULL
);
6412 gfc_init_se (&lse
, NULL
);
6413 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6415 gfc_add_modify (&block
, lse
.expr
,
6416 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6418 return gfc_finish_block (&block
);
6421 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6422 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6424 /* Skip absent members in default initializers. */
6428 field
= cm
->backend_decl
;
6429 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6430 dest
, field
, NULL_TREE
);
6431 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6432 gfc_add_expr_to_block (&block
, tmp
);
6434 return gfc_finish_block (&block
);
6437 /* Build an expression for a constructor. If init is nonzero then
6438 this is part of a static variable initializer. */
6441 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6448 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6450 gcc_assert (se
->ss
== NULL
);
6451 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6452 type
= gfc_typenode_for_spec (&expr
->ts
);
6456 /* Create a temporary variable and fill it in. */
6457 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6458 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6459 gfc_add_expr_to_block (&se
->pre
, tmp
);
6463 cm
= expr
->ts
.u
.derived
->components
;
6465 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6466 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6468 /* Skip absent members in default initializers and allocatable
6469 components. Although the latter have a default initializer
6470 of EXPR_NULL,... by default, the static nullify is not needed
6471 since this is done every time we come into scope. */
6472 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6475 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6476 && strcmp (cm
->name
, "_extends") == 0
6477 && cm
->initializer
->symtree
)
6481 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6482 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6483 vtab
= unshare_expr_without_location (vtab
);
6484 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6486 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6488 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6489 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6490 fold_convert (TREE_TYPE (cm
->backend_decl
),
6495 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6496 TREE_TYPE (cm
->backend_decl
),
6497 cm
->attr
.dimension
, cm
->attr
.pointer
,
6498 cm
->attr
.proc_pointer
);
6499 val
= unshare_expr_without_location (val
);
6501 /* Append it to the constructor list. */
6502 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6505 se
->expr
= build_constructor (type
, v
);
6507 TREE_CONSTANT (se
->expr
) = 1;
6511 /* Translate a substring expression. */
6514 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6520 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6522 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6523 expr
->value
.character
.length
,
6524 expr
->value
.character
.string
);
6526 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6527 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6530 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6534 /* Entry point for expression translation. Evaluates a scalar quantity.
6535 EXPR is the expression to be translated, and SE is the state structure if
6536 called from within the scalarized. */
6539 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6544 if (ss
&& ss
->info
->expr
== expr
6545 && (ss
->info
->type
== GFC_SS_SCALAR
6546 || ss
->info
->type
== GFC_SS_REFERENCE
))
6548 gfc_ss_info
*ss_info
;
6551 /* Substitute a scalar expression evaluated outside the scalarization
6553 se
->expr
= ss_info
->data
.scalar
.value
;
6554 /* If the reference can be NULL, the value field contains the reference,
6555 not the value the reference points to (see gfc_add_loop_ss_code). */
6556 if (ss_info
->can_be_null_ref
)
6557 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6559 se
->string_length
= ss_info
->string_length
;
6560 gfc_advance_se_ss_chain (se
);
6564 /* We need to convert the expressions for the iso_c_binding derived types.
6565 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6566 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6567 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6568 updated to be an integer with a kind equal to the size of a (void *). */
6569 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6571 if (expr
->expr_type
== EXPR_VARIABLE
6572 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6573 || expr
->symtree
->n
.sym
->intmod_sym_id
6574 == ISOCBINDING_NULL_FUNPTR
))
6576 /* Set expr_type to EXPR_NULL, which will result in
6577 null_pointer_node being used below. */
6578 expr
->expr_type
= EXPR_NULL
;
6582 /* Update the type/kind of the expression to be what the new
6583 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6584 expr
->ts
.type
= BT_INTEGER
;
6585 expr
->ts
.f90_type
= BT_VOID
;
6586 expr
->ts
.kind
= gfc_index_integer_kind
;
6590 gfc_fix_class_refs (expr
);
6592 switch (expr
->expr_type
)
6595 gfc_conv_expr_op (se
, expr
);
6599 gfc_conv_function_expr (se
, expr
);
6603 gfc_conv_constant (se
, expr
);
6607 gfc_conv_variable (se
, expr
);
6611 se
->expr
= null_pointer_node
;
6614 case EXPR_SUBSTRING
:
6615 gfc_conv_substring_expr (se
, expr
);
6618 case EXPR_STRUCTURE
:
6619 gfc_conv_structure (se
, expr
, 0);
6623 gfc_conv_array_constructor_expr (se
, expr
);
6632 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6633 of an assignment. */
6635 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6637 gfc_conv_expr (se
, expr
);
6638 /* All numeric lvalues should have empty post chains. If not we need to
6639 figure out a way of rewriting an lvalue so that it has no post chain. */
6640 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6643 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6644 numeric expressions. Used for scalar values where inserting cleanup code
6647 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6651 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6652 gfc_conv_expr (se
, expr
);
6655 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6656 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6658 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6662 /* Helper to translate an expression and convert it to a particular type. */
6664 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6666 gfc_conv_expr_val (se
, expr
);
6667 se
->expr
= convert (type
, se
->expr
);
6671 /* Converts an expression so that it can be passed by reference. Scalar
6675 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6681 if (ss
&& ss
->info
->expr
== expr
6682 && ss
->info
->type
== GFC_SS_REFERENCE
)
6684 /* Returns a reference to the scalar evaluated outside the loop
6686 gfc_conv_expr (se
, expr
);
6688 if (expr
->ts
.type
== BT_CHARACTER
6689 && expr
->expr_type
!= EXPR_FUNCTION
)
6690 gfc_conv_string_parameter (se
);
6692 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6697 if (expr
->ts
.type
== BT_CHARACTER
)
6699 gfc_conv_expr (se
, expr
);
6700 gfc_conv_string_parameter (se
);
6704 if (expr
->expr_type
== EXPR_VARIABLE
)
6706 se
->want_pointer
= 1;
6707 gfc_conv_expr (se
, expr
);
6710 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6711 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6712 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6718 if (expr
->expr_type
== EXPR_FUNCTION
6719 && ((expr
->value
.function
.esym
6720 && expr
->value
.function
.esym
->result
->attr
.pointer
6721 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6722 || (!expr
->value
.function
.esym
&& !expr
->ref
6723 && expr
->symtree
->n
.sym
->attr
.pointer
6724 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6726 se
->want_pointer
= 1;
6727 gfc_conv_expr (se
, expr
);
6728 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6729 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6734 gfc_conv_expr (se
, expr
);
6736 /* Create a temporary var to hold the value. */
6737 if (TREE_CONSTANT (se
->expr
))
6739 tree tmp
= se
->expr
;
6740 STRIP_TYPE_NOPS (tmp
);
6741 var
= build_decl (input_location
,
6742 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6743 DECL_INITIAL (var
) = tmp
;
6744 TREE_STATIC (var
) = 1;
6749 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6750 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6752 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6754 /* Take the address of that value. */
6755 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6756 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6757 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6758 && expr
->ts
.u
.derived
->attr
.alloc_comp
6759 && expr
->expr_type
!= EXPR_VARIABLE
)
6763 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6764 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6766 /* The components shall be deallocated before
6767 their containing entity. */
6768 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6774 gfc_trans_pointer_assign (gfc_code
* code
)
6776 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6780 /* Generate code for a pointer assignment. */
6783 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6785 gfc_expr
*expr1_vptr
= NULL
;
6795 gfc_start_block (&block
);
6797 gfc_init_se (&lse
, NULL
);
6799 /* Check whether the expression is a scalar or not; we cannot use
6800 expr1->rank as it can be nonzero for proc pointers. */
6801 ss
= gfc_walk_expr (expr1
);
6802 scalar
= ss
== gfc_ss_terminator
;
6804 gfc_free_ss_chain (ss
);
6806 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6807 && expr2
->expr_type
!= EXPR_FUNCTION
)
6809 gfc_add_data_component (expr2
);
6810 /* The following is required as gfc_add_data_component doesn't
6811 update ts.type if there is a tailing REF_ARRAY. */
6812 expr2
->ts
.type
= BT_DERIVED
;
6817 /* Scalar pointers. */
6818 lse
.want_pointer
= 1;
6819 gfc_conv_expr (&lse
, expr1
);
6820 gfc_init_se (&rse
, NULL
);
6821 rse
.want_pointer
= 1;
6822 gfc_conv_expr (&rse
, expr2
);
6824 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6825 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6826 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6829 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6830 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6831 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6834 gfc_add_block_to_block (&block
, &lse
.pre
);
6835 gfc_add_block_to_block (&block
, &rse
.pre
);
6837 /* Check character lengths if character expression. The test is only
6838 really added if -fbounds-check is enabled. Exclude deferred
6839 character length lefthand sides. */
6840 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6841 && !expr1
->ts
.deferred
6842 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6843 && !gfc_is_proc_ptr_comp (expr1
))
6845 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6846 gcc_assert (lse
.string_length
&& rse
.string_length
);
6847 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6848 lse
.string_length
, rse
.string_length
,
6852 /* The assignment to an deferred character length sets the string
6853 length to that of the rhs. */
6854 if (expr1
->ts
.deferred
)
6856 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6857 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6858 else if (lse
.string_length
!= NULL
)
6859 gfc_add_modify (&block
, lse
.string_length
,
6860 build_int_cst (gfc_charlen_type_node
, 0));
6863 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6864 rse
.expr
= gfc_class_data_get (rse
.expr
);
6866 gfc_add_modify (&block
, lse
.expr
,
6867 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6869 gfc_add_block_to_block (&block
, &rse
.post
);
6870 gfc_add_block_to_block (&block
, &lse
.post
);
6877 tree strlen_rhs
= NULL_TREE
;
6879 /* Array pointer. Find the last reference on the LHS and if it is an
6880 array section ref, we're dealing with bounds remapping. In this case,
6881 set it to AR_FULL so that gfc_conv_expr_descriptor does
6882 not see it and process the bounds remapping afterwards explicitly. */
6883 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6884 if (!remap
->next
&& remap
->type
== REF_ARRAY
6885 && remap
->u
.ar
.type
== AR_SECTION
)
6887 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6889 gfc_init_se (&lse
, NULL
);
6891 lse
.descriptor_only
= 1;
6892 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6893 && expr1
->ts
.type
== BT_CLASS
)
6894 expr1_vptr
= gfc_copy_expr (expr1
);
6895 gfc_conv_expr_descriptor (&lse
, expr1
);
6896 strlen_lhs
= lse
.string_length
;
6899 if (expr2
->expr_type
== EXPR_NULL
)
6901 /* Just set the data pointer to null. */
6902 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6904 else if (rank_remap
)
6906 /* If we are rank-remapping, just get the RHS's descriptor and
6907 process this later on. */
6908 gfc_init_se (&rse
, NULL
);
6909 rse
.direct_byref
= 1;
6910 rse
.byref_noassign
= 1;
6912 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6914 gfc_conv_function_expr (&rse
, expr2
);
6916 if (expr1
->ts
.type
!= BT_CLASS
)
6917 rse
.expr
= gfc_class_data_get (rse
.expr
);
6920 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6921 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6923 gfc_add_vptr_component (expr1_vptr
);
6924 gfc_init_se (&rse
, NULL
);
6925 rse
.want_pointer
= 1;
6926 gfc_conv_expr (&rse
, expr1_vptr
);
6927 gfc_add_modify (&lse
.pre
, rse
.expr
,
6928 fold_convert (TREE_TYPE (rse
.expr
),
6929 gfc_class_vptr_get (tmp
)));
6930 rse
.expr
= gfc_class_data_get (tmp
);
6933 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6935 tree bound
[GFC_MAX_DIMENSIONS
];
6938 for (i
= 0; i
< expr2
->rank
; i
++)
6939 bound
[i
] = NULL_TREE
;
6940 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6941 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6943 GFC_ARRAY_POINTER_CONT
, false);
6944 tmp
= gfc_create_var (tmp
, "ptrtemp");
6946 lse
.direct_byref
= 1;
6947 gfc_conv_expr_descriptor (&lse
, expr2
);
6948 strlen_rhs
= lse
.string_length
;
6953 gfc_conv_expr_descriptor (&rse
, expr2
);
6954 strlen_rhs
= rse
.string_length
;
6957 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6959 /* Assign directly to the LHS's descriptor. */
6960 lse
.direct_byref
= 1;
6961 gfc_conv_expr_descriptor (&lse
, expr2
);
6962 strlen_rhs
= lse
.string_length
;
6964 /* If this is a subreference array pointer assignment, use the rhs
6965 descriptor element size for the lhs span. */
6966 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6968 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6969 gfc_init_se (&rse
, NULL
);
6970 rse
.descriptor_only
= 1;
6971 gfc_conv_expr (&rse
, expr2
);
6972 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6973 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6974 if (!INTEGER_CST_P (tmp
))
6975 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6976 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6979 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6981 gfc_init_se (&rse
, NULL
);
6982 rse
.want_pointer
= 1;
6983 gfc_conv_function_expr (&rse
, expr2
);
6984 if (expr1
->ts
.type
!= BT_CLASS
)
6986 rse
.expr
= gfc_class_data_get (rse
.expr
);
6987 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6991 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6992 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6994 gfc_add_vptr_component (expr1_vptr
);
6995 gfc_init_se (&rse
, NULL
);
6996 rse
.want_pointer
= 1;
6997 gfc_conv_expr (&rse
, expr1_vptr
);
6998 gfc_add_modify (&lse
.pre
, rse
.expr
,
6999 fold_convert (TREE_TYPE (rse
.expr
),
7000 gfc_class_vptr_get (tmp
)));
7001 rse
.expr
= gfc_class_data_get (tmp
);
7002 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7007 /* Assign to a temporary descriptor and then copy that
7008 temporary to the pointer. */
7009 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7011 lse
.direct_byref
= 1;
7012 gfc_conv_expr_descriptor (&lse
, expr2
);
7013 strlen_rhs
= lse
.string_length
;
7014 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7018 gfc_free_expr (expr1_vptr
);
7020 gfc_add_block_to_block (&block
, &lse
.pre
);
7022 gfc_add_block_to_block (&block
, &rse
.pre
);
7024 /* If we do bounds remapping, update LHS descriptor accordingly. */
7028 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7032 /* Do rank remapping. We already have the RHS's descriptor
7033 converted in rse and now have to build the correct LHS
7034 descriptor for it. */
7038 tree lbound
, ubound
;
7041 dtype
= gfc_conv_descriptor_dtype (desc
);
7042 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7043 gfc_add_modify (&block
, dtype
, tmp
);
7045 /* Copy data pointer. */
7046 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7047 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7049 /* Copy offset but adjust it such that it would correspond
7050 to a lbound of zero. */
7051 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7052 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7054 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7056 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7058 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7059 gfc_array_index_type
, stride
, lbound
);
7060 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7061 gfc_array_index_type
, offs
, tmp
);
7063 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7065 /* Set the bounds as declared for the LHS and calculate strides as
7066 well as another offset update accordingly. */
7067 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7069 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7074 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7076 /* Convert declared bounds. */
7077 gfc_init_se (&lower_se
, NULL
);
7078 gfc_init_se (&upper_se
, NULL
);
7079 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7080 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7082 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7083 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7085 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7086 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7088 lbound
= gfc_evaluate_now (lbound
, &block
);
7089 ubound
= gfc_evaluate_now (ubound
, &block
);
7091 gfc_add_block_to_block (&block
, &lower_se
.post
);
7092 gfc_add_block_to_block (&block
, &upper_se
.post
);
7094 /* Set bounds in descriptor. */
7095 gfc_conv_descriptor_lbound_set (&block
, desc
,
7096 gfc_rank_cst
[dim
], lbound
);
7097 gfc_conv_descriptor_ubound_set (&block
, desc
,
7098 gfc_rank_cst
[dim
], ubound
);
7101 stride
= gfc_evaluate_now (stride
, &block
);
7102 gfc_conv_descriptor_stride_set (&block
, desc
,
7103 gfc_rank_cst
[dim
], stride
);
7105 /* Update offset. */
7106 offs
= gfc_conv_descriptor_offset_get (desc
);
7107 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7108 gfc_array_index_type
, lbound
, stride
);
7109 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7110 gfc_array_index_type
, offs
, tmp
);
7111 offs
= gfc_evaluate_now (offs
, &block
);
7112 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7114 /* Update stride. */
7115 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7116 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7117 gfc_array_index_type
, stride
, tmp
);
7122 /* Bounds remapping. Just shift the lower bounds. */
7124 gcc_assert (expr1
->rank
== expr2
->rank
);
7126 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7130 gcc_assert (remap
->u
.ar
.start
[dim
]);
7131 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7132 gfc_init_se (&lbound_se
, NULL
);
7133 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7135 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7136 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7137 dim
, lbound_se
.expr
);
7138 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7143 /* Check string lengths if applicable. The check is only really added
7144 to the output code if -fbounds-check is enabled. */
7145 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7147 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7148 gcc_assert (strlen_lhs
&& strlen_rhs
);
7149 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7150 strlen_lhs
, strlen_rhs
, &block
);
7153 /* If rank remapping was done, check with -fcheck=bounds that
7154 the target is at least as large as the pointer. */
7155 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7161 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7162 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7164 lsize
= gfc_evaluate_now (lsize
, &block
);
7165 rsize
= gfc_evaluate_now (rsize
, &block
);
7166 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7169 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7170 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7174 gfc_add_block_to_block (&block
, &lse
.post
);
7176 gfc_add_block_to_block (&block
, &rse
.post
);
7179 return gfc_finish_block (&block
);
7183 /* Makes sure se is suitable for passing as a function string parameter. */
7184 /* TODO: Need to check all callers of this function. It may be abused. */
7187 gfc_conv_string_parameter (gfc_se
* se
)
7191 if (TREE_CODE (se
->expr
) == STRING_CST
)
7193 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7194 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7198 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7200 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7202 type
= TREE_TYPE (se
->expr
);
7203 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7207 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7209 type
= build_pointer_type (type
);
7210 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7214 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
7218 /* Generate code for assignment of scalar variables. Includes character
7219 strings and derived types with allocatable components.
7220 If you know that the LHS has no allocations, set dealloc to false.
7222 DEEP_COPY has no effect if the typespec TS is not a derived type with
7223 allocatable components. Otherwise, if it is set, an explicit copy of each
7224 allocatable component is made. This is necessary as a simple copy of the
7225 whole object would copy array descriptors as is, so that the lhs's
7226 allocatable components would point to the rhs's after the assignment.
7227 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7228 necessary if the rhs is a non-pointer function, as the allocatable components
7229 are not accessible by other means than the function's result after the
7230 function has returned. It is even more subtle when temporaries are involved,
7231 as the two following examples show:
7232 1. When we evaluate an array constructor, a temporary is created. Thus
7233 there is theoretically no alias possible. However, no deep copy is
7234 made for this temporary, so that if the constructor is made of one or
7235 more variable with allocatable components, those components still point
7236 to the variable's: DEEP_COPY should be set for the assignment from the
7237 temporary to the lhs in that case.
7238 2. When assigning a scalar to an array, we evaluate the scalar value out
7239 of the loop, store it into a temporary variable, and assign from that.
7240 In that case, deep copying when assigning to the temporary would be a
7241 waste of resources; however deep copies should happen when assigning from
7242 the temporary to each array element: again DEEP_COPY should be set for
7243 the assignment from the temporary to the lhs. */
7246 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7247 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7253 gfc_init_block (&block
);
7255 if (ts
.type
== BT_CHARACTER
)
7260 if (lse
->string_length
!= NULL_TREE
)
7262 gfc_conv_string_parameter (lse
);
7263 gfc_add_block_to_block (&block
, &lse
->pre
);
7264 llen
= lse
->string_length
;
7267 if (rse
->string_length
!= NULL_TREE
)
7269 gcc_assert (rse
->string_length
!= NULL_TREE
);
7270 gfc_conv_string_parameter (rse
);
7271 gfc_add_block_to_block (&block
, &rse
->pre
);
7272 rlen
= rse
->string_length
;
7275 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7276 rse
->expr
, ts
.kind
);
7278 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7280 tree tmp_var
= NULL_TREE
;
7283 /* Are the rhs and the lhs the same? */
7286 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7287 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7288 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7289 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7292 /* Deallocate the lhs allocated components as long as it is not
7293 the same as the rhs. This must be done following the assignment
7294 to prevent deallocating data that could be used in the rhs
7296 if (!l_is_temp
&& dealloc
)
7298 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7299 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7301 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7303 gfc_add_expr_to_block (&lse
->post
, tmp
);
7306 gfc_add_block_to_block (&block
, &rse
->pre
);
7307 gfc_add_block_to_block (&block
, &lse
->pre
);
7309 gfc_add_modify (&block
, lse
->expr
,
7310 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7312 /* Restore pointer address of coarray components. */
7313 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7315 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7316 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7318 gfc_add_expr_to_block (&block
, tmp
);
7321 /* Do a deep copy if the rhs is a variable, if it is not the
7325 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7326 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7328 gfc_add_expr_to_block (&block
, tmp
);
7331 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7333 gfc_add_block_to_block (&block
, &lse
->pre
);
7334 gfc_add_block_to_block (&block
, &rse
->pre
);
7335 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7336 TREE_TYPE (lse
->expr
), rse
->expr
);
7337 gfc_add_modify (&block
, lse
->expr
, tmp
);
7341 gfc_add_block_to_block (&block
, &lse
->pre
);
7342 gfc_add_block_to_block (&block
, &rse
->pre
);
7344 gfc_add_modify (&block
, lse
->expr
,
7345 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7348 gfc_add_block_to_block (&block
, &lse
->post
);
7349 gfc_add_block_to_block (&block
, &rse
->post
);
7351 return gfc_finish_block (&block
);
7355 /* There are quite a lot of restrictions on the optimisation in using an
7356 array function assign without a temporary. */
7359 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7362 bool seen_array_ref
;
7364 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7366 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7367 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7370 /* Elemental functions are scalarized so that they don't need a
7371 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7372 they would need special treatment in gfc_trans_arrayfunc_assign. */
7373 if (expr2
->value
.function
.esym
!= NULL
7374 && expr2
->value
.function
.esym
->attr
.elemental
)
7377 /* Need a temporary if rhs is not FULL or a contiguous section. */
7378 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7381 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7382 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7385 /* Functions returning pointers or allocatables need temporaries. */
7386 c
= expr2
->value
.function
.esym
7387 ? (expr2
->value
.function
.esym
->attr
.pointer
7388 || expr2
->value
.function
.esym
->attr
.allocatable
)
7389 : (expr2
->symtree
->n
.sym
->attr
.pointer
7390 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7394 /* Character array functions need temporaries unless the
7395 character lengths are the same. */
7396 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7398 if (expr1
->ts
.u
.cl
->length
== NULL
7399 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7402 if (expr2
->ts
.u
.cl
->length
== NULL
7403 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7406 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7407 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7411 /* Check that no LHS component references appear during an array
7412 reference. This is needed because we do not have the means to
7413 span any arbitrary stride with an array descriptor. This check
7414 is not needed for the rhs because the function result has to be
7416 seen_array_ref
= false;
7417 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7419 if (ref
->type
== REF_ARRAY
)
7420 seen_array_ref
= true;
7421 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7425 /* Check for a dependency. */
7426 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7427 expr2
->value
.function
.esym
,
7428 expr2
->value
.function
.actual
,
7432 /* If we have reached here with an intrinsic function, we do not
7433 need a temporary except in the particular case that reallocation
7434 on assignment is active and the lhs is allocatable and a target. */
7435 if (expr2
->value
.function
.isym
)
7436 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
7438 /* If the LHS is a dummy, we need a temporary if it is not
7440 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7443 /* If the lhs has been host_associated, is in common, a pointer or is
7444 a target and the function is not using a RESULT variable, aliasing
7445 can occur and a temporary is needed. */
7446 if ((sym
->attr
.host_assoc
7447 || sym
->attr
.in_common
7448 || sym
->attr
.pointer
7449 || sym
->attr
.cray_pointee
7450 || sym
->attr
.target
)
7451 && expr2
->symtree
!= NULL
7452 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7455 /* A PURE function can unconditionally be called without a temporary. */
7456 if (expr2
->value
.function
.esym
!= NULL
7457 && expr2
->value
.function
.esym
->attr
.pure
)
7460 /* Implicit_pure functions are those which could legally be declared
7462 if (expr2
->value
.function
.esym
!= NULL
7463 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7466 if (!sym
->attr
.use_assoc
7467 && !sym
->attr
.in_common
7468 && !sym
->attr
.pointer
7469 && !sym
->attr
.target
7470 && !sym
->attr
.cray_pointee
7471 && expr2
->value
.function
.esym
)
7473 /* A temporary is not needed if the function is not contained and
7474 the variable is local or host associated and not a pointer or
7476 if (!expr2
->value
.function
.esym
->attr
.contained
)
7479 /* A temporary is not needed if the lhs has never been host
7480 associated and the procedure is contained. */
7481 else if (!sym
->attr
.host_assoc
)
7484 /* A temporary is not needed if the variable is local and not
7485 a pointer, a target or a result. */
7487 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7491 /* Default to temporary use. */
7496 /* Provide the loop info so that the lhs descriptor can be built for
7497 reallocatable assignments from extrinsic function calls. */
7500 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7503 /* Signal that the function call should not be made by
7504 gfc_conv_loop_setup. */
7505 se
->ss
->is_alloc_lhs
= 1;
7506 gfc_init_loopinfo (loop
);
7507 gfc_add_ss_to_loop (loop
, *ss
);
7508 gfc_add_ss_to_loop (loop
, se
->ss
);
7509 gfc_conv_ss_startstride (loop
);
7510 gfc_conv_loop_setup (loop
, where
);
7511 gfc_copy_loopinfo_to_se (se
, loop
);
7512 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7513 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7514 se
->ss
->is_alloc_lhs
= 0;
7518 /* For assignment to a reallocatable lhs from intrinsic functions,
7519 replace the se.expr (ie. the result) with a temporary descriptor.
7520 Null the data field so that the library allocates space for the
7521 result. Free the data of the original descriptor after the function,
7522 in case it appears in an argument expression and transfer the
7523 result to the original descriptor. */
7526 fcncall_realloc_result (gfc_se
*se
, int rank
)
7535 /* Use the allocation done by the library. Substitute the lhs
7536 descriptor with a copy, whose data field is nulled.*/
7537 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7538 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7539 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7541 /* Unallocated, the descriptor does not have a dtype. */
7542 tmp
= gfc_conv_descriptor_dtype (desc
);
7543 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7545 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7546 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7547 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7549 /* Free the lhs after the function call and copy the result data to
7550 the lhs descriptor. */
7551 tmp
= gfc_conv_descriptor_data_get (desc
);
7552 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7553 boolean_type_node
, tmp
,
7554 build_int_cst (TREE_TYPE (tmp
), 0));
7555 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7556 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7557 gfc_add_expr_to_block (&se
->post
, tmp
);
7559 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7560 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7562 /* Check that the shapes are the same between lhs and expression. */
7563 for (n
= 0 ; n
< rank
; n
++)
7566 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7567 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7568 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7569 gfc_array_index_type
, tmp
, tmp1
);
7570 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7571 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7572 gfc_array_index_type
, tmp
, tmp1
);
7573 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7574 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7575 gfc_array_index_type
, tmp
, tmp1
);
7576 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7577 boolean_type_node
, tmp
,
7578 gfc_index_zero_node
);
7579 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7580 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7581 boolean_type_node
, tmp
,
7585 /* 'zero_cond' being true is equal to lhs not being allocated or the
7586 shapes being different. */
7587 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7589 /* Now reset the bounds returned from the function call to bounds based
7590 on the lhs lbounds, except where the lhs is not allocated or the shapes
7591 of 'variable and 'expr' are different. Set the offset accordingly. */
7592 offset
= gfc_index_zero_node
;
7593 for (n
= 0 ; n
< rank
; n
++)
7597 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7598 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7599 gfc_array_index_type
, zero_cond
,
7600 gfc_index_one_node
, lbound
);
7601 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7603 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7604 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7605 gfc_array_index_type
, tmp
, lbound
);
7606 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7607 gfc_rank_cst
[n
], lbound
);
7608 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7609 gfc_rank_cst
[n
], tmp
);
7611 /* Set stride and accumulate the offset. */
7612 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7613 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7614 gfc_rank_cst
[n
], tmp
);
7615 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7616 gfc_array_index_type
, lbound
, tmp
);
7617 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7618 gfc_array_index_type
, offset
, tmp
);
7619 offset
= gfc_evaluate_now (offset
, &se
->post
);
7622 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7627 /* Try to translate array(:) = func (...), where func is a transformational
7628 array function, without using a temporary. Returns NULL if this isn't the
7632 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7636 gfc_component
*comp
= NULL
;
7639 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7642 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7644 comp
= gfc_get_proc_ptr_comp (expr2
);
7645 gcc_assert (expr2
->value
.function
.isym
7646 || (comp
&& comp
->attr
.dimension
)
7647 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7648 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7650 gfc_init_se (&se
, NULL
);
7651 gfc_start_block (&se
.pre
);
7652 se
.want_pointer
= 1;
7654 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7656 if (expr1
->ts
.type
== BT_DERIVED
7657 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7660 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7662 gfc_add_expr_to_block (&se
.pre
, tmp
);
7665 se
.direct_byref
= 1;
7666 se
.ss
= gfc_walk_expr (expr2
);
7667 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7669 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7670 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7671 Clearly, this cannot be done for an allocatable function result, since
7672 the shape of the result is unknown and, in any case, the function must
7673 correctly take care of the reallocation internally. For intrinsic
7674 calls, the array data is freed and the library takes care of allocation.
7675 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7677 if (flag_realloc_lhs
7678 && gfc_is_reallocatable_lhs (expr1
)
7679 && !gfc_expr_attr (expr1
).codimension
7680 && !gfc_is_coindexed (expr1
)
7681 && !(expr2
->value
.function
.esym
7682 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7684 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7686 if (!expr2
->value
.function
.isym
)
7688 ss
= gfc_walk_expr (expr1
);
7689 gcc_assert (ss
!= gfc_ss_terminator
);
7691 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7692 ss
->is_alloc_lhs
= 1;
7695 fcncall_realloc_result (&se
, expr1
->rank
);
7698 gfc_conv_function_expr (&se
, expr2
);
7699 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7702 gfc_cleanup_loop (&loop
);
7704 gfc_free_ss_chain (se
.ss
);
7706 return gfc_finish_block (&se
.pre
);
7710 /* Try to efficiently translate array(:) = 0. Return NULL if this
7714 gfc_trans_zero_assign (gfc_expr
* expr
)
7716 tree dest
, len
, type
;
7720 sym
= expr
->symtree
->n
.sym
;
7721 dest
= gfc_get_symbol_decl (sym
);
7723 type
= TREE_TYPE (dest
);
7724 if (POINTER_TYPE_P (type
))
7725 type
= TREE_TYPE (type
);
7726 if (!GFC_ARRAY_TYPE_P (type
))
7729 /* Determine the length of the array. */
7730 len
= GFC_TYPE_ARRAY_SIZE (type
);
7731 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7734 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7735 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7736 fold_convert (gfc_array_index_type
, tmp
));
7738 /* If we are zeroing a local array avoid taking its address by emitting
7740 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7741 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7742 dest
, build_constructor (TREE_TYPE (dest
),
7745 /* Convert arguments to the correct types. */
7746 dest
= fold_convert (pvoid_type_node
, dest
);
7747 len
= fold_convert (size_type_node
, len
);
7749 /* Construct call to __builtin_memset. */
7750 tmp
= build_call_expr_loc (input_location
,
7751 builtin_decl_explicit (BUILT_IN_MEMSET
),
7752 3, dest
, integer_zero_node
, len
);
7753 return fold_convert (void_type_node
, tmp
);
7757 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7758 that constructs the call to __builtin_memcpy. */
7761 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7765 /* Convert arguments to the correct types. */
7766 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7767 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7769 dst
= fold_convert (pvoid_type_node
, dst
);
7771 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7772 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7774 src
= fold_convert (pvoid_type_node
, src
);
7776 len
= fold_convert (size_type_node
, len
);
7778 /* Construct call to __builtin_memcpy. */
7779 tmp
= build_call_expr_loc (input_location
,
7780 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7782 return fold_convert (void_type_node
, tmp
);
7786 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7787 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7788 source/rhs, both are gfc_full_array_ref_p which have been checked for
7792 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7794 tree dst
, dlen
, dtype
;
7795 tree src
, slen
, stype
;
7798 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7799 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7801 dtype
= TREE_TYPE (dst
);
7802 if (POINTER_TYPE_P (dtype
))
7803 dtype
= TREE_TYPE (dtype
);
7804 stype
= TREE_TYPE (src
);
7805 if (POINTER_TYPE_P (stype
))
7806 stype
= TREE_TYPE (stype
);
7808 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7811 /* Determine the lengths of the arrays. */
7812 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7813 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7815 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7816 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7817 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7819 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7820 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7822 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7823 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7824 slen
, fold_convert (gfc_array_index_type
, tmp
));
7826 /* Sanity check that they are the same. This should always be
7827 the case, as we should already have checked for conformance. */
7828 if (!tree_int_cst_equal (slen
, dlen
))
7831 return gfc_build_memcpy_call (dst
, src
, dlen
);
7835 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7836 this can't be done. EXPR1 is the destination/lhs for which
7837 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7840 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7842 unsigned HOST_WIDE_INT nelem
;
7848 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7852 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7853 dtype
= TREE_TYPE (dst
);
7854 if (POINTER_TYPE_P (dtype
))
7855 dtype
= TREE_TYPE (dtype
);
7856 if (!GFC_ARRAY_TYPE_P (dtype
))
7859 /* Determine the lengths of the array. */
7860 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7861 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7864 /* Confirm that the constructor is the same size. */
7865 if (compare_tree_int (len
, nelem
) != 0)
7868 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7869 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7870 fold_convert (gfc_array_index_type
, tmp
));
7872 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7873 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7875 stype
= TREE_TYPE (src
);
7876 if (POINTER_TYPE_P (stype
))
7877 stype
= TREE_TYPE (stype
);
7879 return gfc_build_memcpy_call (dst
, src
, len
);
7883 /* Tells whether the expression is to be treated as a variable reference. */
7886 expr_is_variable (gfc_expr
*expr
)
7889 gfc_component
*comp
;
7890 gfc_symbol
*func_ifc
;
7892 if (expr
->expr_type
== EXPR_VARIABLE
)
7895 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7898 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7899 return expr_is_variable (arg
);
7902 /* A data-pointer-returning function should be considered as a variable
7904 if (expr
->expr_type
== EXPR_FUNCTION
7905 && expr
->ref
== NULL
)
7907 if (expr
->value
.function
.isym
!= NULL
)
7910 if (expr
->value
.function
.esym
!= NULL
)
7912 func_ifc
= expr
->value
.function
.esym
;
7917 gcc_assert (expr
->symtree
);
7918 func_ifc
= expr
->symtree
->n
.sym
;
7925 comp
= gfc_get_proc_ptr_comp (expr
);
7926 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7929 func_ifc
= comp
->ts
.interface
;
7933 if (expr
->expr_type
== EXPR_COMPCALL
)
7935 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7936 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7943 gcc_assert (func_ifc
->attr
.function
7944 && func_ifc
->result
!= NULL
);
7945 return func_ifc
->result
->attr
.pointer
;
7949 /* Is the lhs OK for automatic reallocation? */
7952 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7956 /* An allocatable variable with no reference. */
7957 if (expr
->symtree
->n
.sym
->attr
.allocatable
7961 /* All that can be left are allocatable components. */
7962 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7963 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7964 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7967 /* Find an allocatable component ref last. */
7968 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7969 if (ref
->type
== REF_COMPONENT
7971 && ref
->u
.c
.component
->attr
.allocatable
)
7978 /* Allocate or reallocate scalar lhs, as necessary. */
7981 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7995 if (!expr1
|| expr1
->rank
)
7998 if (!expr2
|| expr2
->rank
)
8001 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8003 /* Since this is a scalar lhs, we can afford to do this. That is,
8004 there is no risk of side effects being repeated. */
8005 gfc_init_se (&lse
, NULL
);
8006 lse
.want_pointer
= 1;
8007 gfc_conv_expr (&lse
, expr1
);
8009 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8010 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8012 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8013 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8014 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8016 tmp
= build3_v (COND_EXPR
, cond
,
8017 build1_v (GOTO_EXPR
, jump_label1
),
8018 build_empty_stmt (input_location
));
8019 gfc_add_expr_to_block (block
, tmp
);
8021 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8023 /* Use the rhs string length and the lhs element size. */
8024 size
= string_length
;
8025 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8026 tmp
= TYPE_SIZE_UNIT (tmp
);
8027 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8028 TREE_TYPE (tmp
), tmp
,
8029 fold_convert (TREE_TYPE (tmp
), size
));
8033 /* Otherwise use the length in bytes of the rhs. */
8034 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8035 size_in_bytes
= size
;
8038 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8039 size_in_bytes
, size_one_node
);
8041 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8043 tmp
= build_call_expr_loc (input_location
,
8044 builtin_decl_explicit (BUILT_IN_CALLOC
),
8045 2, build_one_cst (size_type_node
),
8047 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8048 gfc_add_modify (block
, lse
.expr
, tmp
);
8052 tmp
= build_call_expr_loc (input_location
,
8053 builtin_decl_explicit (BUILT_IN_MALLOC
),
8055 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8056 gfc_add_modify (block
, lse
.expr
, tmp
);
8059 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8061 /* Deferred characters need checking for lhs and rhs string
8062 length. Other deferred parameter variables will have to
8064 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8065 gfc_add_expr_to_block (block
, tmp
);
8067 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8068 gfc_add_expr_to_block (block
, tmp
);
8070 /* For a deferred length character, reallocate if lengths of lhs and
8071 rhs are different. */
8072 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8074 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8075 expr1
->ts
.u
.cl
->backend_decl
, size
);
8076 /* Jump past the realloc if the lengths are the same. */
8077 tmp
= build3_v (COND_EXPR
, cond
,
8078 build1_v (GOTO_EXPR
, jump_label2
),
8079 build_empty_stmt (input_location
));
8080 gfc_add_expr_to_block (block
, tmp
);
8081 tmp
= build_call_expr_loc (input_location
,
8082 builtin_decl_explicit (BUILT_IN_REALLOC
),
8083 2, fold_convert (pvoid_type_node
, lse
.expr
),
8085 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8086 gfc_add_modify (block
, lse
.expr
, tmp
);
8087 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8088 gfc_add_expr_to_block (block
, tmp
);
8090 /* Update the lhs character length. */
8091 size
= string_length
;
8092 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8093 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
8095 gfc_add_modify (block
, lse
.string_length
, size
);
8099 /* Check for assignments of the type
8103 to make sure we do not check for reallocation unneccessarily. */
8107 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8109 gfc_actual_arglist
*a
;
8112 switch (expr2
->expr_type
)
8115 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8118 if (expr2
->value
.function
.esym
8119 && expr2
->value
.function
.esym
->attr
.elemental
)
8121 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8124 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8129 else if (expr2
->value
.function
.isym
8130 && expr2
->value
.function
.isym
->elemental
)
8132 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8135 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8144 switch (expr2
->value
.op
.op
)
8147 case INTRINSIC_UPLUS
:
8148 case INTRINSIC_UMINUS
:
8149 case INTRINSIC_PARENTHESES
:
8150 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8152 case INTRINSIC_PLUS
:
8153 case INTRINSIC_MINUS
:
8154 case INTRINSIC_TIMES
:
8155 case INTRINSIC_DIVIDE
:
8156 case INTRINSIC_POWER
:
8160 case INTRINSIC_NEQV
:
8167 case INTRINSIC_EQ_OS
:
8168 case INTRINSIC_NE_OS
:
8169 case INTRINSIC_GT_OS
:
8170 case INTRINSIC_GE_OS
:
8171 case INTRINSIC_LT_OS
:
8172 case INTRINSIC_LE_OS
:
8174 e1
= expr2
->value
.op
.op1
;
8175 e2
= expr2
->value
.op
.op2
;
8177 if (e1
->rank
== 0 && e2
->rank
> 0)
8178 return is_runtime_conformable (expr1
, e2
);
8179 else if (e1
->rank
> 0 && e2
->rank
== 0)
8180 return is_runtime_conformable (expr1
, e1
);
8181 else if (e1
->rank
> 0 && e2
->rank
> 0)
8182 return is_runtime_conformable (expr1
, e1
)
8183 && is_runtime_conformable (expr1
, e2
);
8199 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8200 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8201 init_flag indicates initialization expressions and dealloc that no
8202 deallocate prior assignment is needed (if in doubt, set true). */
8205 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8211 gfc_ss
*lss_section
;
8218 bool scalar_to_array
;
8222 /* Assignment of the form lhs = rhs. */
8223 gfc_start_block (&block
);
8225 gfc_init_se (&lse
, NULL
);
8226 gfc_init_se (&rse
, NULL
);
8229 lss
= gfc_walk_expr (expr1
);
8230 if (gfc_is_reallocatable_lhs (expr1
)
8231 && !(expr2
->expr_type
== EXPR_FUNCTION
8232 && expr2
->value
.function
.isym
!= NULL
))
8233 lss
->is_alloc_lhs
= 1;
8235 if (lss
!= gfc_ss_terminator
)
8237 /* The assignment needs scalarization. */
8240 /* Find a non-scalar SS from the lhs. */
8241 while (lss_section
!= gfc_ss_terminator
8242 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8243 lss_section
= lss_section
->next
;
8245 gcc_assert (lss_section
!= gfc_ss_terminator
);
8247 /* Initialize the scalarizer. */
8248 gfc_init_loopinfo (&loop
);
8251 rss
= gfc_walk_expr (expr2
);
8252 if (rss
== gfc_ss_terminator
)
8253 /* The rhs is scalar. Add a ss for the expression. */
8254 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8256 /* Associate the SS with the loop. */
8257 gfc_add_ss_to_loop (&loop
, lss
);
8258 gfc_add_ss_to_loop (&loop
, rss
);
8260 /* Calculate the bounds of the scalarization. */
8261 gfc_conv_ss_startstride (&loop
);
8262 /* Enable loop reversal. */
8263 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8264 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8265 /* Resolve any data dependencies in the statement. */
8266 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8267 /* Setup the scalarizing loops. */
8268 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8270 /* Setup the gfc_se structures. */
8271 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8272 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8275 gfc_mark_ss_chain_used (rss
, 1);
8276 if (loop
.temp_ss
== NULL
)
8279 gfc_mark_ss_chain_used (lss
, 1);
8283 lse
.ss
= loop
.temp_ss
;
8284 gfc_mark_ss_chain_used (lss
, 3);
8285 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8288 /* Allow the scalarizer to workshare array assignments. */
8289 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8290 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8292 /* Start the scalarized loop body. */
8293 gfc_start_scalarized_body (&loop
, &body
);
8296 gfc_init_block (&body
);
8298 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8300 /* Translate the expression. */
8301 gfc_conv_expr (&rse
, expr2
);
8303 /* Stabilize a string length for temporaries. */
8304 if (expr2
->ts
.type
== BT_CHARACTER
)
8305 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8307 string_length
= NULL_TREE
;
8311 gfc_conv_tmp_array_ref (&lse
);
8312 if (expr2
->ts
.type
== BT_CHARACTER
)
8313 lse
.string_length
= string_length
;
8316 gfc_conv_expr (&lse
, expr1
);
8318 /* Assignments of scalar derived types with allocatable components
8319 to arrays must be done with a deep copy and the rhs temporary
8320 must have its components deallocated afterwards. */
8321 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8322 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8323 && !expr_is_variable (expr2
)
8324 && !gfc_is_constant_expr (expr2
)
8325 && expr1
->rank
&& !expr2
->rank
);
8326 if (scalar_to_array
&& dealloc
)
8328 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8329 gfc_add_expr_to_block (&loop
.post
, tmp
);
8332 /* When assigning a character function result to a deferred-length variable,
8333 the function call must happen before the (re)allocation of the lhs -
8334 otherwise the character length of the result is not known.
8335 NOTE: This relies on having the exact dependence of the length type
8336 parameter available to the caller; gfortran saves it in the .mod files. */
8337 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8338 gfc_add_block_to_block (&block
, &rse
.pre
);
8340 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8341 l_is_temp
|| init_flag
,
8342 expr_is_variable (expr2
) || scalar_to_array
8343 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8344 gfc_add_expr_to_block (&body
, tmp
);
8346 if (lss
== gfc_ss_terminator
)
8348 /* F2003: Add the code for reallocation on assignment. */
8349 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
8350 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8353 /* Use the scalar assignment as is. */
8354 gfc_add_block_to_block (&block
, &body
);
8358 gcc_assert (lse
.ss
== gfc_ss_terminator
8359 && rse
.ss
== gfc_ss_terminator
);
8363 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8365 /* We need to copy the temporary to the actual lhs. */
8366 gfc_init_se (&lse
, NULL
);
8367 gfc_init_se (&rse
, NULL
);
8368 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8369 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8371 rse
.ss
= loop
.temp_ss
;
8374 gfc_conv_tmp_array_ref (&rse
);
8375 gfc_conv_expr (&lse
, expr1
);
8377 gcc_assert (lse
.ss
== gfc_ss_terminator
8378 && rse
.ss
== gfc_ss_terminator
);
8380 if (expr2
->ts
.type
== BT_CHARACTER
)
8381 rse
.string_length
= string_length
;
8383 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8384 false, false, dealloc
);
8385 gfc_add_expr_to_block (&body
, tmp
);
8388 /* F2003: Allocate or reallocate lhs of allocatable array. */
8389 if (flag_realloc_lhs
8390 && gfc_is_reallocatable_lhs (expr1
)
8391 && !gfc_expr_attr (expr1
).codimension
8392 && !gfc_is_coindexed (expr1
)
8394 && !is_runtime_conformable (expr1
, expr2
))
8396 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8397 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8398 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8399 if (tmp
!= NULL_TREE
)
8400 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8403 /* Generate the copying loops. */
8404 gfc_trans_scalarizing_loops (&loop
, &body
);
8406 /* Wrap the whole thing up. */
8407 gfc_add_block_to_block (&block
, &loop
.pre
);
8408 gfc_add_block_to_block (&block
, &loop
.post
);
8410 gfc_cleanup_loop (&loop
);
8413 return gfc_finish_block (&block
);
8417 /* Check whether EXPR is a copyable array. */
8420 copyable_array_p (gfc_expr
* expr
)
8422 if (expr
->expr_type
!= EXPR_VARIABLE
)
8425 /* First check it's an array. */
8426 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8429 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8432 /* Next check that it's of a simple enough type. */
8433 switch (expr
->ts
.type
)
8445 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8454 /* Translate an assignment. */
8457 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8462 /* Special case a single function returning an array. */
8463 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8465 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8470 /* Special case assigning an array to zero. */
8471 if (copyable_array_p (expr1
)
8472 && is_zero_initializer_p (expr2
))
8474 tmp
= gfc_trans_zero_assign (expr1
);
8479 /* Special case copying one array to another. */
8480 if (copyable_array_p (expr1
)
8481 && copyable_array_p (expr2
)
8482 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8483 && !gfc_check_dependency (expr1
, expr2
, 0))
8485 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8490 /* Special case initializing an array from a constant array constructor. */
8491 if (copyable_array_p (expr1
)
8492 && expr2
->expr_type
== EXPR_ARRAY
8493 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8495 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8500 /* Fallback to the scalarizer to generate explicit loops. */
8501 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8505 gfc_trans_init_assign (gfc_code
* code
)
8507 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8511 gfc_trans_assign (gfc_code
* code
)
8513 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);