1 /* Expression translation
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
29 #include "stringpool.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
61 scalar
= TREE_TYPE (scalar
);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
63 akind
, !(attr
.pointer
|| attr
.target
));
67 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
71 type
= get_scalar_to_descriptor_type (scalar
, attr
);
72 desc
= gfc_create_var (type
, "desc");
73 DECL_ARTIFICIAL (desc
) = 1;
75 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
76 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
77 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
78 gfc_get_dtype (type
));
79 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
81 /* Copy pointer address back - but only if it could have changed and
82 if the actual argument is a pointer and not, e.g., NULL(). */
83 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
84 gfc_add_modify (&se
->post
, scalar
,
85 fold_convert (TREE_TYPE (scalar
),
86 gfc_conv_descriptor_data_get (desc
)));
91 /* This is the seed for an eventual trans-class.c
93 The following parameters should not be used directly since they might
94 in future implementations. Use the corresponding APIs. */
95 #define CLASS_DATA_FIELD 0
96 #define CLASS_VPTR_FIELD 1
97 #define VTABLE_HASH_FIELD 0
98 #define VTABLE_SIZE_FIELD 1
99 #define VTABLE_EXTENDS_FIELD 2
100 #define VTABLE_DEF_INIT_FIELD 3
101 #define VTABLE_COPY_FIELD 4
102 #define VTABLE_FINAL_FIELD 5
106 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
110 vec
<constructor_elt
, va_gc
> *init
= NULL
;
112 field
= TYPE_FIELDS (TREE_TYPE (decl
));
113 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
114 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
116 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
117 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
119 return build_constructor (TREE_TYPE (decl
), init
);
124 gfc_class_data_get (tree decl
)
127 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
128 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
129 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
131 return fold_build3_loc (input_location
, COMPONENT_REF
,
132 TREE_TYPE (data
), decl
, data
,
138 gfc_class_vptr_get (tree decl
)
141 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
142 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
143 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
145 return fold_build3_loc (input_location
, COMPONENT_REF
,
146 TREE_TYPE (vptr
), decl
, vptr
,
152 gfc_vtable_field_get (tree decl
, int field
)
156 vptr
= gfc_class_vptr_get (decl
);
157 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
158 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
160 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
161 TREE_TYPE (size
), vptr
, size
,
163 /* Always return size as an array index type. */
164 if (field
== VTABLE_SIZE_FIELD
)
165 size
= fold_convert (gfc_array_index_type
, size
);
172 gfc_vtable_hash_get (tree decl
)
174 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
179 gfc_vtable_size_get (tree decl
)
181 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
186 gfc_vtable_extends_get (tree decl
)
188 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
193 gfc_vtable_def_init_get (tree decl
)
195 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
200 gfc_vtable_copy_get (tree decl
)
202 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
207 gfc_vtable_final_get (tree decl
)
209 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
213 #undef CLASS_DATA_FIELD
214 #undef CLASS_VPTR_FIELD
215 #undef VTABLE_HASH_FIELD
216 #undef VTABLE_SIZE_FIELD
217 #undef VTABLE_EXTENDS_FIELD
218 #undef VTABLE_DEF_INIT_FIELD
219 #undef VTABLE_COPY_FIELD
220 #undef VTABLE_FINAL_FIELD
223 /* Reset the vptr to the declared type, e.g. after deallocation. */
226 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
228 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
233 /* If we have a class array, we need go back to the class
235 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
236 && lhs
->ref
->next
->type
== REF_ARRAY
237 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
238 && lhs
->ref
->type
== REF_COMPONENT
239 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
241 gfc_free_ref_list (lhs
->ref
);
245 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
246 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
247 && ref
->next
->next
->type
== REF_ARRAY
248 && ref
->next
->next
->u
.ar
.type
== AR_FULL
249 && ref
->next
->type
== REF_COMPONENT
250 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
252 gfc_free_ref_list (ref
->next
);
256 gfc_add_vptr_component (lhs
);
258 if (UNLIMITED_POLY (e
))
259 rhs
= gfc_get_null_expr (NULL
);
262 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
263 rhs
= gfc_lval_expr_from_sym (vtab
);
265 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
266 gfc_add_expr_to_block (block
, tmp
);
272 /* Obtain the vptr of the last class reference in an expression.
273 Return NULL_TREE if no class reference is found. */
276 gfc_get_vptr_from_expr (tree expr
)
281 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
283 type
= TREE_TYPE (tmp
);
286 if (GFC_CLASS_TYPE_P (type
))
287 return gfc_class_vptr_get (tmp
);
288 if (type
!= TYPE_CANONICAL (type
))
289 type
= TYPE_CANONICAL (type
);
293 if (TREE_CODE (tmp
) == VAR_DECL
)
301 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
304 tree tmp
, tmp2
, type
;
306 gfc_conv_descriptor_data_set (block
, lhs_desc
,
307 gfc_conv_descriptor_data_get (rhs_desc
));
308 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
309 gfc_conv_descriptor_offset_get (rhs_desc
));
311 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
312 gfc_conv_descriptor_dtype (rhs_desc
));
314 /* Assign the dimension as range-ref. */
315 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
316 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
318 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
319 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
320 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
321 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
322 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
323 gfc_add_modify (block
, tmp
, tmp2
);
327 /* Takes a derived type expression and returns the address of a temporary
328 class object of the 'declared' type. If vptr is not NULL, this is
329 used for the temporary class object.
330 optional_alloc_ptr is false when the dummy is neither allocatable
331 nor a pointer; that's only relevant for the optional handling. */
333 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
334 gfc_typespec class_ts
, tree vptr
, bool optional
,
335 bool optional_alloc_ptr
)
338 tree cond_optional
= NULL_TREE
;
344 /* The derived type needs to be converted to a temporary
346 tmp
= gfc_typenode_for_spec (&class_ts
);
347 var
= gfc_create_var (tmp
, "class");
350 ctree
= gfc_class_vptr_get (var
);
352 if (vptr
!= NULL_TREE
)
354 /* Use the dynamic vptr. */
359 /* In this case the vtab corresponds to the derived type and the
360 vptr must point to it. */
361 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
363 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
365 gfc_add_modify (&parmse
->pre
, ctree
,
366 fold_convert (TREE_TYPE (ctree
), tmp
));
368 /* Now set the data field. */
369 ctree
= gfc_class_data_get (var
);
372 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
374 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
376 /* For an array reference in an elemental procedure call we need
377 to retain the ss to provide the scalarized array reference. */
378 gfc_conv_expr_reference (parmse
, e
);
379 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
381 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
383 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
384 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
389 ss
= gfc_walk_expr (e
);
390 if (ss
== gfc_ss_terminator
)
393 gfc_conv_expr_reference (parmse
, e
);
395 /* Scalar to an assumed-rank array. */
396 if (class_ts
.u
.derived
->components
->as
)
399 type
= get_scalar_to_descriptor_type (parmse
->expr
,
401 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
402 gfc_get_dtype (type
));
404 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
405 TREE_TYPE (parmse
->expr
),
406 cond_optional
, parmse
->expr
,
407 fold_convert (TREE_TYPE (parmse
->expr
),
409 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
413 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
415 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
417 fold_convert (TREE_TYPE (tmp
),
419 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
425 gfc_init_block (&block
);
428 gfc_conv_expr_descriptor (parmse
, e
);
430 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
432 gcc_assert (class_ts
.u
.derived
->components
->as
->type
434 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
438 if (gfc_expr_attr (e
).codimension
)
439 parmse
->expr
= fold_build1_loc (input_location
,
443 gfc_add_modify (&block
, ctree
, parmse
->expr
);
448 tmp
= gfc_finish_block (&block
);
450 gfc_init_block (&block
);
451 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
453 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
454 gfc_finish_block (&block
));
455 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
458 gfc_add_block_to_block (&parmse
->pre
, &block
);
462 /* Pass the address of the class object. */
463 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
465 if (optional
&& optional_alloc_ptr
)
466 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
467 TREE_TYPE (parmse
->expr
),
468 cond_optional
, parmse
->expr
,
469 fold_convert (TREE_TYPE (parmse
->expr
),
474 /* Create a new class container, which is required as scalar coarrays
475 have an array descriptor while normal scalars haven't. Optionally,
476 NULL pointer checks are added if the argument is OPTIONAL. */
479 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
480 gfc_typespec class_ts
, bool optional
)
482 tree var
, ctree
, tmp
;
487 gfc_init_block (&block
);
490 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
492 if (ref
->type
== REF_COMPONENT
493 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
497 if (class_ref
== NULL
498 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
499 tmp
= e
->symtree
->n
.sym
->backend_decl
;
502 /* Remove everything after the last class reference, convert the
503 expression and then recover its tailend once more. */
505 ref
= class_ref
->next
;
506 class_ref
->next
= NULL
;
507 gfc_init_se (&tmpse
, NULL
);
508 gfc_conv_expr (&tmpse
, e
);
509 class_ref
->next
= ref
;
513 var
= gfc_typenode_for_spec (&class_ts
);
514 var
= gfc_create_var (var
, "class");
516 ctree
= gfc_class_vptr_get (var
);
517 gfc_add_modify (&block
, ctree
,
518 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
520 ctree
= gfc_class_data_get (var
);
521 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
522 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
524 /* Pass the address of the class object. */
525 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
529 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
532 tmp
= gfc_finish_block (&block
);
534 gfc_init_block (&block
);
535 tmp2
= gfc_class_data_get (var
);
536 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
538 tmp2
= gfc_finish_block (&block
);
540 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
542 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
545 gfc_add_block_to_block (&parmse
->pre
, &block
);
549 /* Takes an intrinsic type expression and returns the address of a temporary
550 class object of the 'declared' type. */
552 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
553 gfc_typespec class_ts
)
561 /* The intrinsic type needs to be converted to a temporary
563 tmp
= gfc_typenode_for_spec (&class_ts
);
564 var
= gfc_create_var (tmp
, "class");
567 ctree
= gfc_class_vptr_get (var
);
569 vtab
= gfc_find_vtab (&e
->ts
);
571 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
572 gfc_add_modify (&parmse
->pre
, ctree
,
573 fold_convert (TREE_TYPE (ctree
), tmp
));
575 /* Now set the data field. */
576 ctree
= gfc_class_data_get (var
);
577 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
579 /* For an array reference in an elemental procedure call we need
580 to retain the ss to provide the scalarized array reference. */
581 gfc_conv_expr_reference (parmse
, e
);
582 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
583 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
587 ss
= gfc_walk_expr (e
);
588 if (ss
== gfc_ss_terminator
)
591 gfc_conv_expr_reference (parmse
, e
);
592 if (class_ts
.u
.derived
->components
->as
593 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
595 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
597 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
598 TREE_TYPE (ctree
), tmp
);
601 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
602 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
607 parmse
->use_offset
= 1;
608 gfc_conv_expr_descriptor (parmse
, e
);
609 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
611 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
612 TREE_TYPE (ctree
), parmse
->expr
);
613 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
616 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
620 /* Pass the address of the class object. */
621 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
625 /* Takes a scalarized class array expression and returns the
626 address of a temporary scalar class object of the 'declared'
628 OOP-TODO: This could be improved by adding code that branched on
629 the dynamic type being the same as the declared type. In this case
630 the original class expression can be passed directly.
631 optional_alloc_ptr is false when the dummy is neither allocatable
632 nor a pointer; that's relevant for the optional handling.
633 Set copyback to true if class container's _data and _vtab pointers
634 might get modified. */
637 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
638 bool elemental
, bool copyback
, bool optional
,
639 bool optional_alloc_ptr
)
645 tree cond
= NULL_TREE
;
649 bool full_array
= false;
651 gfc_init_block (&block
);
654 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
656 if (ref
->type
== REF_COMPONENT
657 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
660 if (ref
->next
== NULL
)
664 if ((ref
== NULL
|| class_ref
== ref
)
665 && (!class_ts
.u
.derived
->components
->as
666 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
669 /* Test for FULL_ARRAY. */
670 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
671 && gfc_expr_attr (e
).dimension
)
674 gfc_is_class_array_ref (e
, &full_array
);
676 /* The derived type needs to be converted to a temporary
678 tmp
= gfc_typenode_for_spec (&class_ts
);
679 var
= gfc_create_var (tmp
, "class");
682 ctree
= gfc_class_data_get (var
);
683 if (class_ts
.u
.derived
->components
->as
684 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
688 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
690 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
691 gfc_get_dtype (type
));
693 tmp
= gfc_class_data_get (parmse
->expr
);
694 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
695 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
697 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
700 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
704 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
705 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
706 TREE_TYPE (ctree
), parmse
->expr
);
707 gfc_add_modify (&block
, ctree
, parmse
->expr
);
710 /* Return the data component, except in the case of scalarized array
711 references, where nullification of the cannot occur and so there
713 if (!elemental
&& full_array
&& copyback
)
715 if (class_ts
.u
.derived
->components
->as
716 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
719 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
720 gfc_conv_descriptor_data_get (ctree
));
722 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
725 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
729 ctree
= gfc_class_vptr_get (var
);
731 /* The vptr is the second field of the actual argument.
732 First we have to find the corresponding class reference. */
735 if (class_ref
== NULL
736 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
737 tmp
= e
->symtree
->n
.sym
->backend_decl
;
740 /* Remove everything after the last class reference, convert the
741 expression and then recover its tailend once more. */
743 ref
= class_ref
->next
;
744 class_ref
->next
= NULL
;
745 gfc_init_se (&tmpse
, NULL
);
746 gfc_conv_expr (&tmpse
, e
);
747 class_ref
->next
= ref
;
751 gcc_assert (tmp
!= NULL_TREE
);
753 /* Dereference if needs be. */
754 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
755 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
757 vptr
= gfc_class_vptr_get (tmp
);
758 gfc_add_modify (&block
, ctree
,
759 fold_convert (TREE_TYPE (ctree
), vptr
));
761 /* Return the vptr component, except in the case of scalarized array
762 references, where the dynamic type cannot change. */
763 if (!elemental
&& full_array
&& copyback
)
764 gfc_add_modify (&parmse
->post
, vptr
,
765 fold_convert (TREE_TYPE (vptr
), ctree
));
771 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
772 tmp
= gfc_finish_block (&block
);
774 if (optional_alloc_ptr
)
775 tmp2
= build_empty_stmt (input_location
);
778 gfc_init_block (&block
);
780 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
781 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
783 tmp2
= gfc_finish_block (&block
);
786 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
788 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
791 gfc_add_block_to_block (&parmse
->pre
, &block
);
793 /* Pass the address of the class object. */
794 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
796 if (optional
&& optional_alloc_ptr
)
797 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
798 TREE_TYPE (parmse
->expr
),
800 fold_convert (TREE_TYPE (parmse
->expr
),
805 /* Given a class array declaration and an index, returns the address
806 of the referenced element. */
809 gfc_get_class_array_ref (tree index
, tree class_decl
)
811 tree data
= gfc_class_data_get (class_decl
);
812 tree size
= gfc_vtable_size_get (class_decl
);
813 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
814 gfc_array_index_type
,
817 data
= gfc_conv_descriptor_data_get (data
);
818 ptr
= fold_convert (pvoid_type_node
, data
);
819 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
820 return fold_convert (TREE_TYPE (data
), ptr
);
824 /* Copies one class expression to another, assuming that if either
825 'to' or 'from' are arrays they are packed. Should 'from' be
826 NULL_TREE, the initialization expression for 'to' is used, assuming
827 that the _vptr is set. */
830 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
838 vec
<tree
, va_gc
> *args
;
841 stmtblock_t loopbody
;
847 if (from
!= NULL_TREE
)
848 fcn
= gfc_vtable_copy_get (from
);
850 fcn
= gfc_vtable_copy_get (to
);
852 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
854 if (from
!= NULL_TREE
)
855 from_data
= gfc_class_data_get (from
);
857 from_data
= gfc_vtable_def_init_get (to
);
859 to_data
= gfc_class_data_get (to
);
861 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
863 gfc_init_block (&body
);
864 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
865 gfc_array_index_type
, nelems
,
867 nelems
= gfc_evaluate_now (tmp
, &body
);
868 index
= gfc_create_var (gfc_array_index_type
, "S");
870 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
872 from_ref
= gfc_get_class_array_ref (index
, from
);
873 vec_safe_push (args
, from_ref
);
876 vec_safe_push (args
, from_data
);
878 to_ref
= gfc_get_class_array_ref (index
, to
);
879 vec_safe_push (args
, to_ref
);
881 tmp
= build_call_vec (fcn_type
, fcn
, args
);
883 /* Build the body of the loop. */
884 gfc_init_block (&loopbody
);
885 gfc_add_expr_to_block (&loopbody
, tmp
);
887 /* Build the loop and return. */
888 gfc_init_loopinfo (&loop
);
890 loop
.from
[0] = gfc_index_zero_node
;
891 loop
.loopvar
[0] = index
;
893 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
894 gfc_add_block_to_block (&body
, &loop
.pre
);
895 tmp
= gfc_finish_block (&body
);
896 gfc_cleanup_loop (&loop
);
900 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
901 vec_safe_push (args
, from_data
);
902 vec_safe_push (args
, to_data
);
903 tmp
= build_call_vec (fcn_type
, fcn
, args
);
910 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
912 gfc_actual_arglist
*actual
;
917 actual
= gfc_get_actual_arglist ();
918 actual
->expr
= gfc_copy_expr (rhs
);
919 actual
->next
= gfc_get_actual_arglist ();
920 actual
->next
->expr
= gfc_copy_expr (lhs
);
921 ppc
= gfc_copy_expr (obj
);
922 gfc_add_vptr_component (ppc
);
923 gfc_add_component_ref (ppc
, "_copy");
924 ppc_code
= gfc_get_code (EXEC_CALL
);
925 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
926 /* Although '_copy' is set to be elemental in class.c, it is
927 not staying that way. Find out why, sometime.... */
928 ppc_code
->resolved_sym
->attr
.elemental
= 1;
929 ppc_code
->ext
.actual
= actual
;
930 ppc_code
->expr1
= ppc
;
931 /* Since '_copy' is elemental, the scalarizer will take care
932 of arrays in gfc_trans_call. */
933 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
934 gfc_free_statements (ppc_code
);
938 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
939 A MEMCPY is needed to copy the full data from the default initializer
940 of the dynamic type. */
943 gfc_trans_class_init_assign (gfc_code
*code
)
947 gfc_se dst
,src
,memsz
;
948 gfc_expr
*lhs
, *rhs
, *sz
;
950 gfc_start_block (&block
);
952 lhs
= gfc_copy_expr (code
->expr1
);
953 gfc_add_data_component (lhs
);
955 rhs
= gfc_copy_expr (code
->expr1
);
956 gfc_add_vptr_component (rhs
);
958 /* Make sure that the component backend_decls have been built, which
959 will not have happened if the derived types concerned have not
961 gfc_get_derived_type (rhs
->ts
.u
.derived
);
962 gfc_add_def_init_component (rhs
);
964 if (code
->expr1
->ts
.type
== BT_CLASS
965 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
966 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
969 sz
= gfc_copy_expr (code
->expr1
);
970 gfc_add_vptr_component (sz
);
971 gfc_add_size_component (sz
);
973 gfc_init_se (&dst
, NULL
);
974 gfc_init_se (&src
, NULL
);
975 gfc_init_se (&memsz
, NULL
);
976 gfc_conv_expr (&dst
, lhs
);
977 gfc_conv_expr (&src
, rhs
);
978 gfc_conv_expr (&memsz
, sz
);
979 gfc_add_block_to_block (&block
, &src
.pre
);
980 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
982 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
985 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
986 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
988 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
989 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
991 build_empty_stmt (input_location
));
994 gfc_add_expr_to_block (&block
, tmp
);
996 return gfc_finish_block (&block
);
1000 /* Translate an assignment to a CLASS object
1001 (pointer or ordinary assignment). */
1004 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1012 gfc_start_block (&block
);
1015 while (ref
&& ref
->next
)
1018 /* Class valued proc_pointer assignments do not need any further
1020 if (ref
&& ref
->type
== REF_COMPONENT
1021 && ref
->u
.c
.component
->attr
.proc_pointer
1022 && expr2
->expr_type
== EXPR_VARIABLE
1023 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1024 && op
== EXEC_POINTER_ASSIGN
)
1027 if (expr2
->ts
.type
!= BT_CLASS
)
1029 /* Insert an additional assignment which sets the '_vptr' field. */
1030 gfc_symbol
*vtab
= NULL
;
1033 lhs
= gfc_copy_expr (expr1
);
1034 gfc_add_vptr_component (lhs
);
1036 if (UNLIMITED_POLY (expr1
)
1037 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1039 rhs
= gfc_get_null_expr (&expr2
->where
);
1043 if (expr2
->expr_type
== EXPR_NULL
)
1044 vtab
= gfc_find_vtab (&expr1
->ts
);
1046 vtab
= gfc_find_vtab (&expr2
->ts
);
1049 rhs
= gfc_get_expr ();
1050 rhs
->expr_type
= EXPR_VARIABLE
;
1051 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1055 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1056 gfc_add_expr_to_block (&block
, tmp
);
1058 gfc_free_expr (lhs
);
1059 gfc_free_expr (rhs
);
1061 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1063 /* F2003:C717 only sequence and bind-C types can come here. */
1064 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1065 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1066 gfc_add_data_component (expr2
);
1069 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1071 /* Insert an additional assignment which sets the '_vptr' field. */
1072 lhs
= gfc_copy_expr (expr1
);
1073 gfc_add_vptr_component (lhs
);
1075 rhs
= gfc_copy_expr (expr2
);
1076 gfc_add_vptr_component (rhs
);
1078 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1079 gfc_add_expr_to_block (&block
, tmp
);
1081 gfc_free_expr (lhs
);
1082 gfc_free_expr (rhs
);
1085 /* Do the actual CLASS assignment. */
1086 if (expr2
->ts
.type
== BT_CLASS
1087 && !CLASS_DATA (expr2
)->attr
.dimension
)
1089 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1090 || !CLASS_DATA (expr2
)->attr
.dimension
)
1091 gfc_add_data_component (expr1
);
1095 if (op
== EXEC_ASSIGN
)
1096 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1097 else if (op
== EXEC_POINTER_ASSIGN
)
1098 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1102 gfc_add_expr_to_block (&block
, tmp
);
1104 return gfc_finish_block (&block
);
1108 /* End of prototype trans-class.c */
1112 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1114 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1115 && gfc_option
.warn_realloc_lhs
)
1116 gfc_warning ("Code for reallocating the allocatable array at %L will "
1118 else if (gfc_option
.warn_realloc_lhs_all
)
1119 gfc_warning ("Code for reallocating the allocatable variable at %L "
1120 "will be added", where
);
1124 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1125 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1128 /* Copy the scalarization loop variables. */
1131 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1134 dest
->loop
= src
->loop
;
1138 /* Initialize a simple expression holder.
1140 Care must be taken when multiple se are created with the same parent.
1141 The child se must be kept in sync. The easiest way is to delay creation
1142 of a child se until after after the previous se has been translated. */
1145 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1147 memset (se
, 0, sizeof (gfc_se
));
1148 gfc_init_block (&se
->pre
);
1149 gfc_init_block (&se
->post
);
1151 se
->parent
= parent
;
1154 gfc_copy_se_loopvars (se
, parent
);
1158 /* Advances to the next SS in the chain. Use this rather than setting
1159 se->ss = se->ss->next because all the parents needs to be kept in sync.
1163 gfc_advance_se_ss_chain (gfc_se
* se
)
1168 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1171 /* Walk down the parent chain. */
1174 /* Simple consistency check. */
1175 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1176 || p
->parent
->ss
->nested_ss
== p
->ss
);
1178 /* If we were in a nested loop, the next scalarized expression can be
1179 on the parent ss' next pointer. Thus we should not take the next
1180 pointer blindly, but rather go up one nest level as long as next
1181 is the end of chain. */
1183 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1193 /* Ensures the result of the expression as either a temporary variable
1194 or a constant so that it can be used repeatedly. */
1197 gfc_make_safe_expr (gfc_se
* se
)
1201 if (CONSTANT_CLASS_P (se
->expr
))
1204 /* We need a temporary for this result. */
1205 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1206 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1211 /* Return an expression which determines if a dummy parameter is present.
1212 Also used for arguments to procedures with multiple entry points. */
1215 gfc_conv_expr_present (gfc_symbol
* sym
)
1219 gcc_assert (sym
->attr
.dummy
);
1220 decl
= gfc_get_symbol_decl (sym
);
1222 /* Intrinsic scalars with VALUE attribute which are passed by value
1223 use a hidden argument to denote the present status. */
1224 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1225 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1226 && !sym
->attr
.dimension
)
1228 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1231 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1233 strcpy (&name
[1], sym
->name
);
1234 tree_name
= get_identifier (name
);
1236 /* Walk function argument list to find hidden arg. */
1237 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1238 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1239 if (DECL_NAME (cond
) == tree_name
)
1246 if (TREE_CODE (decl
) != PARM_DECL
)
1248 /* Array parameters use a temporary descriptor, we want the real
1250 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1251 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1252 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1255 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1256 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1258 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1259 as actual argument to denote absent dummies. For array descriptors,
1260 we thus also need to check the array descriptor. For BT_CLASS, it
1261 can also occur for scalars and F2003 due to type->class wrapping and
1262 class->class wrapping. Note further that BT_CLASS always uses an
1263 array descriptor for arrays, also for explicit-shape/assumed-size. */
1265 if (!sym
->attr
.allocatable
1266 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1267 || (sym
->ts
.type
== BT_CLASS
1268 && !CLASS_DATA (sym
)->attr
.allocatable
1269 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1270 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1271 || sym
->ts
.type
== BT_CLASS
))
1275 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1276 || sym
->as
->type
== AS_ASSUMED_RANK
1277 || sym
->attr
.codimension
))
1278 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1280 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1281 if (sym
->ts
.type
== BT_CLASS
)
1282 tmp
= gfc_class_data_get (tmp
);
1283 tmp
= gfc_conv_array_data (tmp
);
1285 else if (sym
->ts
.type
== BT_CLASS
)
1286 tmp
= gfc_class_data_get (decl
);
1290 if (tmp
!= NULL_TREE
)
1292 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1293 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1294 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1295 boolean_type_node
, cond
, tmp
);
1303 /* Converts a missing, dummy argument into a null or zero. */
1306 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1311 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1315 /* Create a temporary and convert it to the correct type. */
1316 tmp
= gfc_get_int_type (kind
);
1317 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1320 /* Test for a NULL value. */
1321 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1322 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1323 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1324 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1328 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1330 build_zero_cst (TREE_TYPE (se
->expr
)));
1331 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1335 if (ts
.type
== BT_CHARACTER
)
1337 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1338 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1339 present
, se
->string_length
, tmp
);
1340 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1341 se
->string_length
= tmp
;
1347 /* Get the character length of an expression, looking through gfc_refs
1351 gfc_get_expr_charlen (gfc_expr
*e
)
1356 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1357 && e
->ts
.type
== BT_CHARACTER
);
1359 length
= NULL
; /* To silence compiler warning. */
1361 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1364 gfc_init_se (&tmpse
, NULL
);
1365 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1366 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1370 /* First candidate: if the variable is of type CHARACTER, the
1371 expression's length could be the length of the character
1373 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1374 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1376 /* Look through the reference chain for component references. */
1377 for (r
= e
->ref
; r
; r
= r
->next
)
1382 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1383 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1391 /* We should never got substring references here. These will be
1392 broken down by the scalarizer. */
1398 gcc_assert (length
!= NULL
);
1403 /* Return for an expression the backend decl of the coarray. */
1406 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1412 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1414 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1415 gcc_assert (caf_decl
);
1416 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1417 caf_decl
= gfc_class_data_get (caf_decl
);
1418 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1421 /* The following code assumes that the coarray is a component reachable via
1422 only scalar components/variables; the Fortran standard guarantees this. */
1424 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1425 if (ref
->type
== REF_COMPONENT
)
1427 gfc_component
*comp
= ref
->u
.c
.component
;
1429 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1430 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1431 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1432 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1433 comp
->backend_decl
, NULL_TREE
);
1434 if (comp
->ts
.type
== BT_CLASS
)
1435 caf_decl
= gfc_class_data_get (caf_decl
);
1436 if (comp
->attr
.codimension
)
1442 gcc_assert (found
&& caf_decl
);
1447 /* Obtain the Coarray token - and optionally also the offset. */
1450 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1455 /* Coarray token. */
1456 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1458 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1459 == GFC_ARRAY_ALLOCATABLE
1460 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1461 *token
= gfc_conv_descriptor_token (caf_decl
);
1463 else if (DECL_LANG_SPECIFIC (caf_decl
)
1464 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1465 *token
= GFC_DECL_TOKEN (caf_decl
);
1468 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1469 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1470 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1476 /* Offset between the coarray base address and the address wanted. */
1477 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1478 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1479 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1480 *offset
= build_int_cst (gfc_array_index_type
, 0);
1481 else if (DECL_LANG_SPECIFIC (caf_decl
)
1482 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1483 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1484 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1485 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1487 *offset
= build_int_cst (gfc_array_index_type
, 0);
1489 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1490 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1492 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1493 tmp
= gfc_conv_descriptor_data_get (tmp
);
1495 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1496 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1499 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1503 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1504 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1506 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1507 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1510 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1514 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1515 fold_convert (gfc_array_index_type
, *offset
),
1516 fold_convert (gfc_array_index_type
, tmp
));
1520 /* Convert the coindex of a coarray into an image index; the result is
1521 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1)
1522 + (idx(3)-lcobound(3)+1)*extent(2) + ... */
1525 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1528 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1532 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1533 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1535 gcc_assert (ref
!= NULL
);
1537 img_idx
= integer_zero_node
;
1538 extent
= integer_one_node
;
1539 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1540 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1542 gfc_init_se (&se
, NULL
);
1543 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1544 gfc_add_block_to_block (block
, &se
.pre
);
1545 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1546 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1547 integer_type_node
, se
.expr
,
1548 fold_convert(integer_type_node
, lbound
));
1549 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1551 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1553 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1555 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1556 extent
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1557 extent
= fold_convert (integer_type_node
, extent
);
1561 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1563 gfc_init_se (&se
, NULL
);
1564 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1565 gfc_add_block_to_block (block
, &se
.pre
);
1566 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1567 lbound
= fold_convert (integer_type_node
, lbound
);
1568 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1569 integer_type_node
, se
.expr
, lbound
);
1570 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1572 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1574 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1576 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1577 ubound
= fold_convert (integer_type_node
, ubound
);
1578 extent
= fold_build2_loc (input_location
, MINUS_EXPR
,
1579 integer_type_node
, ubound
, lbound
);
1580 extent
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1581 extent
, integer_one_node
);
1584 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1585 img_idx
, integer_one_node
);
1590 /* For each character array constructor subexpression without a ts.u.cl->length,
1591 replace it by its first element (if there aren't any elements, the length
1592 should already be set to zero). */
1595 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1597 gfc_actual_arglist
* arg
;
1603 switch (e
->expr_type
)
1607 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1608 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1612 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1616 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1617 flatten_array_ctors_without_strlen (arg
->expr
);
1622 /* We've found what we're looking for. */
1623 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1628 gcc_assert (e
->value
.constructor
);
1630 c
= gfc_constructor_first (e
->value
.constructor
);
1634 flatten_array_ctors_without_strlen (new_expr
);
1635 gfc_replace_expr (e
, new_expr
);
1639 /* Otherwise, fall through to handle constructor elements. */
1640 case EXPR_STRUCTURE
:
1641 for (c
= gfc_constructor_first (e
->value
.constructor
);
1642 c
; c
= gfc_constructor_next (c
))
1643 flatten_array_ctors_without_strlen (c
->expr
);
1653 /* Generate code to initialize a string length variable. Returns the
1654 value. For array constructors, cl->length might be NULL and in this case,
1655 the first element of the constructor is needed. expr is the original
1656 expression so we can access it but can be NULL if this is not needed. */
1659 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1663 gfc_init_se (&se
, NULL
);
1667 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1670 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1671 "flatten" array constructors by taking their first element; all elements
1672 should be the same length or a cl->length should be present. */
1675 gfc_expr
* expr_flat
;
1677 expr_flat
= gfc_copy_expr (expr
);
1678 flatten_array_ctors_without_strlen (expr_flat
);
1679 gfc_resolve_expr (expr_flat
);
1681 gfc_conv_expr (&se
, expr_flat
);
1682 gfc_add_block_to_block (pblock
, &se
.pre
);
1683 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1685 gfc_free_expr (expr_flat
);
1689 /* Convert cl->length. */
1691 gcc_assert (cl
->length
);
1693 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1694 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1695 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1696 gfc_add_block_to_block (pblock
, &se
.pre
);
1698 if (cl
->backend_decl
)
1699 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1701 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1706 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1707 const char *name
, locus
*where
)
1717 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1718 type
= build_pointer_type (type
);
1720 gfc_init_se (&start
, se
);
1721 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1722 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1724 if (integer_onep (start
.expr
))
1725 gfc_conv_string_parameter (se
);
1730 /* Avoid multiple evaluation of substring start. */
1731 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1732 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1734 /* Change the start of the string. */
1735 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1738 tmp
= build_fold_indirect_ref_loc (input_location
,
1740 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1741 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1744 /* Length = end + 1 - start. */
1745 gfc_init_se (&end
, se
);
1746 if (ref
->u
.ss
.end
== NULL
)
1747 end
.expr
= se
->string_length
;
1750 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1751 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1755 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1756 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1758 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1760 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1761 boolean_type_node
, start
.expr
,
1764 /* Check lower bound. */
1765 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1767 build_int_cst (gfc_charlen_type_node
, 1));
1768 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1769 boolean_type_node
, nonempty
, fault
);
1771 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1772 "is less than one", name
);
1774 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1775 "is less than one");
1776 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1777 fold_convert (long_integer_type_node
,
1781 /* Check upper bound. */
1782 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1783 end
.expr
, se
->string_length
);
1784 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1785 boolean_type_node
, nonempty
, fault
);
1787 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1788 "exceeds string length (%%ld)", name
);
1790 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1791 "exceeds string length (%%ld)");
1792 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1793 fold_convert (long_integer_type_node
, end
.expr
),
1794 fold_convert (long_integer_type_node
,
1795 se
->string_length
));
1799 /* Try to calculate the length from the start and end expressions. */
1801 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1805 i_len
= mpz_get_si (length
) + 1;
1809 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1810 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1814 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1815 end
.expr
, start
.expr
);
1816 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1817 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1818 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1819 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1822 se
->string_length
= tmp
;
1826 /* Convert a derived type component reference. */
1829 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1836 c
= ref
->u
.c
.component
;
1838 gcc_assert (c
->backend_decl
);
1840 field
= c
->backend_decl
;
1841 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1844 /* Components can correspond to fields of different containing
1845 types, as components are created without context, whereas
1846 a concrete use of a component has the type of decl as context.
1847 So, if the type doesn't match, we search the corresponding
1848 FIELD_DECL in the parent type. To not waste too much time
1849 we cache this result in norestrict_decl. */
1851 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1853 tree f2
= c
->norestrict_decl
;
1854 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1855 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1856 if (TREE_CODE (f2
) == FIELD_DECL
1857 && DECL_NAME (f2
) == DECL_NAME (field
))
1860 c
->norestrict_decl
= f2
;
1864 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1865 decl
, field
, NULL_TREE
);
1869 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1871 tmp
= c
->ts
.u
.cl
->backend_decl
;
1872 /* Components must always be constant length. */
1873 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1874 se
->string_length
= tmp
;
1877 if (gfc_deferred_strlen (c
, &field
))
1879 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1881 decl
, field
, NULL_TREE
);
1882 se
->string_length
= tmp
;
1885 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1886 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1887 && c
->ts
.type
!= BT_CHARACTER
)
1888 || c
->attr
.proc_pointer
)
1889 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1894 /* This function deals with component references to components of the
1895 parent type for derived type extensions. */
1897 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1905 c
= ref
->u
.c
.component
;
1907 /* Return if the component is in the parent type. */
1908 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1909 if (strcmp (c
->name
, cmp
->name
) == 0)
1912 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1913 parent
.type
= REF_COMPONENT
;
1915 parent
.u
.c
.sym
= dt
;
1916 parent
.u
.c
.component
= dt
->components
;
1918 if (dt
->backend_decl
== NULL
)
1919 gfc_get_derived_type (dt
);
1921 /* Build the reference and call self. */
1922 gfc_conv_component_ref (se
, &parent
);
1923 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1924 parent
.u
.c
.component
= c
;
1925 conv_parent_component_references (se
, &parent
);
1928 /* Return the contents of a variable. Also handles reference/pointer
1929 variables (all Fortran pointer references are implicit). */
1932 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1937 tree parent_decl
= NULL_TREE
;
1940 bool alternate_entry
;
1943 sym
= expr
->symtree
->n
.sym
;
1947 gfc_ss_info
*ss_info
= ss
->info
;
1949 /* Check that something hasn't gone horribly wrong. */
1950 gcc_assert (ss
!= gfc_ss_terminator
);
1951 gcc_assert (ss_info
->expr
== expr
);
1953 /* A scalarized term. We already know the descriptor. */
1954 se
->expr
= ss_info
->data
.array
.descriptor
;
1955 se
->string_length
= ss_info
->string_length
;
1956 ref
= ss_info
->data
.array
.ref
;
1958 gcc_assert (ref
->type
== REF_ARRAY
1959 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1961 gfc_conv_tmp_array_ref (se
);
1965 tree se_expr
= NULL_TREE
;
1967 se
->expr
= gfc_get_symbol_decl (sym
);
1969 /* Deal with references to a parent results or entries by storing
1970 the current_function_decl and moving to the parent_decl. */
1971 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1972 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1973 && sym
->result
== sym
;
1974 entry_master
= sym
->attr
.result
1975 && sym
->ns
->proc_name
->attr
.entry_master
1976 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1977 if (current_function_decl
)
1978 parent_decl
= DECL_CONTEXT (current_function_decl
);
1980 if ((se
->expr
== parent_decl
&& return_value
)
1981 || (sym
->ns
&& sym
->ns
->proc_name
1983 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1984 && (alternate_entry
|| entry_master
)))
1989 /* Special case for assigning the return value of a function.
1990 Self recursive functions must have an explicit return value. */
1991 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1992 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1994 /* Similarly for alternate entry points. */
1995 else if (alternate_entry
1996 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1999 gfc_entry_list
*el
= NULL
;
2001 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2004 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2009 else if (entry_master
2010 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2012 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2017 /* Procedure actual arguments. */
2018 else if (sym
->attr
.flavor
== FL_PROCEDURE
2019 && se
->expr
!= current_function_decl
)
2021 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2023 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2024 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2030 /* Dereference the expression, where needed. Since characters
2031 are entirely different from other types, they are treated
2033 if (sym
->ts
.type
== BT_CHARACTER
)
2035 /* Dereference character pointer dummy arguments
2037 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2039 || sym
->attr
.function
2040 || sym
->attr
.result
))
2041 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2045 else if (!sym
->attr
.value
)
2047 /* Dereference non-character scalar dummy arguments. */
2048 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2049 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
2050 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2053 /* Dereference scalar hidden result. */
2054 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2055 && (sym
->attr
.function
|| sym
->attr
.result
)
2056 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2057 && !sym
->attr
.always_explicit
)
2058 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2061 /* Dereference non-character pointer variables.
2062 These must be dummies, results, or scalars. */
2063 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2064 || gfc_is_associate_pointer (sym
)
2065 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2067 || sym
->attr
.function
2069 || (!sym
->attr
.dimension
2070 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2071 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2078 /* For character variables, also get the length. */
2079 if (sym
->ts
.type
== BT_CHARACTER
)
2081 /* If the character length of an entry isn't set, get the length from
2082 the master function instead. */
2083 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2084 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2086 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2087 gcc_assert (se
->string_length
);
2095 /* Return the descriptor if that's what we want and this is an array
2096 section reference. */
2097 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2099 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2100 /* Return the descriptor for array pointers and allocations. */
2101 if (se
->want_pointer
2102 && ref
->next
== NULL
&& (se
->descriptor_only
))
2105 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2106 /* Return a pointer to an element. */
2110 if (ref
->u
.c
.sym
->attr
.extension
)
2111 conv_parent_component_references (se
, ref
);
2113 gfc_conv_component_ref (se
, ref
);
2114 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2115 && se
->want_pointer
&& se
->descriptor_only
)
2121 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2122 expr
->symtree
->name
, &expr
->where
);
2131 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2133 if (se
->want_pointer
)
2135 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2136 gfc_conv_string_parameter (se
);
2138 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2143 /* Unary ops are easy... Or they would be if ! was a valid op. */
2146 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2151 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2152 /* Initialize the operand. */
2153 gfc_init_se (&operand
, se
);
2154 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2155 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2157 type
= gfc_typenode_for_spec (&expr
->ts
);
2159 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2160 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2161 All other unary operators have an equivalent GIMPLE unary operator. */
2162 if (code
== TRUTH_NOT_EXPR
)
2163 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2164 build_int_cst (type
, 0));
2166 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2170 /* Expand power operator to optimal multiplications when a value is raised
2171 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2172 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2173 Programming", 3rd Edition, 1998. */
2175 /* This code is mostly duplicated from expand_powi in the backend.
2176 We establish the "optimal power tree" lookup table with the defined size.
2177 The items in the table are the exponents used to calculate the index
2178 exponents. Any integer n less than the value can get an "addition chain",
2179 with the first node being one. */
2180 #define POWI_TABLE_SIZE 256
2182 /* The table is from builtins.c. */
2183 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2185 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2186 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2187 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2188 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2189 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2190 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2191 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2192 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2193 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2194 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2195 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2196 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2197 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2198 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2199 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2200 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2201 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2202 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2203 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2204 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2205 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2206 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2207 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2208 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2209 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2210 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2211 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2212 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2213 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2214 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2215 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2216 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2219 /* If n is larger than lookup table's max index, we use the "window
2221 #define POWI_WINDOW_SIZE 3
2223 /* Recursive function to expand the power operator. The temporary
2224 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2226 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2233 if (n
< POWI_TABLE_SIZE
)
2238 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2239 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2243 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2244 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2245 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2249 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2253 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2254 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2256 if (n
< POWI_TABLE_SIZE
)
2263 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2264 return 1. Else return 0 and a call to runtime library functions
2265 will have to be built. */
2267 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2272 tree vartmp
[POWI_TABLE_SIZE
];
2274 unsigned HOST_WIDE_INT n
;
2276 wide_int wrhs
= rhs
;
2278 /* If exponent is too large, we won't expand it anyway, so don't bother
2279 with large integer values. */
2280 if (!wi::fits_shwi_p (wrhs
))
2283 m
= wrhs
.to_shwi ();
2284 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2285 of the asymmetric range of the integer type. */
2286 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2288 type
= TREE_TYPE (lhs
);
2289 sgn
= tree_int_cst_sgn (rhs
);
2291 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2292 || optimize_size
) && (m
> 2 || m
< -1))
2298 se
->expr
= gfc_build_const (type
, integer_one_node
);
2302 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2303 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2305 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2306 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2307 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2308 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2311 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2314 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2315 boolean_type_node
, tmp
, cond
);
2316 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2317 tmp
, build_int_cst (type
, 1),
2318 build_int_cst (type
, 0));
2322 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2323 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2324 build_int_cst (type
, -1),
2325 build_int_cst (type
, 0));
2326 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2327 cond
, build_int_cst (type
, 1), tmp
);
2331 memset (vartmp
, 0, sizeof (vartmp
));
2335 tmp
= gfc_build_const (type
, integer_one_node
);
2336 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2340 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2346 /* Power op (**). Constant integer exponent has special handling. */
2349 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2351 tree gfc_int4_type_node
;
2354 int res_ikind_1
, res_ikind_2
;
2359 gfc_init_se (&lse
, se
);
2360 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2361 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2362 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2364 gfc_init_se (&rse
, se
);
2365 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2366 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2368 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2369 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2370 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2373 gfc_int4_type_node
= gfc_get_int_type (4);
2375 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2376 library routine. But in the end, we have to convert the result back
2377 if this case applies -- with res_ikind_K, we keep track whether operand K
2378 falls into this case. */
2382 kind
= expr
->value
.op
.op1
->ts
.kind
;
2383 switch (expr
->value
.op
.op2
->ts
.type
)
2386 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2391 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2392 res_ikind_2
= ikind
;
2414 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2416 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2443 switch (expr
->value
.op
.op1
->ts
.type
)
2446 if (kind
== 3) /* Case 16 was not handled properly above. */
2448 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2452 /* Use builtins for real ** int4. */
2458 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2462 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2466 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2470 /* Use the __builtin_powil() only if real(kind=16) is
2471 actually the C long double type. */
2472 if (!gfc_real16_is_float128
)
2473 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2481 /* If we don't have a good builtin for this, go for the
2482 library function. */
2484 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2488 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2497 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2501 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2509 se
->expr
= build_call_expr_loc (input_location
,
2510 fndecl
, 2, lse
.expr
, rse
.expr
);
2512 /* Convert the result back if it is of wrong integer kind. */
2513 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2515 /* We want the maximum of both operand kinds as result. */
2516 if (res_ikind_1
< res_ikind_2
)
2517 res_ikind_1
= res_ikind_2
;
2518 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2523 /* Generate code to allocate a string temporary. */
2526 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2531 if (gfc_can_put_var_on_stack (len
))
2533 /* Create a temporary variable to hold the result. */
2534 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2535 gfc_charlen_type_node
, len
,
2536 build_int_cst (gfc_charlen_type_node
, 1));
2537 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2539 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2540 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2542 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2544 var
= gfc_create_var (tmp
, "str");
2545 var
= gfc_build_addr_expr (type
, var
);
2549 /* Allocate a temporary to hold the result. */
2550 var
= gfc_create_var (type
, "pstr");
2551 gcc_assert (POINTER_TYPE_P (type
));
2552 tmp
= TREE_TYPE (type
);
2553 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2554 tmp
= TREE_TYPE (tmp
);
2555 tmp
= TYPE_SIZE_UNIT (tmp
);
2556 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2557 fold_convert (size_type_node
, len
),
2558 fold_convert (size_type_node
, tmp
));
2559 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2560 gfc_add_modify (&se
->pre
, var
, tmp
);
2562 /* Free the temporary afterwards. */
2563 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2564 gfc_add_expr_to_block (&se
->post
, tmp
);
2571 /* Handle a string concatenation operation. A temporary will be allocated to
2575 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2578 tree len
, type
, var
, tmp
, fndecl
;
2580 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2581 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2582 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2584 gfc_init_se (&lse
, se
);
2585 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2586 gfc_conv_string_parameter (&lse
);
2587 gfc_init_se (&rse
, se
);
2588 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2589 gfc_conv_string_parameter (&rse
);
2591 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2592 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2594 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2595 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2596 if (len
== NULL_TREE
)
2598 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2599 TREE_TYPE (lse
.string_length
),
2600 lse
.string_length
, rse
.string_length
);
2603 type
= build_pointer_type (type
);
2605 var
= gfc_conv_string_tmp (se
, type
, len
);
2607 /* Do the actual concatenation. */
2608 if (expr
->ts
.kind
== 1)
2609 fndecl
= gfor_fndecl_concat_string
;
2610 else if (expr
->ts
.kind
== 4)
2611 fndecl
= gfor_fndecl_concat_string_char4
;
2615 tmp
= build_call_expr_loc (input_location
,
2616 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2617 rse
.string_length
, rse
.expr
);
2618 gfc_add_expr_to_block (&se
->pre
, tmp
);
2620 /* Add the cleanup for the operands. */
2621 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2622 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2625 se
->string_length
= len
;
2628 /* Translates an op expression. Common (binary) cases are handled by this
2629 function, others are passed on. Recursion is used in either case.
2630 We use the fact that (op1.ts == op2.ts) (except for the power
2632 Operators need no special handling for scalarized expressions as long as
2633 they call gfc_conv_simple_val to get their operands.
2634 Character strings get special handling. */
2637 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2639 enum tree_code code
;
2648 switch (expr
->value
.op
.op
)
2650 case INTRINSIC_PARENTHESES
:
2651 if ((expr
->ts
.type
== BT_REAL
2652 || expr
->ts
.type
== BT_COMPLEX
)
2653 && gfc_option
.flag_protect_parens
)
2655 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2656 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2661 case INTRINSIC_UPLUS
:
2662 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2665 case INTRINSIC_UMINUS
:
2666 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2670 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2673 case INTRINSIC_PLUS
:
2677 case INTRINSIC_MINUS
:
2681 case INTRINSIC_TIMES
:
2685 case INTRINSIC_DIVIDE
:
2686 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2687 an integer, we must round towards zero, so we use a
2689 if (expr
->ts
.type
== BT_INTEGER
)
2690 code
= TRUNC_DIV_EXPR
;
2695 case INTRINSIC_POWER
:
2696 gfc_conv_power_op (se
, expr
);
2699 case INTRINSIC_CONCAT
:
2700 gfc_conv_concat_op (se
, expr
);
2704 code
= TRUTH_ANDIF_EXPR
;
2709 code
= TRUTH_ORIF_EXPR
;
2713 /* EQV and NEQV only work on logicals, but since we represent them
2714 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2716 case INTRINSIC_EQ_OS
:
2724 case INTRINSIC_NE_OS
:
2725 case INTRINSIC_NEQV
:
2732 case INTRINSIC_GT_OS
:
2739 case INTRINSIC_GE_OS
:
2746 case INTRINSIC_LT_OS
:
2753 case INTRINSIC_LE_OS
:
2759 case INTRINSIC_USER
:
2760 case INTRINSIC_ASSIGN
:
2761 /* These should be converted into function calls by the frontend. */
2765 fatal_error ("Unknown intrinsic op");
2769 /* The only exception to this is **, which is handled separately anyway. */
2770 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2772 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2776 gfc_init_se (&lse
, se
);
2777 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2778 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2781 gfc_init_se (&rse
, se
);
2782 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2783 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2787 gfc_conv_string_parameter (&lse
);
2788 gfc_conv_string_parameter (&rse
);
2790 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2791 rse
.string_length
, rse
.expr
,
2792 expr
->value
.op
.op1
->ts
.kind
,
2794 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2795 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2798 type
= gfc_typenode_for_spec (&expr
->ts
);
2802 /* The result of logical ops is always boolean_type_node. */
2803 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2804 lse
.expr
, rse
.expr
);
2805 se
->expr
= convert (type
, tmp
);
2808 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2810 /* Add the post blocks. */
2811 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2812 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2815 /* If a string's length is one, we convert it to a single character. */
2818 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2822 || !tree_fits_uhwi_p (len
)
2823 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2826 if (TREE_INT_CST_LOW (len
) == 1)
2828 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2829 return build_fold_indirect_ref_loc (input_location
, str
);
2833 && TREE_CODE (str
) == ADDR_EXPR
2834 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2835 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2836 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2837 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2838 && TREE_INT_CST_LOW (len
) > 1
2839 && TREE_INT_CST_LOW (len
)
2840 == (unsigned HOST_WIDE_INT
)
2841 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2843 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2844 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2845 if (TREE_CODE (ret
) == INTEGER_CST
)
2847 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2848 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2849 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2851 for (i
= 1; i
< length
; i
++)
2864 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2867 if (sym
->backend_decl
)
2869 /* This becomes the nominal_type in
2870 function.c:assign_parm_find_data_types. */
2871 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2872 /* This becomes the passed_type in
2873 function.c:assign_parm_find_data_types. C promotes char to
2874 integer for argument passing. */
2875 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2877 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2882 /* If we have a constant character expression, make it into an
2884 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2889 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2890 (int)(*expr
)->value
.character
.string
[0]);
2891 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2893 /* The expr needs to be compatible with a C int. If the
2894 conversion fails, then the 2 causes an ICE. */
2895 ts
.type
= BT_INTEGER
;
2896 ts
.kind
= gfc_c_int_kind
;
2897 gfc_convert_type (*expr
, &ts
, 2);
2900 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2902 if ((*expr
)->ref
== NULL
)
2904 se
->expr
= gfc_string_to_single_character
2905 (build_int_cst (integer_type_node
, 1),
2906 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2908 ((*expr
)->symtree
->n
.sym
)),
2913 gfc_conv_variable (se
, *expr
);
2914 se
->expr
= gfc_string_to_single_character
2915 (build_int_cst (integer_type_node
, 1),
2916 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2924 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2925 if STR is a string literal, otherwise return -1. */
2928 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2931 && TREE_CODE (str
) == ADDR_EXPR
2932 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2933 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2934 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2935 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2936 && tree_fits_uhwi_p (len
)
2937 && tree_to_uhwi (len
) >= 1
2938 && tree_to_uhwi (len
)
2939 == (unsigned HOST_WIDE_INT
)
2940 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2942 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2943 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2944 if (TREE_CODE (folded
) == INTEGER_CST
)
2946 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2947 int length
= TREE_STRING_LENGTH (string_cst
);
2948 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2950 for (; length
> 0; length
--)
2951 if (ptr
[length
- 1] != ' ')
2960 /* Helper to build a call to memcmp. */
2963 build_memcmp_call (tree s1
, tree s2
, tree n
)
2967 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2968 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2970 s1
= fold_convert (pvoid_type_node
, s1
);
2972 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2973 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2975 s2
= fold_convert (pvoid_type_node
, s2
);
2977 n
= fold_convert (size_type_node
, n
);
2979 tmp
= build_call_expr_loc (input_location
,
2980 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2983 return fold_convert (integer_type_node
, tmp
);
2986 /* Compare two strings. If they are all single characters, the result is the
2987 subtraction of them. Otherwise, we build a library call. */
2990 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2991 enum tree_code code
)
2997 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2998 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3000 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3001 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3003 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3005 /* Deal with single character specially. */
3006 sc1
= fold_convert (integer_type_node
, sc1
);
3007 sc2
= fold_convert (integer_type_node
, sc2
);
3008 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3012 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3014 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3016 /* If one string is a string literal with LEN_TRIM longer
3017 than the length of the second string, the strings
3019 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3020 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3021 return integer_one_node
;
3022 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3023 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3024 return integer_one_node
;
3027 /* We can compare via memcpy if the strings are known to be equal
3028 in length and they are
3030 - kind=4 and the comparison is for (in)equality. */
3032 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3033 && tree_int_cst_equal (len1
, len2
)
3034 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3039 chartype
= gfc_get_char_type (kind
);
3040 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3041 fold_convert (TREE_TYPE(len1
),
3042 TYPE_SIZE_UNIT(chartype
)),
3044 return build_memcmp_call (str1
, str2
, tmp
);
3047 /* Build a call for the comparison. */
3049 fndecl
= gfor_fndecl_compare_string
;
3051 fndecl
= gfor_fndecl_compare_string_char4
;
3055 return build_call_expr_loc (input_location
, fndecl
, 4,
3056 len1
, str1
, len2
, str2
);
3060 /* Return the backend_decl for a procedure pointer component. */
3063 get_proc_ptr_comp (gfc_expr
*e
)
3069 gfc_init_se (&comp_se
, NULL
);
3070 e2
= gfc_copy_expr (e
);
3071 /* We have to restore the expr type later so that gfc_free_expr frees
3072 the exact same thing that was allocated.
3073 TODO: This is ugly. */
3074 old_type
= e2
->expr_type
;
3075 e2
->expr_type
= EXPR_VARIABLE
;
3076 gfc_conv_expr (&comp_se
, e2
);
3077 e2
->expr_type
= old_type
;
3079 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3083 /* Convert a typebound function reference from a class object. */
3085 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3090 if (TREE_CODE (base_object
) != VAR_DECL
)
3092 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3093 gfc_add_modify (&se
->pre
, var
, base_object
);
3095 se
->expr
= gfc_class_vptr_get (base_object
);
3096 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3098 while (ref
&& ref
->next
)
3100 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3101 if (ref
->u
.c
.sym
->attr
.extension
)
3102 conv_parent_component_references (se
, ref
);
3103 gfc_conv_component_ref (se
, ref
);
3104 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3109 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3113 if (gfc_is_proc_ptr_comp (expr
))
3114 tmp
= get_proc_ptr_comp (expr
);
3115 else if (sym
->attr
.dummy
)
3117 tmp
= gfc_get_symbol_decl (sym
);
3118 if (sym
->attr
.proc_pointer
)
3119 tmp
= build_fold_indirect_ref_loc (input_location
,
3121 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3122 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3126 if (!sym
->backend_decl
)
3127 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3129 TREE_USED (sym
->backend_decl
) = 1;
3131 tmp
= sym
->backend_decl
;
3133 if (sym
->attr
.cray_pointee
)
3135 /* TODO - make the cray pointee a pointer to a procedure,
3136 assign the pointer to it and use it for the call. This
3138 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3139 gfc_get_symbol_decl (sym
->cp_pointer
));
3140 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3143 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3145 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3146 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3153 /* Initialize MAPPING. */
3156 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3158 mapping
->syms
= NULL
;
3159 mapping
->charlens
= NULL
;
3163 /* Free all memory held by MAPPING (but not MAPPING itself). */
3166 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3168 gfc_interface_sym_mapping
*sym
;
3169 gfc_interface_sym_mapping
*nextsym
;
3171 gfc_charlen
*nextcl
;
3173 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3175 nextsym
= sym
->next
;
3176 sym
->new_sym
->n
.sym
->formal
= NULL
;
3177 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3178 gfc_free_expr (sym
->expr
);
3179 free (sym
->new_sym
);
3182 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3185 gfc_free_expr (cl
->length
);
3191 /* Return a copy of gfc_charlen CL. Add the returned structure to
3192 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3194 static gfc_charlen
*
3195 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3198 gfc_charlen
*new_charlen
;
3200 new_charlen
= gfc_get_charlen ();
3201 new_charlen
->next
= mapping
->charlens
;
3202 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3204 mapping
->charlens
= new_charlen
;
3209 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3210 array variable that can be used as the actual argument for dummy
3211 argument SYM. Add any initialization code to BLOCK. PACKED is as
3212 for gfc_get_nodesc_array_type and DATA points to the first element
3213 in the passed array. */
3216 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3217 gfc_packed packed
, tree data
)
3222 type
= gfc_typenode_for_spec (&sym
->ts
);
3223 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3224 !sym
->attr
.target
&& !sym
->attr
.pointer
3225 && !sym
->attr
.proc_pointer
);
3227 var
= gfc_create_var (type
, "ifm");
3228 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3234 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3235 and offset of descriptorless array type TYPE given that it has the same
3236 size as DESC. Add any set-up code to BLOCK. */
3239 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3246 offset
= gfc_index_zero_node
;
3247 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3249 dim
= gfc_rank_cst
[n
];
3250 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3251 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3253 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3254 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3255 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3256 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3258 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3260 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3261 gfc_array_index_type
,
3262 gfc_conv_descriptor_ubound_get (desc
, dim
),
3263 gfc_conv_descriptor_lbound_get (desc
, dim
));
3264 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3265 gfc_array_index_type
,
3266 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3267 tmp
= gfc_evaluate_now (tmp
, block
);
3268 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3270 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3271 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3272 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3273 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3274 gfc_array_index_type
, offset
, tmp
);
3276 offset
= gfc_evaluate_now (offset
, block
);
3277 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3281 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3282 in SE. The caller may still use se->expr and se->string_length after
3283 calling this function. */
3286 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3287 gfc_symbol
* sym
, gfc_se
* se
,
3290 gfc_interface_sym_mapping
*sm
;
3294 gfc_symbol
*new_sym
;
3296 gfc_symtree
*new_symtree
;
3298 /* Create a new symbol to represent the actual argument. */
3299 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3300 new_sym
->ts
= sym
->ts
;
3301 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3302 new_sym
->attr
.referenced
= 1;
3303 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3304 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3305 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3306 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3307 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3308 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3309 new_sym
->attr
.function
= sym
->attr
.function
;
3311 /* Ensure that the interface is available and that
3312 descriptors are passed for array actual arguments. */
3313 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3315 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3316 new_sym
->attr
.always_explicit
3317 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3320 /* Create a fake symtree for it. */
3322 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3323 new_symtree
->n
.sym
= new_sym
;
3324 gcc_assert (new_symtree
== root
);
3326 /* Create a dummy->actual mapping. */
3327 sm
= XCNEW (gfc_interface_sym_mapping
);
3328 sm
->next
= mapping
->syms
;
3330 sm
->new_sym
= new_symtree
;
3331 sm
->expr
= gfc_copy_expr (expr
);
3334 /* Stabilize the argument's value. */
3335 if (!sym
->attr
.function
&& se
)
3336 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3338 if (sym
->ts
.type
== BT_CHARACTER
)
3340 /* Create a copy of the dummy argument's length. */
3341 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3342 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3344 /* If the length is specified as "*", record the length that
3345 the caller is passing. We should use the callee's length
3346 in all other cases. */
3347 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3349 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3350 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3357 /* Use the passed value as-is if the argument is a function. */
3358 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3361 /* If the argument is either a string or a pointer to a string,
3362 convert it to a boundless character type. */
3363 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3365 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3366 tmp
= build_pointer_type (tmp
);
3367 if (sym
->attr
.pointer
)
3368 value
= build_fold_indirect_ref_loc (input_location
,
3372 value
= fold_convert (tmp
, value
);
3375 /* If the argument is a scalar, a pointer to an array or an allocatable,
3377 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3378 value
= build_fold_indirect_ref_loc (input_location
,
3381 /* For character(*), use the actual argument's descriptor. */
3382 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3383 value
= build_fold_indirect_ref_loc (input_location
,
3386 /* If the argument is an array descriptor, use it to determine
3387 information about the actual argument's shape. */
3388 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3389 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3391 /* Get the actual argument's descriptor. */
3392 desc
= build_fold_indirect_ref_loc (input_location
,
3395 /* Create the replacement variable. */
3396 tmp
= gfc_conv_descriptor_data_get (desc
);
3397 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3400 /* Use DESC to work out the upper bounds, strides and offset. */
3401 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3404 /* Otherwise we have a packed array. */
3405 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3406 PACKED_FULL
, se
->expr
);
3408 new_sym
->backend_decl
= value
;
3412 /* Called once all dummy argument mappings have been added to MAPPING,
3413 but before the mapping is used to evaluate expressions. Pre-evaluate
3414 the length of each argument, adding any initialization code to PRE and
3415 any finalization code to POST. */
3418 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3419 stmtblock_t
* pre
, stmtblock_t
* post
)
3421 gfc_interface_sym_mapping
*sym
;
3425 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3426 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3427 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3429 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3430 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3431 gfc_init_se (&se
, NULL
);
3432 gfc_conv_expr (&se
, expr
);
3433 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3434 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3435 gfc_add_block_to_block (pre
, &se
.pre
);
3436 gfc_add_block_to_block (post
, &se
.post
);
3438 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3443 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3447 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3448 gfc_constructor_base base
)
3451 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3453 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3456 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3457 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3458 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3464 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3468 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3473 for (; ref
; ref
= ref
->next
)
3477 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3479 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3480 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3481 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3489 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3490 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3496 /* Convert intrinsic function calls into result expressions. */
3499 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3507 arg1
= expr
->value
.function
.actual
->expr
;
3508 if (expr
->value
.function
.actual
->next
)
3509 arg2
= expr
->value
.function
.actual
->next
->expr
;
3513 sym
= arg1
->symtree
->n
.sym
;
3515 if (sym
->attr
.dummy
)
3520 switch (expr
->value
.function
.isym
->id
)
3523 /* TODO figure out why this condition is necessary. */
3524 if (sym
->attr
.function
3525 && (arg1
->ts
.u
.cl
->length
== NULL
3526 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3527 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3530 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3534 if (!sym
->as
|| sym
->as
->rank
== 0)
3537 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3539 dup
= mpz_get_si (arg2
->value
.integer
);
3544 dup
= sym
->as
->rank
;
3548 for (; d
< dup
; d
++)
3552 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3554 gfc_free_expr (new_expr
);
3558 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3559 gfc_get_int_expr (gfc_default_integer_kind
,
3561 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3563 new_expr
= gfc_multiply (new_expr
, tmp
);
3569 case GFC_ISYM_LBOUND
:
3570 case GFC_ISYM_UBOUND
:
3571 /* TODO These implementations of lbound and ubound do not limit if
3572 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3574 if (!sym
->as
|| sym
->as
->rank
== 0)
3577 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3578 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3580 /* TODO: If the need arises, this could produce an array of
3584 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3586 if (sym
->as
->lower
[d
])
3587 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3591 if (sym
->as
->upper
[d
])
3592 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3600 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3604 gfc_replace_expr (expr
, new_expr
);
3610 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3611 gfc_interface_mapping
* mapping
)
3613 gfc_formal_arglist
*f
;
3614 gfc_actual_arglist
*actual
;
3616 actual
= expr
->value
.function
.actual
;
3617 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3619 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3624 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3627 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3632 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3634 for (d
= 0; d
< as
->rank
; d
++)
3636 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3637 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3640 expr
->value
.function
.esym
->as
= as
;
3643 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3645 expr
->value
.function
.esym
->ts
.u
.cl
->length
3646 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3648 gfc_apply_interface_mapping_to_expr (mapping
,
3649 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3654 /* EXPR is a copy of an expression that appeared in the interface
3655 associated with MAPPING. Walk it recursively looking for references to
3656 dummy arguments that MAPPING maps to actual arguments. Replace each such
3657 reference with a reference to the associated actual argument. */
3660 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3663 gfc_interface_sym_mapping
*sym
;
3664 gfc_actual_arglist
*actual
;
3669 /* Copying an expression does not copy its length, so do that here. */
3670 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3672 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3673 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3676 /* Apply the mapping to any references. */
3677 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3679 /* ...and to the expression's symbol, if it has one. */
3680 /* TODO Find out why the condition on expr->symtree had to be moved into
3681 the loop rather than being outside it, as originally. */
3682 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3683 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3685 if (sym
->new_sym
->n
.sym
->backend_decl
)
3686 expr
->symtree
= sym
->new_sym
;
3688 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3689 /* Replace base type for polymorphic arguments. */
3690 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3691 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3692 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3695 /* ...and to subexpressions in expr->value. */
3696 switch (expr
->expr_type
)
3701 case EXPR_SUBSTRING
:
3705 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3706 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3710 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3711 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3713 if (expr
->value
.function
.esym
== NULL
3714 && expr
->value
.function
.isym
!= NULL
3715 && expr
->value
.function
.actual
->expr
->symtree
3716 && gfc_map_intrinsic_function (expr
, mapping
))
3719 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3720 if (sym
->old
== expr
->value
.function
.esym
)
3722 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3723 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3724 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3729 case EXPR_STRUCTURE
:
3730 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3743 /* Evaluate interface expression EXPR using MAPPING. Store the result
3747 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3748 gfc_se
* se
, gfc_expr
* expr
)
3750 expr
= gfc_copy_expr (expr
);
3751 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3752 gfc_conv_expr (se
, expr
);
3753 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3754 gfc_free_expr (expr
);
3758 /* Returns a reference to a temporary array into which a component of
3759 an actual argument derived type array is copied and then returned
3760 after the function call. */
3762 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3763 sym_intent intent
, bool formal_ptr
)
3771 gfc_array_info
*info
;
3781 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3783 gfc_init_se (&lse
, NULL
);
3784 gfc_init_se (&rse
, NULL
);
3786 /* Walk the argument expression. */
3787 rss
= gfc_walk_expr (expr
);
3789 gcc_assert (rss
!= gfc_ss_terminator
);
3791 /* Initialize the scalarizer. */
3792 gfc_init_loopinfo (&loop
);
3793 gfc_add_ss_to_loop (&loop
, rss
);
3795 /* Calculate the bounds of the scalarization. */
3796 gfc_conv_ss_startstride (&loop
);
3798 /* Build an ss for the temporary. */
3799 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3800 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3802 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3803 if (GFC_ARRAY_TYPE_P (base_type
)
3804 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3805 base_type
= gfc_get_element_type (base_type
);
3807 if (expr
->ts
.type
== BT_CLASS
)
3808 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3810 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3811 ? expr
->ts
.u
.cl
->backend_decl
3815 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3817 /* Associate the SS with the loop. */
3818 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3820 /* Setup the scalarizing loops. */
3821 gfc_conv_loop_setup (&loop
, &expr
->where
);
3823 /* Pass the temporary descriptor back to the caller. */
3824 info
= &loop
.temp_ss
->info
->data
.array
;
3825 parmse
->expr
= info
->descriptor
;
3827 /* Setup the gfc_se structures. */
3828 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3829 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3832 lse
.ss
= loop
.temp_ss
;
3833 gfc_mark_ss_chain_used (rss
, 1);
3834 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3836 /* Start the scalarized loop body. */
3837 gfc_start_scalarized_body (&loop
, &body
);
3839 /* Translate the expression. */
3840 gfc_conv_expr (&rse
, expr
);
3842 gfc_conv_tmp_array_ref (&lse
);
3844 if (intent
!= INTENT_OUT
)
3846 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3847 gfc_add_expr_to_block (&body
, tmp
);
3848 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3849 gfc_trans_scalarizing_loops (&loop
, &body
);
3853 /* Make sure that the temporary declaration survives by merging
3854 all the loop declarations into the current context. */
3855 for (n
= 0; n
< loop
.dimen
; n
++)
3857 gfc_merge_block_scope (&body
);
3858 body
= loop
.code
[loop
.order
[n
]];
3860 gfc_merge_block_scope (&body
);
3863 /* Add the post block after the second loop, so that any
3864 freeing of allocated memory is done at the right time. */
3865 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3867 /**********Copy the temporary back again.*********/
3869 gfc_init_se (&lse
, NULL
);
3870 gfc_init_se (&rse
, NULL
);
3872 /* Walk the argument expression. */
3873 lss
= gfc_walk_expr (expr
);
3874 rse
.ss
= loop
.temp_ss
;
3877 /* Initialize the scalarizer. */
3878 gfc_init_loopinfo (&loop2
);
3879 gfc_add_ss_to_loop (&loop2
, lss
);
3881 /* Calculate the bounds of the scalarization. */
3882 gfc_conv_ss_startstride (&loop2
);
3884 /* Setup the scalarizing loops. */
3885 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3887 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3888 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3890 gfc_mark_ss_chain_used (lss
, 1);
3891 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3893 /* Declare the variable to hold the temporary offset and start the
3894 scalarized loop body. */
3895 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3896 gfc_start_scalarized_body (&loop2
, &body
);
3898 /* Build the offsets for the temporary from the loop variables. The
3899 temporary array has lbounds of zero and strides of one in all
3900 dimensions, so this is very simple. The offset is only computed
3901 outside the innermost loop, so the overall transfer could be
3902 optimized further. */
3903 info
= &rse
.ss
->info
->data
.array
;
3904 dimen
= rse
.ss
->dimen
;
3906 tmp_index
= gfc_index_zero_node
;
3907 for (n
= dimen
- 1; n
> 0; n
--)
3910 tmp
= rse
.loop
->loopvar
[n
];
3911 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3912 tmp
, rse
.loop
->from
[n
]);
3913 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3916 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3917 gfc_array_index_type
,
3918 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3919 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3920 gfc_array_index_type
,
3921 tmp_str
, gfc_index_one_node
);
3923 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3924 gfc_array_index_type
, tmp
, tmp_str
);
3927 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3928 gfc_array_index_type
,
3929 tmp_index
, rse
.loop
->from
[0]);
3930 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3932 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3933 gfc_array_index_type
,
3934 rse
.loop
->loopvar
[0], offset
);
3936 /* Now use the offset for the reference. */
3937 tmp
= build_fold_indirect_ref_loc (input_location
,
3939 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3941 if (expr
->ts
.type
== BT_CHARACTER
)
3942 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3944 gfc_conv_expr (&lse
, expr
);
3946 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3948 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3949 gfc_add_expr_to_block (&body
, tmp
);
3951 /* Generate the copying loops. */
3952 gfc_trans_scalarizing_loops (&loop2
, &body
);
3954 /* Wrap the whole thing up by adding the second loop to the post-block
3955 and following it by the post-block of the first loop. In this way,
3956 if the temporary needs freeing, it is done after use! */
3957 if (intent
!= INTENT_IN
)
3959 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3960 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3963 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3965 gfc_cleanup_loop (&loop
);
3966 gfc_cleanup_loop (&loop2
);
3968 /* Pass the string length to the argument expression. */
3969 if (expr
->ts
.type
== BT_CHARACTER
)
3970 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3972 /* Determine the offset for pointer formal arguments and set the
3976 size
= gfc_index_one_node
;
3977 offset
= gfc_index_zero_node
;
3978 for (n
= 0; n
< dimen
; n
++)
3980 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3982 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3983 gfc_array_index_type
, tmp
,
3984 gfc_index_one_node
);
3985 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3989 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3992 gfc_index_one_node
);
3993 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3994 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3995 gfc_array_index_type
,
3997 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3998 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3999 gfc_array_index_type
,
4000 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4001 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4002 gfc_array_index_type
,
4003 tmp
, gfc_index_one_node
);
4004 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4005 gfc_array_index_type
, size
, tmp
);
4008 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4012 /* We want either the address for the data or the address of the descriptor,
4013 depending on the mode of passing array arguments. */
4015 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4017 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4023 /* Generate the code for argument list functions. */
4026 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4028 /* Pass by value for g77 %VAL(arg), pass the address
4029 indirectly for %LOC, else by reference. Thus %REF
4030 is a "do-nothing" and %LOC is the same as an F95
4032 if (strncmp (name
, "%VAL", 4) == 0)
4033 gfc_conv_expr (se
, expr
);
4034 else if (strncmp (name
, "%LOC", 4) == 0)
4036 gfc_conv_expr_reference (se
, expr
);
4037 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4039 else if (strncmp (name
, "%REF", 4) == 0)
4040 gfc_conv_expr_reference (se
, expr
);
4042 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4046 /* Generate code for a procedure call. Note can return se->post != NULL.
4047 If se->direct_byref is set then se->expr contains the return parameter.
4048 Return nonzero, if the call has alternate specifiers.
4049 'expr' is only needed for procedure pointer components. */
4052 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4053 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4054 vec
<tree
, va_gc
> *append_args
)
4056 gfc_interface_mapping mapping
;
4057 vec
<tree
, va_gc
> *arglist
;
4058 vec
<tree
, va_gc
> *retargs
;
4062 gfc_array_info
*info
;
4069 vec
<tree
, va_gc
> *stringargs
;
4070 vec
<tree
, va_gc
> *optionalargs
;
4072 gfc_formal_arglist
*formal
;
4073 gfc_actual_arglist
*arg
;
4074 int has_alternate_specifier
= 0;
4075 bool need_interface_mapping
;
4082 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4083 gfc_component
*comp
= NULL
;
4089 optionalargs
= NULL
;
4094 comp
= gfc_get_proc_ptr_comp (expr
);
4098 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4100 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4101 if (se
->ss
->info
->useflags
)
4103 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4104 && sym
->result
->attr
.dimension
)
4105 || (comp
&& comp
->attr
.dimension
));
4106 gcc_assert (se
->loop
!= NULL
);
4108 /* Access the previously obtained result. */
4109 gfc_conv_tmp_array_ref (se
);
4113 info
= &se
->ss
->info
->data
.array
;
4118 gfc_init_block (&post
);
4119 gfc_init_interface_mapping (&mapping
);
4122 formal
= gfc_sym_get_dummy_args (sym
);
4123 need_interface_mapping
= sym
->attr
.dimension
||
4124 (sym
->ts
.type
== BT_CHARACTER
4125 && sym
->ts
.u
.cl
->length
4126 && sym
->ts
.u
.cl
->length
->expr_type
4131 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4132 need_interface_mapping
= comp
->attr
.dimension
||
4133 (comp
->ts
.type
== BT_CHARACTER
4134 && comp
->ts
.u
.cl
->length
4135 && comp
->ts
.u
.cl
->length
->expr_type
4139 base_object
= NULL_TREE
;
4141 /* Evaluate the arguments. */
4142 for (arg
= args
; arg
!= NULL
;
4143 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4146 fsym
= formal
? formal
->sym
: NULL
;
4147 parm_kind
= MISSING
;
4149 /* Class array expressions are sometimes coming completely unadorned
4150 with either arrayspec or _data component. Correct that here.
4151 OOP-TODO: Move this to the frontend. */
4152 if (e
&& e
->expr_type
== EXPR_VARIABLE
4154 && e
->ts
.type
== BT_CLASS
4155 && (CLASS_DATA (e
)->attr
.codimension
4156 || CLASS_DATA (e
)->attr
.dimension
))
4158 gfc_typespec temp_ts
= e
->ts
;
4159 gfc_add_class_array_ref (e
);
4165 if (se
->ignore_optional
)
4167 /* Some intrinsics have already been resolved to the correct
4171 else if (arg
->label
)
4173 has_alternate_specifier
= 1;
4178 gfc_init_se (&parmse
, NULL
);
4180 /* For scalar arguments with VALUE attribute which are passed by
4181 value, pass "0" and a hidden argument gives the optional
4183 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4184 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4185 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4187 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4189 vec_safe_push (optionalargs
, boolean_false_node
);
4193 /* Pass a NULL pointer for an absent arg. */
4194 parmse
.expr
= null_pointer_node
;
4195 if (arg
->missing_arg_type
== BT_CHARACTER
)
4196 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4201 else if (arg
->expr
->expr_type
== EXPR_NULL
4202 && fsym
&& !fsym
->attr
.pointer
4203 && (fsym
->ts
.type
!= BT_CLASS
4204 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4206 /* Pass a NULL pointer to denote an absent arg. */
4207 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4208 && (fsym
->ts
.type
!= BT_CLASS
4209 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4210 gfc_init_se (&parmse
, NULL
);
4211 parmse
.expr
= null_pointer_node
;
4212 if (arg
->missing_arg_type
== BT_CHARACTER
)
4213 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4215 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4216 && e
->ts
.type
== BT_DERIVED
)
4218 /* The derived type needs to be converted to a temporary
4220 gfc_init_se (&parmse
, se
);
4221 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4223 && e
->expr_type
== EXPR_VARIABLE
4224 && e
->symtree
->n
.sym
->attr
.optional
,
4225 CLASS_DATA (fsym
)->attr
.class_pointer
4226 || CLASS_DATA (fsym
)->attr
.allocatable
);
4228 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4230 /* The intrinsic type needs to be converted to a temporary
4231 CLASS object for the unlimited polymorphic formal. */
4232 gfc_init_se (&parmse
, se
);
4233 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4235 else if (se
->ss
&& se
->ss
->info
->useflags
)
4241 /* An elemental function inside a scalarized loop. */
4242 gfc_init_se (&parmse
, se
);
4243 parm_kind
= ELEMENTAL
;
4245 if (fsym
&& fsym
->attr
.value
)
4246 gfc_conv_expr (&parmse
, e
);
4248 gfc_conv_expr_reference (&parmse
, e
);
4250 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4251 && e
->expr_type
== EXPR_FUNCTION
)
4252 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4255 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4256 && gfc_is_class_container_ref (e
))
4258 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4260 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4261 && e
->symtree
->n
.sym
->attr
.optional
)
4263 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4264 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4265 TREE_TYPE (parmse
.expr
),
4267 fold_convert (TREE_TYPE (parmse
.expr
),
4268 null_pointer_node
));
4272 /* If we are passing an absent array as optional dummy to an
4273 elemental procedure, make sure that we pass NULL when the data
4274 pointer is NULL. We need this extra conditional because of
4275 scalarization which passes arrays elements to the procedure,
4276 ignoring the fact that the array can be absent/unallocated/... */
4277 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4279 tree descriptor_data
;
4281 descriptor_data
= ss
->info
->data
.array
.data
;
4282 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4284 fold_convert (TREE_TYPE (descriptor_data
),
4285 null_pointer_node
));
4287 = fold_build3_loc (input_location
, COND_EXPR
,
4288 TREE_TYPE (parmse
.expr
),
4289 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4290 fold_convert (TREE_TYPE (parmse
.expr
),
4295 /* The scalarizer does not repackage the reference to a class
4296 array - instead it returns a pointer to the data element. */
4297 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4298 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4299 fsym
->attr
.intent
!= INTENT_IN
4300 && (CLASS_DATA (fsym
)->attr
.class_pointer
4301 || CLASS_DATA (fsym
)->attr
.allocatable
),
4303 && e
->expr_type
== EXPR_VARIABLE
4304 && e
->symtree
->n
.sym
->attr
.optional
,
4305 CLASS_DATA (fsym
)->attr
.class_pointer
4306 || CLASS_DATA (fsym
)->attr
.allocatable
);
4313 gfc_init_se (&parmse
, NULL
);
4315 /* Check whether the expression is a scalar or not; we cannot use
4316 e->rank as it can be nonzero for functions arguments. */
4317 argss
= gfc_walk_expr (e
);
4318 scalar
= argss
== gfc_ss_terminator
;
4320 gfc_free_ss_chain (argss
);
4322 /* Special handling for passing scalar polymorphic coarrays;
4323 otherwise one passes "class->_data.data" instead of "&class". */
4324 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4325 && fsym
&& fsym
->ts
.type
== BT_CLASS
4326 && CLASS_DATA (fsym
)->attr
.codimension
4327 && !CLASS_DATA (fsym
)->attr
.dimension
)
4329 gfc_add_class_array_ref (e
);
4330 parmse
.want_coarray
= 1;
4334 /* A scalar or transformational function. */
4337 if (e
->expr_type
== EXPR_VARIABLE
4338 && e
->symtree
->n
.sym
->attr
.cray_pointee
4339 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4341 /* The Cray pointer needs to be converted to a pointer to
4342 a type given by the expression. */
4343 gfc_conv_expr (&parmse
, e
);
4344 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4345 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4346 parmse
.expr
= convert (type
, tmp
);
4348 else if (fsym
&& fsym
->attr
.value
)
4350 if (fsym
->ts
.type
== BT_CHARACTER
4351 && fsym
->ts
.is_c_interop
4352 && fsym
->ns
->proc_name
!= NULL
4353 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4356 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4357 if (parmse
.expr
== NULL
)
4358 gfc_conv_expr (&parmse
, e
);
4362 gfc_conv_expr (&parmse
, e
);
4363 if (fsym
->attr
.optional
4364 && fsym
->ts
.type
!= BT_CLASS
4365 && fsym
->ts
.type
!= BT_DERIVED
)
4367 if (e
->expr_type
!= EXPR_VARIABLE
4368 || !e
->symtree
->n
.sym
->attr
.optional
4370 vec_safe_push (optionalargs
, boolean_true_node
);
4373 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4374 if (!e
->symtree
->n
.sym
->attr
.value
)
4376 = fold_build3_loc (input_location
, COND_EXPR
,
4377 TREE_TYPE (parmse
.expr
),
4379 fold_convert (TREE_TYPE (parmse
.expr
),
4380 integer_zero_node
));
4382 vec_safe_push (optionalargs
, tmp
);
4387 else if (arg
->name
&& arg
->name
[0] == '%')
4388 /* Argument list functions %VAL, %LOC and %REF are signalled
4389 through arg->name. */
4390 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4391 else if ((e
->expr_type
== EXPR_FUNCTION
)
4392 && ((e
->value
.function
.esym
4393 && e
->value
.function
.esym
->result
->attr
.pointer
)
4394 || (!e
->value
.function
.esym
4395 && e
->symtree
->n
.sym
->attr
.pointer
))
4396 && fsym
&& fsym
->attr
.target
)
4398 gfc_conv_expr (&parmse
, e
);
4399 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4401 else if (e
->expr_type
== EXPR_FUNCTION
4402 && e
->symtree
->n
.sym
->result
4403 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4404 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4406 /* Functions returning procedure pointers. */
4407 gfc_conv_expr (&parmse
, e
);
4408 if (fsym
&& fsym
->attr
.proc_pointer
)
4409 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4413 if (e
->ts
.type
== BT_CLASS
&& fsym
4414 && fsym
->ts
.type
== BT_CLASS
4415 && (!CLASS_DATA (fsym
)->as
4416 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4417 && CLASS_DATA (e
)->attr
.codimension
)
4419 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4420 gcc_assert (!CLASS_DATA (fsym
)->as
);
4421 gfc_add_class_array_ref (e
);
4422 parmse
.want_coarray
= 1;
4423 gfc_conv_expr_reference (&parmse
, e
);
4424 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4426 && e
->expr_type
== EXPR_VARIABLE
);
4429 gfc_conv_expr_reference (&parmse
, e
);
4431 /* Catch base objects that are not variables. */
4432 if (e
->ts
.type
== BT_CLASS
4433 && e
->expr_type
!= EXPR_VARIABLE
4434 && expr
&& e
== expr
->base_expr
)
4435 base_object
= build_fold_indirect_ref_loc (input_location
,
4438 /* A class array element needs converting back to be a
4439 class object, if the formal argument is a class object. */
4440 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4441 && e
->ts
.type
== BT_CLASS
4442 && ((CLASS_DATA (fsym
)->as
4443 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4444 || CLASS_DATA (e
)->attr
.dimension
))
4445 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4446 fsym
->attr
.intent
!= INTENT_IN
4447 && (CLASS_DATA (fsym
)->attr
.class_pointer
4448 || CLASS_DATA (fsym
)->attr
.allocatable
),
4450 && e
->expr_type
== EXPR_VARIABLE
4451 && e
->symtree
->n
.sym
->attr
.optional
,
4452 CLASS_DATA (fsym
)->attr
.class_pointer
4453 || CLASS_DATA (fsym
)->attr
.allocatable
);
4455 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4456 allocated on entry, it must be deallocated. */
4457 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4458 && (fsym
->attr
.allocatable
4459 || (fsym
->ts
.type
== BT_CLASS
4460 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4465 gfc_init_block (&block
);
4467 if (e
->ts
.type
== BT_CLASS
)
4468 ptr
= gfc_class_data_get (ptr
);
4470 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4472 gfc_add_expr_to_block (&block
, tmp
);
4473 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4474 void_type_node
, ptr
,
4476 gfc_add_expr_to_block (&block
, tmp
);
4478 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4480 gfc_add_modify (&block
, ptr
,
4481 fold_convert (TREE_TYPE (ptr
),
4482 null_pointer_node
));
4483 gfc_add_expr_to_block (&block
, tmp
);
4485 else if (fsym
->ts
.type
== BT_CLASS
)
4488 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4489 tmp
= gfc_get_symbol_decl (vtab
);
4490 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4491 ptr
= gfc_class_vptr_get (parmse
.expr
);
4492 gfc_add_modify (&block
, ptr
,
4493 fold_convert (TREE_TYPE (ptr
), tmp
));
4494 gfc_add_expr_to_block (&block
, tmp
);
4497 if (fsym
->attr
.optional
4498 && e
->expr_type
== EXPR_VARIABLE
4499 && e
->symtree
->n
.sym
->attr
.optional
)
4501 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4503 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4504 gfc_finish_block (&block
),
4505 build_empty_stmt (input_location
));
4508 tmp
= gfc_finish_block (&block
);
4510 gfc_add_expr_to_block (&se
->pre
, tmp
);
4513 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4514 || fsym
->ts
.type
== BT_ASSUMED
)
4515 && e
->ts
.type
== BT_CLASS
4516 && !CLASS_DATA (e
)->attr
.dimension
4517 && !CLASS_DATA (e
)->attr
.codimension
)
4518 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4520 /* Wrap scalar variable in a descriptor. We need to convert
4521 the address of a pointer back to the pointer itself before,
4522 we can assign it to the data field. */
4524 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4525 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4528 if (TREE_CODE (tmp
) == ADDR_EXPR
4529 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4530 tmp
= TREE_OPERAND (tmp
, 0);
4531 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4533 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4536 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4537 && ((fsym
->attr
.pointer
4538 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4539 || (fsym
->attr
.proc_pointer
4540 && !(e
->expr_type
== EXPR_VARIABLE
4541 && e
->symtree
->n
.sym
->attr
.dummy
))
4542 || (fsym
->attr
.proc_pointer
4543 && e
->expr_type
== EXPR_VARIABLE
4544 && gfc_is_proc_ptr_comp (e
))
4545 || (fsym
->attr
.allocatable
4546 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4548 /* Scalar pointer dummy args require an extra level of
4549 indirection. The null pointer already contains
4550 this level of indirection. */
4551 parm_kind
= SCALAR_POINTER
;
4552 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4556 else if (e
->ts
.type
== BT_CLASS
4557 && fsym
&& fsym
->ts
.type
== BT_CLASS
4558 && (CLASS_DATA (fsym
)->attr
.dimension
4559 || CLASS_DATA (fsym
)->attr
.codimension
))
4561 /* Pass a class array. */
4562 parmse
.use_offset
= 1;
4563 gfc_conv_expr_descriptor (&parmse
, e
);
4565 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4566 allocated on entry, it must be deallocated. */
4567 if (fsym
->attr
.intent
== INTENT_OUT
4568 && CLASS_DATA (fsym
)->attr
.allocatable
)
4573 gfc_init_block (&block
);
4575 ptr
= gfc_class_data_get (ptr
);
4577 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4578 NULL_TREE
, NULL_TREE
,
4581 gfc_add_expr_to_block (&block
, tmp
);
4582 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4583 void_type_node
, ptr
,
4585 gfc_add_expr_to_block (&block
, tmp
);
4586 gfc_reset_vptr (&block
, e
);
4588 if (fsym
->attr
.optional
4589 && e
->expr_type
== EXPR_VARIABLE
4591 || (e
->ref
->type
== REF_ARRAY
4592 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4593 && e
->symtree
->n
.sym
->attr
.optional
)
4595 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4597 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4598 gfc_finish_block (&block
),
4599 build_empty_stmt (input_location
));
4602 tmp
= gfc_finish_block (&block
);
4604 gfc_add_expr_to_block (&se
->pre
, tmp
);
4607 /* The conversion does not repackage the reference to a class
4608 array - _data descriptor. */
4609 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4610 fsym
->attr
.intent
!= INTENT_IN
4611 && (CLASS_DATA (fsym
)->attr
.class_pointer
4612 || CLASS_DATA (fsym
)->attr
.allocatable
),
4614 && e
->expr_type
== EXPR_VARIABLE
4615 && e
->symtree
->n
.sym
->attr
.optional
,
4616 CLASS_DATA (fsym
)->attr
.class_pointer
4617 || CLASS_DATA (fsym
)->attr
.allocatable
);
4621 /* If the procedure requires an explicit interface, the actual
4622 argument is passed according to the corresponding formal
4623 argument. If the corresponding formal argument is a POINTER,
4624 ALLOCATABLE or assumed shape, we do not use g77's calling
4625 convention, and pass the address of the array descriptor
4626 instead. Otherwise we use g77's calling convention. */
4629 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4630 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4631 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4633 f
= f
|| !comp
->attr
.always_explicit
;
4635 f
= f
|| !sym
->attr
.always_explicit
;
4637 /* If the argument is a function call that may not create
4638 a temporary for the result, we have to check that we
4639 can do it, i.e. that there is no alias between this
4640 argument and another one. */
4641 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4647 intent
= fsym
->attr
.intent
;
4649 intent
= INTENT_UNKNOWN
;
4651 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4653 parmse
.force_tmp
= 1;
4655 iarg
= e
->value
.function
.actual
->expr
;
4657 /* Temporary needed if aliasing due to host association. */
4658 if (sym
->attr
.contained
4660 && !sym
->attr
.implicit_pure
4661 && !sym
->attr
.use_assoc
4662 && iarg
->expr_type
== EXPR_VARIABLE
4663 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4664 parmse
.force_tmp
= 1;
4666 /* Ditto within module. */
4667 if (sym
->attr
.use_assoc
4669 && !sym
->attr
.implicit_pure
4670 && iarg
->expr_type
== EXPR_VARIABLE
4671 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4672 parmse
.force_tmp
= 1;
4675 if (e
->expr_type
== EXPR_VARIABLE
4676 && is_subref_array (e
))
4677 /* The actual argument is a component reference to an
4678 array of derived types. In this case, the argument
4679 is converted to a temporary, which is passed and then
4680 written back after the procedure call. */
4681 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4682 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4683 fsym
&& fsym
->attr
.pointer
);
4684 else if (gfc_is_class_array_ref (e
, NULL
)
4685 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4686 /* The actual argument is a component reference to an
4687 array of derived types. In this case, the argument
4688 is converted to a temporary, which is passed and then
4689 written back after the procedure call.
4690 OOP-TODO: Insert code so that if the dynamic type is
4691 the same as the declared type, copy-in/copy-out does
4693 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4694 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4695 fsym
&& fsym
->attr
.pointer
);
4697 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4699 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4700 allocated on entry, it must be deallocated. */
4701 if (fsym
&& fsym
->attr
.allocatable
4702 && fsym
->attr
.intent
== INTENT_OUT
)
4704 tmp
= build_fold_indirect_ref_loc (input_location
,
4706 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4707 if (fsym
->attr
.optional
4708 && e
->expr_type
== EXPR_VARIABLE
4709 && e
->symtree
->n
.sym
->attr
.optional
)
4710 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4712 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4713 tmp
, build_empty_stmt (input_location
));
4714 gfc_add_expr_to_block (&se
->pre
, tmp
);
4719 /* The case with fsym->attr.optional is that of a user subroutine
4720 with an interface indicating an optional argument. When we call
4721 an intrinsic subroutine, however, fsym is NULL, but we might still
4722 have an optional argument, so we proceed to the substitution
4724 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4726 /* If an optional argument is itself an optional dummy argument,
4727 check its presence and substitute a null if absent. This is
4728 only needed when passing an array to an elemental procedure
4729 as then array elements are accessed - or no NULL pointer is
4730 allowed and a "1" or "0" should be passed if not present.
4731 When passing a non-array-descriptor full array to a
4732 non-array-descriptor dummy, no check is needed. For
4733 array-descriptor actual to array-descriptor dummy, see
4734 PR 41911 for why a check has to be inserted.
4735 fsym == NULL is checked as intrinsics required the descriptor
4736 but do not always set fsym. */
4737 if (e
->expr_type
== EXPR_VARIABLE
4738 && e
->symtree
->n
.sym
->attr
.optional
4739 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4740 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4744 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4745 || fsym
->as
->type
== AS_ASSUMED_RANK
4746 || fsym
->as
->type
== AS_DEFERRED
))))))
4747 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4748 e
->representation
.length
);
4753 /* Obtain the character length of an assumed character length
4754 length procedure from the typespec. */
4755 if (fsym
->ts
.type
== BT_CHARACTER
4756 && parmse
.string_length
== NULL_TREE
4757 && e
->ts
.type
== BT_PROCEDURE
4758 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4759 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4760 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4762 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4763 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4767 if (fsym
&& need_interface_mapping
&& e
)
4768 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4770 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4771 gfc_add_block_to_block (&post
, &parmse
.post
);
4773 /* Allocated allocatable components of derived types must be
4774 deallocated for non-variable scalars. Non-variable arrays are
4775 dealt with in trans-array.c(gfc_conv_array_parameter). */
4776 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4777 && e
->ts
.u
.derived
->attr
.alloc_comp
4778 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4779 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4782 tmp
= build_fold_indirect_ref_loc (input_location
,
4784 parm_rank
= e
->rank
;
4792 case (SCALAR_POINTER
):
4793 tmp
= build_fold_indirect_ref_loc (input_location
,
4798 if (e
->expr_type
== EXPR_OP
4799 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4800 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4803 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4804 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4805 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4808 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4810 /* The derived type is passed to gfc_deallocate_alloc_comp.
4811 Therefore, class actuals can handled correctly but derived
4812 types passed to class formals need the _data component. */
4813 tmp
= gfc_class_data_get (tmp
);
4814 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4815 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4818 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4820 gfc_add_expr_to_block (&se
->post
, tmp
);
4823 /* Add argument checking of passing an unallocated/NULL actual to
4824 a nonallocatable/nonpointer dummy. */
4826 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4828 symbol_attribute attr
;
4832 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4833 attr
= gfc_expr_attr (e
);
4835 goto end_pointer_check
;
4837 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4838 allocatable to an optional dummy, cf. 12.5.2.12. */
4839 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4840 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4841 goto end_pointer_check
;
4845 /* If the actual argument is an optional pointer/allocatable and
4846 the formal argument takes an nonpointer optional value,
4847 it is invalid to pass a non-present argument on, even
4848 though there is no technical reason for this in gfortran.
4849 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4850 tree present
, null_ptr
, type
;
4852 if (attr
.allocatable
4853 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4854 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4855 "allocated or not present", e
->symtree
->n
.sym
->name
);
4856 else if (attr
.pointer
4857 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4858 asprintf (&msg
, "Pointer actual argument '%s' is not "
4859 "associated or not present",
4860 e
->symtree
->n
.sym
->name
);
4861 else if (attr
.proc_pointer
4862 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4863 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4864 "associated or not present",
4865 e
->symtree
->n
.sym
->name
);
4867 goto end_pointer_check
;
4869 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4870 type
= TREE_TYPE (present
);
4871 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4872 boolean_type_node
, present
,
4874 null_pointer_node
));
4875 type
= TREE_TYPE (parmse
.expr
);
4876 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4877 boolean_type_node
, parmse
.expr
,
4879 null_pointer_node
));
4880 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4881 boolean_type_node
, present
, null_ptr
);
4885 if (attr
.allocatable
4886 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4887 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4888 "allocated", e
->symtree
->n
.sym
->name
);
4889 else if (attr
.pointer
4890 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4891 asprintf (&msg
, "Pointer actual argument '%s' is not "
4892 "associated", e
->symtree
->n
.sym
->name
);
4893 else if (attr
.proc_pointer
4894 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4895 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4896 "associated", e
->symtree
->n
.sym
->name
);
4898 goto end_pointer_check
;
4902 /* If the argument is passed by value, we need to strip the
4904 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4905 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4907 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4908 boolean_type_node
, tmp
,
4909 fold_convert (TREE_TYPE (tmp
),
4910 null_pointer_node
));
4913 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4919 /* Deferred length dummies pass the character length by reference
4920 so that the value can be returned. */
4921 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4923 tmp
= parmse
.string_length
;
4924 if (TREE_CODE (tmp
) != VAR_DECL
)
4925 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4926 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4929 /* Character strings are passed as two parameters, a length and a
4930 pointer - except for Bind(c) which only passes the pointer.
4931 An unlimited polymorphic formal argument likewise does not
4933 if (parmse
.string_length
!= NULL_TREE
4934 && !sym
->attr
.is_bind_c
4935 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4936 vec_safe_push (stringargs
, parmse
.string_length
);
4938 /* When calling __copy for character expressions to unlimited
4939 polymorphic entities, the dst argument needs a string length. */
4940 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4941 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4942 && arg
->next
&& arg
->next
->expr
4943 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4944 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4945 vec_safe_push (stringargs
, parmse
.string_length
);
4947 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4948 pass the token and the offset as additional arguments. */
4949 if (fsym
&& e
== NULL
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4950 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4951 && !fsym
->attr
.allocatable
)
4952 || (fsym
->ts
.type
== BT_CLASS
4953 && CLASS_DATA (fsym
)->attr
.codimension
4954 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4956 /* Token and offset. */
4957 vec_safe_push (stringargs
, null_pointer_node
);
4958 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4959 gcc_assert (fsym
->attr
.optional
);
4961 else if (fsym
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
4962 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
4963 && !fsym
->attr
.allocatable
)
4964 || (fsym
->ts
.type
== BT_CLASS
4965 && CLASS_DATA (fsym
)->attr
.codimension
4966 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
4968 tree caf_decl
, caf_type
;
4971 caf_decl
= gfc_get_tree_for_caf_expr (e
);
4972 caf_type
= TREE_TYPE (caf_decl
);
4974 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4975 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
4976 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
4977 tmp
= gfc_conv_descriptor_token (caf_decl
);
4978 else if (DECL_LANG_SPECIFIC (caf_decl
)
4979 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4980 tmp
= GFC_DECL_TOKEN (caf_decl
);
4983 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4984 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4985 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4988 vec_safe_push (stringargs
, tmp
);
4990 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4991 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4992 offset
= build_int_cst (gfc_array_index_type
, 0);
4993 else if (DECL_LANG_SPECIFIC (caf_decl
)
4994 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4995 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4996 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4997 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4999 offset
= build_int_cst (gfc_array_index_type
, 0);
5001 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5002 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5005 gcc_assert (POINTER_TYPE_P (caf_type
));
5009 tmp2
= fsym
->ts
.type
== BT_CLASS
5010 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5011 if ((fsym
->ts
.type
!= BT_CLASS
5012 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5013 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5014 || (fsym
->ts
.type
== BT_CLASS
5015 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5016 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5018 if (fsym
->ts
.type
== BT_CLASS
)
5019 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5022 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5023 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5025 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5026 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5028 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5029 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5032 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5035 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5036 gfc_array_index_type
,
5037 fold_convert (gfc_array_index_type
, tmp2
),
5038 fold_convert (gfc_array_index_type
, tmp
));
5039 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5040 gfc_array_index_type
, offset
, tmp
);
5042 vec_safe_push (stringargs
, offset
);
5045 vec_safe_push (arglist
, parmse
.expr
);
5047 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5054 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5055 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5056 else if (ts
.type
== BT_CHARACTER
)
5058 if (ts
.u
.cl
->length
== NULL
)
5060 /* Assumed character length results are not allowed by 5.1.1.5 of the
5061 standard and are trapped in resolve.c; except in the case of SPREAD
5062 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5063 we take the character length of the first argument for the result.
5064 For dummies, we have to look through the formal argument list for
5065 this function and use the character length found there.*/
5067 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5068 else if (!sym
->attr
.dummy
)
5069 cl
.backend_decl
= (*stringargs
)[0];
5072 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5073 for (; formal
; formal
= formal
->next
)
5074 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5075 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5077 len
= cl
.backend_decl
;
5083 /* Calculate the length of the returned string. */
5084 gfc_init_se (&parmse
, NULL
);
5085 if (need_interface_mapping
)
5086 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5088 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5089 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5090 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5092 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5093 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5094 gfc_charlen_type_node
, tmp
,
5095 build_int_cst (gfc_charlen_type_node
, 0));
5096 cl
.backend_decl
= tmp
;
5099 /* Set up a charlen structure for it. */
5104 len
= cl
.backend_decl
;
5107 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5108 || (!comp
&& gfc_return_by_reference (sym
));
5111 if (se
->direct_byref
)
5113 /* Sometimes, too much indirection can be applied; e.g. for
5114 function_result = array_valued_recursive_function. */
5115 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5116 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5117 && GFC_DESCRIPTOR_TYPE_P
5118 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5119 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5122 /* If the lhs of an assignment x = f(..) is allocatable and
5123 f2003 is allowed, we must do the automatic reallocation.
5124 TODO - deal with intrinsics, without using a temporary. */
5125 if (gfc_option
.flag_realloc_lhs
5126 && se
->ss
&& se
->ss
->loop_chain
5127 && se
->ss
->loop_chain
->is_alloc_lhs
5128 && !expr
->value
.function
.isym
5129 && sym
->result
->as
!= NULL
)
5131 /* Evaluate the bounds of the result, if known. */
5132 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5135 /* Perform the automatic reallocation. */
5136 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5138 gfc_add_expr_to_block (&se
->pre
, tmp
);
5140 /* Pass the temporary as the first argument. */
5141 result
= info
->descriptor
;
5144 result
= build_fold_indirect_ref_loc (input_location
,
5146 vec_safe_push (retargs
, se
->expr
);
5148 else if (comp
&& comp
->attr
.dimension
)
5150 gcc_assert (se
->loop
&& info
);
5152 /* Set the type of the array. */
5153 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5154 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5156 /* Evaluate the bounds of the result, if known. */
5157 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5159 /* If the lhs of an assignment x = f(..) is allocatable and
5160 f2003 is allowed, we must not generate the function call
5161 here but should just send back the results of the mapping.
5162 This is signalled by the function ss being flagged. */
5163 if (gfc_option
.flag_realloc_lhs
5164 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5166 gfc_free_interface_mapping (&mapping
);
5167 return has_alternate_specifier
;
5170 /* Create a temporary to store the result. In case the function
5171 returns a pointer, the temporary will be a shallow copy and
5172 mustn't be deallocated. */
5173 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5174 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5175 tmp
, NULL_TREE
, false,
5176 !comp
->attr
.pointer
, callee_alloc
,
5177 &se
->ss
->info
->expr
->where
);
5179 /* Pass the temporary as the first argument. */
5180 result
= info
->descriptor
;
5181 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5182 vec_safe_push (retargs
, tmp
);
5184 else if (!comp
&& sym
->result
->attr
.dimension
)
5186 gcc_assert (se
->loop
&& info
);
5188 /* Set the type of the array. */
5189 tmp
= gfc_typenode_for_spec (&ts
);
5190 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5192 /* Evaluate the bounds of the result, if known. */
5193 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5195 /* If the lhs of an assignment x = f(..) is allocatable and
5196 f2003 is allowed, we must not generate the function call
5197 here but should just send back the results of the mapping.
5198 This is signalled by the function ss being flagged. */
5199 if (gfc_option
.flag_realloc_lhs
5200 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5202 gfc_free_interface_mapping (&mapping
);
5203 return has_alternate_specifier
;
5206 /* Create a temporary to store the result. In case the function
5207 returns a pointer, the temporary will be a shallow copy and
5208 mustn't be deallocated. */
5209 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5210 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5211 tmp
, NULL_TREE
, false,
5212 !sym
->attr
.pointer
, callee_alloc
,
5213 &se
->ss
->info
->expr
->where
);
5215 /* Pass the temporary as the first argument. */
5216 result
= info
->descriptor
;
5217 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5218 vec_safe_push (retargs
, tmp
);
5220 else if (ts
.type
== BT_CHARACTER
)
5222 /* Pass the string length. */
5223 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5224 type
= build_pointer_type (type
);
5226 /* Return an address to a char[0:len-1]* temporary for
5227 character pointers. */
5228 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5229 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5231 var
= gfc_create_var (type
, "pstr");
5233 if ((!comp
&& sym
->attr
.allocatable
)
5234 || (comp
&& comp
->attr
.allocatable
))
5236 gfc_add_modify (&se
->pre
, var
,
5237 fold_convert (TREE_TYPE (var
),
5238 null_pointer_node
));
5239 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5240 gfc_add_expr_to_block (&se
->post
, tmp
);
5243 /* Provide an address expression for the function arguments. */
5244 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5247 var
= gfc_conv_string_tmp (se
, type
, len
);
5249 vec_safe_push (retargs
, var
);
5253 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5255 type
= gfc_get_complex_type (ts
.kind
);
5256 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5257 vec_safe_push (retargs
, var
);
5260 /* Add the string length to the argument list. */
5261 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5264 if (TREE_CODE (tmp
) != VAR_DECL
)
5265 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5266 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5267 vec_safe_push (retargs
, tmp
);
5269 else if (ts
.type
== BT_CHARACTER
)
5270 vec_safe_push (retargs
, len
);
5272 gfc_free_interface_mapping (&mapping
);
5274 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5275 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5276 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5277 vec_safe_reserve (retargs
, arglen
);
5279 /* Add the return arguments. */
5280 retargs
->splice (arglist
);
5282 /* Add the hidden present status for optional+value to the arguments. */
5283 retargs
->splice (optionalargs
);
5285 /* Add the hidden string length parameters to the arguments. */
5286 retargs
->splice (stringargs
);
5288 /* We may want to append extra arguments here. This is used e.g. for
5289 calls to libgfortran_matmul_??, which need extra information. */
5290 if (!vec_safe_is_empty (append_args
))
5291 retargs
->splice (append_args
);
5294 /* Generate the actual call. */
5295 if (base_object
== NULL_TREE
)
5296 conv_function_val (se
, sym
, expr
);
5298 conv_base_obj_fcn_val (se
, base_object
, expr
);
5300 /* If there are alternate return labels, function type should be
5301 integer. Can't modify the type in place though, since it can be shared
5302 with other functions. For dummy arguments, the typing is done to
5303 this result, even if it has to be repeated for each call. */
5304 if (has_alternate_specifier
5305 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5307 if (!sym
->attr
.dummy
)
5309 TREE_TYPE (sym
->backend_decl
)
5310 = build_function_type (integer_type_node
,
5311 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5312 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5315 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5318 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5319 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5321 /* If we have a pointer function, but we don't want a pointer, e.g.
5324 where f is pointer valued, we have to dereference the result. */
5325 if (!se
->want_pointer
&& !byref
5326 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5327 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5328 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5330 /* f2c calling conventions require a scalar default real function to
5331 return a double precision result. Convert this back to default
5332 real. We only care about the cases that can happen in Fortran 77.
5334 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5335 && sym
->ts
.kind
== gfc_default_real_kind
5336 && !sym
->attr
.always_explicit
)
5337 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5339 /* A pure function may still have side-effects - it may modify its
5341 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5343 if (!sym
->attr
.pure
)
5344 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5349 /* Add the function call to the pre chain. There is no expression. */
5350 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5351 se
->expr
= NULL_TREE
;
5353 if (!se
->direct_byref
)
5355 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5357 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5359 /* Check the data pointer hasn't been modified. This would
5360 happen in a function returning a pointer. */
5361 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5362 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5365 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5368 se
->expr
= info
->descriptor
;
5369 /* Bundle in the string length. */
5370 se
->string_length
= len
;
5372 else if (ts
.type
== BT_CHARACTER
)
5374 /* Dereference for character pointer results. */
5375 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5376 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5377 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5381 se
->string_length
= len
;
5385 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5386 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5391 /* Follow the function call with the argument post block. */
5394 gfc_add_block_to_block (&se
->pre
, &post
);
5396 /* Transformational functions of derived types with allocatable
5397 components must have the result allocatable components copied. */
5398 arg
= expr
->value
.function
.actual
;
5399 if (result
&& arg
&& expr
->rank
5400 && expr
->value
.function
.isym
5401 && expr
->value
.function
.isym
->transformational
5402 && arg
->expr
->ts
.type
== BT_DERIVED
5403 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5406 /* Copy the allocatable components. We have to use a
5407 temporary here to prevent source allocatable components
5408 from being corrupted. */
5409 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5410 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5411 result
, tmp2
, expr
->rank
);
5412 gfc_add_expr_to_block (&se
->pre
, tmp
);
5413 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5415 gfc_add_expr_to_block (&se
->pre
, tmp
);
5417 /* Finally free the temporary's data field. */
5418 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5419 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5420 NULL_TREE
, NULL_TREE
, true,
5422 gfc_add_expr_to_block (&se
->pre
, tmp
);
5426 gfc_add_block_to_block (&se
->post
, &post
);
5428 return has_alternate_specifier
;
5432 /* Fill a character string with spaces. */
5435 fill_with_spaces (tree start
, tree type
, tree size
)
5437 stmtblock_t block
, loop
;
5438 tree i
, el
, exit_label
, cond
, tmp
;
5440 /* For a simple char type, we can call memset(). */
5441 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5442 return build_call_expr_loc (input_location
,
5443 builtin_decl_explicit (BUILT_IN_MEMSET
),
5445 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5446 lang_hooks
.to_target_charset (' ')),
5449 /* Otherwise, we use a loop:
5450 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5454 /* Initialize variables. */
5455 gfc_init_block (&block
);
5456 i
= gfc_create_var (sizetype
, "i");
5457 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5458 el
= gfc_create_var (build_pointer_type (type
), "el");
5459 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5460 exit_label
= gfc_build_label_decl (NULL_TREE
);
5461 TREE_USED (exit_label
) = 1;
5465 gfc_init_block (&loop
);
5467 /* Exit condition. */
5468 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5469 build_zero_cst (sizetype
));
5470 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5471 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5472 build_empty_stmt (input_location
));
5473 gfc_add_expr_to_block (&loop
, tmp
);
5476 gfc_add_modify (&loop
,
5477 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5478 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5480 /* Increment loop variables. */
5481 gfc_add_modify (&loop
, i
,
5482 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5483 TYPE_SIZE_UNIT (type
)));
5484 gfc_add_modify (&loop
, el
,
5485 fold_build_pointer_plus_loc (input_location
,
5486 el
, TYPE_SIZE_UNIT (type
)));
5488 /* Making the loop... actually loop! */
5489 tmp
= gfc_finish_block (&loop
);
5490 tmp
= build1_v (LOOP_EXPR
, tmp
);
5491 gfc_add_expr_to_block (&block
, tmp
);
5493 /* The exit label. */
5494 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5495 gfc_add_expr_to_block (&block
, tmp
);
5498 return gfc_finish_block (&block
);
5502 /* Generate code to copy a string. */
5505 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5506 int dkind
, tree slength
, tree src
, int skind
)
5508 tree tmp
, dlen
, slen
;
5517 stmtblock_t tempblock
;
5519 gcc_assert (dkind
== skind
);
5521 if (slength
!= NULL_TREE
)
5523 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5524 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5528 slen
= build_int_cst (size_type_node
, 1);
5532 if (dlength
!= NULL_TREE
)
5534 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5535 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5539 dlen
= build_int_cst (size_type_node
, 1);
5543 /* Assign directly if the types are compatible. */
5544 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5545 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5547 gfc_add_modify (block
, dsc
, ssc
);
5551 /* Do nothing if the destination length is zero. */
5552 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5553 build_int_cst (size_type_node
, 0));
5555 /* The following code was previously in _gfortran_copy_string:
5557 // The two strings may overlap so we use memmove.
5559 copy_string (GFC_INTEGER_4 destlen, char * dest,
5560 GFC_INTEGER_4 srclen, const char * src)
5562 if (srclen >= destlen)
5564 // This will truncate if too long.
5565 memmove (dest, src, destlen);
5569 memmove (dest, src, srclen);
5571 memset (&dest[srclen], ' ', destlen - srclen);
5575 We're now doing it here for better optimization, but the logic
5578 /* For non-default character kinds, we have to multiply the string
5579 length by the base type size. */
5580 chartype
= gfc_get_char_type (dkind
);
5581 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5582 fold_convert (size_type_node
, slen
),
5583 fold_convert (size_type_node
,
5584 TYPE_SIZE_UNIT (chartype
)));
5585 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5586 fold_convert (size_type_node
, dlen
),
5587 fold_convert (size_type_node
,
5588 TYPE_SIZE_UNIT (chartype
)));
5590 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5591 dest
= fold_convert (pvoid_type_node
, dest
);
5593 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5595 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5596 src
= fold_convert (pvoid_type_node
, src
);
5598 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5600 /* Truncate string if source is too long. */
5601 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5603 tmp2
= build_call_expr_loc (input_location
,
5604 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5605 3, dest
, src
, dlen
);
5607 /* Else copy and pad with spaces. */
5608 tmp3
= build_call_expr_loc (input_location
,
5609 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5610 3, dest
, src
, slen
);
5612 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5613 tmp4
= fill_with_spaces (tmp4
, chartype
,
5614 fold_build2_loc (input_location
, MINUS_EXPR
,
5615 TREE_TYPE(dlen
), dlen
, slen
));
5617 gfc_init_block (&tempblock
);
5618 gfc_add_expr_to_block (&tempblock
, tmp3
);
5619 gfc_add_expr_to_block (&tempblock
, tmp4
);
5620 tmp3
= gfc_finish_block (&tempblock
);
5622 /* The whole copy_string function is there. */
5623 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5625 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5626 build_empty_stmt (input_location
));
5627 gfc_add_expr_to_block (block
, tmp
);
5631 /* Translate a statement function.
5632 The value of a statement function reference is obtained by evaluating the
5633 expression using the values of the actual arguments for the values of the
5634 corresponding dummy arguments. */
5637 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5641 gfc_formal_arglist
*fargs
;
5642 gfc_actual_arglist
*args
;
5645 gfc_saved_var
*saved_vars
;
5651 sym
= expr
->symtree
->n
.sym
;
5652 args
= expr
->value
.function
.actual
;
5653 gfc_init_se (&lse
, NULL
);
5654 gfc_init_se (&rse
, NULL
);
5657 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5659 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5660 temp_vars
= XCNEWVEC (tree
, n
);
5662 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5663 fargs
= fargs
->next
, n
++)
5665 /* Each dummy shall be specified, explicitly or implicitly, to be
5667 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5670 if (fsym
->ts
.type
== BT_CHARACTER
)
5672 /* Copy string arguments. */
5675 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5676 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5678 /* Create a temporary to hold the value. */
5679 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5680 fsym
->ts
.u
.cl
->backend_decl
5681 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5683 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5684 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5686 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5688 gfc_conv_expr (&rse
, args
->expr
);
5689 gfc_conv_string_parameter (&rse
);
5690 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5691 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5693 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5694 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5695 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5696 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5700 /* For everything else, just evaluate the expression. */
5702 /* Create a temporary to hold the value. */
5703 type
= gfc_typenode_for_spec (&fsym
->ts
);
5704 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5706 gfc_conv_expr (&lse
, args
->expr
);
5708 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5709 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5710 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5716 /* Use the temporary variables in place of the real ones. */
5717 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5718 fargs
= fargs
->next
, n
++)
5719 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5721 gfc_conv_expr (se
, sym
->value
);
5723 if (sym
->ts
.type
== BT_CHARACTER
)
5725 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5727 /* Force the expression to the correct length. */
5728 if (!INTEGER_CST_P (se
->string_length
)
5729 || tree_int_cst_lt (se
->string_length
,
5730 sym
->ts
.u
.cl
->backend_decl
))
5732 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5733 tmp
= gfc_create_var (type
, sym
->name
);
5734 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5735 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5736 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5740 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5743 /* Restore the original variables. */
5744 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5745 fargs
= fargs
->next
, n
++)
5746 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5752 /* Translate a function expression. */
5755 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5759 if (expr
->value
.function
.isym
)
5761 gfc_conv_intrinsic_function (se
, expr
);
5765 /* expr.value.function.esym is the resolved (specific) function symbol for
5766 most functions. However this isn't set for dummy procedures. */
5767 sym
= expr
->value
.function
.esym
;
5769 sym
= expr
->symtree
->n
.sym
;
5771 /* The IEEE_ARITHMETIC functions are caught here. */
5772 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
5773 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
5776 /* We distinguish statement functions from general functions to improve
5777 runtime performance. */
5778 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5780 gfc_conv_statement_function (se
, expr
);
5784 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5789 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5792 is_zero_initializer_p (gfc_expr
* expr
)
5794 if (expr
->expr_type
!= EXPR_CONSTANT
)
5797 /* We ignore constants with prescribed memory representations for now. */
5798 if (expr
->representation
.string
)
5801 switch (expr
->ts
.type
)
5804 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5807 return mpfr_zero_p (expr
->value
.real
)
5808 && MPFR_SIGN (expr
->value
.real
) >= 0;
5811 return expr
->value
.logical
== 0;
5814 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5815 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5816 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5817 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5827 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5832 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5833 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5835 gfc_conv_tmp_array_ref (se
);
5839 /* Build a static initializer. EXPR is the expression for the initial value.
5840 The other parameters describe the variable of the component being
5841 initialized. EXPR may be null. */
5844 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5845 bool array
, bool pointer
, bool procptr
)
5849 if (!(expr
|| pointer
|| procptr
))
5852 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5853 (these are the only two iso_c_binding derived types that can be
5854 used as initialization expressions). If so, we need to modify
5855 the 'expr' to be that for a (void *). */
5856 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5857 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5859 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5861 /* The derived symbol has already been converted to a (void *). Use
5863 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5864 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5866 gfc_init_se (&se
, NULL
);
5867 gfc_conv_constant (&se
, expr
);
5868 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5872 if (array
&& !procptr
)
5875 /* Arrays need special handling. */
5877 ctor
= gfc_build_null_descriptor (type
);
5878 /* Special case assigning an array to zero. */
5879 else if (is_zero_initializer_p (expr
))
5880 ctor
= build_constructor (type
, NULL
);
5882 ctor
= gfc_conv_array_initializer (type
, expr
);
5883 TREE_STATIC (ctor
) = 1;
5886 else if (pointer
|| procptr
)
5888 if (ts
->type
== BT_CLASS
&& !procptr
)
5890 gfc_init_se (&se
, NULL
);
5891 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5892 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5893 TREE_STATIC (se
.expr
) = 1;
5896 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5897 return fold_convert (type
, null_pointer_node
);
5900 gfc_init_se (&se
, NULL
);
5901 se
.want_pointer
= 1;
5902 gfc_conv_expr (&se
, expr
);
5903 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5913 gfc_init_se (&se
, NULL
);
5914 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5915 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5917 gfc_conv_structure (&se
, expr
, 1);
5918 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5919 TREE_STATIC (se
.expr
) = 1;
5924 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5925 TREE_STATIC (ctor
) = 1;
5930 gfc_init_se (&se
, NULL
);
5931 gfc_conv_constant (&se
, expr
);
5932 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5939 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5945 gfc_array_info
*lss_array
;
5952 gfc_start_block (&block
);
5954 /* Initialize the scalarizer. */
5955 gfc_init_loopinfo (&loop
);
5957 gfc_init_se (&lse
, NULL
);
5958 gfc_init_se (&rse
, NULL
);
5961 rss
= gfc_walk_expr (expr
);
5962 if (rss
== gfc_ss_terminator
)
5963 /* The rhs is scalar. Add a ss for the expression. */
5964 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5966 /* Create a SS for the destination. */
5967 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5969 lss_array
= &lss
->info
->data
.array
;
5970 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5971 lss_array
->descriptor
= dest
;
5972 lss_array
->data
= gfc_conv_array_data (dest
);
5973 lss_array
->offset
= gfc_conv_array_offset (dest
);
5974 for (n
= 0; n
< cm
->as
->rank
; n
++)
5976 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5977 lss_array
->stride
[n
] = gfc_index_one_node
;
5979 mpz_init (lss_array
->shape
[n
]);
5980 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5981 cm
->as
->lower
[n
]->value
.integer
);
5982 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5985 /* Associate the SS with the loop. */
5986 gfc_add_ss_to_loop (&loop
, lss
);
5987 gfc_add_ss_to_loop (&loop
, rss
);
5989 /* Calculate the bounds of the scalarization. */
5990 gfc_conv_ss_startstride (&loop
);
5992 /* Setup the scalarizing loops. */
5993 gfc_conv_loop_setup (&loop
, &expr
->where
);
5995 /* Setup the gfc_se structures. */
5996 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5997 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6000 gfc_mark_ss_chain_used (rss
, 1);
6002 gfc_mark_ss_chain_used (lss
, 1);
6004 /* Start the scalarized loop body. */
6005 gfc_start_scalarized_body (&loop
, &body
);
6007 gfc_conv_tmp_array_ref (&lse
);
6008 if (cm
->ts
.type
== BT_CHARACTER
)
6009 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6011 gfc_conv_expr (&rse
, expr
);
6013 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6014 gfc_add_expr_to_block (&body
, tmp
);
6016 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6018 /* Generate the copying loops. */
6019 gfc_trans_scalarizing_loops (&loop
, &body
);
6021 /* Wrap the whole thing up. */
6022 gfc_add_block_to_block (&block
, &loop
.pre
);
6023 gfc_add_block_to_block (&block
, &loop
.post
);
6025 gcc_assert (lss_array
->shape
!= NULL
);
6026 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6027 gfc_cleanup_loop (&loop
);
6029 return gfc_finish_block (&block
);
6034 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6044 gfc_expr
*arg
= NULL
;
6046 gfc_start_block (&block
);
6047 gfc_init_se (&se
, NULL
);
6049 /* Get the descriptor for the expressions. */
6050 se
.want_pointer
= 0;
6051 gfc_conv_expr_descriptor (&se
, expr
);
6052 gfc_add_block_to_block (&block
, &se
.pre
);
6053 gfc_add_modify (&block
, dest
, se
.expr
);
6055 /* Deal with arrays of derived types with allocatable components. */
6056 if (cm
->ts
.type
== BT_DERIVED
6057 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6058 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6062 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6063 TREE_TYPE(cm
->backend_decl
),
6066 gfc_add_expr_to_block (&block
, tmp
);
6067 gfc_add_block_to_block (&block
, &se
.post
);
6069 if (expr
->expr_type
!= EXPR_VARIABLE
)
6070 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6073 /* We need to know if the argument of a conversion function is a
6074 variable, so that the correct lower bound can be used. */
6075 if (expr
->expr_type
== EXPR_FUNCTION
6076 && expr
->value
.function
.isym
6077 && expr
->value
.function
.isym
->conversion
6078 && expr
->value
.function
.actual
->expr
6079 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6080 arg
= expr
->value
.function
.actual
->expr
;
6082 /* Obtain the array spec of full array references. */
6084 as
= gfc_get_full_arrayspec_from_expr (arg
);
6086 as
= gfc_get_full_arrayspec_from_expr (expr
);
6088 /* Shift the lbound and ubound of temporaries to being unity,
6089 rather than zero, based. Always calculate the offset. */
6090 offset
= gfc_conv_descriptor_offset_get (dest
);
6091 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6092 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6094 for (n
= 0; n
< expr
->rank
; n
++)
6099 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6100 TODO It looks as if gfc_conv_expr_descriptor should return
6101 the correct bounds and that the following should not be
6102 necessary. This would simplify gfc_conv_intrinsic_bound
6104 if (as
&& as
->lower
[n
])
6107 gfc_init_se (&lbse
, NULL
);
6108 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6109 gfc_add_block_to_block (&block
, &lbse
.pre
);
6110 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6114 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6115 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6119 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6122 lbound
= gfc_index_one_node
;
6124 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6126 /* Shift the bounds and set the offset accordingly. */
6127 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6128 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6129 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6130 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6132 gfc_conv_descriptor_ubound_set (&block
, dest
,
6133 gfc_rank_cst
[n
], tmp
);
6134 gfc_conv_descriptor_lbound_set (&block
, dest
,
6135 gfc_rank_cst
[n
], lbound
);
6137 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6138 gfc_conv_descriptor_lbound_get (dest
,
6140 gfc_conv_descriptor_stride_get (dest
,
6142 gfc_add_modify (&block
, tmp2
, tmp
);
6143 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6145 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6150 /* If a conversion expression has a null data pointer
6151 argument, nullify the allocatable component. */
6155 if (arg
->symtree
->n
.sym
->attr
.allocatable
6156 || arg
->symtree
->n
.sym
->attr
.pointer
)
6158 non_null_expr
= gfc_finish_block (&block
);
6159 gfc_start_block (&block
);
6160 gfc_conv_descriptor_data_set (&block
, dest
,
6162 null_expr
= gfc_finish_block (&block
);
6163 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6164 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6165 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6166 return build3_v (COND_EXPR
, tmp
,
6167 null_expr
, non_null_expr
);
6171 return gfc_finish_block (&block
);
6175 /* Assign a single component of a derived type constructor. */
6178 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6185 gfc_start_block (&block
);
6187 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6189 gfc_init_se (&se
, NULL
);
6190 /* Pointer component. */
6191 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6192 && !cm
->attr
.proc_pointer
)
6194 /* Array pointer. */
6195 if (expr
->expr_type
== EXPR_NULL
)
6196 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6199 se
.direct_byref
= 1;
6201 gfc_conv_expr_descriptor (&se
, expr
);
6202 gfc_add_block_to_block (&block
, &se
.pre
);
6203 gfc_add_block_to_block (&block
, &se
.post
);
6208 /* Scalar pointers. */
6209 se
.want_pointer
= 1;
6210 gfc_conv_expr (&se
, expr
);
6211 gfc_add_block_to_block (&block
, &se
.pre
);
6213 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6214 && expr
->symtree
->n
.sym
->attr
.dummy
)
6215 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6217 gfc_add_modify (&block
, dest
,
6218 fold_convert (TREE_TYPE (dest
), se
.expr
));
6219 gfc_add_block_to_block (&block
, &se
.post
);
6222 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6224 /* NULL initialization for CLASS components. */
6225 tmp
= gfc_trans_structure_assign (dest
,
6226 gfc_class_initializer (&cm
->ts
, expr
));
6227 gfc_add_expr_to_block (&block
, tmp
);
6229 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6230 && !cm
->attr
.proc_pointer
)
6232 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6233 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6234 else if (cm
->attr
.allocatable
)
6236 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6237 gfc_add_expr_to_block (&block
, tmp
);
6241 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6242 gfc_add_expr_to_block (&block
, tmp
);
6245 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6247 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6249 gfc_init_se (&se
, NULL
);
6250 gfc_conv_expr (&se
, expr
);
6251 gfc_add_block_to_block (&block
, &se
.pre
);
6252 gfc_add_modify (&block
, dest
,
6253 fold_convert (TREE_TYPE (dest
), se
.expr
));
6254 gfc_add_block_to_block (&block
, &se
.post
);
6258 /* Nested constructors. */
6259 tmp
= gfc_trans_structure_assign (dest
, expr
);
6260 gfc_add_expr_to_block (&block
, tmp
);
6263 else if (gfc_deferred_strlen (cm
, &tmp
))
6267 gcc_assert (strlen
);
6268 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6270 TREE_OPERAND (dest
, 0),
6273 if (expr
->expr_type
== EXPR_NULL
)
6275 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6276 gfc_add_modify (&block
, dest
, tmp
);
6277 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6278 gfc_add_modify (&block
, strlen
, tmp
);
6283 gfc_init_se (&se
, NULL
);
6284 gfc_conv_expr (&se
, expr
);
6285 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6286 tmp
= build_call_expr_loc (input_location
,
6287 builtin_decl_explicit (BUILT_IN_MALLOC
),
6289 gfc_add_modify (&block
, dest
,
6290 fold_convert (TREE_TYPE (dest
), tmp
));
6291 gfc_add_modify (&block
, strlen
, se
.string_length
);
6292 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6293 gfc_add_expr_to_block (&block
, tmp
);
6296 else if (!cm
->attr
.deferred_parameter
)
6298 /* Scalar component (excluding deferred parameters). */
6299 gfc_init_se (&se
, NULL
);
6300 gfc_init_se (&lse
, NULL
);
6302 gfc_conv_expr (&se
, expr
);
6303 if (cm
->ts
.type
== BT_CHARACTER
)
6304 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6306 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6307 gfc_add_expr_to_block (&block
, tmp
);
6309 return gfc_finish_block (&block
);
6312 /* Assign a derived type constructor to a variable. */
6315 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6323 gfc_start_block (&block
);
6324 cm
= expr
->ts
.u
.derived
->components
;
6326 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6327 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6328 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6332 gcc_assert (cm
->backend_decl
== NULL
);
6333 gfc_init_se (&se
, NULL
);
6334 gfc_init_se (&lse
, NULL
);
6335 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6337 gfc_add_modify (&block
, lse
.expr
,
6338 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6340 return gfc_finish_block (&block
);
6343 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6344 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6346 /* Skip absent members in default initializers. */
6350 field
= cm
->backend_decl
;
6351 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6352 dest
, field
, NULL_TREE
);
6353 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6354 gfc_add_expr_to_block (&block
, tmp
);
6356 return gfc_finish_block (&block
);
6359 /* Build an expression for a constructor. If init is nonzero then
6360 this is part of a static variable initializer. */
6363 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6370 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6372 gcc_assert (se
->ss
== NULL
);
6373 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6374 type
= gfc_typenode_for_spec (&expr
->ts
);
6378 /* Create a temporary variable and fill it in. */
6379 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6380 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6381 gfc_add_expr_to_block (&se
->pre
, tmp
);
6385 cm
= expr
->ts
.u
.derived
->components
;
6387 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6388 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6390 /* Skip absent members in default initializers and allocatable
6391 components. Although the latter have a default initializer
6392 of EXPR_NULL,... by default, the static nullify is not needed
6393 since this is done every time we come into scope. */
6394 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6397 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6398 && strcmp (cm
->name
, "_extends") == 0
6399 && cm
->initializer
->symtree
)
6403 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6404 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6405 vtab
= unshare_expr_without_location (vtab
);
6406 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6408 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6410 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6411 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6412 fold_convert (TREE_TYPE (cm
->backend_decl
),
6417 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6418 TREE_TYPE (cm
->backend_decl
),
6419 cm
->attr
.dimension
, cm
->attr
.pointer
,
6420 cm
->attr
.proc_pointer
);
6421 val
= unshare_expr_without_location (val
);
6423 /* Append it to the constructor list. */
6424 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6427 se
->expr
= build_constructor (type
, v
);
6429 TREE_CONSTANT (se
->expr
) = 1;
6433 /* Translate a substring expression. */
6436 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6442 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6444 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6445 expr
->value
.character
.length
,
6446 expr
->value
.character
.string
);
6448 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6449 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6452 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6456 /* Entry point for expression translation. Evaluates a scalar quantity.
6457 EXPR is the expression to be translated, and SE is the state structure if
6458 called from within the scalarized. */
6461 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6466 if (ss
&& ss
->info
->expr
== expr
6467 && (ss
->info
->type
== GFC_SS_SCALAR
6468 || ss
->info
->type
== GFC_SS_REFERENCE
))
6470 gfc_ss_info
*ss_info
;
6473 /* Substitute a scalar expression evaluated outside the scalarization
6475 se
->expr
= ss_info
->data
.scalar
.value
;
6476 /* If the reference can be NULL, the value field contains the reference,
6477 not the value the reference points to (see gfc_add_loop_ss_code). */
6478 if (ss_info
->can_be_null_ref
)
6479 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6481 se
->string_length
= ss_info
->string_length
;
6482 gfc_advance_se_ss_chain (se
);
6486 /* We need to convert the expressions for the iso_c_binding derived types.
6487 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6488 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6489 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6490 updated to be an integer with a kind equal to the size of a (void *). */
6491 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6493 if (expr
->expr_type
== EXPR_VARIABLE
6494 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6495 || expr
->symtree
->n
.sym
->intmod_sym_id
6496 == ISOCBINDING_NULL_FUNPTR
))
6498 /* Set expr_type to EXPR_NULL, which will result in
6499 null_pointer_node being used below. */
6500 expr
->expr_type
= EXPR_NULL
;
6504 /* Update the type/kind of the expression to be what the new
6505 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6506 expr
->ts
.type
= BT_INTEGER
;
6507 expr
->ts
.f90_type
= BT_VOID
;
6508 expr
->ts
.kind
= gfc_index_integer_kind
;
6512 gfc_fix_class_refs (expr
);
6514 switch (expr
->expr_type
)
6517 gfc_conv_expr_op (se
, expr
);
6521 gfc_conv_function_expr (se
, expr
);
6525 gfc_conv_constant (se
, expr
);
6529 gfc_conv_variable (se
, expr
);
6533 se
->expr
= null_pointer_node
;
6536 case EXPR_SUBSTRING
:
6537 gfc_conv_substring_expr (se
, expr
);
6540 case EXPR_STRUCTURE
:
6541 gfc_conv_structure (se
, expr
, 0);
6545 gfc_conv_array_constructor_expr (se
, expr
);
6554 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6555 of an assignment. */
6557 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6559 gfc_conv_expr (se
, expr
);
6560 /* All numeric lvalues should have empty post chains. If not we need to
6561 figure out a way of rewriting an lvalue so that it has no post chain. */
6562 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6565 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6566 numeric expressions. Used for scalar values where inserting cleanup code
6569 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6573 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6574 gfc_conv_expr (se
, expr
);
6577 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6578 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6580 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6584 /* Helper to translate an expression and convert it to a particular type. */
6586 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6588 gfc_conv_expr_val (se
, expr
);
6589 se
->expr
= convert (type
, se
->expr
);
6593 /* Converts an expression so that it can be passed by reference. Scalar
6597 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6603 if (ss
&& ss
->info
->expr
== expr
6604 && ss
->info
->type
== GFC_SS_REFERENCE
)
6606 /* Returns a reference to the scalar evaluated outside the loop
6608 gfc_conv_expr (se
, expr
);
6610 if (expr
->ts
.type
== BT_CHARACTER
6611 && expr
->expr_type
!= EXPR_FUNCTION
)
6612 gfc_conv_string_parameter (se
);
6614 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6619 if (expr
->ts
.type
== BT_CHARACTER
)
6621 gfc_conv_expr (se
, expr
);
6622 gfc_conv_string_parameter (se
);
6626 if (expr
->expr_type
== EXPR_VARIABLE
)
6628 se
->want_pointer
= 1;
6629 gfc_conv_expr (se
, expr
);
6632 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6633 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6634 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6640 if (expr
->expr_type
== EXPR_FUNCTION
6641 && ((expr
->value
.function
.esym
6642 && expr
->value
.function
.esym
->result
->attr
.pointer
6643 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6644 || (!expr
->value
.function
.esym
&& !expr
->ref
6645 && expr
->symtree
->n
.sym
->attr
.pointer
6646 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6648 se
->want_pointer
= 1;
6649 gfc_conv_expr (se
, expr
);
6650 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6651 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6656 gfc_conv_expr (se
, expr
);
6658 /* Create a temporary var to hold the value. */
6659 if (TREE_CONSTANT (se
->expr
))
6661 tree tmp
= se
->expr
;
6662 STRIP_TYPE_NOPS (tmp
);
6663 var
= build_decl (input_location
,
6664 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6665 DECL_INITIAL (var
) = tmp
;
6666 TREE_STATIC (var
) = 1;
6671 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6672 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6674 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6676 /* Take the address of that value. */
6677 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6678 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6679 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6680 && expr
->ts
.u
.derived
->attr
.alloc_comp
6681 && expr
->expr_type
!= EXPR_VARIABLE
)
6685 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6686 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6688 /* The components shall be deallocated before
6689 their containing entity. */
6690 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6696 gfc_trans_pointer_assign (gfc_code
* code
)
6698 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6702 /* Generate code for a pointer assignment. */
6705 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6707 gfc_expr
*expr1_vptr
= NULL
;
6717 gfc_start_block (&block
);
6719 gfc_init_se (&lse
, NULL
);
6721 /* Check whether the expression is a scalar or not; we cannot use
6722 expr1->rank as it can be nonzero for proc pointers. */
6723 ss
= gfc_walk_expr (expr1
);
6724 scalar
= ss
== gfc_ss_terminator
;
6726 gfc_free_ss_chain (ss
);
6728 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6729 && expr2
->expr_type
!= EXPR_FUNCTION
)
6731 gfc_add_data_component (expr2
);
6732 /* The following is required as gfc_add_data_component doesn't
6733 update ts.type if there is a tailing REF_ARRAY. */
6734 expr2
->ts
.type
= BT_DERIVED
;
6739 /* Scalar pointers. */
6740 lse
.want_pointer
= 1;
6741 gfc_conv_expr (&lse
, expr1
);
6742 gfc_init_se (&rse
, NULL
);
6743 rse
.want_pointer
= 1;
6744 gfc_conv_expr (&rse
, expr2
);
6746 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6747 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6748 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6751 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6752 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6753 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6756 gfc_add_block_to_block (&block
, &lse
.pre
);
6757 gfc_add_block_to_block (&block
, &rse
.pre
);
6759 /* Check character lengths if character expression. The test is only
6760 really added if -fbounds-check is enabled. Exclude deferred
6761 character length lefthand sides. */
6762 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6763 && !expr1
->ts
.deferred
6764 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6765 && !gfc_is_proc_ptr_comp (expr1
))
6767 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6768 gcc_assert (lse
.string_length
&& rse
.string_length
);
6769 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6770 lse
.string_length
, rse
.string_length
,
6774 /* The assignment to an deferred character length sets the string
6775 length to that of the rhs. */
6776 if (expr1
->ts
.deferred
)
6778 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6779 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6780 else if (lse
.string_length
!= NULL
)
6781 gfc_add_modify (&block
, lse
.string_length
,
6782 build_int_cst (gfc_charlen_type_node
, 0));
6785 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6786 rse
.expr
= gfc_class_data_get (rse
.expr
);
6788 gfc_add_modify (&block
, lse
.expr
,
6789 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6791 gfc_add_block_to_block (&block
, &rse
.post
);
6792 gfc_add_block_to_block (&block
, &lse
.post
);
6799 tree strlen_rhs
= NULL_TREE
;
6801 /* Array pointer. Find the last reference on the LHS and if it is an
6802 array section ref, we're dealing with bounds remapping. In this case,
6803 set it to AR_FULL so that gfc_conv_expr_descriptor does
6804 not see it and process the bounds remapping afterwards explicitly. */
6805 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6806 if (!remap
->next
&& remap
->type
== REF_ARRAY
6807 && remap
->u
.ar
.type
== AR_SECTION
)
6809 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6811 gfc_init_se (&lse
, NULL
);
6813 lse
.descriptor_only
= 1;
6814 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6815 && expr1
->ts
.type
== BT_CLASS
)
6816 expr1_vptr
= gfc_copy_expr (expr1
);
6817 gfc_conv_expr_descriptor (&lse
, expr1
);
6818 strlen_lhs
= lse
.string_length
;
6821 if (expr2
->expr_type
== EXPR_NULL
)
6823 /* Just set the data pointer to null. */
6824 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6826 else if (rank_remap
)
6828 /* If we are rank-remapping, just get the RHS's descriptor and
6829 process this later on. */
6830 gfc_init_se (&rse
, NULL
);
6831 rse
.direct_byref
= 1;
6832 rse
.byref_noassign
= 1;
6834 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6836 gfc_conv_function_expr (&rse
, expr2
);
6838 if (expr1
->ts
.type
!= BT_CLASS
)
6839 rse
.expr
= gfc_class_data_get (rse
.expr
);
6842 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6843 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6845 gfc_add_vptr_component (expr1_vptr
);
6846 gfc_init_se (&rse
, NULL
);
6847 rse
.want_pointer
= 1;
6848 gfc_conv_expr (&rse
, expr1_vptr
);
6849 gfc_add_modify (&lse
.pre
, rse
.expr
,
6850 fold_convert (TREE_TYPE (rse
.expr
),
6851 gfc_class_vptr_get (tmp
)));
6852 rse
.expr
= gfc_class_data_get (tmp
);
6855 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6857 tree bound
[GFC_MAX_DIMENSIONS
];
6860 for (i
= 0; i
< expr2
->rank
; i
++)
6861 bound
[i
] = NULL_TREE
;
6862 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6863 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6865 GFC_ARRAY_POINTER_CONT
, false);
6866 tmp
= gfc_create_var (tmp
, "ptrtemp");
6868 lse
.direct_byref
= 1;
6869 gfc_conv_expr_descriptor (&lse
, expr2
);
6870 strlen_rhs
= lse
.string_length
;
6875 gfc_conv_expr_descriptor (&rse
, expr2
);
6876 strlen_rhs
= rse
.string_length
;
6879 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6881 /* Assign directly to the LHS's descriptor. */
6882 lse
.direct_byref
= 1;
6883 gfc_conv_expr_descriptor (&lse
, expr2
);
6884 strlen_rhs
= lse
.string_length
;
6886 /* If this is a subreference array pointer assignment, use the rhs
6887 descriptor element size for the lhs span. */
6888 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6890 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6891 gfc_init_se (&rse
, NULL
);
6892 rse
.descriptor_only
= 1;
6893 gfc_conv_expr (&rse
, expr2
);
6894 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6895 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6896 if (!INTEGER_CST_P (tmp
))
6897 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6898 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6901 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6903 gfc_init_se (&rse
, NULL
);
6904 rse
.want_pointer
= 1;
6905 gfc_conv_function_expr (&rse
, expr2
);
6906 if (expr1
->ts
.type
!= BT_CLASS
)
6908 rse
.expr
= gfc_class_data_get (rse
.expr
);
6909 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6913 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6914 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6916 gfc_add_vptr_component (expr1_vptr
);
6917 gfc_init_se (&rse
, NULL
);
6918 rse
.want_pointer
= 1;
6919 gfc_conv_expr (&rse
, expr1_vptr
);
6920 gfc_add_modify (&lse
.pre
, rse
.expr
,
6921 fold_convert (TREE_TYPE (rse
.expr
),
6922 gfc_class_vptr_get (tmp
)));
6923 rse
.expr
= gfc_class_data_get (tmp
);
6924 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6929 /* Assign to a temporary descriptor and then copy that
6930 temporary to the pointer. */
6931 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6933 lse
.direct_byref
= 1;
6934 gfc_conv_expr_descriptor (&lse
, expr2
);
6935 strlen_rhs
= lse
.string_length
;
6936 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6940 gfc_free_expr (expr1_vptr
);
6942 gfc_add_block_to_block (&block
, &lse
.pre
);
6944 gfc_add_block_to_block (&block
, &rse
.pre
);
6946 /* If we do bounds remapping, update LHS descriptor accordingly. */
6950 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6954 /* Do rank remapping. We already have the RHS's descriptor
6955 converted in rse and now have to build the correct LHS
6956 descriptor for it. */
6960 tree lbound
, ubound
;
6963 dtype
= gfc_conv_descriptor_dtype (desc
);
6964 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6965 gfc_add_modify (&block
, dtype
, tmp
);
6967 /* Copy data pointer. */
6968 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6969 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6971 /* Copy offset but adjust it such that it would correspond
6972 to a lbound of zero. */
6973 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6974 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6976 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6978 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6980 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6981 gfc_array_index_type
, stride
, lbound
);
6982 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6983 gfc_array_index_type
, offs
, tmp
);
6985 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6987 /* Set the bounds as declared for the LHS and calculate strides as
6988 well as another offset update accordingly. */
6989 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6991 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6996 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6998 /* Convert declared bounds. */
6999 gfc_init_se (&lower_se
, NULL
);
7000 gfc_init_se (&upper_se
, NULL
);
7001 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7002 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7004 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7005 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7007 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7008 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7010 lbound
= gfc_evaluate_now (lbound
, &block
);
7011 ubound
= gfc_evaluate_now (ubound
, &block
);
7013 gfc_add_block_to_block (&block
, &lower_se
.post
);
7014 gfc_add_block_to_block (&block
, &upper_se
.post
);
7016 /* Set bounds in descriptor. */
7017 gfc_conv_descriptor_lbound_set (&block
, desc
,
7018 gfc_rank_cst
[dim
], lbound
);
7019 gfc_conv_descriptor_ubound_set (&block
, desc
,
7020 gfc_rank_cst
[dim
], ubound
);
7023 stride
= gfc_evaluate_now (stride
, &block
);
7024 gfc_conv_descriptor_stride_set (&block
, desc
,
7025 gfc_rank_cst
[dim
], stride
);
7027 /* Update offset. */
7028 offs
= gfc_conv_descriptor_offset_get (desc
);
7029 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7030 gfc_array_index_type
, lbound
, stride
);
7031 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7032 gfc_array_index_type
, offs
, tmp
);
7033 offs
= gfc_evaluate_now (offs
, &block
);
7034 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7036 /* Update stride. */
7037 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7038 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7039 gfc_array_index_type
, stride
, tmp
);
7044 /* Bounds remapping. Just shift the lower bounds. */
7046 gcc_assert (expr1
->rank
== expr2
->rank
);
7048 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7052 gcc_assert (remap
->u
.ar
.start
[dim
]);
7053 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7054 gfc_init_se (&lbound_se
, NULL
);
7055 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7057 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7058 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7059 dim
, lbound_se
.expr
);
7060 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7065 /* Check string lengths if applicable. The check is only really added
7066 to the output code if -fbounds-check is enabled. */
7067 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7069 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7070 gcc_assert (strlen_lhs
&& strlen_rhs
);
7071 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7072 strlen_lhs
, strlen_rhs
, &block
);
7075 /* If rank remapping was done, check with -fcheck=bounds that
7076 the target is at least as large as the pointer. */
7077 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7083 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7084 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7086 lsize
= gfc_evaluate_now (lsize
, &block
);
7087 rsize
= gfc_evaluate_now (rsize
, &block
);
7088 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7091 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7092 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7096 gfc_add_block_to_block (&block
, &lse
.post
);
7098 gfc_add_block_to_block (&block
, &rse
.post
);
7101 return gfc_finish_block (&block
);
7105 /* Makes sure se is suitable for passing as a function string parameter. */
7106 /* TODO: Need to check all callers of this function. It may be abused. */
7109 gfc_conv_string_parameter (gfc_se
* se
)
7113 if (TREE_CODE (se
->expr
) == STRING_CST
)
7115 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7116 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7120 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7122 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7124 type
= TREE_TYPE (se
->expr
);
7125 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7129 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7131 type
= build_pointer_type (type
);
7132 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7136 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
7140 /* Generate code for assignment of scalar variables. Includes character
7141 strings and derived types with allocatable components.
7142 If you know that the LHS has no allocations, set dealloc to false.
7144 DEEP_COPY has no effect if the typespec TS is not a derived type with
7145 allocatable components. Otherwise, if it is set, an explicit copy of each
7146 allocatable component is made. This is necessary as a simple copy of the
7147 whole object would copy array descriptors as is, so that the lhs's
7148 allocatable components would point to the rhs's after the assignment.
7149 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7150 necessary if the rhs is a non-pointer function, as the allocatable components
7151 are not accessible by other means than the function's result after the
7152 function has returned. It is even more subtle when temporaries are involved,
7153 as the two following examples show:
7154 1. When we evaluate an array constructor, a temporary is created. Thus
7155 there is theoretically no alias possible. However, no deep copy is
7156 made for this temporary, so that if the constructor is made of one or
7157 more variable with allocatable components, those components still point
7158 to the variable's: DEEP_COPY should be set for the assignment from the
7159 temporary to the lhs in that case.
7160 2. When assigning a scalar to an array, we evaluate the scalar value out
7161 of the loop, store it into a temporary variable, and assign from that.
7162 In that case, deep copying when assigning to the temporary would be a
7163 waste of resources; however deep copies should happen when assigning from
7164 the temporary to each array element: again DEEP_COPY should be set for
7165 the assignment from the temporary to the lhs. */
7168 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7169 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7175 gfc_init_block (&block
);
7177 if (ts
.type
== BT_CHARACTER
)
7182 if (lse
->string_length
!= NULL_TREE
)
7184 gfc_conv_string_parameter (lse
);
7185 gfc_add_block_to_block (&block
, &lse
->pre
);
7186 llen
= lse
->string_length
;
7189 if (rse
->string_length
!= NULL_TREE
)
7191 gcc_assert (rse
->string_length
!= NULL_TREE
);
7192 gfc_conv_string_parameter (rse
);
7193 gfc_add_block_to_block (&block
, &rse
->pre
);
7194 rlen
= rse
->string_length
;
7197 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7198 rse
->expr
, ts
.kind
);
7200 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7202 tree tmp_var
= NULL_TREE
;
7205 /* Are the rhs and the lhs the same? */
7208 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7209 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7210 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7211 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7214 /* Deallocate the lhs allocated components as long as it is not
7215 the same as the rhs. This must be done following the assignment
7216 to prevent deallocating data that could be used in the rhs
7218 if (!l_is_temp
&& dealloc
)
7220 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7221 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7223 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7225 gfc_add_expr_to_block (&lse
->post
, tmp
);
7228 gfc_add_block_to_block (&block
, &rse
->pre
);
7229 gfc_add_block_to_block (&block
, &lse
->pre
);
7231 gfc_add_modify (&block
, lse
->expr
,
7232 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7234 /* Restore pointer address of coarray components. */
7235 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7237 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7238 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7240 gfc_add_expr_to_block (&block
, tmp
);
7243 /* Do a deep copy if the rhs is a variable, if it is not the
7247 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7248 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7250 gfc_add_expr_to_block (&block
, tmp
);
7253 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7255 gfc_add_block_to_block (&block
, &lse
->pre
);
7256 gfc_add_block_to_block (&block
, &rse
->pre
);
7257 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7258 TREE_TYPE (lse
->expr
), rse
->expr
);
7259 gfc_add_modify (&block
, lse
->expr
, tmp
);
7263 gfc_add_block_to_block (&block
, &lse
->pre
);
7264 gfc_add_block_to_block (&block
, &rse
->pre
);
7266 gfc_add_modify (&block
, lse
->expr
,
7267 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7270 gfc_add_block_to_block (&block
, &lse
->post
);
7271 gfc_add_block_to_block (&block
, &rse
->post
);
7273 return gfc_finish_block (&block
);
7277 /* There are quite a lot of restrictions on the optimisation in using an
7278 array function assign without a temporary. */
7281 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7284 bool seen_array_ref
;
7286 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7288 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7289 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7292 /* Elemental functions are scalarized so that they don't need a
7293 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7294 they would need special treatment in gfc_trans_arrayfunc_assign. */
7295 if (expr2
->value
.function
.esym
!= NULL
7296 && expr2
->value
.function
.esym
->attr
.elemental
)
7299 /* Need a temporary if rhs is not FULL or a contiguous section. */
7300 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7303 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7304 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7307 /* Functions returning pointers or allocatables need temporaries. */
7308 c
= expr2
->value
.function
.esym
7309 ? (expr2
->value
.function
.esym
->attr
.pointer
7310 || expr2
->value
.function
.esym
->attr
.allocatable
)
7311 : (expr2
->symtree
->n
.sym
->attr
.pointer
7312 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7316 /* Character array functions need temporaries unless the
7317 character lengths are the same. */
7318 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7320 if (expr1
->ts
.u
.cl
->length
== NULL
7321 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7324 if (expr2
->ts
.u
.cl
->length
== NULL
7325 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7328 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7329 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7333 /* Check that no LHS component references appear during an array
7334 reference. This is needed because we do not have the means to
7335 span any arbitrary stride with an array descriptor. This check
7336 is not needed for the rhs because the function result has to be
7338 seen_array_ref
= false;
7339 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7341 if (ref
->type
== REF_ARRAY
)
7342 seen_array_ref
= true;
7343 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7347 /* Check for a dependency. */
7348 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7349 expr2
->value
.function
.esym
,
7350 expr2
->value
.function
.actual
,
7354 /* If we have reached here with an intrinsic function, we do not
7355 need a temporary except in the particular case that reallocation
7356 on assignment is active and the lhs is allocatable and a target. */
7357 if (expr2
->value
.function
.isym
)
7358 return (gfc_option
.flag_realloc_lhs
7359 && sym
->attr
.allocatable
7360 && sym
->attr
.target
);
7362 /* If the LHS is a dummy, we need a temporary if it is not
7364 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7367 /* If the lhs has been host_associated, is in common, a pointer or is
7368 a target and the function is not using a RESULT variable, aliasing
7369 can occur and a temporary is needed. */
7370 if ((sym
->attr
.host_assoc
7371 || sym
->attr
.in_common
7372 || sym
->attr
.pointer
7373 || sym
->attr
.cray_pointee
7374 || sym
->attr
.target
)
7375 && expr2
->symtree
!= NULL
7376 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7379 /* A PURE function can unconditionally be called without a temporary. */
7380 if (expr2
->value
.function
.esym
!= NULL
7381 && expr2
->value
.function
.esym
->attr
.pure
)
7384 /* Implicit_pure functions are those which could legally be declared
7386 if (expr2
->value
.function
.esym
!= NULL
7387 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7390 if (!sym
->attr
.use_assoc
7391 && !sym
->attr
.in_common
7392 && !sym
->attr
.pointer
7393 && !sym
->attr
.target
7394 && !sym
->attr
.cray_pointee
7395 && expr2
->value
.function
.esym
)
7397 /* A temporary is not needed if the function is not contained and
7398 the variable is local or host associated and not a pointer or
7400 if (!expr2
->value
.function
.esym
->attr
.contained
)
7403 /* A temporary is not needed if the lhs has never been host
7404 associated and the procedure is contained. */
7405 else if (!sym
->attr
.host_assoc
)
7408 /* A temporary is not needed if the variable is local and not
7409 a pointer, a target or a result. */
7411 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7415 /* Default to temporary use. */
7420 /* Provide the loop info so that the lhs descriptor can be built for
7421 reallocatable assignments from extrinsic function calls. */
7424 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7427 /* Signal that the function call should not be made by
7428 gfc_conv_loop_setup. */
7429 se
->ss
->is_alloc_lhs
= 1;
7430 gfc_init_loopinfo (loop
);
7431 gfc_add_ss_to_loop (loop
, *ss
);
7432 gfc_add_ss_to_loop (loop
, se
->ss
);
7433 gfc_conv_ss_startstride (loop
);
7434 gfc_conv_loop_setup (loop
, where
);
7435 gfc_copy_loopinfo_to_se (se
, loop
);
7436 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7437 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7438 se
->ss
->is_alloc_lhs
= 0;
7442 /* For assignment to a reallocatable lhs from intrinsic functions,
7443 replace the se.expr (ie. the result) with a temporary descriptor.
7444 Null the data field so that the library allocates space for the
7445 result. Free the data of the original descriptor after the function,
7446 in case it appears in an argument expression and transfer the
7447 result to the original descriptor. */
7450 fcncall_realloc_result (gfc_se
*se
, int rank
)
7459 /* Use the allocation done by the library. Substitute the lhs
7460 descriptor with a copy, whose data field is nulled.*/
7461 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7462 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7463 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7465 /* Unallocated, the descriptor does not have a dtype. */
7466 tmp
= gfc_conv_descriptor_dtype (desc
);
7467 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7469 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7470 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7471 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7473 /* Free the lhs after the function call and copy the result data to
7474 the lhs descriptor. */
7475 tmp
= gfc_conv_descriptor_data_get (desc
);
7476 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7477 boolean_type_node
, tmp
,
7478 build_int_cst (TREE_TYPE (tmp
), 0));
7479 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7480 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7481 gfc_add_expr_to_block (&se
->post
, tmp
);
7483 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7484 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7486 /* Check that the shapes are the same between lhs and expression. */
7487 for (n
= 0 ; n
< rank
; n
++)
7490 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7491 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7492 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7493 gfc_array_index_type
, tmp
, tmp1
);
7494 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7495 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7496 gfc_array_index_type
, tmp
, tmp1
);
7497 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7498 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7499 gfc_array_index_type
, tmp
, tmp1
);
7500 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7501 boolean_type_node
, tmp
,
7502 gfc_index_zero_node
);
7503 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7504 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7505 boolean_type_node
, tmp
,
7509 /* 'zero_cond' being true is equal to lhs not being allocated or the
7510 shapes being different. */
7511 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7513 /* Now reset the bounds returned from the function call to bounds based
7514 on the lhs lbounds, except where the lhs is not allocated or the shapes
7515 of 'variable and 'expr' are different. Set the offset accordingly. */
7516 offset
= gfc_index_zero_node
;
7517 for (n
= 0 ; n
< rank
; n
++)
7521 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7522 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7523 gfc_array_index_type
, zero_cond
,
7524 gfc_index_one_node
, lbound
);
7525 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7527 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7528 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7529 gfc_array_index_type
, tmp
, lbound
);
7530 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7531 gfc_rank_cst
[n
], lbound
);
7532 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7533 gfc_rank_cst
[n
], tmp
);
7535 /* Set stride and accumulate the offset. */
7536 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7537 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7538 gfc_rank_cst
[n
], tmp
);
7539 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7540 gfc_array_index_type
, lbound
, tmp
);
7541 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7542 gfc_array_index_type
, offset
, tmp
);
7543 offset
= gfc_evaluate_now (offset
, &se
->post
);
7546 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7551 /* Try to translate array(:) = func (...), where func is a transformational
7552 array function, without using a temporary. Returns NULL if this isn't the
7556 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7560 gfc_component
*comp
= NULL
;
7563 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7566 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7568 comp
= gfc_get_proc_ptr_comp (expr2
);
7569 gcc_assert (expr2
->value
.function
.isym
7570 || (comp
&& comp
->attr
.dimension
)
7571 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7572 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7574 gfc_init_se (&se
, NULL
);
7575 gfc_start_block (&se
.pre
);
7576 se
.want_pointer
= 1;
7578 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7580 if (expr1
->ts
.type
== BT_DERIVED
7581 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7584 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7586 gfc_add_expr_to_block (&se
.pre
, tmp
);
7589 se
.direct_byref
= 1;
7590 se
.ss
= gfc_walk_expr (expr2
);
7591 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7593 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7594 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7595 Clearly, this cannot be done for an allocatable function result, since
7596 the shape of the result is unknown and, in any case, the function must
7597 correctly take care of the reallocation internally. For intrinsic
7598 calls, the array data is freed and the library takes care of allocation.
7599 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7601 if (gfc_option
.flag_realloc_lhs
7602 && gfc_is_reallocatable_lhs (expr1
)
7603 && !gfc_expr_attr (expr1
).codimension
7604 && !gfc_is_coindexed (expr1
)
7605 && !(expr2
->value
.function
.esym
7606 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7608 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7610 if (!expr2
->value
.function
.isym
)
7612 ss
= gfc_walk_expr (expr1
);
7613 gcc_assert (ss
!= gfc_ss_terminator
);
7615 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7616 ss
->is_alloc_lhs
= 1;
7619 fcncall_realloc_result (&se
, expr1
->rank
);
7622 gfc_conv_function_expr (&se
, expr2
);
7623 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7626 gfc_cleanup_loop (&loop
);
7628 gfc_free_ss_chain (se
.ss
);
7630 return gfc_finish_block (&se
.pre
);
7634 /* Try to efficiently translate array(:) = 0. Return NULL if this
7638 gfc_trans_zero_assign (gfc_expr
* expr
)
7640 tree dest
, len
, type
;
7644 sym
= expr
->symtree
->n
.sym
;
7645 dest
= gfc_get_symbol_decl (sym
);
7647 type
= TREE_TYPE (dest
);
7648 if (POINTER_TYPE_P (type
))
7649 type
= TREE_TYPE (type
);
7650 if (!GFC_ARRAY_TYPE_P (type
))
7653 /* Determine the length of the array. */
7654 len
= GFC_TYPE_ARRAY_SIZE (type
);
7655 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7658 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7659 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7660 fold_convert (gfc_array_index_type
, tmp
));
7662 /* If we are zeroing a local array avoid taking its address by emitting
7664 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7665 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7666 dest
, build_constructor (TREE_TYPE (dest
),
7669 /* Convert arguments to the correct types. */
7670 dest
= fold_convert (pvoid_type_node
, dest
);
7671 len
= fold_convert (size_type_node
, len
);
7673 /* Construct call to __builtin_memset. */
7674 tmp
= build_call_expr_loc (input_location
,
7675 builtin_decl_explicit (BUILT_IN_MEMSET
),
7676 3, dest
, integer_zero_node
, len
);
7677 return fold_convert (void_type_node
, tmp
);
7681 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7682 that constructs the call to __builtin_memcpy. */
7685 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7689 /* Convert arguments to the correct types. */
7690 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7691 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7693 dst
= fold_convert (pvoid_type_node
, dst
);
7695 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7696 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7698 src
= fold_convert (pvoid_type_node
, src
);
7700 len
= fold_convert (size_type_node
, len
);
7702 /* Construct call to __builtin_memcpy. */
7703 tmp
= build_call_expr_loc (input_location
,
7704 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7706 return fold_convert (void_type_node
, tmp
);
7710 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7711 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7712 source/rhs, both are gfc_full_array_ref_p which have been checked for
7716 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7718 tree dst
, dlen
, dtype
;
7719 tree src
, slen
, stype
;
7722 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7723 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7725 dtype
= TREE_TYPE (dst
);
7726 if (POINTER_TYPE_P (dtype
))
7727 dtype
= TREE_TYPE (dtype
);
7728 stype
= TREE_TYPE (src
);
7729 if (POINTER_TYPE_P (stype
))
7730 stype
= TREE_TYPE (stype
);
7732 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7735 /* Determine the lengths of the arrays. */
7736 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7737 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7739 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7740 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7741 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7743 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7744 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7746 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7747 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7748 slen
, fold_convert (gfc_array_index_type
, tmp
));
7750 /* Sanity check that they are the same. This should always be
7751 the case, as we should already have checked for conformance. */
7752 if (!tree_int_cst_equal (slen
, dlen
))
7755 return gfc_build_memcpy_call (dst
, src
, dlen
);
7759 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7760 this can't be done. EXPR1 is the destination/lhs for which
7761 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7764 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7766 unsigned HOST_WIDE_INT nelem
;
7772 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7776 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7777 dtype
= TREE_TYPE (dst
);
7778 if (POINTER_TYPE_P (dtype
))
7779 dtype
= TREE_TYPE (dtype
);
7780 if (!GFC_ARRAY_TYPE_P (dtype
))
7783 /* Determine the lengths of the array. */
7784 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7785 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7788 /* Confirm that the constructor is the same size. */
7789 if (compare_tree_int (len
, nelem
) != 0)
7792 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7793 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7794 fold_convert (gfc_array_index_type
, tmp
));
7796 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7797 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7799 stype
= TREE_TYPE (src
);
7800 if (POINTER_TYPE_P (stype
))
7801 stype
= TREE_TYPE (stype
);
7803 return gfc_build_memcpy_call (dst
, src
, len
);
7807 /* Tells whether the expression is to be treated as a variable reference. */
7810 expr_is_variable (gfc_expr
*expr
)
7813 gfc_component
*comp
;
7814 gfc_symbol
*func_ifc
;
7816 if (expr
->expr_type
== EXPR_VARIABLE
)
7819 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7822 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7823 return expr_is_variable (arg
);
7826 /* A data-pointer-returning function should be considered as a variable
7828 if (expr
->expr_type
== EXPR_FUNCTION
7829 && expr
->ref
== NULL
)
7831 if (expr
->value
.function
.isym
!= NULL
)
7834 if (expr
->value
.function
.esym
!= NULL
)
7836 func_ifc
= expr
->value
.function
.esym
;
7841 gcc_assert (expr
->symtree
);
7842 func_ifc
= expr
->symtree
->n
.sym
;
7849 comp
= gfc_get_proc_ptr_comp (expr
);
7850 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7853 func_ifc
= comp
->ts
.interface
;
7857 if (expr
->expr_type
== EXPR_COMPCALL
)
7859 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7860 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7867 gcc_assert (func_ifc
->attr
.function
7868 && func_ifc
->result
!= NULL
);
7869 return func_ifc
->result
->attr
.pointer
;
7873 /* Is the lhs OK for automatic reallocation? */
7876 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7880 /* An allocatable variable with no reference. */
7881 if (expr
->symtree
->n
.sym
->attr
.allocatable
7885 /* All that can be left are allocatable components. */
7886 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7887 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7888 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7891 /* Find an allocatable component ref last. */
7892 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7893 if (ref
->type
== REF_COMPONENT
7895 && ref
->u
.c
.component
->attr
.allocatable
)
7902 /* Allocate or reallocate scalar lhs, as necessary. */
7905 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7919 if (!expr1
|| expr1
->rank
)
7922 if (!expr2
|| expr2
->rank
)
7925 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7927 /* Since this is a scalar lhs, we can afford to do this. That is,
7928 there is no risk of side effects being repeated. */
7929 gfc_init_se (&lse
, NULL
);
7930 lse
.want_pointer
= 1;
7931 gfc_conv_expr (&lse
, expr1
);
7933 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7934 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7936 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7937 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7938 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7940 tmp
= build3_v (COND_EXPR
, cond
,
7941 build1_v (GOTO_EXPR
, jump_label1
),
7942 build_empty_stmt (input_location
));
7943 gfc_add_expr_to_block (block
, tmp
);
7945 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7947 /* Use the rhs string length and the lhs element size. */
7948 size
= string_length
;
7949 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7950 tmp
= TYPE_SIZE_UNIT (tmp
);
7951 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7952 TREE_TYPE (tmp
), tmp
,
7953 fold_convert (TREE_TYPE (tmp
), size
));
7957 /* Otherwise use the length in bytes of the rhs. */
7958 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7959 size_in_bytes
= size
;
7962 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7963 size_in_bytes
, size_one_node
);
7965 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7967 tmp
= build_call_expr_loc (input_location
,
7968 builtin_decl_explicit (BUILT_IN_CALLOC
),
7969 2, build_one_cst (size_type_node
),
7971 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7972 gfc_add_modify (block
, lse
.expr
, tmp
);
7976 tmp
= build_call_expr_loc (input_location
,
7977 builtin_decl_explicit (BUILT_IN_MALLOC
),
7979 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7980 gfc_add_modify (block
, lse
.expr
, tmp
);
7983 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7985 /* Deferred characters need checking for lhs and rhs string
7986 length. Other deferred parameter variables will have to
7988 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7989 gfc_add_expr_to_block (block
, tmp
);
7991 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7992 gfc_add_expr_to_block (block
, tmp
);
7994 /* For a deferred length character, reallocate if lengths of lhs and
7995 rhs are different. */
7996 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7998 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7999 expr1
->ts
.u
.cl
->backend_decl
, size
);
8000 /* Jump past the realloc if the lengths are the same. */
8001 tmp
= build3_v (COND_EXPR
, cond
,
8002 build1_v (GOTO_EXPR
, jump_label2
),
8003 build_empty_stmt (input_location
));
8004 gfc_add_expr_to_block (block
, tmp
);
8005 tmp
= build_call_expr_loc (input_location
,
8006 builtin_decl_explicit (BUILT_IN_REALLOC
),
8007 2, fold_convert (pvoid_type_node
, lse
.expr
),
8009 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8010 gfc_add_modify (block
, lse
.expr
, tmp
);
8011 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8012 gfc_add_expr_to_block (block
, tmp
);
8014 /* Update the lhs character length. */
8015 size
= string_length
;
8016 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8017 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
8019 gfc_add_modify (block
, lse
.string_length
, size
);
8023 /* Check for assignments of the type
8027 to make sure we do not check for reallocation unneccessarily. */
8031 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8033 gfc_actual_arglist
*a
;
8036 switch (expr2
->expr_type
)
8039 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8042 if (expr2
->value
.function
.esym
8043 && expr2
->value
.function
.esym
->attr
.elemental
)
8045 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8048 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8053 else if (expr2
->value
.function
.isym
8054 && expr2
->value
.function
.isym
->elemental
)
8056 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8059 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8068 switch (expr2
->value
.op
.op
)
8071 case INTRINSIC_UPLUS
:
8072 case INTRINSIC_UMINUS
:
8073 case INTRINSIC_PARENTHESES
:
8074 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8076 case INTRINSIC_PLUS
:
8077 case INTRINSIC_MINUS
:
8078 case INTRINSIC_TIMES
:
8079 case INTRINSIC_DIVIDE
:
8080 case INTRINSIC_POWER
:
8084 case INTRINSIC_NEQV
:
8091 case INTRINSIC_EQ_OS
:
8092 case INTRINSIC_NE_OS
:
8093 case INTRINSIC_GT_OS
:
8094 case INTRINSIC_GE_OS
:
8095 case INTRINSIC_LT_OS
:
8096 case INTRINSIC_LE_OS
:
8098 e1
= expr2
->value
.op
.op1
;
8099 e2
= expr2
->value
.op
.op2
;
8101 if (e1
->rank
== 0 && e2
->rank
> 0)
8102 return is_runtime_conformable (expr1
, e2
);
8103 else if (e1
->rank
> 0 && e2
->rank
== 0)
8104 return is_runtime_conformable (expr1
, e1
);
8105 else if (e1
->rank
> 0 && e2
->rank
> 0)
8106 return is_runtime_conformable (expr1
, e1
)
8107 && is_runtime_conformable (expr1
, e2
);
8123 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8124 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8125 init_flag indicates initialization expressions and dealloc that no
8126 deallocate prior assignment is needed (if in doubt, set true). */
8129 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8135 gfc_ss
*lss_section
;
8142 bool scalar_to_array
;
8146 /* Assignment of the form lhs = rhs. */
8147 gfc_start_block (&block
);
8149 gfc_init_se (&lse
, NULL
);
8150 gfc_init_se (&rse
, NULL
);
8153 lss
= gfc_walk_expr (expr1
);
8154 if (gfc_is_reallocatable_lhs (expr1
)
8155 && !(expr2
->expr_type
== EXPR_FUNCTION
8156 && expr2
->value
.function
.isym
!= NULL
))
8157 lss
->is_alloc_lhs
= 1;
8159 if (lss
!= gfc_ss_terminator
)
8161 /* The assignment needs scalarization. */
8164 /* Find a non-scalar SS from the lhs. */
8165 while (lss_section
!= gfc_ss_terminator
8166 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8167 lss_section
= lss_section
->next
;
8169 gcc_assert (lss_section
!= gfc_ss_terminator
);
8171 /* Initialize the scalarizer. */
8172 gfc_init_loopinfo (&loop
);
8175 rss
= gfc_walk_expr (expr2
);
8176 if (rss
== gfc_ss_terminator
)
8177 /* The rhs is scalar. Add a ss for the expression. */
8178 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8180 /* Associate the SS with the loop. */
8181 gfc_add_ss_to_loop (&loop
, lss
);
8182 gfc_add_ss_to_loop (&loop
, rss
);
8184 /* Calculate the bounds of the scalarization. */
8185 gfc_conv_ss_startstride (&loop
);
8186 /* Enable loop reversal. */
8187 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8188 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8189 /* Resolve any data dependencies in the statement. */
8190 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8191 /* Setup the scalarizing loops. */
8192 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8194 /* Setup the gfc_se structures. */
8195 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8196 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8199 gfc_mark_ss_chain_used (rss
, 1);
8200 if (loop
.temp_ss
== NULL
)
8203 gfc_mark_ss_chain_used (lss
, 1);
8207 lse
.ss
= loop
.temp_ss
;
8208 gfc_mark_ss_chain_used (lss
, 3);
8209 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8212 /* Allow the scalarizer to workshare array assignments. */
8213 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8214 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8216 /* Start the scalarized loop body. */
8217 gfc_start_scalarized_body (&loop
, &body
);
8220 gfc_init_block (&body
);
8222 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8224 /* Translate the expression. */
8225 gfc_conv_expr (&rse
, expr2
);
8227 /* Stabilize a string length for temporaries. */
8228 if (expr2
->ts
.type
== BT_CHARACTER
)
8229 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8231 string_length
= NULL_TREE
;
8235 gfc_conv_tmp_array_ref (&lse
);
8236 if (expr2
->ts
.type
== BT_CHARACTER
)
8237 lse
.string_length
= string_length
;
8240 gfc_conv_expr (&lse
, expr1
);
8242 /* Assignments of scalar derived types with allocatable components
8243 to arrays must be done with a deep copy and the rhs temporary
8244 must have its components deallocated afterwards. */
8245 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8246 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8247 && !expr_is_variable (expr2
)
8248 && !gfc_is_constant_expr (expr2
)
8249 && expr1
->rank
&& !expr2
->rank
);
8250 if (scalar_to_array
&& dealloc
)
8252 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8253 gfc_add_expr_to_block (&loop
.post
, tmp
);
8256 /* When assigning a character function result to a deferred-length variable,
8257 the function call must happen before the (re)allocation of the lhs -
8258 otherwise the character length of the result is not known.
8259 NOTE: This relies on having the exact dependence of the length type
8260 parameter available to the caller; gfortran saves it in the .mod files. */
8261 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
8262 && expr1
->ts
.deferred
)
8263 gfc_add_block_to_block (&block
, &rse
.pre
);
8265 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8266 l_is_temp
|| init_flag
,
8267 expr_is_variable (expr2
) || scalar_to_array
8268 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8269 gfc_add_expr_to_block (&body
, tmp
);
8271 if (lss
== gfc_ss_terminator
)
8273 /* F2003: Add the code for reallocation on assignment. */
8274 if (gfc_option
.flag_realloc_lhs
8275 && is_scalar_reallocatable_lhs (expr1
))
8276 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8279 /* Use the scalar assignment as is. */
8280 gfc_add_block_to_block (&block
, &body
);
8284 gcc_assert (lse
.ss
== gfc_ss_terminator
8285 && rse
.ss
== gfc_ss_terminator
);
8289 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8291 /* We need to copy the temporary to the actual lhs. */
8292 gfc_init_se (&lse
, NULL
);
8293 gfc_init_se (&rse
, NULL
);
8294 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8295 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8297 rse
.ss
= loop
.temp_ss
;
8300 gfc_conv_tmp_array_ref (&rse
);
8301 gfc_conv_expr (&lse
, expr1
);
8303 gcc_assert (lse
.ss
== gfc_ss_terminator
8304 && rse
.ss
== gfc_ss_terminator
);
8306 if (expr2
->ts
.type
== BT_CHARACTER
)
8307 rse
.string_length
= string_length
;
8309 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8310 false, false, dealloc
);
8311 gfc_add_expr_to_block (&body
, tmp
);
8314 /* F2003: Allocate or reallocate lhs of allocatable array. */
8315 if (gfc_option
.flag_realloc_lhs
8316 && gfc_is_reallocatable_lhs (expr1
)
8317 && !gfc_expr_attr (expr1
).codimension
8318 && !gfc_is_coindexed (expr1
)
8320 && !is_runtime_conformable (expr1
, expr2
))
8322 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8323 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8324 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8325 if (tmp
!= NULL_TREE
)
8326 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8329 /* Generate the copying loops. */
8330 gfc_trans_scalarizing_loops (&loop
, &body
);
8332 /* Wrap the whole thing up. */
8333 gfc_add_block_to_block (&block
, &loop
.pre
);
8334 gfc_add_block_to_block (&block
, &loop
.post
);
8336 gfc_cleanup_loop (&loop
);
8339 return gfc_finish_block (&block
);
8343 /* Check whether EXPR is a copyable array. */
8346 copyable_array_p (gfc_expr
* expr
)
8348 if (expr
->expr_type
!= EXPR_VARIABLE
)
8351 /* First check it's an array. */
8352 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8355 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8358 /* Next check that it's of a simple enough type. */
8359 switch (expr
->ts
.type
)
8371 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8380 /* Translate an assignment. */
8383 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8388 /* Special case a single function returning an array. */
8389 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8391 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8396 /* Special case assigning an array to zero. */
8397 if (copyable_array_p (expr1
)
8398 && is_zero_initializer_p (expr2
))
8400 tmp
= gfc_trans_zero_assign (expr1
);
8405 /* Special case copying one array to another. */
8406 if (copyable_array_p (expr1
)
8407 && copyable_array_p (expr2
)
8408 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8409 && !gfc_check_dependency (expr1
, expr2
, 0))
8411 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8416 /* Special case initializing an array from a constant array constructor. */
8417 if (copyable_array_p (expr1
)
8418 && expr2
->expr_type
== EXPR_ARRAY
8419 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8421 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8426 /* Fallback to the scalarizer to generate explicit loops. */
8427 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8431 gfc_trans_init_assign (gfc_code
* code
)
8433 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8437 gfc_trans_assign (gfc_code
* code
)
8439 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);