1 /* Expression translation
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
28 #include "stringpool.h"
29 #include "diagnostic-core.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
61 akind
, !(attr
.pointer
|| attr
.target
));
65 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 type
= get_scalar_to_descriptor_type (scalar
, attr
);
70 desc
= gfc_create_var (type
, "desc");
71 DECL_ARTIFICIAL (desc
) = 1;
72 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
73 gfc_get_dtype (type
));
74 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
76 /* Copy pointer address back - but only if it could have changed and
77 if the actual argument is a pointer and not, e.g., NULL(). */
78 if ((attr
.pointer
|| attr
.allocatable
)
79 && attr
.intent
!= INTENT_IN
&& POINTER_TYPE_P (TREE_TYPE (scalar
)))
80 gfc_add_modify (&se
->post
, scalar
,
81 fold_convert (TREE_TYPE (scalar
),
82 gfc_conv_descriptor_data_get (desc
)));
87 /* This is the seed for an eventual trans-class.c
89 The following parameters should not be used directly since they might
90 in future implementations. Use the corresponding APIs. */
91 #define CLASS_DATA_FIELD 0
92 #define CLASS_VPTR_FIELD 1
93 #define VTABLE_HASH_FIELD 0
94 #define VTABLE_SIZE_FIELD 1
95 #define VTABLE_EXTENDS_FIELD 2
96 #define VTABLE_DEF_INIT_FIELD 3
97 #define VTABLE_COPY_FIELD 4
98 #define VTABLE_FINAL_FIELD 5
102 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
106 vec
<constructor_elt
, va_gc
> *init
= NULL
;
108 field
= TYPE_FIELDS (TREE_TYPE (decl
));
109 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
110 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
112 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
113 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
115 return build_constructor (TREE_TYPE (decl
), init
);
120 gfc_class_data_get (tree decl
)
123 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
124 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
125 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
127 return fold_build3_loc (input_location
, COMPONENT_REF
,
128 TREE_TYPE (data
), decl
, data
,
134 gfc_class_vptr_get (tree decl
)
137 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
138 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
139 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
141 return fold_build3_loc (input_location
, COMPONENT_REF
,
142 TREE_TYPE (vptr
), decl
, vptr
,
148 gfc_vtable_field_get (tree decl
, int field
)
152 vptr
= gfc_class_vptr_get (decl
);
153 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
154 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
156 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
157 TREE_TYPE (size
), vptr
, size
,
159 /* Always return size as an array index type. */
160 if (field
== VTABLE_SIZE_FIELD
)
161 size
= fold_convert (gfc_array_index_type
, size
);
168 gfc_vtable_hash_get (tree decl
)
170 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
175 gfc_vtable_size_get (tree decl
)
177 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
182 gfc_vtable_extends_get (tree decl
)
184 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
189 gfc_vtable_def_init_get (tree decl
)
191 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
196 gfc_vtable_copy_get (tree decl
)
198 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
203 gfc_vtable_final_get (tree decl
)
205 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
209 #undef CLASS_DATA_FIELD
210 #undef CLASS_VPTR_FIELD
211 #undef VTABLE_HASH_FIELD
212 #undef VTABLE_SIZE_FIELD
213 #undef VTABLE_EXTENDS_FIELD
214 #undef VTABLE_DEF_INIT_FIELD
215 #undef VTABLE_COPY_FIELD
216 #undef VTABLE_FINAL_FIELD
219 /* Reset the vptr to the declared type, e.g. after deallocation. */
222 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
224 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
229 /* If we have a class array, we need go back to the class
231 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
232 && lhs
->ref
->next
->type
== REF_ARRAY
233 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
234 && lhs
->ref
->type
== REF_COMPONENT
235 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
237 gfc_free_ref_list (lhs
->ref
);
241 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
242 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
243 && ref
->next
->next
->type
== REF_ARRAY
244 && ref
->next
->next
->u
.ar
.type
== AR_FULL
245 && ref
->next
->type
== REF_COMPONENT
246 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
248 gfc_free_ref_list (ref
->next
);
252 gfc_add_vptr_component (lhs
);
254 if (UNLIMITED_POLY (e
))
255 rhs
= gfc_get_null_expr (NULL
);
258 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
259 rhs
= gfc_lval_expr_from_sym (vtab
);
261 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
262 gfc_add_expr_to_block (block
, tmp
);
268 /* Obtain the vptr of the last class reference in an expression.
269 Return NULL_TREE if no class reference is found. */
272 gfc_get_vptr_from_expr (tree expr
)
277 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
279 type
= TREE_TYPE (tmp
);
282 if (GFC_CLASS_TYPE_P (type
))
283 return gfc_class_vptr_get (tmp
);
284 if (type
!= TYPE_CANONICAL (type
))
285 type
= TYPE_CANONICAL (type
);
289 if (TREE_CODE (tmp
) == VAR_DECL
)
297 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
300 tree tmp
, tmp2
, type
;
302 gfc_conv_descriptor_data_set (block
, lhs_desc
,
303 gfc_conv_descriptor_data_get (rhs_desc
));
304 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
305 gfc_conv_descriptor_offset_get (rhs_desc
));
307 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
308 gfc_conv_descriptor_dtype (rhs_desc
));
310 /* Assign the dimension as range-ref. */
311 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
312 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
314 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
315 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
316 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
317 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
318 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
319 gfc_add_modify (block
, tmp
, tmp2
);
323 /* Takes a derived type expression and returns the address of a temporary
324 class object of the 'declared' type. If vptr is not NULL, this is
325 used for the temporary class object.
326 optional_alloc_ptr is false when the dummy is neither allocatable
327 nor a pointer; that's only relevant for the optional handling. */
329 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
330 gfc_typespec class_ts
, tree vptr
, bool optional
,
331 bool optional_alloc_ptr
)
334 tree cond_optional
= NULL_TREE
;
340 /* The derived type needs to be converted to a temporary
342 tmp
= gfc_typenode_for_spec (&class_ts
);
343 var
= gfc_create_var (tmp
, "class");
346 ctree
= gfc_class_vptr_get (var
);
348 if (vptr
!= NULL_TREE
)
350 /* Use the dynamic vptr. */
355 /* In this case the vtab corresponds to the derived type and the
356 vptr must point to it. */
357 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
359 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
361 gfc_add_modify (&parmse
->pre
, ctree
,
362 fold_convert (TREE_TYPE (ctree
), tmp
));
364 /* Now set the data field. */
365 ctree
= gfc_class_data_get (var
);
368 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
370 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
372 /* For an array reference in an elemental procedure call we need
373 to retain the ss to provide the scalarized array reference. */
374 gfc_conv_expr_reference (parmse
, e
);
375 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
377 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
379 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
380 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
385 ss
= gfc_walk_expr (e
);
386 if (ss
== gfc_ss_terminator
)
389 gfc_conv_expr_reference (parmse
, e
);
391 /* Scalar to an assumed-rank array. */
392 if (class_ts
.u
.derived
->components
->as
)
395 type
= get_scalar_to_descriptor_type (parmse
->expr
,
397 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
398 gfc_get_dtype (type
));
400 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
401 TREE_TYPE (parmse
->expr
),
402 cond_optional
, parmse
->expr
,
403 fold_convert (TREE_TYPE (parmse
->expr
),
405 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
409 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
411 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
413 fold_convert (TREE_TYPE (tmp
),
415 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
421 gfc_init_block (&block
);
424 gfc_conv_expr_descriptor (parmse
, e
);
426 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
427 class_array_data_assign (&block
, ctree
, parmse
->expr
, true);
430 if (gfc_expr_attr (e
).codimension
)
431 parmse
->expr
= fold_build1_loc (input_location
,
435 gfc_add_modify (&block
, ctree
, parmse
->expr
);
440 tmp
= gfc_finish_block (&block
);
442 gfc_init_block (&block
);
443 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
445 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
446 gfc_finish_block (&block
));
447 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
450 gfc_add_block_to_block (&parmse
->pre
, &block
);
454 /* Pass the address of the class object. */
455 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
457 if (optional
&& optional_alloc_ptr
)
458 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
459 TREE_TYPE (parmse
->expr
),
460 cond_optional
, parmse
->expr
,
461 fold_convert (TREE_TYPE (parmse
->expr
),
466 /* Create a new class container, which is required as scalar coarrays
467 have an array descriptor while normal scalars haven't. Optionally,
468 NULL pointer checks are added if the argument is OPTIONAL. */
471 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
472 gfc_typespec class_ts
, bool optional
)
474 tree var
, ctree
, tmp
;
479 gfc_init_block (&block
);
482 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
484 if (ref
->type
== REF_COMPONENT
485 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
489 if (class_ref
== NULL
490 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
491 tmp
= e
->symtree
->n
.sym
->backend_decl
;
494 /* Remove everything after the last class reference, convert the
495 expression and then recover its tailend once more. */
497 ref
= class_ref
->next
;
498 class_ref
->next
= NULL
;
499 gfc_init_se (&tmpse
, NULL
);
500 gfc_conv_expr (&tmpse
, e
);
501 class_ref
->next
= ref
;
505 var
= gfc_typenode_for_spec (&class_ts
);
506 var
= gfc_create_var (var
, "class");
508 ctree
= gfc_class_vptr_get (var
);
509 gfc_add_modify (&block
, ctree
,
510 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
512 ctree
= gfc_class_data_get (var
);
513 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
514 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
516 /* Pass the address of the class object. */
517 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
521 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
524 tmp
= gfc_finish_block (&block
);
526 gfc_init_block (&block
);
527 tmp2
= gfc_class_data_get (var
);
528 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
530 tmp2
= gfc_finish_block (&block
);
532 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
534 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
537 gfc_add_block_to_block (&parmse
->pre
, &block
);
541 /* Takes an intrinsic type expression and returns the address of a temporary
542 class object of the 'declared' type. */
544 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
545 gfc_typespec class_ts
)
553 /* The intrinsic type needs to be converted to a temporary
555 tmp
= gfc_typenode_for_spec (&class_ts
);
556 var
= gfc_create_var (tmp
, "class");
559 ctree
= gfc_class_vptr_get (var
);
561 vtab
= gfc_find_vtab (&e
->ts
);
563 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
564 gfc_add_modify (&parmse
->pre
, ctree
,
565 fold_convert (TREE_TYPE (ctree
), tmp
));
567 /* Now set the data field. */
568 ctree
= gfc_class_data_get (var
);
569 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
571 /* For an array reference in an elemental procedure call we need
572 to retain the ss to provide the scalarized array reference. */
573 gfc_conv_expr_reference (parmse
, e
);
574 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
575 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
579 ss
= gfc_walk_expr (e
);
580 if (ss
== gfc_ss_terminator
)
583 gfc_conv_expr_reference (parmse
, e
);
584 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
585 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
590 gfc_conv_expr_descriptor (parmse
, e
);
591 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
595 /* Pass the address of the class object. */
596 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
600 /* Takes a scalarized class array expression and returns the
601 address of a temporary scalar class object of the 'declared'
603 OOP-TODO: This could be improved by adding code that branched on
604 the dynamic type being the same as the declared type. In this case
605 the original class expression can be passed directly.
606 optional_alloc_ptr is false when the dummy is neither allocatable
607 nor a pointer; that's relevant for the optional handling.
608 Set copyback to true if class container's _data and _vtab pointers
609 might get modified. */
612 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
613 bool elemental
, bool copyback
, bool optional
,
614 bool optional_alloc_ptr
)
620 tree cond
= NULL_TREE
;
624 bool full_array
= false;
626 gfc_init_block (&block
);
629 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
631 if (ref
->type
== REF_COMPONENT
632 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
635 if (ref
->next
== NULL
)
639 if ((ref
== NULL
|| class_ref
== ref
)
640 && (!class_ts
.u
.derived
->components
->as
641 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
644 /* Test for FULL_ARRAY. */
645 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
646 && gfc_expr_attr (e
).dimension
)
649 gfc_is_class_array_ref (e
, &full_array
);
651 /* The derived type needs to be converted to a temporary
653 tmp
= gfc_typenode_for_spec (&class_ts
);
654 var
= gfc_create_var (tmp
, "class");
657 ctree
= gfc_class_data_get (var
);
658 if (class_ts
.u
.derived
->components
->as
659 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
663 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
665 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
666 gfc_get_dtype (type
));
668 tmp
= gfc_class_data_get (parmse
->expr
);
669 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
670 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
672 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
675 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
679 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
680 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
681 TREE_TYPE (ctree
), parmse
->expr
);
682 gfc_add_modify (&block
, ctree
, parmse
->expr
);
685 /* Return the data component, except in the case of scalarized array
686 references, where nullification of the cannot occur and so there
688 if (!elemental
&& full_array
&& copyback
)
690 if (class_ts
.u
.derived
->components
->as
691 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
694 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
695 gfc_conv_descriptor_data_get (ctree
));
697 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
700 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
704 ctree
= gfc_class_vptr_get (var
);
706 /* The vptr is the second field of the actual argument.
707 First we have to find the corresponding class reference. */
710 if (class_ref
== NULL
711 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
712 tmp
= e
->symtree
->n
.sym
->backend_decl
;
715 /* Remove everything after the last class reference, convert the
716 expression and then recover its tailend once more. */
718 ref
= class_ref
->next
;
719 class_ref
->next
= NULL
;
720 gfc_init_se (&tmpse
, NULL
);
721 gfc_conv_expr (&tmpse
, e
);
722 class_ref
->next
= ref
;
726 gcc_assert (tmp
!= NULL_TREE
);
728 /* Dereference if needs be. */
729 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
730 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
732 vptr
= gfc_class_vptr_get (tmp
);
733 gfc_add_modify (&block
, ctree
,
734 fold_convert (TREE_TYPE (ctree
), vptr
));
736 /* Return the vptr component, except in the case of scalarized array
737 references, where the dynamic type cannot change. */
738 if (!elemental
&& full_array
&& copyback
)
739 gfc_add_modify (&parmse
->post
, vptr
,
740 fold_convert (TREE_TYPE (vptr
), ctree
));
746 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
747 tmp
= gfc_finish_block (&block
);
749 if (optional_alloc_ptr
)
750 tmp2
= build_empty_stmt (input_location
);
753 gfc_init_block (&block
);
755 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
756 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
758 tmp2
= gfc_finish_block (&block
);
761 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
763 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
766 gfc_add_block_to_block (&parmse
->pre
, &block
);
768 /* Pass the address of the class object. */
769 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
771 if (optional
&& optional_alloc_ptr
)
772 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
773 TREE_TYPE (parmse
->expr
),
775 fold_convert (TREE_TYPE (parmse
->expr
),
780 /* Given a class array declaration and an index, returns the address
781 of the referenced element. */
784 gfc_get_class_array_ref (tree index
, tree class_decl
)
786 tree data
= gfc_class_data_get (class_decl
);
787 tree size
= gfc_vtable_size_get (class_decl
);
788 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
789 gfc_array_index_type
,
792 data
= gfc_conv_descriptor_data_get (data
);
793 ptr
= fold_convert (pvoid_type_node
, data
);
794 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
795 return fold_convert (TREE_TYPE (data
), ptr
);
799 /* Copies one class expression to another, assuming that if either
800 'to' or 'from' are arrays they are packed. Should 'from' be
801 NULL_TREE, the initialization expression for 'to' is used, assuming
802 that the _vptr is set. */
805 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
813 vec
<tree
, va_gc
> *args
;
816 stmtblock_t loopbody
;
822 if (from
!= NULL_TREE
)
823 fcn
= gfc_vtable_copy_get (from
);
825 fcn
= gfc_vtable_copy_get (to
);
827 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
829 if (from
!= NULL_TREE
)
830 from_data
= gfc_class_data_get (from
);
832 from_data
= gfc_vtable_def_init_get (to
);
834 to_data
= gfc_class_data_get (to
);
836 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
838 gfc_init_block (&body
);
839 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
840 gfc_array_index_type
, nelems
,
842 nelems
= gfc_evaluate_now (tmp
, &body
);
843 index
= gfc_create_var (gfc_array_index_type
, "S");
845 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
847 from_ref
= gfc_get_class_array_ref (index
, from
);
848 vec_safe_push (args
, from_ref
);
851 vec_safe_push (args
, from_data
);
853 to_ref
= gfc_get_class_array_ref (index
, to
);
854 vec_safe_push (args
, to_ref
);
856 tmp
= build_call_vec (fcn_type
, fcn
, args
);
858 /* Build the body of the loop. */
859 gfc_init_block (&loopbody
);
860 gfc_add_expr_to_block (&loopbody
, tmp
);
862 /* Build the loop and return. */
863 gfc_init_loopinfo (&loop
);
865 loop
.from
[0] = gfc_index_zero_node
;
866 loop
.loopvar
[0] = index
;
868 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
869 gfc_add_block_to_block (&body
, &loop
.pre
);
870 tmp
= gfc_finish_block (&body
);
871 gfc_cleanup_loop (&loop
);
875 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
876 vec_safe_push (args
, from_data
);
877 vec_safe_push (args
, to_data
);
878 tmp
= build_call_vec (fcn_type
, fcn
, args
);
885 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
887 gfc_actual_arglist
*actual
;
892 actual
= gfc_get_actual_arglist ();
893 actual
->expr
= gfc_copy_expr (rhs
);
894 actual
->next
= gfc_get_actual_arglist ();
895 actual
->next
->expr
= gfc_copy_expr (lhs
);
896 ppc
= gfc_copy_expr (obj
);
897 gfc_add_vptr_component (ppc
);
898 gfc_add_component_ref (ppc
, "_copy");
899 ppc_code
= gfc_get_code (EXEC_CALL
);
900 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
901 /* Although '_copy' is set to be elemental in class.c, it is
902 not staying that way. Find out why, sometime.... */
903 ppc_code
->resolved_sym
->attr
.elemental
= 1;
904 ppc_code
->ext
.actual
= actual
;
905 ppc_code
->expr1
= ppc
;
906 /* Since '_copy' is elemental, the scalarizer will take care
907 of arrays in gfc_trans_call. */
908 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
909 gfc_free_statements (ppc_code
);
913 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
914 A MEMCPY is needed to copy the full data from the default initializer
915 of the dynamic type. */
918 gfc_trans_class_init_assign (gfc_code
*code
)
922 gfc_se dst
,src
,memsz
;
923 gfc_expr
*lhs
, *rhs
, *sz
;
925 gfc_start_block (&block
);
927 lhs
= gfc_copy_expr (code
->expr1
);
928 gfc_add_data_component (lhs
);
930 rhs
= gfc_copy_expr (code
->expr1
);
931 gfc_add_vptr_component (rhs
);
933 /* Make sure that the component backend_decls have been built, which
934 will not have happened if the derived types concerned have not
936 gfc_get_derived_type (rhs
->ts
.u
.derived
);
937 gfc_add_def_init_component (rhs
);
939 if (code
->expr1
->ts
.type
== BT_CLASS
940 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
941 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
944 sz
= gfc_copy_expr (code
->expr1
);
945 gfc_add_vptr_component (sz
);
946 gfc_add_size_component (sz
);
948 gfc_init_se (&dst
, NULL
);
949 gfc_init_se (&src
, NULL
);
950 gfc_init_se (&memsz
, NULL
);
951 gfc_conv_expr (&dst
, lhs
);
952 gfc_conv_expr (&src
, rhs
);
953 gfc_conv_expr (&memsz
, sz
);
954 gfc_add_block_to_block (&block
, &src
.pre
);
955 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
957 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
960 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
961 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
963 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
964 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
966 build_empty_stmt (input_location
));
969 gfc_add_expr_to_block (&block
, tmp
);
971 return gfc_finish_block (&block
);
975 /* Translate an assignment to a CLASS object
976 (pointer or ordinary assignment). */
979 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
987 gfc_start_block (&block
);
990 while (ref
&& ref
->next
)
993 /* Class valued proc_pointer assignments do not need any further
995 if (ref
&& ref
->type
== REF_COMPONENT
996 && ref
->u
.c
.component
->attr
.proc_pointer
997 && expr2
->expr_type
== EXPR_VARIABLE
998 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
999 && op
== EXEC_POINTER_ASSIGN
)
1002 if (expr2
->ts
.type
!= BT_CLASS
)
1004 /* Insert an additional assignment which sets the '_vptr' field. */
1005 gfc_symbol
*vtab
= NULL
;
1008 lhs
= gfc_copy_expr (expr1
);
1009 gfc_add_vptr_component (lhs
);
1011 if (UNLIMITED_POLY (expr1
)
1012 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1014 rhs
= gfc_get_null_expr (&expr2
->where
);
1018 if (expr2
->expr_type
== EXPR_NULL
)
1019 vtab
= gfc_find_vtab (&expr1
->ts
);
1021 vtab
= gfc_find_vtab (&expr2
->ts
);
1024 rhs
= gfc_get_expr ();
1025 rhs
->expr_type
= EXPR_VARIABLE
;
1026 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1030 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1031 gfc_add_expr_to_block (&block
, tmp
);
1033 gfc_free_expr (lhs
);
1034 gfc_free_expr (rhs
);
1036 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1038 /* F2003:C717 only sequence and bind-C types can come here. */
1039 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1040 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1041 gfc_add_data_component (expr2
);
1044 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1046 /* Insert an additional assignment which sets the '_vptr' field. */
1047 lhs
= gfc_copy_expr (expr1
);
1048 gfc_add_vptr_component (lhs
);
1050 rhs
= gfc_copy_expr (expr2
);
1051 gfc_add_vptr_component (rhs
);
1053 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1054 gfc_add_expr_to_block (&block
, tmp
);
1056 gfc_free_expr (lhs
);
1057 gfc_free_expr (rhs
);
1060 /* Do the actual CLASS assignment. */
1061 if (expr2
->ts
.type
== BT_CLASS
1062 && !CLASS_DATA (expr2
)->attr
.dimension
)
1064 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1065 || !CLASS_DATA (expr2
)->attr
.dimension
)
1066 gfc_add_data_component (expr1
);
1070 if (op
== EXEC_ASSIGN
)
1071 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1072 else if (op
== EXEC_POINTER_ASSIGN
)
1073 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1077 gfc_add_expr_to_block (&block
, tmp
);
1079 return gfc_finish_block (&block
);
1083 /* End of prototype trans-class.c */
1087 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1089 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1090 && gfc_option
.warn_realloc_lhs
)
1091 gfc_warning ("Code for reallocating the allocatable array at %L will "
1093 else if (gfc_option
.warn_realloc_lhs_all
)
1094 gfc_warning ("Code for reallocating the allocatable variable at %L "
1095 "will be added", where
);
1099 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1100 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1103 /* Copy the scalarization loop variables. */
1106 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1109 dest
->loop
= src
->loop
;
1113 /* Initialize a simple expression holder.
1115 Care must be taken when multiple se are created with the same parent.
1116 The child se must be kept in sync. The easiest way is to delay creation
1117 of a child se until after after the previous se has been translated. */
1120 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1122 memset (se
, 0, sizeof (gfc_se
));
1123 gfc_init_block (&se
->pre
);
1124 gfc_init_block (&se
->post
);
1126 se
->parent
= parent
;
1129 gfc_copy_se_loopvars (se
, parent
);
1133 /* Advances to the next SS in the chain. Use this rather than setting
1134 se->ss = se->ss->next because all the parents needs to be kept in sync.
1138 gfc_advance_se_ss_chain (gfc_se
* se
)
1143 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1146 /* Walk down the parent chain. */
1149 /* Simple consistency check. */
1150 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1151 || p
->parent
->ss
->nested_ss
== p
->ss
);
1153 /* If we were in a nested loop, the next scalarized expression can be
1154 on the parent ss' next pointer. Thus we should not take the next
1155 pointer blindly, but rather go up one nest level as long as next
1156 is the end of chain. */
1158 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1168 /* Ensures the result of the expression as either a temporary variable
1169 or a constant so that it can be used repeatedly. */
1172 gfc_make_safe_expr (gfc_se
* se
)
1176 if (CONSTANT_CLASS_P (se
->expr
))
1179 /* We need a temporary for this result. */
1180 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1181 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1186 /* Return an expression which determines if a dummy parameter is present.
1187 Also used for arguments to procedures with multiple entry points. */
1190 gfc_conv_expr_present (gfc_symbol
* sym
)
1194 gcc_assert (sym
->attr
.dummy
);
1195 decl
= gfc_get_symbol_decl (sym
);
1197 /* Intrinsic scalars with VALUE attribute which are passed by value
1198 use a hidden argument to denote the present status. */
1199 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1200 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1201 && !sym
->attr
.dimension
)
1203 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1206 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1208 strcpy (&name
[1], sym
->name
);
1209 tree_name
= get_identifier (name
);
1211 /* Walk function argument list to find hidden arg. */
1212 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1213 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1214 if (DECL_NAME (cond
) == tree_name
)
1221 if (TREE_CODE (decl
) != PARM_DECL
)
1223 /* Array parameters use a temporary descriptor, we want the real
1225 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1226 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1227 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1230 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1231 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1233 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1234 as actual argument to denote absent dummies. For array descriptors,
1235 we thus also need to check the array descriptor. For BT_CLASS, it
1236 can also occur for scalars and F2003 due to type->class wrapping and
1237 class->class wrapping. Note further that BT_CLASS always uses an
1238 array descriptor for arrays, also for explicit-shape/assumed-size. */
1240 if (!sym
->attr
.allocatable
1241 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1242 || (sym
->ts
.type
== BT_CLASS
1243 && !CLASS_DATA (sym
)->attr
.allocatable
1244 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1245 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1246 || sym
->ts
.type
== BT_CLASS
))
1250 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1251 || sym
->as
->type
== AS_ASSUMED_RANK
1252 || sym
->attr
.codimension
))
1253 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1255 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1256 if (sym
->ts
.type
== BT_CLASS
)
1257 tmp
= gfc_class_data_get (tmp
);
1258 tmp
= gfc_conv_array_data (tmp
);
1260 else if (sym
->ts
.type
== BT_CLASS
)
1261 tmp
= gfc_class_data_get (decl
);
1265 if (tmp
!= NULL_TREE
)
1267 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1268 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1269 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1270 boolean_type_node
, cond
, tmp
);
1278 /* Converts a missing, dummy argument into a null or zero. */
1281 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1286 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1290 /* Create a temporary and convert it to the correct type. */
1291 tmp
= gfc_get_int_type (kind
);
1292 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1295 /* Test for a NULL value. */
1296 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1297 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1298 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1299 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1303 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1305 build_zero_cst (TREE_TYPE (se
->expr
)));
1306 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1310 if (ts
.type
== BT_CHARACTER
)
1312 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1313 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1314 present
, se
->string_length
, tmp
);
1315 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1316 se
->string_length
= tmp
;
1322 /* Get the character length of an expression, looking through gfc_refs
1326 gfc_get_expr_charlen (gfc_expr
*e
)
1331 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1332 && e
->ts
.type
== BT_CHARACTER
);
1334 length
= NULL
; /* To silence compiler warning. */
1336 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1339 gfc_init_se (&tmpse
, NULL
);
1340 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1341 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1345 /* First candidate: if the variable is of type CHARACTER, the
1346 expression's length could be the length of the character
1348 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1349 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1351 /* Look through the reference chain for component references. */
1352 for (r
= e
->ref
; r
; r
= r
->next
)
1357 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1358 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1366 /* We should never got substring references here. These will be
1367 broken down by the scalarizer. */
1373 gcc_assert (length
!= NULL
);
1378 /* Return for an expression the backend decl of the coarray. */
1381 get_tree_for_caf_expr (gfc_expr
*expr
)
1383 tree caf_decl
= NULL_TREE
;
1386 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1387 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1388 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1390 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1391 if (ref
->type
== REF_COMPONENT
)
1393 gfc_component
*comp
= ref
->u
.c
.component
;
1394 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
1395 caf_decl
= NULL_TREE
;
1396 if (comp
->attr
.codimension
)
1397 caf_decl
= comp
->backend_decl
;
1400 gcc_assert (caf_decl
!= NULL_TREE
);
1405 /* For each character array constructor subexpression without a ts.u.cl->length,
1406 replace it by its first element (if there aren't any elements, the length
1407 should already be set to zero). */
1410 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1412 gfc_actual_arglist
* arg
;
1418 switch (e
->expr_type
)
1422 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1423 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1427 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1431 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1432 flatten_array_ctors_without_strlen (arg
->expr
);
1437 /* We've found what we're looking for. */
1438 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1443 gcc_assert (e
->value
.constructor
);
1445 c
= gfc_constructor_first (e
->value
.constructor
);
1449 flatten_array_ctors_without_strlen (new_expr
);
1450 gfc_replace_expr (e
, new_expr
);
1454 /* Otherwise, fall through to handle constructor elements. */
1455 case EXPR_STRUCTURE
:
1456 for (c
= gfc_constructor_first (e
->value
.constructor
);
1457 c
; c
= gfc_constructor_next (c
))
1458 flatten_array_ctors_without_strlen (c
->expr
);
1468 /* Generate code to initialize a string length variable. Returns the
1469 value. For array constructors, cl->length might be NULL and in this case,
1470 the first element of the constructor is needed. expr is the original
1471 expression so we can access it but can be NULL if this is not needed. */
1474 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1478 gfc_init_se (&se
, NULL
);
1482 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1485 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1486 "flatten" array constructors by taking their first element; all elements
1487 should be the same length or a cl->length should be present. */
1490 gfc_expr
* expr_flat
;
1492 expr_flat
= gfc_copy_expr (expr
);
1493 flatten_array_ctors_without_strlen (expr_flat
);
1494 gfc_resolve_expr (expr_flat
);
1496 gfc_conv_expr (&se
, expr_flat
);
1497 gfc_add_block_to_block (pblock
, &se
.pre
);
1498 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1500 gfc_free_expr (expr_flat
);
1504 /* Convert cl->length. */
1506 gcc_assert (cl
->length
);
1508 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1509 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1510 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1511 gfc_add_block_to_block (pblock
, &se
.pre
);
1513 if (cl
->backend_decl
)
1514 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1516 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1521 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1522 const char *name
, locus
*where
)
1532 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1533 type
= build_pointer_type (type
);
1535 gfc_init_se (&start
, se
);
1536 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1537 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1539 if (integer_onep (start
.expr
))
1540 gfc_conv_string_parameter (se
);
1545 /* Avoid multiple evaluation of substring start. */
1546 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1547 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1549 /* Change the start of the string. */
1550 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1553 tmp
= build_fold_indirect_ref_loc (input_location
,
1555 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1556 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1559 /* Length = end + 1 - start. */
1560 gfc_init_se (&end
, se
);
1561 if (ref
->u
.ss
.end
== NULL
)
1562 end
.expr
= se
->string_length
;
1565 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1566 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1570 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1571 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1573 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1575 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1576 boolean_type_node
, start
.expr
,
1579 /* Check lower bound. */
1580 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1582 build_int_cst (gfc_charlen_type_node
, 1));
1583 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1584 boolean_type_node
, nonempty
, fault
);
1586 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1587 "is less than one", name
);
1589 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1590 "is less than one");
1591 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1592 fold_convert (long_integer_type_node
,
1596 /* Check upper bound. */
1597 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1598 end
.expr
, se
->string_length
);
1599 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1600 boolean_type_node
, nonempty
, fault
);
1602 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1603 "exceeds string length (%%ld)", name
);
1605 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1606 "exceeds string length (%%ld)");
1607 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1608 fold_convert (long_integer_type_node
, end
.expr
),
1609 fold_convert (long_integer_type_node
,
1610 se
->string_length
));
1614 /* Try to calculate the length from the start and end expressions. */
1616 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1620 i_len
= mpz_get_si (length
) + 1;
1624 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1625 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1629 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1630 end
.expr
, start
.expr
);
1631 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1632 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1633 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1634 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1637 se
->string_length
= tmp
;
1641 /* Convert a derived type component reference. */
1644 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1651 c
= ref
->u
.c
.component
;
1653 gcc_assert (c
->backend_decl
);
1655 field
= c
->backend_decl
;
1656 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1659 /* Components can correspond to fields of different containing
1660 types, as components are created without context, whereas
1661 a concrete use of a component has the type of decl as context.
1662 So, if the type doesn't match, we search the corresponding
1663 FIELD_DECL in the parent type. To not waste too much time
1664 we cache this result in norestrict_decl. */
1666 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1668 tree f2
= c
->norestrict_decl
;
1669 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1670 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1671 if (TREE_CODE (f2
) == FIELD_DECL
1672 && DECL_NAME (f2
) == DECL_NAME (field
))
1675 c
->norestrict_decl
= f2
;
1679 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1680 decl
, field
, NULL_TREE
);
1684 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1686 tmp
= c
->ts
.u
.cl
->backend_decl
;
1687 /* Components must always be constant length. */
1688 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1689 se
->string_length
= tmp
;
1692 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1693 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1694 && c
->ts
.type
!= BT_CHARACTER
)
1695 || c
->attr
.proc_pointer
)
1696 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1701 /* This function deals with component references to components of the
1702 parent type for derived type extensions. */
1704 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1712 c
= ref
->u
.c
.component
;
1714 /* Return if the component is in the parent type. */
1715 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1716 if (strcmp (c
->name
, cmp
->name
) == 0)
1719 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1720 parent
.type
= REF_COMPONENT
;
1722 parent
.u
.c
.sym
= dt
;
1723 parent
.u
.c
.component
= dt
->components
;
1725 if (dt
->backend_decl
== NULL
)
1726 gfc_get_derived_type (dt
);
1728 /* Build the reference and call self. */
1729 gfc_conv_component_ref (se
, &parent
);
1730 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1731 parent
.u
.c
.component
= c
;
1732 conv_parent_component_references (se
, &parent
);
1735 /* Return the contents of a variable. Also handles reference/pointer
1736 variables (all Fortran pointer references are implicit). */
1739 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1744 tree parent_decl
= NULL_TREE
;
1747 bool alternate_entry
;
1750 sym
= expr
->symtree
->n
.sym
;
1754 gfc_ss_info
*ss_info
= ss
->info
;
1756 /* Check that something hasn't gone horribly wrong. */
1757 gcc_assert (ss
!= gfc_ss_terminator
);
1758 gcc_assert (ss_info
->expr
== expr
);
1760 /* A scalarized term. We already know the descriptor. */
1761 se
->expr
= ss_info
->data
.array
.descriptor
;
1762 se
->string_length
= ss_info
->string_length
;
1763 ref
= ss_info
->data
.array
.ref
;
1765 gcc_assert (ref
->type
== REF_ARRAY
1766 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1768 gfc_conv_tmp_array_ref (se
);
1772 tree se_expr
= NULL_TREE
;
1774 se
->expr
= gfc_get_symbol_decl (sym
);
1776 /* Deal with references to a parent results or entries by storing
1777 the current_function_decl and moving to the parent_decl. */
1778 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1779 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1780 && sym
->result
== sym
;
1781 entry_master
= sym
->attr
.result
1782 && sym
->ns
->proc_name
->attr
.entry_master
1783 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1784 if (current_function_decl
)
1785 parent_decl
= DECL_CONTEXT (current_function_decl
);
1787 if ((se
->expr
== parent_decl
&& return_value
)
1788 || (sym
->ns
&& sym
->ns
->proc_name
1790 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1791 && (alternate_entry
|| entry_master
)))
1796 /* Special case for assigning the return value of a function.
1797 Self recursive functions must have an explicit return value. */
1798 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1799 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1801 /* Similarly for alternate entry points. */
1802 else if (alternate_entry
1803 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1806 gfc_entry_list
*el
= NULL
;
1808 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1811 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1816 else if (entry_master
1817 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1819 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1824 /* Procedure actual arguments. */
1825 else if (sym
->attr
.flavor
== FL_PROCEDURE
1826 && se
->expr
!= current_function_decl
)
1828 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1830 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1831 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1837 /* Dereference the expression, where needed. Since characters
1838 are entirely different from other types, they are treated
1840 if (sym
->ts
.type
== BT_CHARACTER
)
1842 /* Dereference character pointer dummy arguments
1844 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1846 || sym
->attr
.function
1847 || sym
->attr
.result
))
1848 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1852 else if (!sym
->attr
.value
)
1854 /* Dereference non-character scalar dummy arguments. */
1855 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1856 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1857 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1860 /* Dereference scalar hidden result. */
1861 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1862 && (sym
->attr
.function
|| sym
->attr
.result
)
1863 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1864 && !sym
->attr
.always_explicit
)
1865 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1868 /* Dereference non-character pointer variables.
1869 These must be dummies, results, or scalars. */
1870 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1871 || gfc_is_associate_pointer (sym
)
1872 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1874 || sym
->attr
.function
1876 || (!sym
->attr
.dimension
1877 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1878 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1885 /* For character variables, also get the length. */
1886 if (sym
->ts
.type
== BT_CHARACTER
)
1888 /* If the character length of an entry isn't set, get the length from
1889 the master function instead. */
1890 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1891 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1893 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1894 gcc_assert (se
->string_length
);
1902 /* Return the descriptor if that's what we want and this is an array
1903 section reference. */
1904 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1906 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1907 /* Return the descriptor for array pointers and allocations. */
1908 if (se
->want_pointer
1909 && ref
->next
== NULL
&& (se
->descriptor_only
))
1912 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1913 /* Return a pointer to an element. */
1917 if (ref
->u
.c
.sym
->attr
.extension
)
1918 conv_parent_component_references (se
, ref
);
1920 gfc_conv_component_ref (se
, ref
);
1921 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1922 && se
->want_pointer
&& se
->descriptor_only
)
1928 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1929 expr
->symtree
->name
, &expr
->where
);
1938 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1940 if (se
->want_pointer
)
1942 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1943 gfc_conv_string_parameter (se
);
1945 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1950 /* Unary ops are easy... Or they would be if ! was a valid op. */
1953 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1958 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1959 /* Initialize the operand. */
1960 gfc_init_se (&operand
, se
);
1961 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1962 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1964 type
= gfc_typenode_for_spec (&expr
->ts
);
1966 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1967 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1968 All other unary operators have an equivalent GIMPLE unary operator. */
1969 if (code
== TRUTH_NOT_EXPR
)
1970 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1971 build_int_cst (type
, 0));
1973 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1977 /* Expand power operator to optimal multiplications when a value is raised
1978 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1979 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1980 Programming", 3rd Edition, 1998. */
1982 /* This code is mostly duplicated from expand_powi in the backend.
1983 We establish the "optimal power tree" lookup table with the defined size.
1984 The items in the table are the exponents used to calculate the index
1985 exponents. Any integer n less than the value can get an "addition chain",
1986 with the first node being one. */
1987 #define POWI_TABLE_SIZE 256
1989 /* The table is from builtins.c. */
1990 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1992 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1993 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1994 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1995 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1996 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1997 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1998 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1999 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2000 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2001 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2002 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2003 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2004 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2005 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2006 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2007 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2008 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2009 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2010 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2011 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2012 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2013 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2014 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2015 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2016 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2017 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2018 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2019 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2020 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2021 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2022 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2023 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2026 /* If n is larger than lookup table's max index, we use the "window
2028 #define POWI_WINDOW_SIZE 3
2030 /* Recursive function to expand the power operator. The temporary
2031 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2033 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2040 if (n
< POWI_TABLE_SIZE
)
2045 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2046 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2050 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2051 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2052 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2056 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2060 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2061 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2063 if (n
< POWI_TABLE_SIZE
)
2070 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2071 return 1. Else return 0 and a call to runtime library functions
2072 will have to be built. */
2074 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2079 tree vartmp
[POWI_TABLE_SIZE
];
2081 unsigned HOST_WIDE_INT n
;
2084 /* If exponent is too large, we won't expand it anyway, so don't bother
2085 with large integer values. */
2086 if (!TREE_INT_CST (rhs
).fits_shwi ())
2089 m
= TREE_INT_CST (rhs
).to_shwi ();
2090 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2091 of the asymmetric range of the integer type. */
2092 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2094 type
= TREE_TYPE (lhs
);
2095 sgn
= tree_int_cst_sgn (rhs
);
2097 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2098 || optimize_size
) && (m
> 2 || m
< -1))
2104 se
->expr
= gfc_build_const (type
, integer_one_node
);
2108 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2109 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2111 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2112 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2113 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2114 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2117 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2120 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2121 boolean_type_node
, tmp
, cond
);
2122 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2123 tmp
, build_int_cst (type
, 1),
2124 build_int_cst (type
, 0));
2128 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2129 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2130 build_int_cst (type
, -1),
2131 build_int_cst (type
, 0));
2132 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2133 cond
, build_int_cst (type
, 1), tmp
);
2137 memset (vartmp
, 0, sizeof (vartmp
));
2141 tmp
= gfc_build_const (type
, integer_one_node
);
2142 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2146 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2152 /* Power op (**). Constant integer exponent has special handling. */
2155 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2157 tree gfc_int4_type_node
;
2160 int res_ikind_1
, res_ikind_2
;
2165 gfc_init_se (&lse
, se
);
2166 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2167 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2168 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2170 gfc_init_se (&rse
, se
);
2171 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2172 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2174 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2175 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2176 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2179 gfc_int4_type_node
= gfc_get_int_type (4);
2181 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2182 library routine. But in the end, we have to convert the result back
2183 if this case applies -- with res_ikind_K, we keep track whether operand K
2184 falls into this case. */
2188 kind
= expr
->value
.op
.op1
->ts
.kind
;
2189 switch (expr
->value
.op
.op2
->ts
.type
)
2192 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2197 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2198 res_ikind_2
= ikind
;
2220 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2222 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2249 switch (expr
->value
.op
.op1
->ts
.type
)
2252 if (kind
== 3) /* Case 16 was not handled properly above. */
2254 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2258 /* Use builtins for real ** int4. */
2264 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2268 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2272 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2276 /* Use the __builtin_powil() only if real(kind=16) is
2277 actually the C long double type. */
2278 if (!gfc_real16_is_float128
)
2279 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2287 /* If we don't have a good builtin for this, go for the
2288 library function. */
2290 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2294 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2303 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2307 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2315 se
->expr
= build_call_expr_loc (input_location
,
2316 fndecl
, 2, lse
.expr
, rse
.expr
);
2318 /* Convert the result back if it is of wrong integer kind. */
2319 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2321 /* We want the maximum of both operand kinds as result. */
2322 if (res_ikind_1
< res_ikind_2
)
2323 res_ikind_1
= res_ikind_2
;
2324 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2329 /* Generate code to allocate a string temporary. */
2332 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2337 if (gfc_can_put_var_on_stack (len
))
2339 /* Create a temporary variable to hold the result. */
2340 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2341 gfc_charlen_type_node
, len
,
2342 build_int_cst (gfc_charlen_type_node
, 1));
2343 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2345 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2346 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2348 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2350 var
= gfc_create_var (tmp
, "str");
2351 var
= gfc_build_addr_expr (type
, var
);
2355 /* Allocate a temporary to hold the result. */
2356 var
= gfc_create_var (type
, "pstr");
2357 gcc_assert (POINTER_TYPE_P (type
));
2358 tmp
= TREE_TYPE (type
);
2359 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2360 tmp
= TREE_TYPE (tmp
);
2361 tmp
= TYPE_SIZE_UNIT (tmp
);
2362 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2363 fold_convert (size_type_node
, len
),
2364 fold_convert (size_type_node
, tmp
));
2365 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2366 gfc_add_modify (&se
->pre
, var
, tmp
);
2368 /* Free the temporary afterwards. */
2369 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2370 gfc_add_expr_to_block (&se
->post
, tmp
);
2377 /* Handle a string concatenation operation. A temporary will be allocated to
2381 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2384 tree len
, type
, var
, tmp
, fndecl
;
2386 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2387 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2388 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2390 gfc_init_se (&lse
, se
);
2391 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2392 gfc_conv_string_parameter (&lse
);
2393 gfc_init_se (&rse
, se
);
2394 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2395 gfc_conv_string_parameter (&rse
);
2397 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2398 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2400 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2401 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2402 if (len
== NULL_TREE
)
2404 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2405 TREE_TYPE (lse
.string_length
),
2406 lse
.string_length
, rse
.string_length
);
2409 type
= build_pointer_type (type
);
2411 var
= gfc_conv_string_tmp (se
, type
, len
);
2413 /* Do the actual concatenation. */
2414 if (expr
->ts
.kind
== 1)
2415 fndecl
= gfor_fndecl_concat_string
;
2416 else if (expr
->ts
.kind
== 4)
2417 fndecl
= gfor_fndecl_concat_string_char4
;
2421 tmp
= build_call_expr_loc (input_location
,
2422 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2423 rse
.string_length
, rse
.expr
);
2424 gfc_add_expr_to_block (&se
->pre
, tmp
);
2426 /* Add the cleanup for the operands. */
2427 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2428 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2431 se
->string_length
= len
;
2434 /* Translates an op expression. Common (binary) cases are handled by this
2435 function, others are passed on. Recursion is used in either case.
2436 We use the fact that (op1.ts == op2.ts) (except for the power
2438 Operators need no special handling for scalarized expressions as long as
2439 they call gfc_conv_simple_val to get their operands.
2440 Character strings get special handling. */
2443 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2445 enum tree_code code
;
2454 switch (expr
->value
.op
.op
)
2456 case INTRINSIC_PARENTHESES
:
2457 if ((expr
->ts
.type
== BT_REAL
2458 || expr
->ts
.type
== BT_COMPLEX
)
2459 && gfc_option
.flag_protect_parens
)
2461 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2462 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2467 case INTRINSIC_UPLUS
:
2468 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2471 case INTRINSIC_UMINUS
:
2472 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2476 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2479 case INTRINSIC_PLUS
:
2483 case INTRINSIC_MINUS
:
2487 case INTRINSIC_TIMES
:
2491 case INTRINSIC_DIVIDE
:
2492 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2493 an integer, we must round towards zero, so we use a
2495 if (expr
->ts
.type
== BT_INTEGER
)
2496 code
= TRUNC_DIV_EXPR
;
2501 case INTRINSIC_POWER
:
2502 gfc_conv_power_op (se
, expr
);
2505 case INTRINSIC_CONCAT
:
2506 gfc_conv_concat_op (se
, expr
);
2510 code
= TRUTH_ANDIF_EXPR
;
2515 code
= TRUTH_ORIF_EXPR
;
2519 /* EQV and NEQV only work on logicals, but since we represent them
2520 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2522 case INTRINSIC_EQ_OS
:
2530 case INTRINSIC_NE_OS
:
2531 case INTRINSIC_NEQV
:
2538 case INTRINSIC_GT_OS
:
2545 case INTRINSIC_GE_OS
:
2552 case INTRINSIC_LT_OS
:
2559 case INTRINSIC_LE_OS
:
2565 case INTRINSIC_USER
:
2566 case INTRINSIC_ASSIGN
:
2567 /* These should be converted into function calls by the frontend. */
2571 fatal_error ("Unknown intrinsic op");
2575 /* The only exception to this is **, which is handled separately anyway. */
2576 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2578 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2582 gfc_init_se (&lse
, se
);
2583 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2584 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2587 gfc_init_se (&rse
, se
);
2588 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2589 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2593 gfc_conv_string_parameter (&lse
);
2594 gfc_conv_string_parameter (&rse
);
2596 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2597 rse
.string_length
, rse
.expr
,
2598 expr
->value
.op
.op1
->ts
.kind
,
2600 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2601 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2604 type
= gfc_typenode_for_spec (&expr
->ts
);
2608 /* The result of logical ops is always boolean_type_node. */
2609 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2610 lse
.expr
, rse
.expr
);
2611 se
->expr
= convert (type
, tmp
);
2614 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2616 /* Add the post blocks. */
2617 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2618 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2621 /* If a string's length is one, we convert it to a single character. */
2624 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2628 || !INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2629 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2632 if (TREE_INT_CST_LOW (len
) == 1)
2634 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2635 return build_fold_indirect_ref_loc (input_location
, str
);
2639 && TREE_CODE (str
) == ADDR_EXPR
2640 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2641 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2642 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2643 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2644 && TREE_INT_CST_LOW (len
) > 1
2645 && TREE_INT_CST_LOW (len
)
2646 == (unsigned HOST_WIDE_INT
)
2647 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2649 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2650 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2651 if (TREE_CODE (ret
) == INTEGER_CST
)
2653 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2654 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2655 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2657 for (i
= 1; i
< length
; i
++)
2670 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2673 if (sym
->backend_decl
)
2675 /* This becomes the nominal_type in
2676 function.c:assign_parm_find_data_types. */
2677 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2678 /* This becomes the passed_type in
2679 function.c:assign_parm_find_data_types. C promotes char to
2680 integer for argument passing. */
2681 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2683 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2688 /* If we have a constant character expression, make it into an
2690 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2695 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2696 (int)(*expr
)->value
.character
.string
[0]);
2697 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2699 /* The expr needs to be compatible with a C int. If the
2700 conversion fails, then the 2 causes an ICE. */
2701 ts
.type
= BT_INTEGER
;
2702 ts
.kind
= gfc_c_int_kind
;
2703 gfc_convert_type (*expr
, &ts
, 2);
2706 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2708 if ((*expr
)->ref
== NULL
)
2710 se
->expr
= gfc_string_to_single_character
2711 (build_int_cst (integer_type_node
, 1),
2712 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2714 ((*expr
)->symtree
->n
.sym
)),
2719 gfc_conv_variable (se
, *expr
);
2720 se
->expr
= gfc_string_to_single_character
2721 (build_int_cst (integer_type_node
, 1),
2722 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2730 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2731 if STR is a string literal, otherwise return -1. */
2734 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2737 && TREE_CODE (str
) == ADDR_EXPR
2738 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2739 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2740 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2741 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2742 && TREE_INT_CST_LOW (len
) >= 1
2743 && TREE_INT_CST_LOW (len
)
2744 == (unsigned HOST_WIDE_INT
)
2745 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2747 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2748 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2749 if (TREE_CODE (folded
) == INTEGER_CST
)
2751 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2752 int length
= TREE_STRING_LENGTH (string_cst
);
2753 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2755 for (; length
> 0; length
--)
2756 if (ptr
[length
- 1] != ' ')
2765 /* Helper to build a call to memcmp. */
2768 build_memcmp_call (tree s1
, tree s2
, tree n
)
2772 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2773 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2775 s1
= fold_convert (pvoid_type_node
, s1
);
2777 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2778 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2780 s2
= fold_convert (pvoid_type_node
, s2
);
2782 n
= fold_convert (size_type_node
, n
);
2784 tmp
= build_call_expr_loc (input_location
,
2785 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2788 return fold_convert (integer_type_node
, tmp
);
2791 /* Compare two strings. If they are all single characters, the result is the
2792 subtraction of them. Otherwise, we build a library call. */
2795 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2796 enum tree_code code
)
2802 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2803 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2805 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2806 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2808 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2810 /* Deal with single character specially. */
2811 sc1
= fold_convert (integer_type_node
, sc1
);
2812 sc2
= fold_convert (integer_type_node
, sc2
);
2813 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2817 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2819 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2821 /* If one string is a string literal with LEN_TRIM longer
2822 than the length of the second string, the strings
2824 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2825 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2826 return integer_one_node
;
2827 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2828 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2829 return integer_one_node
;
2832 /* We can compare via memcpy if the strings are known to be equal
2833 in length and they are
2835 - kind=4 and the comparison is for (in)equality. */
2837 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2838 && tree_int_cst_equal (len1
, len2
)
2839 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2844 chartype
= gfc_get_char_type (kind
);
2845 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2846 fold_convert (TREE_TYPE(len1
),
2847 TYPE_SIZE_UNIT(chartype
)),
2849 return build_memcmp_call (str1
, str2
, tmp
);
2852 /* Build a call for the comparison. */
2854 fndecl
= gfor_fndecl_compare_string
;
2856 fndecl
= gfor_fndecl_compare_string_char4
;
2860 return build_call_expr_loc (input_location
, fndecl
, 4,
2861 len1
, str1
, len2
, str2
);
2865 /* Return the backend_decl for a procedure pointer component. */
2868 get_proc_ptr_comp (gfc_expr
*e
)
2874 gfc_init_se (&comp_se
, NULL
);
2875 e2
= gfc_copy_expr (e
);
2876 /* We have to restore the expr type later so that gfc_free_expr frees
2877 the exact same thing that was allocated.
2878 TODO: This is ugly. */
2879 old_type
= e2
->expr_type
;
2880 e2
->expr_type
= EXPR_VARIABLE
;
2881 gfc_conv_expr (&comp_se
, e2
);
2882 e2
->expr_type
= old_type
;
2884 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2888 /* Convert a typebound function reference from a class object. */
2890 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2895 if (TREE_CODE (base_object
) != VAR_DECL
)
2897 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2898 gfc_add_modify (&se
->pre
, var
, base_object
);
2900 se
->expr
= gfc_class_vptr_get (base_object
);
2901 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2903 while (ref
&& ref
->next
)
2905 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2906 if (ref
->u
.c
.sym
->attr
.extension
)
2907 conv_parent_component_references (se
, ref
);
2908 gfc_conv_component_ref (se
, ref
);
2909 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2914 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2918 if (gfc_is_proc_ptr_comp (expr
))
2919 tmp
= get_proc_ptr_comp (expr
);
2920 else if (sym
->attr
.dummy
)
2922 tmp
= gfc_get_symbol_decl (sym
);
2923 if (sym
->attr
.proc_pointer
)
2924 tmp
= build_fold_indirect_ref_loc (input_location
,
2926 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2927 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2931 if (!sym
->backend_decl
)
2932 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2934 TREE_USED (sym
->backend_decl
) = 1;
2936 tmp
= sym
->backend_decl
;
2938 if (sym
->attr
.cray_pointee
)
2940 /* TODO - make the cray pointee a pointer to a procedure,
2941 assign the pointer to it and use it for the call. This
2943 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2944 gfc_get_symbol_decl (sym
->cp_pointer
));
2945 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2948 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2950 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2951 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2958 /* Initialize MAPPING. */
2961 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2963 mapping
->syms
= NULL
;
2964 mapping
->charlens
= NULL
;
2968 /* Free all memory held by MAPPING (but not MAPPING itself). */
2971 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2973 gfc_interface_sym_mapping
*sym
;
2974 gfc_interface_sym_mapping
*nextsym
;
2976 gfc_charlen
*nextcl
;
2978 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2980 nextsym
= sym
->next
;
2981 sym
->new_sym
->n
.sym
->formal
= NULL
;
2982 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2983 gfc_free_expr (sym
->expr
);
2984 free (sym
->new_sym
);
2987 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2990 gfc_free_expr (cl
->length
);
2996 /* Return a copy of gfc_charlen CL. Add the returned structure to
2997 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2999 static gfc_charlen
*
3000 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3003 gfc_charlen
*new_charlen
;
3005 new_charlen
= gfc_get_charlen ();
3006 new_charlen
->next
= mapping
->charlens
;
3007 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3009 mapping
->charlens
= new_charlen
;
3014 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3015 array variable that can be used as the actual argument for dummy
3016 argument SYM. Add any initialization code to BLOCK. PACKED is as
3017 for gfc_get_nodesc_array_type and DATA points to the first element
3018 in the passed array. */
3021 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3022 gfc_packed packed
, tree data
)
3027 type
= gfc_typenode_for_spec (&sym
->ts
);
3028 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3029 !sym
->attr
.target
&& !sym
->attr
.pointer
3030 && !sym
->attr
.proc_pointer
);
3032 var
= gfc_create_var (type
, "ifm");
3033 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3039 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3040 and offset of descriptorless array type TYPE given that it has the same
3041 size as DESC. Add any set-up code to BLOCK. */
3044 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3051 offset
= gfc_index_zero_node
;
3052 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3054 dim
= gfc_rank_cst
[n
];
3055 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3056 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3058 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3059 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3060 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3061 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3063 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3065 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3066 gfc_array_index_type
,
3067 gfc_conv_descriptor_ubound_get (desc
, dim
),
3068 gfc_conv_descriptor_lbound_get (desc
, dim
));
3069 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3070 gfc_array_index_type
,
3071 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3072 tmp
= gfc_evaluate_now (tmp
, block
);
3073 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3075 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3076 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3077 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3078 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3079 gfc_array_index_type
, offset
, tmp
);
3081 offset
= gfc_evaluate_now (offset
, block
);
3082 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3086 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3087 in SE. The caller may still use se->expr and se->string_length after
3088 calling this function. */
3091 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3092 gfc_symbol
* sym
, gfc_se
* se
,
3095 gfc_interface_sym_mapping
*sm
;
3099 gfc_symbol
*new_sym
;
3101 gfc_symtree
*new_symtree
;
3103 /* Create a new symbol to represent the actual argument. */
3104 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3105 new_sym
->ts
= sym
->ts
;
3106 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3107 new_sym
->attr
.referenced
= 1;
3108 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3109 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3110 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3111 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3112 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3113 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3114 new_sym
->attr
.function
= sym
->attr
.function
;
3116 /* Ensure that the interface is available and that
3117 descriptors are passed for array actual arguments. */
3118 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3120 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3121 new_sym
->attr
.always_explicit
3122 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3125 /* Create a fake symtree for it. */
3127 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3128 new_symtree
->n
.sym
= new_sym
;
3129 gcc_assert (new_symtree
== root
);
3131 /* Create a dummy->actual mapping. */
3132 sm
= XCNEW (gfc_interface_sym_mapping
);
3133 sm
->next
= mapping
->syms
;
3135 sm
->new_sym
= new_symtree
;
3136 sm
->expr
= gfc_copy_expr (expr
);
3139 /* Stabilize the argument's value. */
3140 if (!sym
->attr
.function
&& se
)
3141 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3143 if (sym
->ts
.type
== BT_CHARACTER
)
3145 /* Create a copy of the dummy argument's length. */
3146 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3147 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3149 /* If the length is specified as "*", record the length that
3150 the caller is passing. We should use the callee's length
3151 in all other cases. */
3152 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3154 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3155 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3162 /* Use the passed value as-is if the argument is a function. */
3163 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3166 /* If the argument is either a string or a pointer to a string,
3167 convert it to a boundless character type. */
3168 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3170 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3171 tmp
= build_pointer_type (tmp
);
3172 if (sym
->attr
.pointer
)
3173 value
= build_fold_indirect_ref_loc (input_location
,
3177 value
= fold_convert (tmp
, value
);
3180 /* If the argument is a scalar, a pointer to an array or an allocatable,
3182 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3183 value
= build_fold_indirect_ref_loc (input_location
,
3186 /* For character(*), use the actual argument's descriptor. */
3187 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3188 value
= build_fold_indirect_ref_loc (input_location
,
3191 /* If the argument is an array descriptor, use it to determine
3192 information about the actual argument's shape. */
3193 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3194 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3196 /* Get the actual argument's descriptor. */
3197 desc
= build_fold_indirect_ref_loc (input_location
,
3200 /* Create the replacement variable. */
3201 tmp
= gfc_conv_descriptor_data_get (desc
);
3202 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3205 /* Use DESC to work out the upper bounds, strides and offset. */
3206 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3209 /* Otherwise we have a packed array. */
3210 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3211 PACKED_FULL
, se
->expr
);
3213 new_sym
->backend_decl
= value
;
3217 /* Called once all dummy argument mappings have been added to MAPPING,
3218 but before the mapping is used to evaluate expressions. Pre-evaluate
3219 the length of each argument, adding any initialization code to PRE and
3220 any finalization code to POST. */
3223 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3224 stmtblock_t
* pre
, stmtblock_t
* post
)
3226 gfc_interface_sym_mapping
*sym
;
3230 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3231 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3232 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3234 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3235 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3236 gfc_init_se (&se
, NULL
);
3237 gfc_conv_expr (&se
, expr
);
3238 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3239 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3240 gfc_add_block_to_block (pre
, &se
.pre
);
3241 gfc_add_block_to_block (post
, &se
.post
);
3243 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3248 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3252 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3253 gfc_constructor_base base
)
3256 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3258 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3261 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3262 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3263 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3269 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3273 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3278 for (; ref
; ref
= ref
->next
)
3282 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3284 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3285 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3286 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3294 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3295 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3301 /* Convert intrinsic function calls into result expressions. */
3304 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3312 arg1
= expr
->value
.function
.actual
->expr
;
3313 if (expr
->value
.function
.actual
->next
)
3314 arg2
= expr
->value
.function
.actual
->next
->expr
;
3318 sym
= arg1
->symtree
->n
.sym
;
3320 if (sym
->attr
.dummy
)
3325 switch (expr
->value
.function
.isym
->id
)
3328 /* TODO figure out why this condition is necessary. */
3329 if (sym
->attr
.function
3330 && (arg1
->ts
.u
.cl
->length
== NULL
3331 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3332 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3335 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3339 if (!sym
->as
|| sym
->as
->rank
== 0)
3342 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3344 dup
= mpz_get_si (arg2
->value
.integer
);
3349 dup
= sym
->as
->rank
;
3353 for (; d
< dup
; d
++)
3357 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3359 gfc_free_expr (new_expr
);
3363 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3364 gfc_get_int_expr (gfc_default_integer_kind
,
3366 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3368 new_expr
= gfc_multiply (new_expr
, tmp
);
3374 case GFC_ISYM_LBOUND
:
3375 case GFC_ISYM_UBOUND
:
3376 /* TODO These implementations of lbound and ubound do not limit if
3377 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3379 if (!sym
->as
|| sym
->as
->rank
== 0)
3382 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3383 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3385 /* TODO: If the need arises, this could produce an array of
3389 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3391 if (sym
->as
->lower
[d
])
3392 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3396 if (sym
->as
->upper
[d
])
3397 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3405 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3409 gfc_replace_expr (expr
, new_expr
);
3415 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3416 gfc_interface_mapping
* mapping
)
3418 gfc_formal_arglist
*f
;
3419 gfc_actual_arglist
*actual
;
3421 actual
= expr
->value
.function
.actual
;
3422 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3424 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3429 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3432 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3437 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3439 for (d
= 0; d
< as
->rank
; d
++)
3441 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3442 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3445 expr
->value
.function
.esym
->as
= as
;
3448 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3450 expr
->value
.function
.esym
->ts
.u
.cl
->length
3451 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3453 gfc_apply_interface_mapping_to_expr (mapping
,
3454 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3459 /* EXPR is a copy of an expression that appeared in the interface
3460 associated with MAPPING. Walk it recursively looking for references to
3461 dummy arguments that MAPPING maps to actual arguments. Replace each such
3462 reference with a reference to the associated actual argument. */
3465 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3468 gfc_interface_sym_mapping
*sym
;
3469 gfc_actual_arglist
*actual
;
3474 /* Copying an expression does not copy its length, so do that here. */
3475 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3477 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3478 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3481 /* Apply the mapping to any references. */
3482 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3484 /* ...and to the expression's symbol, if it has one. */
3485 /* TODO Find out why the condition on expr->symtree had to be moved into
3486 the loop rather than being outside it, as originally. */
3487 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3488 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3490 if (sym
->new_sym
->n
.sym
->backend_decl
)
3491 expr
->symtree
= sym
->new_sym
;
3493 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3494 /* Replace base type for polymorphic arguments. */
3495 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3496 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3497 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3500 /* ...and to subexpressions in expr->value. */
3501 switch (expr
->expr_type
)
3506 case EXPR_SUBSTRING
:
3510 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3511 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3515 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3516 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3518 if (expr
->value
.function
.esym
== NULL
3519 && expr
->value
.function
.isym
!= NULL
3520 && expr
->value
.function
.actual
->expr
->symtree
3521 && gfc_map_intrinsic_function (expr
, mapping
))
3524 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3525 if (sym
->old
== expr
->value
.function
.esym
)
3527 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3528 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3529 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3534 case EXPR_STRUCTURE
:
3535 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3548 /* Evaluate interface expression EXPR using MAPPING. Store the result
3552 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3553 gfc_se
* se
, gfc_expr
* expr
)
3555 expr
= gfc_copy_expr (expr
);
3556 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3557 gfc_conv_expr (se
, expr
);
3558 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3559 gfc_free_expr (expr
);
3563 /* Returns a reference to a temporary array into which a component of
3564 an actual argument derived type array is copied and then returned
3565 after the function call. */
3567 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3568 sym_intent intent
, bool formal_ptr
)
3576 gfc_array_info
*info
;
3586 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3588 gfc_init_se (&lse
, NULL
);
3589 gfc_init_se (&rse
, NULL
);
3591 /* Walk the argument expression. */
3592 rss
= gfc_walk_expr (expr
);
3594 gcc_assert (rss
!= gfc_ss_terminator
);
3596 /* Initialize the scalarizer. */
3597 gfc_init_loopinfo (&loop
);
3598 gfc_add_ss_to_loop (&loop
, rss
);
3600 /* Calculate the bounds of the scalarization. */
3601 gfc_conv_ss_startstride (&loop
);
3603 /* Build an ss for the temporary. */
3604 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3605 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3607 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3608 if (GFC_ARRAY_TYPE_P (base_type
)
3609 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3610 base_type
= gfc_get_element_type (base_type
);
3612 if (expr
->ts
.type
== BT_CLASS
)
3613 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3615 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3616 ? expr
->ts
.u
.cl
->backend_decl
3620 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3622 /* Associate the SS with the loop. */
3623 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3625 /* Setup the scalarizing loops. */
3626 gfc_conv_loop_setup (&loop
, &expr
->where
);
3628 /* Pass the temporary descriptor back to the caller. */
3629 info
= &loop
.temp_ss
->info
->data
.array
;
3630 parmse
->expr
= info
->descriptor
;
3632 /* Setup the gfc_se structures. */
3633 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3634 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3637 lse
.ss
= loop
.temp_ss
;
3638 gfc_mark_ss_chain_used (rss
, 1);
3639 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3641 /* Start the scalarized loop body. */
3642 gfc_start_scalarized_body (&loop
, &body
);
3644 /* Translate the expression. */
3645 gfc_conv_expr (&rse
, expr
);
3647 gfc_conv_tmp_array_ref (&lse
);
3649 if (intent
!= INTENT_OUT
)
3651 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3652 gfc_add_expr_to_block (&body
, tmp
);
3653 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3654 gfc_trans_scalarizing_loops (&loop
, &body
);
3658 /* Make sure that the temporary declaration survives by merging
3659 all the loop declarations into the current context. */
3660 for (n
= 0; n
< loop
.dimen
; n
++)
3662 gfc_merge_block_scope (&body
);
3663 body
= loop
.code
[loop
.order
[n
]];
3665 gfc_merge_block_scope (&body
);
3668 /* Add the post block after the second loop, so that any
3669 freeing of allocated memory is done at the right time. */
3670 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3672 /**********Copy the temporary back again.*********/
3674 gfc_init_se (&lse
, NULL
);
3675 gfc_init_se (&rse
, NULL
);
3677 /* Walk the argument expression. */
3678 lss
= gfc_walk_expr (expr
);
3679 rse
.ss
= loop
.temp_ss
;
3682 /* Initialize the scalarizer. */
3683 gfc_init_loopinfo (&loop2
);
3684 gfc_add_ss_to_loop (&loop2
, lss
);
3686 /* Calculate the bounds of the scalarization. */
3687 gfc_conv_ss_startstride (&loop2
);
3689 /* Setup the scalarizing loops. */
3690 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3692 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3693 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3695 gfc_mark_ss_chain_used (lss
, 1);
3696 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3698 /* Declare the variable to hold the temporary offset and start the
3699 scalarized loop body. */
3700 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3701 gfc_start_scalarized_body (&loop2
, &body
);
3703 /* Build the offsets for the temporary from the loop variables. The
3704 temporary array has lbounds of zero and strides of one in all
3705 dimensions, so this is very simple. The offset is only computed
3706 outside the innermost loop, so the overall transfer could be
3707 optimized further. */
3708 info
= &rse
.ss
->info
->data
.array
;
3709 dimen
= rse
.ss
->dimen
;
3711 tmp_index
= gfc_index_zero_node
;
3712 for (n
= dimen
- 1; n
> 0; n
--)
3715 tmp
= rse
.loop
->loopvar
[n
];
3716 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3717 tmp
, rse
.loop
->from
[n
]);
3718 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3721 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3722 gfc_array_index_type
,
3723 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3724 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3725 gfc_array_index_type
,
3726 tmp_str
, gfc_index_one_node
);
3728 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3729 gfc_array_index_type
, tmp
, tmp_str
);
3732 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3733 gfc_array_index_type
,
3734 tmp_index
, rse
.loop
->from
[0]);
3735 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3737 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3738 gfc_array_index_type
,
3739 rse
.loop
->loopvar
[0], offset
);
3741 /* Now use the offset for the reference. */
3742 tmp
= build_fold_indirect_ref_loc (input_location
,
3744 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3746 if (expr
->ts
.type
== BT_CHARACTER
)
3747 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3749 gfc_conv_expr (&lse
, expr
);
3751 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3753 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3754 gfc_add_expr_to_block (&body
, tmp
);
3756 /* Generate the copying loops. */
3757 gfc_trans_scalarizing_loops (&loop2
, &body
);
3759 /* Wrap the whole thing up by adding the second loop to the post-block
3760 and following it by the post-block of the first loop. In this way,
3761 if the temporary needs freeing, it is done after use! */
3762 if (intent
!= INTENT_IN
)
3764 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3765 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3768 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3770 gfc_cleanup_loop (&loop
);
3771 gfc_cleanup_loop (&loop2
);
3773 /* Pass the string length to the argument expression. */
3774 if (expr
->ts
.type
== BT_CHARACTER
)
3775 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3777 /* Determine the offset for pointer formal arguments and set the
3781 size
= gfc_index_one_node
;
3782 offset
= gfc_index_zero_node
;
3783 for (n
= 0; n
< dimen
; n
++)
3785 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3787 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3788 gfc_array_index_type
, tmp
,
3789 gfc_index_one_node
);
3790 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3794 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3797 gfc_index_one_node
);
3798 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3799 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3800 gfc_array_index_type
,
3802 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3803 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3804 gfc_array_index_type
,
3805 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3806 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3807 gfc_array_index_type
,
3808 tmp
, gfc_index_one_node
);
3809 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3810 gfc_array_index_type
, size
, tmp
);
3813 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3817 /* We want either the address for the data or the address of the descriptor,
3818 depending on the mode of passing array arguments. */
3820 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3822 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3828 /* Generate the code for argument list functions. */
3831 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3833 /* Pass by value for g77 %VAL(arg), pass the address
3834 indirectly for %LOC, else by reference. Thus %REF
3835 is a "do-nothing" and %LOC is the same as an F95
3837 if (strncmp (name
, "%VAL", 4) == 0)
3838 gfc_conv_expr (se
, expr
);
3839 else if (strncmp (name
, "%LOC", 4) == 0)
3841 gfc_conv_expr_reference (se
, expr
);
3842 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3844 else if (strncmp (name
, "%REF", 4) == 0)
3845 gfc_conv_expr_reference (se
, expr
);
3847 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3851 /* Generate code for a procedure call. Note can return se->post != NULL.
3852 If se->direct_byref is set then se->expr contains the return parameter.
3853 Return nonzero, if the call has alternate specifiers.
3854 'expr' is only needed for procedure pointer components. */
3857 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3858 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3859 vec
<tree
, va_gc
> *append_args
)
3861 gfc_interface_mapping mapping
;
3862 vec
<tree
, va_gc
> *arglist
;
3863 vec
<tree
, va_gc
> *retargs
;
3867 gfc_array_info
*info
;
3874 vec
<tree
, va_gc
> *stringargs
;
3875 vec
<tree
, va_gc
> *optionalargs
;
3877 gfc_formal_arglist
*formal
;
3878 gfc_actual_arglist
*arg
;
3879 int has_alternate_specifier
= 0;
3880 bool need_interface_mapping
;
3887 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3888 gfc_component
*comp
= NULL
;
3894 optionalargs
= NULL
;
3899 comp
= gfc_get_proc_ptr_comp (expr
);
3903 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3905 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3906 if (se
->ss
->info
->useflags
)
3908 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3909 && sym
->result
->attr
.dimension
)
3910 || (comp
&& comp
->attr
.dimension
));
3911 gcc_assert (se
->loop
!= NULL
);
3913 /* Access the previously obtained result. */
3914 gfc_conv_tmp_array_ref (se
);
3918 info
= &se
->ss
->info
->data
.array
;
3923 gfc_init_block (&post
);
3924 gfc_init_interface_mapping (&mapping
);
3927 formal
= gfc_sym_get_dummy_args (sym
);
3928 need_interface_mapping
= sym
->attr
.dimension
||
3929 (sym
->ts
.type
== BT_CHARACTER
3930 && sym
->ts
.u
.cl
->length
3931 && sym
->ts
.u
.cl
->length
->expr_type
3936 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3937 need_interface_mapping
= comp
->attr
.dimension
||
3938 (comp
->ts
.type
== BT_CHARACTER
3939 && comp
->ts
.u
.cl
->length
3940 && comp
->ts
.u
.cl
->length
->expr_type
3944 base_object
= NULL_TREE
;
3946 /* Evaluate the arguments. */
3947 for (arg
= args
; arg
!= NULL
;
3948 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3951 fsym
= formal
? formal
->sym
: NULL
;
3952 parm_kind
= MISSING
;
3954 /* Class array expressions are sometimes coming completely unadorned
3955 with either arrayspec or _data component. Correct that here.
3956 OOP-TODO: Move this to the frontend. */
3957 if (e
&& e
->expr_type
== EXPR_VARIABLE
3959 && e
->ts
.type
== BT_CLASS
3960 && (CLASS_DATA (e
)->attr
.codimension
3961 || CLASS_DATA (e
)->attr
.dimension
))
3963 gfc_typespec temp_ts
= e
->ts
;
3964 gfc_add_class_array_ref (e
);
3970 if (se
->ignore_optional
)
3972 /* Some intrinsics have already been resolved to the correct
3976 else if (arg
->label
)
3978 has_alternate_specifier
= 1;
3983 gfc_init_se (&parmse
, NULL
);
3985 /* For scalar arguments with VALUE attribute which are passed by
3986 value, pass "0" and a hidden argument gives the optional
3988 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
3989 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
3990 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
3992 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
3994 vec_safe_push (optionalargs
, boolean_false_node
);
3998 /* Pass a NULL pointer for an absent arg. */
3999 parmse
.expr
= null_pointer_node
;
4000 if (arg
->missing_arg_type
== BT_CHARACTER
)
4001 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4006 else if (arg
->expr
->expr_type
== EXPR_NULL
4007 && fsym
&& !fsym
->attr
.pointer
4008 && (fsym
->ts
.type
!= BT_CLASS
4009 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4011 /* Pass a NULL pointer to denote an absent arg. */
4012 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4013 && (fsym
->ts
.type
!= BT_CLASS
4014 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4015 gfc_init_se (&parmse
, NULL
);
4016 parmse
.expr
= null_pointer_node
;
4017 if (arg
->missing_arg_type
== BT_CHARACTER
)
4018 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4020 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4021 && e
->ts
.type
== BT_DERIVED
)
4023 /* The derived type needs to be converted to a temporary
4025 gfc_init_se (&parmse
, se
);
4026 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4028 && e
->expr_type
== EXPR_VARIABLE
4029 && e
->symtree
->n
.sym
->attr
.optional
,
4030 CLASS_DATA (fsym
)->attr
.class_pointer
4031 || CLASS_DATA (fsym
)->attr
.allocatable
);
4033 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4035 /* The intrinsic type needs to be converted to a temporary
4036 CLASS object for the unlimited polymorphic formal. */
4037 gfc_init_se (&parmse
, se
);
4038 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4040 else if (se
->ss
&& se
->ss
->info
->useflags
)
4046 /* An elemental function inside a scalarized loop. */
4047 gfc_init_se (&parmse
, se
);
4048 parm_kind
= ELEMENTAL
;
4050 gfc_conv_expr_reference (&parmse
, e
);
4051 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4052 && e
->expr_type
== EXPR_FUNCTION
)
4053 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4056 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4057 && gfc_is_class_container_ref (e
))
4059 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4061 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4062 && e
->symtree
->n
.sym
->attr
.optional
)
4064 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4065 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4066 TREE_TYPE (parmse
.expr
),
4068 fold_convert (TREE_TYPE (parmse
.expr
),
4069 null_pointer_node
));
4073 /* If we are passing an absent array as optional dummy to an
4074 elemental procedure, make sure that we pass NULL when the data
4075 pointer is NULL. We need this extra conditional because of
4076 scalarization which passes arrays elements to the procedure,
4077 ignoring the fact that the array can be absent/unallocated/... */
4078 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4080 tree descriptor_data
;
4082 descriptor_data
= ss
->info
->data
.array
.data
;
4083 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4085 fold_convert (TREE_TYPE (descriptor_data
),
4086 null_pointer_node
));
4088 = fold_build3_loc (input_location
, COND_EXPR
,
4089 TREE_TYPE (parmse
.expr
),
4091 fold_convert (TREE_TYPE (parmse
.expr
),
4096 /* The scalarizer does not repackage the reference to a class
4097 array - instead it returns a pointer to the data element. */
4098 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4099 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4100 fsym
->attr
.intent
!= INTENT_IN
4101 && (CLASS_DATA (fsym
)->attr
.class_pointer
4102 || CLASS_DATA (fsym
)->attr
.allocatable
),
4104 && e
->expr_type
== EXPR_VARIABLE
4105 && e
->symtree
->n
.sym
->attr
.optional
,
4106 CLASS_DATA (fsym
)->attr
.class_pointer
4107 || CLASS_DATA (fsym
)->attr
.allocatable
);
4114 gfc_init_se (&parmse
, NULL
);
4116 /* Check whether the expression is a scalar or not; we cannot use
4117 e->rank as it can be nonzero for functions arguments. */
4118 argss
= gfc_walk_expr (e
);
4119 scalar
= argss
== gfc_ss_terminator
;
4121 gfc_free_ss_chain (argss
);
4123 /* Special handling for passing scalar polymorphic coarrays;
4124 otherwise one passes "class->_data.data" instead of "&class". */
4125 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4126 && fsym
&& fsym
->ts
.type
== BT_CLASS
4127 && CLASS_DATA (fsym
)->attr
.codimension
4128 && !CLASS_DATA (fsym
)->attr
.dimension
)
4130 gfc_add_class_array_ref (e
);
4131 parmse
.want_coarray
= 1;
4135 /* A scalar or transformational function. */
4138 if (e
->expr_type
== EXPR_VARIABLE
4139 && e
->symtree
->n
.sym
->attr
.cray_pointee
4140 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4142 /* The Cray pointer needs to be converted to a pointer to
4143 a type given by the expression. */
4144 gfc_conv_expr (&parmse
, e
);
4145 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4146 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4147 parmse
.expr
= convert (type
, tmp
);
4149 else if (fsym
&& fsym
->attr
.value
)
4151 if (fsym
->ts
.type
== BT_CHARACTER
4152 && fsym
->ts
.is_c_interop
4153 && fsym
->ns
->proc_name
!= NULL
4154 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4157 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4158 if (parmse
.expr
== NULL
)
4159 gfc_conv_expr (&parmse
, e
);
4163 gfc_conv_expr (&parmse
, e
);
4164 if (fsym
->attr
.optional
4165 && fsym
->ts
.type
!= BT_CLASS
4166 && fsym
->ts
.type
!= BT_DERIVED
)
4168 if (e
->expr_type
!= EXPR_VARIABLE
4169 || !e
->symtree
->n
.sym
->attr
.optional
4171 vec_safe_push (optionalargs
, boolean_true_node
);
4174 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4175 if (!e
->symtree
->n
.sym
->attr
.value
)
4177 = fold_build3_loc (input_location
, COND_EXPR
,
4178 TREE_TYPE (parmse
.expr
),
4180 fold_convert (TREE_TYPE (parmse
.expr
),
4181 integer_zero_node
));
4183 vec_safe_push (optionalargs
, tmp
);
4188 else if (arg
->name
&& arg
->name
[0] == '%')
4189 /* Argument list functions %VAL, %LOC and %REF are signalled
4190 through arg->name. */
4191 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4192 else if ((e
->expr_type
== EXPR_FUNCTION
)
4193 && ((e
->value
.function
.esym
4194 && e
->value
.function
.esym
->result
->attr
.pointer
)
4195 || (!e
->value
.function
.esym
4196 && e
->symtree
->n
.sym
->attr
.pointer
))
4197 && fsym
&& fsym
->attr
.target
)
4199 gfc_conv_expr (&parmse
, e
);
4200 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4202 else if (e
->expr_type
== EXPR_FUNCTION
4203 && e
->symtree
->n
.sym
->result
4204 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4205 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4207 /* Functions returning procedure pointers. */
4208 gfc_conv_expr (&parmse
, e
);
4209 if (fsym
&& fsym
->attr
.proc_pointer
)
4210 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4214 if (e
->ts
.type
== BT_CLASS
&& fsym
4215 && fsym
->ts
.type
== BT_CLASS
4216 && (!CLASS_DATA (fsym
)->as
4217 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4218 && CLASS_DATA (e
)->attr
.codimension
)
4220 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4221 gcc_assert (!CLASS_DATA (fsym
)->as
);
4222 gfc_add_class_array_ref (e
);
4223 parmse
.want_coarray
= 1;
4224 gfc_conv_expr_reference (&parmse
, e
);
4225 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4227 && e
->expr_type
== EXPR_VARIABLE
);
4230 gfc_conv_expr_reference (&parmse
, e
);
4232 /* Catch base objects that are not variables. */
4233 if (e
->ts
.type
== BT_CLASS
4234 && e
->expr_type
!= EXPR_VARIABLE
4235 && expr
&& e
== expr
->base_expr
)
4236 base_object
= build_fold_indirect_ref_loc (input_location
,
4239 /* A class array element needs converting back to be a
4240 class object, if the formal argument is a class object. */
4241 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4242 && e
->ts
.type
== BT_CLASS
4243 && ((CLASS_DATA (fsym
)->as
4244 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4245 || CLASS_DATA (e
)->attr
.dimension
))
4246 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4247 fsym
->attr
.intent
!= INTENT_IN
4248 && (CLASS_DATA (fsym
)->attr
.class_pointer
4249 || CLASS_DATA (fsym
)->attr
.allocatable
),
4251 && e
->expr_type
== EXPR_VARIABLE
4252 && e
->symtree
->n
.sym
->attr
.optional
,
4253 CLASS_DATA (fsym
)->attr
.class_pointer
4254 || CLASS_DATA (fsym
)->attr
.allocatable
);
4256 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4257 allocated on entry, it must be deallocated. */
4258 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4259 && (fsym
->attr
.allocatable
4260 || (fsym
->ts
.type
== BT_CLASS
4261 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4266 gfc_init_block (&block
);
4268 if (e
->ts
.type
== BT_CLASS
)
4269 ptr
= gfc_class_data_get (ptr
);
4271 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4273 gfc_add_expr_to_block (&block
, tmp
);
4274 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4275 void_type_node
, ptr
,
4277 gfc_add_expr_to_block (&block
, tmp
);
4279 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4281 gfc_add_modify (&block
, ptr
,
4282 fold_convert (TREE_TYPE (ptr
),
4283 null_pointer_node
));
4284 gfc_add_expr_to_block (&block
, tmp
);
4286 else if (fsym
->ts
.type
== BT_CLASS
)
4289 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4290 tmp
= gfc_get_symbol_decl (vtab
);
4291 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4292 ptr
= gfc_class_vptr_get (parmse
.expr
);
4293 gfc_add_modify (&block
, ptr
,
4294 fold_convert (TREE_TYPE (ptr
), tmp
));
4295 gfc_add_expr_to_block (&block
, tmp
);
4298 if (fsym
->attr
.optional
4299 && e
->expr_type
== EXPR_VARIABLE
4300 && e
->symtree
->n
.sym
->attr
.optional
)
4302 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4304 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4305 gfc_finish_block (&block
),
4306 build_empty_stmt (input_location
));
4309 tmp
= gfc_finish_block (&block
);
4311 gfc_add_expr_to_block (&se
->pre
, tmp
);
4314 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4315 || fsym
->ts
.type
== BT_ASSUMED
)
4316 && e
->ts
.type
== BT_CLASS
4317 && !CLASS_DATA (e
)->attr
.dimension
4318 && !CLASS_DATA (e
)->attr
.codimension
)
4319 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4321 /* Wrap scalar variable in a descriptor. We need to convert
4322 the address of a pointer back to the pointer itself before,
4323 we can assign it to the data field. */
4325 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4326 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4329 if (TREE_CODE (tmp
) == ADDR_EXPR
4330 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4331 tmp
= TREE_OPERAND (tmp
, 0);
4332 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4334 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4337 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4338 && ((fsym
->attr
.pointer
4339 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4340 || (fsym
->attr
.proc_pointer
4341 && !(e
->expr_type
== EXPR_VARIABLE
4342 && e
->symtree
->n
.sym
->attr
.dummy
))
4343 || (fsym
->attr
.proc_pointer
4344 && e
->expr_type
== EXPR_VARIABLE
4345 && gfc_is_proc_ptr_comp (e
))
4346 || (fsym
->attr
.allocatable
4347 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4349 /* Scalar pointer dummy args require an extra level of
4350 indirection. The null pointer already contains
4351 this level of indirection. */
4352 parm_kind
= SCALAR_POINTER
;
4353 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4357 else if (e
->ts
.type
== BT_CLASS
4358 && fsym
&& fsym
->ts
.type
== BT_CLASS
4359 && (CLASS_DATA (fsym
)->attr
.dimension
4360 || CLASS_DATA (fsym
)->attr
.codimension
))
4362 /* Pass a class array. */
4363 gfc_conv_expr_descriptor (&parmse
, e
);
4365 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4366 allocated on entry, it must be deallocated. */
4367 if (fsym
->attr
.intent
== INTENT_OUT
4368 && CLASS_DATA (fsym
)->attr
.allocatable
)
4373 gfc_init_block (&block
);
4375 ptr
= gfc_class_data_get (ptr
);
4377 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4378 NULL_TREE
, NULL_TREE
,
4381 gfc_add_expr_to_block (&block
, tmp
);
4382 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4383 void_type_node
, ptr
,
4385 gfc_add_expr_to_block (&block
, tmp
);
4386 gfc_reset_vptr (&block
, e
);
4388 if (fsym
->attr
.optional
4389 && e
->expr_type
== EXPR_VARIABLE
4391 || (e
->ref
->type
== REF_ARRAY
4392 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4393 && e
->symtree
->n
.sym
->attr
.optional
)
4395 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4397 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4398 gfc_finish_block (&block
),
4399 build_empty_stmt (input_location
));
4402 tmp
= gfc_finish_block (&block
);
4404 gfc_add_expr_to_block (&se
->pre
, tmp
);
4407 /* The conversion does not repackage the reference to a class
4408 array - _data descriptor. */
4409 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4410 fsym
->attr
.intent
!= INTENT_IN
4411 && (CLASS_DATA (fsym
)->attr
.class_pointer
4412 || CLASS_DATA (fsym
)->attr
.allocatable
),
4414 && e
->expr_type
== EXPR_VARIABLE
4415 && e
->symtree
->n
.sym
->attr
.optional
,
4416 CLASS_DATA (fsym
)->attr
.class_pointer
4417 || CLASS_DATA (fsym
)->attr
.allocatable
);
4421 /* If the procedure requires an explicit interface, the actual
4422 argument is passed according to the corresponding formal
4423 argument. If the corresponding formal argument is a POINTER,
4424 ALLOCATABLE or assumed shape, we do not use g77's calling
4425 convention, and pass the address of the array descriptor
4426 instead. Otherwise we use g77's calling convention. */
4429 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4430 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4431 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4433 f
= f
|| !comp
->attr
.always_explicit
;
4435 f
= f
|| !sym
->attr
.always_explicit
;
4437 /* If the argument is a function call that may not create
4438 a temporary for the result, we have to check that we
4439 can do it, i.e. that there is no alias between this
4440 argument and another one. */
4441 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4447 intent
= fsym
->attr
.intent
;
4449 intent
= INTENT_UNKNOWN
;
4451 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4453 parmse
.force_tmp
= 1;
4455 iarg
= e
->value
.function
.actual
->expr
;
4457 /* Temporary needed if aliasing due to host association. */
4458 if (sym
->attr
.contained
4460 && !sym
->attr
.implicit_pure
4461 && !sym
->attr
.use_assoc
4462 && iarg
->expr_type
== EXPR_VARIABLE
4463 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4464 parmse
.force_tmp
= 1;
4466 /* Ditto within module. */
4467 if (sym
->attr
.use_assoc
4469 && !sym
->attr
.implicit_pure
4470 && iarg
->expr_type
== EXPR_VARIABLE
4471 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4472 parmse
.force_tmp
= 1;
4475 if (e
->expr_type
== EXPR_VARIABLE
4476 && is_subref_array (e
))
4477 /* The actual argument is a component reference to an
4478 array of derived types. In this case, the argument
4479 is converted to a temporary, which is passed and then
4480 written back after the procedure call. */
4481 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4482 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4483 fsym
&& fsym
->attr
.pointer
);
4484 else if (gfc_is_class_array_ref (e
, NULL
)
4485 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4486 /* The actual argument is a component reference to an
4487 array of derived types. In this case, the argument
4488 is converted to a temporary, which is passed and then
4489 written back after the procedure call.
4490 OOP-TODO: Insert code so that if the dynamic type is
4491 the same as the declared type, copy-in/copy-out does
4493 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4494 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4495 fsym
&& fsym
->attr
.pointer
);
4497 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4499 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4500 allocated on entry, it must be deallocated. */
4501 if (fsym
&& fsym
->attr
.allocatable
4502 && fsym
->attr
.intent
== INTENT_OUT
)
4504 tmp
= build_fold_indirect_ref_loc (input_location
,
4506 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4507 if (fsym
->attr
.optional
4508 && e
->expr_type
== EXPR_VARIABLE
4509 && e
->symtree
->n
.sym
->attr
.optional
)
4510 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4512 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4513 tmp
, build_empty_stmt (input_location
));
4514 gfc_add_expr_to_block (&se
->pre
, tmp
);
4519 /* The case with fsym->attr.optional is that of a user subroutine
4520 with an interface indicating an optional argument. When we call
4521 an intrinsic subroutine, however, fsym is NULL, but we might still
4522 have an optional argument, so we proceed to the substitution
4524 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4526 /* If an optional argument is itself an optional dummy argument,
4527 check its presence and substitute a null if absent. This is
4528 only needed when passing an array to an elemental procedure
4529 as then array elements are accessed - or no NULL pointer is
4530 allowed and a "1" or "0" should be passed if not present.
4531 When passing a non-array-descriptor full array to a
4532 non-array-descriptor dummy, no check is needed. For
4533 array-descriptor actual to array-descriptor dummy, see
4534 PR 41911 for why a check has to be inserted.
4535 fsym == NULL is checked as intrinsics required the descriptor
4536 but do not always set fsym. */
4537 if (e
->expr_type
== EXPR_VARIABLE
4538 && e
->symtree
->n
.sym
->attr
.optional
4539 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4540 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4544 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4545 || fsym
->as
->type
== AS_ASSUMED_RANK
4546 || fsym
->as
->type
== AS_DEFERRED
))))))
4547 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4548 e
->representation
.length
);
4553 /* Obtain the character length of an assumed character length
4554 length procedure from the typespec. */
4555 if (fsym
->ts
.type
== BT_CHARACTER
4556 && parmse
.string_length
== NULL_TREE
4557 && e
->ts
.type
== BT_PROCEDURE
4558 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4559 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4560 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4562 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4563 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4567 if (fsym
&& need_interface_mapping
&& e
)
4568 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4570 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4571 gfc_add_block_to_block (&post
, &parmse
.post
);
4573 /* Allocated allocatable components of derived types must be
4574 deallocated for non-variable scalars. Non-variable arrays are
4575 dealt with in trans-array.c(gfc_conv_array_parameter). */
4576 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4577 && e
->ts
.u
.derived
->attr
.alloc_comp
4578 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4579 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4582 tmp
= build_fold_indirect_ref_loc (input_location
,
4584 parm_rank
= e
->rank
;
4592 case (SCALAR_POINTER
):
4593 tmp
= build_fold_indirect_ref_loc (input_location
,
4598 if (e
->expr_type
== EXPR_OP
4599 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4600 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4603 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4604 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4605 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4608 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4610 /* The derived type is passed to gfc_deallocate_alloc_comp.
4611 Therefore, class actuals can handled correctly but derived
4612 types passed to class formals need the _data component. */
4613 tmp
= gfc_class_data_get (tmp
);
4614 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4615 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4618 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4620 gfc_add_expr_to_block (&se
->post
, tmp
);
4623 /* Add argument checking of passing an unallocated/NULL actual to
4624 a nonallocatable/nonpointer dummy. */
4626 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4628 symbol_attribute attr
;
4632 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4633 attr
= gfc_expr_attr (e
);
4635 goto end_pointer_check
;
4637 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4638 allocatable to an optional dummy, cf. 12.5.2.12. */
4639 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4640 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4641 goto end_pointer_check
;
4645 /* If the actual argument is an optional pointer/allocatable and
4646 the formal argument takes an nonpointer optional value,
4647 it is invalid to pass a non-present argument on, even
4648 though there is no technical reason for this in gfortran.
4649 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4650 tree present
, null_ptr
, type
;
4652 if (attr
.allocatable
4653 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4654 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4655 "allocated or not present", e
->symtree
->n
.sym
->name
);
4656 else if (attr
.pointer
4657 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4658 asprintf (&msg
, "Pointer actual argument '%s' is not "
4659 "associated or not present",
4660 e
->symtree
->n
.sym
->name
);
4661 else if (attr
.proc_pointer
4662 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4663 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4664 "associated or not present",
4665 e
->symtree
->n
.sym
->name
);
4667 goto end_pointer_check
;
4669 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4670 type
= TREE_TYPE (present
);
4671 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4672 boolean_type_node
, present
,
4674 null_pointer_node
));
4675 type
= TREE_TYPE (parmse
.expr
);
4676 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4677 boolean_type_node
, parmse
.expr
,
4679 null_pointer_node
));
4680 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4681 boolean_type_node
, present
, null_ptr
);
4685 if (attr
.allocatable
4686 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4687 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4688 "allocated", e
->symtree
->n
.sym
->name
);
4689 else if (attr
.pointer
4690 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4691 asprintf (&msg
, "Pointer actual argument '%s' is not "
4692 "associated", e
->symtree
->n
.sym
->name
);
4693 else if (attr
.proc_pointer
4694 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4695 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4696 "associated", e
->symtree
->n
.sym
->name
);
4698 goto end_pointer_check
;
4702 /* If the argument is passed by value, we need to strip the
4704 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4705 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4707 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4708 boolean_type_node
, tmp
,
4709 fold_convert (TREE_TYPE (tmp
),
4710 null_pointer_node
));
4713 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4719 /* Deferred length dummies pass the character length by reference
4720 so that the value can be returned. */
4721 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4723 tmp
= parmse
.string_length
;
4724 if (TREE_CODE (tmp
) != VAR_DECL
)
4725 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4726 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4729 /* Character strings are passed as two parameters, a length and a
4730 pointer - except for Bind(c) which only passes the pointer.
4731 An unlimited polymorphic formal argument likewise does not
4733 if (parmse
.string_length
!= NULL_TREE
4734 && !sym
->attr
.is_bind_c
4735 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4736 vec_safe_push (stringargs
, parmse
.string_length
);
4738 /* When calling __copy for character expressions to unlimited
4739 polymorphic entities, the dst argument needs a string length. */
4740 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4741 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4742 && arg
->next
&& arg
->next
->expr
4743 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4744 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4745 vec_safe_push (stringargs
, parmse
.string_length
);
4747 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4748 pass the token and the offset as additional arguments. */
4749 if (fsym
&& fsym
->attr
.codimension
4750 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4751 && !fsym
->attr
.allocatable
4754 /* Token and offset. */
4755 vec_safe_push (stringargs
, null_pointer_node
);
4756 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4757 gcc_assert (fsym
->attr
.optional
);
4759 else if (fsym
&& fsym
->attr
.codimension
4760 && !fsym
->attr
.allocatable
4761 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4763 tree caf_decl
, caf_type
;
4766 caf_decl
= get_tree_for_caf_expr (e
);
4767 caf_type
= TREE_TYPE (caf_decl
);
4769 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4770 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4771 tmp
= gfc_conv_descriptor_token (caf_decl
);
4772 else if (DECL_LANG_SPECIFIC (caf_decl
)
4773 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4774 tmp
= GFC_DECL_TOKEN (caf_decl
);
4777 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4778 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4779 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4782 vec_safe_push (stringargs
, tmp
);
4784 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4785 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4786 offset
= build_int_cst (gfc_array_index_type
, 0);
4787 else if (DECL_LANG_SPECIFIC (caf_decl
)
4788 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4789 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4790 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4791 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4793 offset
= build_int_cst (gfc_array_index_type
, 0);
4795 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4796 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4799 gcc_assert (POINTER_TYPE_P (caf_type
));
4803 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4804 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4805 && !fsym
->attr
.allocatable
))
4807 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4808 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4809 (TREE_TYPE (parmse
.expr
))));
4810 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4811 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4813 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4814 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4817 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4821 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4822 gfc_array_index_type
,
4823 fold_convert (gfc_array_index_type
, tmp2
),
4824 fold_convert (gfc_array_index_type
, tmp
));
4825 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4826 gfc_array_index_type
, offset
, tmp
);
4828 vec_safe_push (stringargs
, offset
);
4831 vec_safe_push (arglist
, parmse
.expr
);
4833 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4840 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4841 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4842 else if (ts
.type
== BT_CHARACTER
)
4844 if (ts
.u
.cl
->length
== NULL
)
4846 /* Assumed character length results are not allowed by 5.1.1.5 of the
4847 standard and are trapped in resolve.c; except in the case of SPREAD
4848 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4849 we take the character length of the first argument for the result.
4850 For dummies, we have to look through the formal argument list for
4851 this function and use the character length found there.*/
4853 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4854 else if (!sym
->attr
.dummy
)
4855 cl
.backend_decl
= (*stringargs
)[0];
4858 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4859 for (; formal
; formal
= formal
->next
)
4860 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4861 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4863 len
= cl
.backend_decl
;
4869 /* Calculate the length of the returned string. */
4870 gfc_init_se (&parmse
, NULL
);
4871 if (need_interface_mapping
)
4872 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4874 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4875 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4876 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4878 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4879 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4880 gfc_charlen_type_node
, tmp
,
4881 build_int_cst (gfc_charlen_type_node
, 0));
4882 cl
.backend_decl
= tmp
;
4885 /* Set up a charlen structure for it. */
4890 len
= cl
.backend_decl
;
4893 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4894 || (!comp
&& gfc_return_by_reference (sym
));
4897 if (se
->direct_byref
)
4899 /* Sometimes, too much indirection can be applied; e.g. for
4900 function_result = array_valued_recursive_function. */
4901 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4902 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4903 && GFC_DESCRIPTOR_TYPE_P
4904 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4905 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4908 /* If the lhs of an assignment x = f(..) is allocatable and
4909 f2003 is allowed, we must do the automatic reallocation.
4910 TODO - deal with intrinsics, without using a temporary. */
4911 if (gfc_option
.flag_realloc_lhs
4912 && se
->ss
&& se
->ss
->loop_chain
4913 && se
->ss
->loop_chain
->is_alloc_lhs
4914 && !expr
->value
.function
.isym
4915 && sym
->result
->as
!= NULL
)
4917 /* Evaluate the bounds of the result, if known. */
4918 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4921 /* Perform the automatic reallocation. */
4922 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4924 gfc_add_expr_to_block (&se
->pre
, tmp
);
4926 /* Pass the temporary as the first argument. */
4927 result
= info
->descriptor
;
4930 result
= build_fold_indirect_ref_loc (input_location
,
4932 vec_safe_push (retargs
, se
->expr
);
4934 else if (comp
&& comp
->attr
.dimension
)
4936 gcc_assert (se
->loop
&& info
);
4938 /* Set the type of the array. */
4939 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4940 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4942 /* Evaluate the bounds of the result, if known. */
4943 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4945 /* If the lhs of an assignment x = f(..) is allocatable and
4946 f2003 is allowed, we must not generate the function call
4947 here but should just send back the results of the mapping.
4948 This is signalled by the function ss being flagged. */
4949 if (gfc_option
.flag_realloc_lhs
4950 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4952 gfc_free_interface_mapping (&mapping
);
4953 return has_alternate_specifier
;
4956 /* Create a temporary to store the result. In case the function
4957 returns a pointer, the temporary will be a shallow copy and
4958 mustn't be deallocated. */
4959 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4960 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4961 tmp
, NULL_TREE
, false,
4962 !comp
->attr
.pointer
, callee_alloc
,
4963 &se
->ss
->info
->expr
->where
);
4965 /* Pass the temporary as the first argument. */
4966 result
= info
->descriptor
;
4967 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4968 vec_safe_push (retargs
, tmp
);
4970 else if (!comp
&& sym
->result
->attr
.dimension
)
4972 gcc_assert (se
->loop
&& info
);
4974 /* Set the type of the array. */
4975 tmp
= gfc_typenode_for_spec (&ts
);
4976 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4978 /* Evaluate the bounds of the result, if known. */
4979 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
4981 /* If the lhs of an assignment x = f(..) is allocatable and
4982 f2003 is allowed, we must not generate the function call
4983 here but should just send back the results of the mapping.
4984 This is signalled by the function ss being flagged. */
4985 if (gfc_option
.flag_realloc_lhs
4986 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4988 gfc_free_interface_mapping (&mapping
);
4989 return has_alternate_specifier
;
4992 /* Create a temporary to store the result. In case the function
4993 returns a pointer, the temporary will be a shallow copy and
4994 mustn't be deallocated. */
4995 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
4996 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4997 tmp
, NULL_TREE
, false,
4998 !sym
->attr
.pointer
, callee_alloc
,
4999 &se
->ss
->info
->expr
->where
);
5001 /* Pass the temporary as the first argument. */
5002 result
= info
->descriptor
;
5003 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5004 vec_safe_push (retargs
, tmp
);
5006 else if (ts
.type
== BT_CHARACTER
)
5008 /* Pass the string length. */
5009 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5010 type
= build_pointer_type (type
);
5012 /* Return an address to a char[0:len-1]* temporary for
5013 character pointers. */
5014 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5015 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5017 var
= gfc_create_var (type
, "pstr");
5019 if ((!comp
&& sym
->attr
.allocatable
)
5020 || (comp
&& comp
->attr
.allocatable
))
5022 gfc_add_modify (&se
->pre
, var
,
5023 fold_convert (TREE_TYPE (var
),
5024 null_pointer_node
));
5025 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5026 gfc_add_expr_to_block (&se
->post
, tmp
);
5029 /* Provide an address expression for the function arguments. */
5030 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5033 var
= gfc_conv_string_tmp (se
, type
, len
);
5035 vec_safe_push (retargs
, var
);
5039 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5041 type
= gfc_get_complex_type (ts
.kind
);
5042 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5043 vec_safe_push (retargs
, var
);
5046 /* Add the string length to the argument list. */
5047 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5050 if (TREE_CODE (tmp
) != VAR_DECL
)
5051 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5052 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5053 vec_safe_push (retargs
, tmp
);
5055 else if (ts
.type
== BT_CHARACTER
)
5056 vec_safe_push (retargs
, len
);
5058 gfc_free_interface_mapping (&mapping
);
5060 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5061 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5062 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5063 vec_safe_reserve (retargs
, arglen
);
5065 /* Add the return arguments. */
5066 retargs
->splice (arglist
);
5068 /* Add the hidden present status for optional+value to the arguments. */
5069 retargs
->splice (optionalargs
);
5071 /* Add the hidden string length parameters to the arguments. */
5072 retargs
->splice (stringargs
);
5074 /* We may want to append extra arguments here. This is used e.g. for
5075 calls to libgfortran_matmul_??, which need extra information. */
5076 if (!vec_safe_is_empty (append_args
))
5077 retargs
->splice (append_args
);
5080 /* Generate the actual call. */
5081 if (base_object
== NULL_TREE
)
5082 conv_function_val (se
, sym
, expr
);
5084 conv_base_obj_fcn_val (se
, base_object
, expr
);
5086 /* If there are alternate return labels, function type should be
5087 integer. Can't modify the type in place though, since it can be shared
5088 with other functions. For dummy arguments, the typing is done to
5089 this result, even if it has to be repeated for each call. */
5090 if (has_alternate_specifier
5091 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5093 if (!sym
->attr
.dummy
)
5095 TREE_TYPE (sym
->backend_decl
)
5096 = build_function_type (integer_type_node
,
5097 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5098 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5101 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5104 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5105 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5107 /* If we have a pointer function, but we don't want a pointer, e.g.
5110 where f is pointer valued, we have to dereference the result. */
5111 if (!se
->want_pointer
&& !byref
5112 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5113 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5114 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5116 /* f2c calling conventions require a scalar default real function to
5117 return a double precision result. Convert this back to default
5118 real. We only care about the cases that can happen in Fortran 77.
5120 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5121 && sym
->ts
.kind
== gfc_default_real_kind
5122 && !sym
->attr
.always_explicit
)
5123 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5125 /* A pure function may still have side-effects - it may modify its
5127 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5129 if (!sym
->attr
.pure
)
5130 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5135 /* Add the function call to the pre chain. There is no expression. */
5136 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5137 se
->expr
= NULL_TREE
;
5139 if (!se
->direct_byref
)
5141 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5143 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5145 /* Check the data pointer hasn't been modified. This would
5146 happen in a function returning a pointer. */
5147 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5148 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5151 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5154 se
->expr
= info
->descriptor
;
5155 /* Bundle in the string length. */
5156 se
->string_length
= len
;
5158 else if (ts
.type
== BT_CHARACTER
)
5160 /* Dereference for character pointer results. */
5161 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5162 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5163 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5167 se
->string_length
= len
;
5171 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5172 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5177 /* Follow the function call with the argument post block. */
5180 gfc_add_block_to_block (&se
->pre
, &post
);
5182 /* Transformational functions of derived types with allocatable
5183 components must have the result allocatable components copied. */
5184 arg
= expr
->value
.function
.actual
;
5185 if (result
&& arg
&& expr
->rank
5186 && expr
->value
.function
.isym
5187 && expr
->value
.function
.isym
->transformational
5188 && arg
->expr
->ts
.type
== BT_DERIVED
5189 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5192 /* Copy the allocatable components. We have to use a
5193 temporary here to prevent source allocatable components
5194 from being corrupted. */
5195 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5196 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5197 result
, tmp2
, expr
->rank
);
5198 gfc_add_expr_to_block (&se
->pre
, tmp
);
5199 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5201 gfc_add_expr_to_block (&se
->pre
, tmp
);
5203 /* Finally free the temporary's data field. */
5204 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5205 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5206 NULL_TREE
, NULL_TREE
, true,
5208 gfc_add_expr_to_block (&se
->pre
, tmp
);
5212 gfc_add_block_to_block (&se
->post
, &post
);
5214 return has_alternate_specifier
;
5218 /* Fill a character string with spaces. */
5221 fill_with_spaces (tree start
, tree type
, tree size
)
5223 stmtblock_t block
, loop
;
5224 tree i
, el
, exit_label
, cond
, tmp
;
5226 /* For a simple char type, we can call memset(). */
5227 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5228 return build_call_expr_loc (input_location
,
5229 builtin_decl_explicit (BUILT_IN_MEMSET
),
5231 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5232 lang_hooks
.to_target_charset (' ')),
5235 /* Otherwise, we use a loop:
5236 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5240 /* Initialize variables. */
5241 gfc_init_block (&block
);
5242 i
= gfc_create_var (sizetype
, "i");
5243 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5244 el
= gfc_create_var (build_pointer_type (type
), "el");
5245 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5246 exit_label
= gfc_build_label_decl (NULL_TREE
);
5247 TREE_USED (exit_label
) = 1;
5251 gfc_init_block (&loop
);
5253 /* Exit condition. */
5254 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5255 build_zero_cst (sizetype
));
5256 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5257 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5258 build_empty_stmt (input_location
));
5259 gfc_add_expr_to_block (&loop
, tmp
);
5262 gfc_add_modify (&loop
,
5263 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5264 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5266 /* Increment loop variables. */
5267 gfc_add_modify (&loop
, i
,
5268 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5269 TYPE_SIZE_UNIT (type
)));
5270 gfc_add_modify (&loop
, el
,
5271 fold_build_pointer_plus_loc (input_location
,
5272 el
, TYPE_SIZE_UNIT (type
)));
5274 /* Making the loop... actually loop! */
5275 tmp
= gfc_finish_block (&loop
);
5276 tmp
= build1_v (LOOP_EXPR
, tmp
);
5277 gfc_add_expr_to_block (&block
, tmp
);
5279 /* The exit label. */
5280 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5281 gfc_add_expr_to_block (&block
, tmp
);
5284 return gfc_finish_block (&block
);
5288 /* Generate code to copy a string. */
5291 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5292 int dkind
, tree slength
, tree src
, int skind
)
5294 tree tmp
, dlen
, slen
;
5303 stmtblock_t tempblock
;
5305 gcc_assert (dkind
== skind
);
5307 if (slength
!= NULL_TREE
)
5309 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5310 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5314 slen
= build_int_cst (size_type_node
, 1);
5318 if (dlength
!= NULL_TREE
)
5320 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5321 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5325 dlen
= build_int_cst (size_type_node
, 1);
5329 /* Assign directly if the types are compatible. */
5330 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5331 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5333 gfc_add_modify (block
, dsc
, ssc
);
5337 /* Do nothing if the destination length is zero. */
5338 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5339 build_int_cst (size_type_node
, 0));
5341 /* The following code was previously in _gfortran_copy_string:
5343 // The two strings may overlap so we use memmove.
5345 copy_string (GFC_INTEGER_4 destlen, char * dest,
5346 GFC_INTEGER_4 srclen, const char * src)
5348 if (srclen >= destlen)
5350 // This will truncate if too long.
5351 memmove (dest, src, destlen);
5355 memmove (dest, src, srclen);
5357 memset (&dest[srclen], ' ', destlen - srclen);
5361 We're now doing it here for better optimization, but the logic
5364 /* For non-default character kinds, we have to multiply the string
5365 length by the base type size. */
5366 chartype
= gfc_get_char_type (dkind
);
5367 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5368 fold_convert (size_type_node
, slen
),
5369 fold_convert (size_type_node
,
5370 TYPE_SIZE_UNIT (chartype
)));
5371 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5372 fold_convert (size_type_node
, dlen
),
5373 fold_convert (size_type_node
,
5374 TYPE_SIZE_UNIT (chartype
)));
5376 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5377 dest
= fold_convert (pvoid_type_node
, dest
);
5379 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5381 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5382 src
= fold_convert (pvoid_type_node
, src
);
5384 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5386 /* Truncate string if source is too long. */
5387 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5389 tmp2
= build_call_expr_loc (input_location
,
5390 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5391 3, dest
, src
, dlen
);
5393 /* Else copy and pad with spaces. */
5394 tmp3
= build_call_expr_loc (input_location
,
5395 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5396 3, dest
, src
, slen
);
5398 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5399 tmp4
= fill_with_spaces (tmp4
, chartype
,
5400 fold_build2_loc (input_location
, MINUS_EXPR
,
5401 TREE_TYPE(dlen
), dlen
, slen
));
5403 gfc_init_block (&tempblock
);
5404 gfc_add_expr_to_block (&tempblock
, tmp3
);
5405 gfc_add_expr_to_block (&tempblock
, tmp4
);
5406 tmp3
= gfc_finish_block (&tempblock
);
5408 /* The whole copy_string function is there. */
5409 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5411 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5412 build_empty_stmt (input_location
));
5413 gfc_add_expr_to_block (block
, tmp
);
5417 /* Translate a statement function.
5418 The value of a statement function reference is obtained by evaluating the
5419 expression using the values of the actual arguments for the values of the
5420 corresponding dummy arguments. */
5423 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5427 gfc_formal_arglist
*fargs
;
5428 gfc_actual_arglist
*args
;
5431 gfc_saved_var
*saved_vars
;
5437 sym
= expr
->symtree
->n
.sym
;
5438 args
= expr
->value
.function
.actual
;
5439 gfc_init_se (&lse
, NULL
);
5440 gfc_init_se (&rse
, NULL
);
5443 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5445 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5446 temp_vars
= XCNEWVEC (tree
, n
);
5448 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5449 fargs
= fargs
->next
, n
++)
5451 /* Each dummy shall be specified, explicitly or implicitly, to be
5453 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5456 if (fsym
->ts
.type
== BT_CHARACTER
)
5458 /* Copy string arguments. */
5461 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5462 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5464 /* Create a temporary to hold the value. */
5465 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5466 fsym
->ts
.u
.cl
->backend_decl
5467 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5469 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5470 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5472 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5474 gfc_conv_expr (&rse
, args
->expr
);
5475 gfc_conv_string_parameter (&rse
);
5476 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5477 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5479 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5480 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5481 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5482 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5486 /* For everything else, just evaluate the expression. */
5488 /* Create a temporary to hold the value. */
5489 type
= gfc_typenode_for_spec (&fsym
->ts
);
5490 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5492 gfc_conv_expr (&lse
, args
->expr
);
5494 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5495 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5496 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5502 /* Use the temporary variables in place of the real ones. */
5503 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5504 fargs
= fargs
->next
, n
++)
5505 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5507 gfc_conv_expr (se
, sym
->value
);
5509 if (sym
->ts
.type
== BT_CHARACTER
)
5511 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5513 /* Force the expression to the correct length. */
5514 if (!INTEGER_CST_P (se
->string_length
)
5515 || tree_int_cst_lt (se
->string_length
,
5516 sym
->ts
.u
.cl
->backend_decl
))
5518 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5519 tmp
= gfc_create_var (type
, sym
->name
);
5520 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5521 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5522 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5526 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5529 /* Restore the original variables. */
5530 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5531 fargs
= fargs
->next
, n
++)
5532 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5538 /* Translate a function expression. */
5541 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5545 if (expr
->value
.function
.isym
)
5547 gfc_conv_intrinsic_function (se
, expr
);
5551 /* expr.value.function.esym is the resolved (specific) function symbol for
5552 most functions. However this isn't set for dummy procedures. */
5553 sym
= expr
->value
.function
.esym
;
5555 sym
= expr
->symtree
->n
.sym
;
5557 /* We distinguish statement functions from general functions to improve
5558 runtime performance. */
5559 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5561 gfc_conv_statement_function (se
, expr
);
5565 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5570 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5573 is_zero_initializer_p (gfc_expr
* expr
)
5575 if (expr
->expr_type
!= EXPR_CONSTANT
)
5578 /* We ignore constants with prescribed memory representations for now. */
5579 if (expr
->representation
.string
)
5582 switch (expr
->ts
.type
)
5585 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5588 return mpfr_zero_p (expr
->value
.real
)
5589 && MPFR_SIGN (expr
->value
.real
) >= 0;
5592 return expr
->value
.logical
== 0;
5595 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5596 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5597 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5598 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5608 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5613 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5614 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5616 gfc_conv_tmp_array_ref (se
);
5620 /* Build a static initializer. EXPR is the expression for the initial value.
5621 The other parameters describe the variable of the component being
5622 initialized. EXPR may be null. */
5625 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5626 bool array
, bool pointer
, bool procptr
)
5630 if (!(expr
|| pointer
|| procptr
))
5633 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5634 (these are the only two iso_c_binding derived types that can be
5635 used as initialization expressions). If so, we need to modify
5636 the 'expr' to be that for a (void *). */
5637 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5638 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5640 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5642 /* The derived symbol has already been converted to a (void *). Use
5644 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5645 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5647 gfc_init_se (&se
, NULL
);
5648 gfc_conv_constant (&se
, expr
);
5649 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5653 if (array
&& !procptr
)
5656 /* Arrays need special handling. */
5658 ctor
= gfc_build_null_descriptor (type
);
5659 /* Special case assigning an array to zero. */
5660 else if (is_zero_initializer_p (expr
))
5661 ctor
= build_constructor (type
, NULL
);
5663 ctor
= gfc_conv_array_initializer (type
, expr
);
5664 TREE_STATIC (ctor
) = 1;
5667 else if (pointer
|| procptr
)
5669 if (ts
->type
== BT_CLASS
&& !procptr
)
5671 gfc_init_se (&se
, NULL
);
5672 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5673 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5674 TREE_STATIC (se
.expr
) = 1;
5677 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5678 return fold_convert (type
, null_pointer_node
);
5681 gfc_init_se (&se
, NULL
);
5682 se
.want_pointer
= 1;
5683 gfc_conv_expr (&se
, expr
);
5684 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5694 gfc_init_se (&se
, NULL
);
5695 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5696 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5698 gfc_conv_structure (&se
, expr
, 1);
5699 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5700 TREE_STATIC (se
.expr
) = 1;
5705 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5706 TREE_STATIC (ctor
) = 1;
5711 gfc_init_se (&se
, NULL
);
5712 gfc_conv_constant (&se
, expr
);
5713 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5720 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5726 gfc_array_info
*lss_array
;
5733 gfc_start_block (&block
);
5735 /* Initialize the scalarizer. */
5736 gfc_init_loopinfo (&loop
);
5738 gfc_init_se (&lse
, NULL
);
5739 gfc_init_se (&rse
, NULL
);
5742 rss
= gfc_walk_expr (expr
);
5743 if (rss
== gfc_ss_terminator
)
5744 /* The rhs is scalar. Add a ss for the expression. */
5745 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5747 /* Create a SS for the destination. */
5748 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5750 lss_array
= &lss
->info
->data
.array
;
5751 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5752 lss_array
->descriptor
= dest
;
5753 lss_array
->data
= gfc_conv_array_data (dest
);
5754 lss_array
->offset
= gfc_conv_array_offset (dest
);
5755 for (n
= 0; n
< cm
->as
->rank
; n
++)
5757 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5758 lss_array
->stride
[n
] = gfc_index_one_node
;
5760 mpz_init (lss_array
->shape
[n
]);
5761 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5762 cm
->as
->lower
[n
]->value
.integer
);
5763 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5766 /* Associate the SS with the loop. */
5767 gfc_add_ss_to_loop (&loop
, lss
);
5768 gfc_add_ss_to_loop (&loop
, rss
);
5770 /* Calculate the bounds of the scalarization. */
5771 gfc_conv_ss_startstride (&loop
);
5773 /* Setup the scalarizing loops. */
5774 gfc_conv_loop_setup (&loop
, &expr
->where
);
5776 /* Setup the gfc_se structures. */
5777 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5778 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5781 gfc_mark_ss_chain_used (rss
, 1);
5783 gfc_mark_ss_chain_used (lss
, 1);
5785 /* Start the scalarized loop body. */
5786 gfc_start_scalarized_body (&loop
, &body
);
5788 gfc_conv_tmp_array_ref (&lse
);
5789 if (cm
->ts
.type
== BT_CHARACTER
)
5790 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5792 gfc_conv_expr (&rse
, expr
);
5794 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5795 gfc_add_expr_to_block (&body
, tmp
);
5797 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5799 /* Generate the copying loops. */
5800 gfc_trans_scalarizing_loops (&loop
, &body
);
5802 /* Wrap the whole thing up. */
5803 gfc_add_block_to_block (&block
, &loop
.pre
);
5804 gfc_add_block_to_block (&block
, &loop
.post
);
5806 gcc_assert (lss_array
->shape
!= NULL
);
5807 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5808 gfc_cleanup_loop (&loop
);
5810 return gfc_finish_block (&block
);
5815 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5825 gfc_expr
*arg
= NULL
;
5827 gfc_start_block (&block
);
5828 gfc_init_se (&se
, NULL
);
5830 /* Get the descriptor for the expressions. */
5831 se
.want_pointer
= 0;
5832 gfc_conv_expr_descriptor (&se
, expr
);
5833 gfc_add_block_to_block (&block
, &se
.pre
);
5834 gfc_add_modify (&block
, dest
, se
.expr
);
5836 /* Deal with arrays of derived types with allocatable components. */
5837 if (cm
->ts
.type
== BT_DERIVED
5838 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5839 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5843 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5844 TREE_TYPE(cm
->backend_decl
),
5847 gfc_add_expr_to_block (&block
, tmp
);
5848 gfc_add_block_to_block (&block
, &se
.post
);
5850 if (expr
->expr_type
!= EXPR_VARIABLE
)
5851 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5854 /* We need to know if the argument of a conversion function is a
5855 variable, so that the correct lower bound can be used. */
5856 if (expr
->expr_type
== EXPR_FUNCTION
5857 && expr
->value
.function
.isym
5858 && expr
->value
.function
.isym
->conversion
5859 && expr
->value
.function
.actual
->expr
5860 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5861 arg
= expr
->value
.function
.actual
->expr
;
5863 /* Obtain the array spec of full array references. */
5865 as
= gfc_get_full_arrayspec_from_expr (arg
);
5867 as
= gfc_get_full_arrayspec_from_expr (expr
);
5869 /* Shift the lbound and ubound of temporaries to being unity,
5870 rather than zero, based. Always calculate the offset. */
5871 offset
= gfc_conv_descriptor_offset_get (dest
);
5872 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5873 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5875 for (n
= 0; n
< expr
->rank
; n
++)
5880 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5881 TODO It looks as if gfc_conv_expr_descriptor should return
5882 the correct bounds and that the following should not be
5883 necessary. This would simplify gfc_conv_intrinsic_bound
5885 if (as
&& as
->lower
[n
])
5888 gfc_init_se (&lbse
, NULL
);
5889 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5890 gfc_add_block_to_block (&block
, &lbse
.pre
);
5891 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5895 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5896 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5900 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5903 lbound
= gfc_index_one_node
;
5905 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5907 /* Shift the bounds and set the offset accordingly. */
5908 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5909 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5910 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5911 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5913 gfc_conv_descriptor_ubound_set (&block
, dest
,
5914 gfc_rank_cst
[n
], tmp
);
5915 gfc_conv_descriptor_lbound_set (&block
, dest
,
5916 gfc_rank_cst
[n
], lbound
);
5918 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5919 gfc_conv_descriptor_lbound_get (dest
,
5921 gfc_conv_descriptor_stride_get (dest
,
5923 gfc_add_modify (&block
, tmp2
, tmp
);
5924 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5926 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5931 /* If a conversion expression has a null data pointer
5932 argument, nullify the allocatable component. */
5936 if (arg
->symtree
->n
.sym
->attr
.allocatable
5937 || arg
->symtree
->n
.sym
->attr
.pointer
)
5939 non_null_expr
= gfc_finish_block (&block
);
5940 gfc_start_block (&block
);
5941 gfc_conv_descriptor_data_set (&block
, dest
,
5943 null_expr
= gfc_finish_block (&block
);
5944 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5945 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5946 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5947 return build3_v (COND_EXPR
, tmp
,
5948 null_expr
, non_null_expr
);
5952 return gfc_finish_block (&block
);
5956 /* Assign a single component of a derived type constructor. */
5959 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5966 gfc_start_block (&block
);
5968 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5970 gfc_init_se (&se
, NULL
);
5971 /* Pointer component. */
5972 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5974 /* Array pointer. */
5975 if (expr
->expr_type
== EXPR_NULL
)
5976 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5979 se
.direct_byref
= 1;
5981 gfc_conv_expr_descriptor (&se
, expr
);
5982 gfc_add_block_to_block (&block
, &se
.pre
);
5983 gfc_add_block_to_block (&block
, &se
.post
);
5988 /* Scalar pointers. */
5989 se
.want_pointer
= 1;
5990 gfc_conv_expr (&se
, expr
);
5991 gfc_add_block_to_block (&block
, &se
.pre
);
5993 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
5994 && expr
->symtree
->n
.sym
->attr
.dummy
)
5995 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5997 gfc_add_modify (&block
, dest
,
5998 fold_convert (TREE_TYPE (dest
), se
.expr
));
5999 gfc_add_block_to_block (&block
, &se
.post
);
6002 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6004 /* NULL initialization for CLASS components. */
6005 tmp
= gfc_trans_structure_assign (dest
,
6006 gfc_class_initializer (&cm
->ts
, expr
));
6007 gfc_add_expr_to_block (&block
, tmp
);
6009 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
6011 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6012 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6013 else if (cm
->attr
.allocatable
)
6015 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6016 gfc_add_expr_to_block (&block
, tmp
);
6020 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6021 gfc_add_expr_to_block (&block
, tmp
);
6024 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6026 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6028 gfc_init_se (&se
, NULL
);
6029 gfc_conv_expr (&se
, expr
);
6030 gfc_add_block_to_block (&block
, &se
.pre
);
6031 gfc_add_modify (&block
, dest
,
6032 fold_convert (TREE_TYPE (dest
), se
.expr
));
6033 gfc_add_block_to_block (&block
, &se
.post
);
6037 /* Nested constructors. */
6038 tmp
= gfc_trans_structure_assign (dest
, expr
);
6039 gfc_add_expr_to_block (&block
, tmp
);
6044 /* Scalar component. */
6045 gfc_init_se (&se
, NULL
);
6046 gfc_init_se (&lse
, NULL
);
6048 gfc_conv_expr (&se
, expr
);
6049 if (cm
->ts
.type
== BT_CHARACTER
)
6050 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6052 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6053 gfc_add_expr_to_block (&block
, tmp
);
6055 return gfc_finish_block (&block
);
6058 /* Assign a derived type constructor to a variable. */
6061 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6069 gfc_start_block (&block
);
6070 cm
= expr
->ts
.u
.derived
->components
;
6072 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6073 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6074 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6078 gcc_assert (cm
->backend_decl
== NULL
);
6079 gfc_init_se (&se
, NULL
);
6080 gfc_init_se (&lse
, NULL
);
6081 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6083 gfc_add_modify (&block
, lse
.expr
,
6084 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6086 return gfc_finish_block (&block
);
6089 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6090 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6092 /* Skip absent members in default initializers. */
6096 field
= cm
->backend_decl
;
6097 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6098 dest
, field
, NULL_TREE
);
6099 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6100 gfc_add_expr_to_block (&block
, tmp
);
6102 return gfc_finish_block (&block
);
6105 /* Build an expression for a constructor. If init is nonzero then
6106 this is part of a static variable initializer. */
6109 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6116 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6118 gcc_assert (se
->ss
== NULL
);
6119 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6120 type
= gfc_typenode_for_spec (&expr
->ts
);
6124 /* Create a temporary variable and fill it in. */
6125 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6126 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6127 gfc_add_expr_to_block (&se
->pre
, tmp
);
6131 cm
= expr
->ts
.u
.derived
->components
;
6133 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6134 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6136 /* Skip absent members in default initializers and allocatable
6137 components. Although the latter have a default initializer
6138 of EXPR_NULL,... by default, the static nullify is not needed
6139 since this is done every time we come into scope. */
6140 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6143 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6144 && strcmp (cm
->name
, "_extends") == 0
6145 && cm
->initializer
->symtree
)
6149 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6150 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6151 vtab
= unshare_expr_without_location (vtab
);
6152 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6154 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6156 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6157 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6161 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6162 TREE_TYPE (cm
->backend_decl
),
6163 cm
->attr
.dimension
, cm
->attr
.pointer
,
6164 cm
->attr
.proc_pointer
);
6165 val
= unshare_expr_without_location (val
);
6167 /* Append it to the constructor list. */
6168 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6171 se
->expr
= build_constructor (type
, v
);
6173 TREE_CONSTANT (se
->expr
) = 1;
6177 /* Translate a substring expression. */
6180 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6186 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6188 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6189 expr
->value
.character
.length
,
6190 expr
->value
.character
.string
);
6192 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6193 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6196 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6200 /* Entry point for expression translation. Evaluates a scalar quantity.
6201 EXPR is the expression to be translated, and SE is the state structure if
6202 called from within the scalarized. */
6205 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6210 if (ss
&& ss
->info
->expr
== expr
6211 && (ss
->info
->type
== GFC_SS_SCALAR
6212 || ss
->info
->type
== GFC_SS_REFERENCE
))
6214 gfc_ss_info
*ss_info
;
6217 /* Substitute a scalar expression evaluated outside the scalarization
6219 se
->expr
= ss_info
->data
.scalar
.value
;
6220 /* If the reference can be NULL, the value field contains the reference,
6221 not the value the reference points to (see gfc_add_loop_ss_code). */
6222 if (ss_info
->can_be_null_ref
)
6223 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6225 se
->string_length
= ss_info
->string_length
;
6226 gfc_advance_se_ss_chain (se
);
6230 /* We need to convert the expressions for the iso_c_binding derived types.
6231 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6232 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6233 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6234 updated to be an integer with a kind equal to the size of a (void *). */
6235 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6237 if (expr
->expr_type
== EXPR_VARIABLE
6238 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6239 || expr
->symtree
->n
.sym
->intmod_sym_id
6240 == ISOCBINDING_NULL_FUNPTR
))
6242 /* Set expr_type to EXPR_NULL, which will result in
6243 null_pointer_node being used below. */
6244 expr
->expr_type
= EXPR_NULL
;
6248 /* Update the type/kind of the expression to be what the new
6249 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6250 expr
->ts
.type
= BT_INTEGER
;
6251 expr
->ts
.f90_type
= BT_VOID
;
6252 expr
->ts
.kind
= gfc_index_integer_kind
;
6256 gfc_fix_class_refs (expr
);
6258 switch (expr
->expr_type
)
6261 gfc_conv_expr_op (se
, expr
);
6265 gfc_conv_function_expr (se
, expr
);
6269 gfc_conv_constant (se
, expr
);
6273 gfc_conv_variable (se
, expr
);
6277 se
->expr
= null_pointer_node
;
6280 case EXPR_SUBSTRING
:
6281 gfc_conv_substring_expr (se
, expr
);
6284 case EXPR_STRUCTURE
:
6285 gfc_conv_structure (se
, expr
, 0);
6289 gfc_conv_array_constructor_expr (se
, expr
);
6298 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6299 of an assignment. */
6301 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6303 gfc_conv_expr (se
, expr
);
6304 /* All numeric lvalues should have empty post chains. If not we need to
6305 figure out a way of rewriting an lvalue so that it has no post chain. */
6306 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6309 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6310 numeric expressions. Used for scalar values where inserting cleanup code
6313 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6317 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6318 gfc_conv_expr (se
, expr
);
6321 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6322 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6324 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6328 /* Helper to translate an expression and convert it to a particular type. */
6330 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6332 gfc_conv_expr_val (se
, expr
);
6333 se
->expr
= convert (type
, se
->expr
);
6337 /* Converts an expression so that it can be passed by reference. Scalar
6341 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6347 if (ss
&& ss
->info
->expr
== expr
6348 && ss
->info
->type
== GFC_SS_REFERENCE
)
6350 /* Returns a reference to the scalar evaluated outside the loop
6352 gfc_conv_expr (se
, expr
);
6353 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6357 if (expr
->ts
.type
== BT_CHARACTER
)
6359 gfc_conv_expr (se
, expr
);
6360 gfc_conv_string_parameter (se
);
6364 if (expr
->expr_type
== EXPR_VARIABLE
)
6366 se
->want_pointer
= 1;
6367 gfc_conv_expr (se
, expr
);
6370 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6371 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6372 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6378 if (expr
->expr_type
== EXPR_FUNCTION
6379 && ((expr
->value
.function
.esym
6380 && expr
->value
.function
.esym
->result
->attr
.pointer
6381 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6382 || (!expr
->value
.function
.esym
&& !expr
->ref
6383 && expr
->symtree
->n
.sym
->attr
.pointer
6384 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6386 se
->want_pointer
= 1;
6387 gfc_conv_expr (se
, expr
);
6388 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6389 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6394 gfc_conv_expr (se
, expr
);
6396 /* Create a temporary var to hold the value. */
6397 if (TREE_CONSTANT (se
->expr
))
6399 tree tmp
= se
->expr
;
6400 STRIP_TYPE_NOPS (tmp
);
6401 var
= build_decl (input_location
,
6402 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6403 DECL_INITIAL (var
) = tmp
;
6404 TREE_STATIC (var
) = 1;
6409 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6410 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6412 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6414 /* Take the address of that value. */
6415 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6420 gfc_trans_pointer_assign (gfc_code
* code
)
6422 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6426 /* Generate code for a pointer assignment. */
6429 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6431 gfc_expr
*expr1_vptr
= NULL
;
6441 gfc_start_block (&block
);
6443 gfc_init_se (&lse
, NULL
);
6445 /* Check whether the expression is a scalar or not; we cannot use
6446 expr1->rank as it can be nonzero for proc pointers. */
6447 ss
= gfc_walk_expr (expr1
);
6448 scalar
= ss
== gfc_ss_terminator
;
6450 gfc_free_ss_chain (ss
);
6452 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6453 && expr2
->expr_type
!= EXPR_FUNCTION
)
6455 gfc_add_data_component (expr2
);
6456 /* The following is required as gfc_add_data_component doesn't
6457 update ts.type if there is a tailing REF_ARRAY. */
6458 expr2
->ts
.type
= BT_DERIVED
;
6463 /* Scalar pointers. */
6464 lse
.want_pointer
= 1;
6465 gfc_conv_expr (&lse
, expr1
);
6466 gfc_init_se (&rse
, NULL
);
6467 rse
.want_pointer
= 1;
6468 gfc_conv_expr (&rse
, expr2
);
6470 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6471 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6472 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6475 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6476 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6477 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6480 gfc_add_block_to_block (&block
, &lse
.pre
);
6481 gfc_add_block_to_block (&block
, &rse
.pre
);
6483 /* Check character lengths if character expression. The test is only
6484 really added if -fbounds-check is enabled. Exclude deferred
6485 character length lefthand sides. */
6486 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6487 && !expr1
->ts
.deferred
6488 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6489 && !gfc_is_proc_ptr_comp (expr1
))
6491 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6492 gcc_assert (lse
.string_length
&& rse
.string_length
);
6493 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6494 lse
.string_length
, rse
.string_length
,
6498 /* The assignment to an deferred character length sets the string
6499 length to that of the rhs. */
6500 if (expr1
->ts
.deferred
)
6502 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6503 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6504 else if (lse
.string_length
!= NULL
)
6505 gfc_add_modify (&block
, lse
.string_length
,
6506 build_int_cst (gfc_charlen_type_node
, 0));
6509 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6510 rse
.expr
= gfc_class_data_get (rse
.expr
);
6512 gfc_add_modify (&block
, lse
.expr
,
6513 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6515 gfc_add_block_to_block (&block
, &rse
.post
);
6516 gfc_add_block_to_block (&block
, &lse
.post
);
6523 tree strlen_rhs
= NULL_TREE
;
6525 /* Array pointer. Find the last reference on the LHS and if it is an
6526 array section ref, we're dealing with bounds remapping. In this case,
6527 set it to AR_FULL so that gfc_conv_expr_descriptor does
6528 not see it and process the bounds remapping afterwards explicitly. */
6529 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6530 if (!remap
->next
&& remap
->type
== REF_ARRAY
6531 && remap
->u
.ar
.type
== AR_SECTION
)
6533 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6535 gfc_init_se (&lse
, NULL
);
6537 lse
.descriptor_only
= 1;
6538 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6539 && expr1
->ts
.type
== BT_CLASS
)
6540 expr1_vptr
= gfc_copy_expr (expr1
);
6541 gfc_conv_expr_descriptor (&lse
, expr1
);
6542 strlen_lhs
= lse
.string_length
;
6545 if (expr2
->expr_type
== EXPR_NULL
)
6547 /* Just set the data pointer to null. */
6548 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6550 else if (rank_remap
)
6552 /* If we are rank-remapping, just get the RHS's descriptor and
6553 process this later on. */
6554 gfc_init_se (&rse
, NULL
);
6555 rse
.direct_byref
= 1;
6556 rse
.byref_noassign
= 1;
6558 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6560 gfc_conv_function_expr (&rse
, expr2
);
6562 if (expr1
->ts
.type
!= BT_CLASS
)
6563 rse
.expr
= gfc_class_data_get (rse
.expr
);
6566 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6567 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6569 gfc_add_vptr_component (expr1_vptr
);
6570 gfc_init_se (&rse
, NULL
);
6571 rse
.want_pointer
= 1;
6572 gfc_conv_expr (&rse
, expr1_vptr
);
6573 gfc_add_modify (&lse
.pre
, rse
.expr
,
6574 fold_convert (TREE_TYPE (rse
.expr
),
6575 gfc_class_vptr_get (tmp
)));
6576 rse
.expr
= gfc_class_data_get (tmp
);
6579 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6581 tree bound
[GFC_MAX_DIMENSIONS
];
6584 for (i
= 0; i
< expr2
->rank
; i
++)
6585 bound
[i
] = NULL_TREE
;
6586 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6587 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6589 GFC_ARRAY_POINTER_CONT
, false);
6590 tmp
= gfc_create_var (tmp
, "ptrtemp");
6592 lse
.direct_byref
= 1;
6593 gfc_conv_expr_descriptor (&lse
, expr2
);
6594 strlen_rhs
= lse
.string_length
;
6599 gfc_conv_expr_descriptor (&rse
, expr2
);
6600 strlen_rhs
= rse
.string_length
;
6603 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6605 /* Assign directly to the LHS's descriptor. */
6606 lse
.direct_byref
= 1;
6607 gfc_conv_expr_descriptor (&lse
, expr2
);
6608 strlen_rhs
= lse
.string_length
;
6610 /* If this is a subreference array pointer assignment, use the rhs
6611 descriptor element size for the lhs span. */
6612 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6614 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6615 gfc_init_se (&rse
, NULL
);
6616 rse
.descriptor_only
= 1;
6617 gfc_conv_expr (&rse
, expr2
);
6618 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6619 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6620 if (!INTEGER_CST_P (tmp
))
6621 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6622 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6625 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6627 gfc_init_se (&rse
, NULL
);
6628 rse
.want_pointer
= 1;
6629 gfc_conv_function_expr (&rse
, expr2
);
6630 if (expr1
->ts
.type
!= BT_CLASS
)
6632 rse
.expr
= gfc_class_data_get (rse
.expr
);
6633 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6637 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6638 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6640 gfc_add_vptr_component (expr1_vptr
);
6641 gfc_init_se (&rse
, NULL
);
6642 rse
.want_pointer
= 1;
6643 gfc_conv_expr (&rse
, expr1_vptr
);
6644 gfc_add_modify (&lse
.pre
, rse
.expr
,
6645 fold_convert (TREE_TYPE (rse
.expr
),
6646 gfc_class_vptr_get (tmp
)));
6647 rse
.expr
= gfc_class_data_get (tmp
);
6648 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6653 /* Assign to a temporary descriptor and then copy that
6654 temporary to the pointer. */
6655 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6657 lse
.direct_byref
= 1;
6658 gfc_conv_expr_descriptor (&lse
, expr2
);
6659 strlen_rhs
= lse
.string_length
;
6660 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6664 gfc_free_expr (expr1_vptr
);
6666 gfc_add_block_to_block (&block
, &lse
.pre
);
6668 gfc_add_block_to_block (&block
, &rse
.pre
);
6670 /* If we do bounds remapping, update LHS descriptor accordingly. */
6674 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6678 /* Do rank remapping. We already have the RHS's descriptor
6679 converted in rse and now have to build the correct LHS
6680 descriptor for it. */
6684 tree lbound
, ubound
;
6687 dtype
= gfc_conv_descriptor_dtype (desc
);
6688 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6689 gfc_add_modify (&block
, dtype
, tmp
);
6691 /* Copy data pointer. */
6692 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6693 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6695 /* Copy offset but adjust it such that it would correspond
6696 to a lbound of zero. */
6697 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6698 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6700 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6702 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6704 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6705 gfc_array_index_type
, stride
, lbound
);
6706 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6707 gfc_array_index_type
, offs
, tmp
);
6709 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6711 /* Set the bounds as declared for the LHS and calculate strides as
6712 well as another offset update accordingly. */
6713 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6715 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6720 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6722 /* Convert declared bounds. */
6723 gfc_init_se (&lower_se
, NULL
);
6724 gfc_init_se (&upper_se
, NULL
);
6725 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6726 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6728 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6729 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6731 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6732 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6734 lbound
= gfc_evaluate_now (lbound
, &block
);
6735 ubound
= gfc_evaluate_now (ubound
, &block
);
6737 gfc_add_block_to_block (&block
, &lower_se
.post
);
6738 gfc_add_block_to_block (&block
, &upper_se
.post
);
6740 /* Set bounds in descriptor. */
6741 gfc_conv_descriptor_lbound_set (&block
, desc
,
6742 gfc_rank_cst
[dim
], lbound
);
6743 gfc_conv_descriptor_ubound_set (&block
, desc
,
6744 gfc_rank_cst
[dim
], ubound
);
6747 stride
= gfc_evaluate_now (stride
, &block
);
6748 gfc_conv_descriptor_stride_set (&block
, desc
,
6749 gfc_rank_cst
[dim
], stride
);
6751 /* Update offset. */
6752 offs
= gfc_conv_descriptor_offset_get (desc
);
6753 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6754 gfc_array_index_type
, lbound
, stride
);
6755 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6756 gfc_array_index_type
, offs
, tmp
);
6757 offs
= gfc_evaluate_now (offs
, &block
);
6758 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6760 /* Update stride. */
6761 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6762 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6763 gfc_array_index_type
, stride
, tmp
);
6768 /* Bounds remapping. Just shift the lower bounds. */
6770 gcc_assert (expr1
->rank
== expr2
->rank
);
6772 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6776 gcc_assert (remap
->u
.ar
.start
[dim
]);
6777 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6778 gfc_init_se (&lbound_se
, NULL
);
6779 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6781 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6782 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6783 dim
, lbound_se
.expr
);
6784 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6789 /* Check string lengths if applicable. The check is only really added
6790 to the output code if -fbounds-check is enabled. */
6791 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6793 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6794 gcc_assert (strlen_lhs
&& strlen_rhs
);
6795 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6796 strlen_lhs
, strlen_rhs
, &block
);
6799 /* If rank remapping was done, check with -fcheck=bounds that
6800 the target is at least as large as the pointer. */
6801 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6807 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6808 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6810 lsize
= gfc_evaluate_now (lsize
, &block
);
6811 rsize
= gfc_evaluate_now (rsize
, &block
);
6812 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6815 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6816 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6820 gfc_add_block_to_block (&block
, &lse
.post
);
6822 gfc_add_block_to_block (&block
, &rse
.post
);
6825 return gfc_finish_block (&block
);
6829 /* Makes sure se is suitable for passing as a function string parameter. */
6830 /* TODO: Need to check all callers of this function. It may be abused. */
6833 gfc_conv_string_parameter (gfc_se
* se
)
6837 if (TREE_CODE (se
->expr
) == STRING_CST
)
6839 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6840 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6844 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6846 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6848 type
= TREE_TYPE (se
->expr
);
6849 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6853 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6855 type
= build_pointer_type (type
);
6856 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6860 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6864 /* Generate code for assignment of scalar variables. Includes character
6865 strings and derived types with allocatable components.
6866 If you know that the LHS has no allocations, set dealloc to false.
6868 DEEP_COPY has no effect if the typespec TS is not a derived type with
6869 allocatable components. Otherwise, if it is set, an explicit copy of each
6870 allocatable component is made. This is necessary as a simple copy of the
6871 whole object would copy array descriptors as is, so that the lhs's
6872 allocatable components would point to the rhs's after the assignment.
6873 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6874 necessary if the rhs is a non-pointer function, as the allocatable components
6875 are not accessible by other means than the function's result after the
6876 function has returned. It is even more subtle when temporaries are involved,
6877 as the two following examples show:
6878 1. When we evaluate an array constructor, a temporary is created. Thus
6879 there is theoretically no alias possible. However, no deep copy is
6880 made for this temporary, so that if the constructor is made of one or
6881 more variable with allocatable components, those components still point
6882 to the variable's: DEEP_COPY should be set for the assignment from the
6883 temporary to the lhs in that case.
6884 2. When assigning a scalar to an array, we evaluate the scalar value out
6885 of the loop, store it into a temporary variable, and assign from that.
6886 In that case, deep copying when assigning to the temporary would be a
6887 waste of resources; however deep copies should happen when assigning from
6888 the temporary to each array element: again DEEP_COPY should be set for
6889 the assignment from the temporary to the lhs. */
6892 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6893 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6899 gfc_init_block (&block
);
6901 if (ts
.type
== BT_CHARACTER
)
6906 if (lse
->string_length
!= NULL_TREE
)
6908 gfc_conv_string_parameter (lse
);
6909 gfc_add_block_to_block (&block
, &lse
->pre
);
6910 llen
= lse
->string_length
;
6913 if (rse
->string_length
!= NULL_TREE
)
6915 gcc_assert (rse
->string_length
!= NULL_TREE
);
6916 gfc_conv_string_parameter (rse
);
6917 gfc_add_block_to_block (&block
, &rse
->pre
);
6918 rlen
= rse
->string_length
;
6921 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6922 rse
->expr
, ts
.kind
);
6924 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6926 tree tmp_var
= NULL_TREE
;
6929 /* Are the rhs and the lhs the same? */
6932 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6933 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6934 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6935 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6938 /* Deallocate the lhs allocated components as long as it is not
6939 the same as the rhs. This must be done following the assignment
6940 to prevent deallocating data that could be used in the rhs
6942 if (!l_is_temp
&& dealloc
)
6944 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
6945 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
6947 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6949 gfc_add_expr_to_block (&lse
->post
, tmp
);
6952 gfc_add_block_to_block (&block
, &rse
->pre
);
6953 gfc_add_block_to_block (&block
, &lse
->pre
);
6955 gfc_add_modify (&block
, lse
->expr
,
6956 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6958 /* Restore pointer address of coarray components. */
6959 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
6961 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
6962 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6964 gfc_add_expr_to_block (&block
, tmp
);
6967 /* Do a deep copy if the rhs is a variable, if it is not the
6971 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
6972 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6974 gfc_add_expr_to_block (&block
, tmp
);
6977 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
6979 gfc_add_block_to_block (&block
, &lse
->pre
);
6980 gfc_add_block_to_block (&block
, &rse
->pre
);
6981 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
6982 TREE_TYPE (lse
->expr
), rse
->expr
);
6983 gfc_add_modify (&block
, lse
->expr
, tmp
);
6987 gfc_add_block_to_block (&block
, &lse
->pre
);
6988 gfc_add_block_to_block (&block
, &rse
->pre
);
6990 gfc_add_modify (&block
, lse
->expr
,
6991 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6994 gfc_add_block_to_block (&block
, &lse
->post
);
6995 gfc_add_block_to_block (&block
, &rse
->post
);
6997 return gfc_finish_block (&block
);
7001 /* There are quite a lot of restrictions on the optimisation in using an
7002 array function assign without a temporary. */
7005 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7008 bool seen_array_ref
;
7010 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7012 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7013 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7016 /* Elemental functions are scalarized so that they don't need a
7017 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7018 they would need special treatment in gfc_trans_arrayfunc_assign. */
7019 if (expr2
->value
.function
.esym
!= NULL
7020 && expr2
->value
.function
.esym
->attr
.elemental
)
7023 /* Need a temporary if rhs is not FULL or a contiguous section. */
7024 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7027 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7028 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7031 /* Functions returning pointers or allocatables need temporaries. */
7032 c
= expr2
->value
.function
.esym
7033 ? (expr2
->value
.function
.esym
->attr
.pointer
7034 || expr2
->value
.function
.esym
->attr
.allocatable
)
7035 : (expr2
->symtree
->n
.sym
->attr
.pointer
7036 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7040 /* Character array functions need temporaries unless the
7041 character lengths are the same. */
7042 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7044 if (expr1
->ts
.u
.cl
->length
== NULL
7045 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7048 if (expr2
->ts
.u
.cl
->length
== NULL
7049 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7052 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7053 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7057 /* Check that no LHS component references appear during an array
7058 reference. This is needed because we do not have the means to
7059 span any arbitrary stride with an array descriptor. This check
7060 is not needed for the rhs because the function result has to be
7062 seen_array_ref
= false;
7063 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7065 if (ref
->type
== REF_ARRAY
)
7066 seen_array_ref
= true;
7067 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7071 /* Check for a dependency. */
7072 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7073 expr2
->value
.function
.esym
,
7074 expr2
->value
.function
.actual
,
7078 /* If we have reached here with an intrinsic function, we do not
7079 need a temporary except in the particular case that reallocation
7080 on assignment is active and the lhs is allocatable and a target. */
7081 if (expr2
->value
.function
.isym
)
7082 return (gfc_option
.flag_realloc_lhs
7083 && sym
->attr
.allocatable
7084 && sym
->attr
.target
);
7086 /* If the LHS is a dummy, we need a temporary if it is not
7088 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7091 /* If the lhs has been host_associated, is in common, a pointer or is
7092 a target and the function is not using a RESULT variable, aliasing
7093 can occur and a temporary is needed. */
7094 if ((sym
->attr
.host_assoc
7095 || sym
->attr
.in_common
7096 || sym
->attr
.pointer
7097 || sym
->attr
.cray_pointee
7098 || sym
->attr
.target
)
7099 && expr2
->symtree
!= NULL
7100 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7103 /* A PURE function can unconditionally be called without a temporary. */
7104 if (expr2
->value
.function
.esym
!= NULL
7105 && expr2
->value
.function
.esym
->attr
.pure
)
7108 /* Implicit_pure functions are those which could legally be declared
7110 if (expr2
->value
.function
.esym
!= NULL
7111 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7114 if (!sym
->attr
.use_assoc
7115 && !sym
->attr
.in_common
7116 && !sym
->attr
.pointer
7117 && !sym
->attr
.target
7118 && !sym
->attr
.cray_pointee
7119 && expr2
->value
.function
.esym
)
7121 /* A temporary is not needed if the function is not contained and
7122 the variable is local or host associated and not a pointer or
7124 if (!expr2
->value
.function
.esym
->attr
.contained
)
7127 /* A temporary is not needed if the lhs has never been host
7128 associated and the procedure is contained. */
7129 else if (!sym
->attr
.host_assoc
)
7132 /* A temporary is not needed if the variable is local and not
7133 a pointer, a target or a result. */
7135 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7139 /* Default to temporary use. */
7144 /* Provide the loop info so that the lhs descriptor can be built for
7145 reallocatable assignments from extrinsic function calls. */
7148 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7151 /* Signal that the function call should not be made by
7152 gfc_conv_loop_setup. */
7153 se
->ss
->is_alloc_lhs
= 1;
7154 gfc_init_loopinfo (loop
);
7155 gfc_add_ss_to_loop (loop
, *ss
);
7156 gfc_add_ss_to_loop (loop
, se
->ss
);
7157 gfc_conv_ss_startstride (loop
);
7158 gfc_conv_loop_setup (loop
, where
);
7159 gfc_copy_loopinfo_to_se (se
, loop
);
7160 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7161 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7162 se
->ss
->is_alloc_lhs
= 0;
7166 /* For assignment to a reallocatable lhs from intrinsic functions,
7167 replace the se.expr (ie. the result) with a temporary descriptor.
7168 Null the data field so that the library allocates space for the
7169 result. Free the data of the original descriptor after the function,
7170 in case it appears in an argument expression and transfer the
7171 result to the original descriptor. */
7174 fcncall_realloc_result (gfc_se
*se
, int rank
)
7183 /* Use the allocation done by the library. Substitute the lhs
7184 descriptor with a copy, whose data field is nulled.*/
7185 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7186 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7187 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7189 /* Unallocated, the descriptor does not have a dtype. */
7190 tmp
= gfc_conv_descriptor_dtype (desc
);
7191 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7193 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7194 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7195 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
7197 /* Free the lhs after the function call and copy the result data to
7198 the lhs descriptor. */
7199 tmp
= gfc_conv_descriptor_data_get (desc
);
7200 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7201 boolean_type_node
, tmp
,
7202 build_int_cst (TREE_TYPE (tmp
), 0));
7203 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7204 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7205 gfc_add_expr_to_block (&se
->post
, tmp
);
7207 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7208 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7210 /* Check that the shapes are the same between lhs and expression. */
7211 for (n
= 0 ; n
< rank
; n
++)
7214 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7215 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7216 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7217 gfc_array_index_type
, tmp
, tmp1
);
7218 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7219 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7220 gfc_array_index_type
, tmp
, tmp1
);
7221 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7222 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7223 gfc_array_index_type
, tmp
, tmp1
);
7224 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7225 boolean_type_node
, tmp
,
7226 gfc_index_zero_node
);
7227 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7228 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7229 boolean_type_node
, tmp
,
7233 /* 'zero_cond' being true is equal to lhs not being allocated or the
7234 shapes being different. */
7235 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7237 /* Now reset the bounds returned from the function call to bounds based
7238 on the lhs lbounds, except where the lhs is not allocated or the shapes
7239 of 'variable and 'expr' are different. Set the offset accordingly. */
7240 offset
= gfc_index_zero_node
;
7241 for (n
= 0 ; n
< rank
; n
++)
7245 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7246 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7247 gfc_array_index_type
, zero_cond
,
7248 gfc_index_one_node
, lbound
);
7249 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7251 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7252 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7253 gfc_array_index_type
, tmp
, lbound
);
7254 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7255 gfc_rank_cst
[n
], lbound
);
7256 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7257 gfc_rank_cst
[n
], tmp
);
7259 /* Set stride and accumulate the offset. */
7260 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7261 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7262 gfc_rank_cst
[n
], tmp
);
7263 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7264 gfc_array_index_type
, lbound
, tmp
);
7265 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7266 gfc_array_index_type
, offset
, tmp
);
7267 offset
= gfc_evaluate_now (offset
, &se
->post
);
7270 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7275 /* Try to translate array(:) = func (...), where func is a transformational
7276 array function, without using a temporary. Returns NULL if this isn't the
7280 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7284 gfc_component
*comp
= NULL
;
7287 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7290 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7292 comp
= gfc_get_proc_ptr_comp (expr2
);
7293 gcc_assert (expr2
->value
.function
.isym
7294 || (comp
&& comp
->attr
.dimension
)
7295 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7296 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7298 gfc_init_se (&se
, NULL
);
7299 gfc_start_block (&se
.pre
);
7300 se
.want_pointer
= 1;
7302 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7304 if (expr1
->ts
.type
== BT_DERIVED
7305 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7308 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7310 gfc_add_expr_to_block (&se
.pre
, tmp
);
7313 se
.direct_byref
= 1;
7314 se
.ss
= gfc_walk_expr (expr2
);
7315 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7317 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7318 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7319 Clearly, this cannot be done for an allocatable function result, since
7320 the shape of the result is unknown and, in any case, the function must
7321 correctly take care of the reallocation internally. For intrinsic
7322 calls, the array data is freed and the library takes care of allocation.
7323 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7325 if (gfc_option
.flag_realloc_lhs
7326 && gfc_is_reallocatable_lhs (expr1
)
7327 && !gfc_expr_attr (expr1
).codimension
7328 && !gfc_is_coindexed (expr1
)
7329 && !(expr2
->value
.function
.esym
7330 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7332 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7334 if (!expr2
->value
.function
.isym
)
7336 ss
= gfc_walk_expr (expr1
);
7337 gcc_assert (ss
!= gfc_ss_terminator
);
7339 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7340 ss
->is_alloc_lhs
= 1;
7343 fcncall_realloc_result (&se
, expr1
->rank
);
7346 gfc_conv_function_expr (&se
, expr2
);
7347 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7350 gfc_cleanup_loop (&loop
);
7352 gfc_free_ss_chain (se
.ss
);
7354 return gfc_finish_block (&se
.pre
);
7358 /* Try to efficiently translate array(:) = 0. Return NULL if this
7362 gfc_trans_zero_assign (gfc_expr
* expr
)
7364 tree dest
, len
, type
;
7368 sym
= expr
->symtree
->n
.sym
;
7369 dest
= gfc_get_symbol_decl (sym
);
7371 type
= TREE_TYPE (dest
);
7372 if (POINTER_TYPE_P (type
))
7373 type
= TREE_TYPE (type
);
7374 if (!GFC_ARRAY_TYPE_P (type
))
7377 /* Determine the length of the array. */
7378 len
= GFC_TYPE_ARRAY_SIZE (type
);
7379 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7382 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7383 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7384 fold_convert (gfc_array_index_type
, tmp
));
7386 /* If we are zeroing a local array avoid taking its address by emitting
7388 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7389 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7390 dest
, build_constructor (TREE_TYPE (dest
),
7393 /* Convert arguments to the correct types. */
7394 dest
= fold_convert (pvoid_type_node
, dest
);
7395 len
= fold_convert (size_type_node
, len
);
7397 /* Construct call to __builtin_memset. */
7398 tmp
= build_call_expr_loc (input_location
,
7399 builtin_decl_explicit (BUILT_IN_MEMSET
),
7400 3, dest
, integer_zero_node
, len
);
7401 return fold_convert (void_type_node
, tmp
);
7405 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7406 that constructs the call to __builtin_memcpy. */
7409 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7413 /* Convert arguments to the correct types. */
7414 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7415 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7417 dst
= fold_convert (pvoid_type_node
, dst
);
7419 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7420 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7422 src
= fold_convert (pvoid_type_node
, src
);
7424 len
= fold_convert (size_type_node
, len
);
7426 /* Construct call to __builtin_memcpy. */
7427 tmp
= build_call_expr_loc (input_location
,
7428 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7430 return fold_convert (void_type_node
, tmp
);
7434 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7435 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7436 source/rhs, both are gfc_full_array_ref_p which have been checked for
7440 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7442 tree dst
, dlen
, dtype
;
7443 tree src
, slen
, stype
;
7446 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7447 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7449 dtype
= TREE_TYPE (dst
);
7450 if (POINTER_TYPE_P (dtype
))
7451 dtype
= TREE_TYPE (dtype
);
7452 stype
= TREE_TYPE (src
);
7453 if (POINTER_TYPE_P (stype
))
7454 stype
= TREE_TYPE (stype
);
7456 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7459 /* Determine the lengths of the arrays. */
7460 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7461 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7463 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7464 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7465 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7467 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7468 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7470 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7471 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7472 slen
, fold_convert (gfc_array_index_type
, tmp
));
7474 /* Sanity check that they are the same. This should always be
7475 the case, as we should already have checked for conformance. */
7476 if (!tree_int_cst_equal (slen
, dlen
))
7479 return gfc_build_memcpy_call (dst
, src
, dlen
);
7483 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7484 this can't be done. EXPR1 is the destination/lhs for which
7485 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7488 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7490 unsigned HOST_WIDE_INT nelem
;
7496 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7500 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7501 dtype
= TREE_TYPE (dst
);
7502 if (POINTER_TYPE_P (dtype
))
7503 dtype
= TREE_TYPE (dtype
);
7504 if (!GFC_ARRAY_TYPE_P (dtype
))
7507 /* Determine the lengths of the array. */
7508 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7509 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7512 /* Confirm that the constructor is the same size. */
7513 if (compare_tree_int (len
, nelem
) != 0)
7516 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7517 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7518 fold_convert (gfc_array_index_type
, tmp
));
7520 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7521 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7523 stype
= TREE_TYPE (src
);
7524 if (POINTER_TYPE_P (stype
))
7525 stype
= TREE_TYPE (stype
);
7527 return gfc_build_memcpy_call (dst
, src
, len
);
7531 /* Tells whether the expression is to be treated as a variable reference. */
7534 expr_is_variable (gfc_expr
*expr
)
7537 gfc_component
*comp
;
7538 gfc_symbol
*func_ifc
;
7540 if (expr
->expr_type
== EXPR_VARIABLE
)
7543 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7546 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7547 return expr_is_variable (arg
);
7550 /* A data-pointer-returning function should be considered as a variable
7552 if (expr
->expr_type
== EXPR_FUNCTION
7553 && expr
->ref
== NULL
)
7555 if (expr
->value
.function
.isym
!= NULL
)
7558 if (expr
->value
.function
.esym
!= NULL
)
7560 func_ifc
= expr
->value
.function
.esym
;
7565 gcc_assert (expr
->symtree
);
7566 func_ifc
= expr
->symtree
->n
.sym
;
7573 comp
= gfc_get_proc_ptr_comp (expr
);
7574 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7577 func_ifc
= comp
->ts
.interface
;
7581 if (expr
->expr_type
== EXPR_COMPCALL
)
7583 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7584 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7591 gcc_assert (func_ifc
->attr
.function
7592 && func_ifc
->result
!= NULL
);
7593 return func_ifc
->result
->attr
.pointer
;
7597 /* Is the lhs OK for automatic reallocation? */
7600 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7604 /* An allocatable variable with no reference. */
7605 if (expr
->symtree
->n
.sym
->attr
.allocatable
7609 /* All that can be left are allocatable components. */
7610 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7611 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7612 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7615 /* Find an allocatable component ref last. */
7616 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7617 if (ref
->type
== REF_COMPONENT
7619 && ref
->u
.c
.component
->attr
.allocatable
)
7626 /* Allocate or reallocate scalar lhs, as necessary. */
7629 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7643 if (!expr1
|| expr1
->rank
)
7646 if (!expr2
|| expr2
->rank
)
7649 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7651 /* Since this is a scalar lhs, we can afford to do this. That is,
7652 there is no risk of side effects being repeated. */
7653 gfc_init_se (&lse
, NULL
);
7654 lse
.want_pointer
= 1;
7655 gfc_conv_expr (&lse
, expr1
);
7657 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7658 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7660 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7661 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7662 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7664 tmp
= build3_v (COND_EXPR
, cond
,
7665 build1_v (GOTO_EXPR
, jump_label1
),
7666 build_empty_stmt (input_location
));
7667 gfc_add_expr_to_block (block
, tmp
);
7669 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7671 /* Use the rhs string length and the lhs element size. */
7672 size
= string_length
;
7673 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7674 tmp
= TYPE_SIZE_UNIT (tmp
);
7675 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7676 TREE_TYPE (tmp
), tmp
,
7677 fold_convert (TREE_TYPE (tmp
), size
));
7681 /* Otherwise use the length in bytes of the rhs. */
7682 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7683 size_in_bytes
= size
;
7686 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7687 size_in_bytes
, size_one_node
);
7689 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7691 tmp
= build_call_expr_loc (input_location
,
7692 builtin_decl_explicit (BUILT_IN_CALLOC
),
7693 2, build_one_cst (size_type_node
),
7695 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7696 gfc_add_modify (block
, lse
.expr
, tmp
);
7700 tmp
= build_call_expr_loc (input_location
,
7701 builtin_decl_explicit (BUILT_IN_MALLOC
),
7703 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7704 gfc_add_modify (block
, lse
.expr
, tmp
);
7707 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7709 /* Deferred characters need checking for lhs and rhs string
7710 length. Other deferred parameter variables will have to
7712 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7713 gfc_add_expr_to_block (block
, tmp
);
7715 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7716 gfc_add_expr_to_block (block
, tmp
);
7718 /* For a deferred length character, reallocate if lengths of lhs and
7719 rhs are different. */
7720 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7722 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7723 expr1
->ts
.u
.cl
->backend_decl
, size
);
7724 /* Jump past the realloc if the lengths are the same. */
7725 tmp
= build3_v (COND_EXPR
, cond
,
7726 build1_v (GOTO_EXPR
, jump_label2
),
7727 build_empty_stmt (input_location
));
7728 gfc_add_expr_to_block (block
, tmp
);
7729 tmp
= build_call_expr_loc (input_location
,
7730 builtin_decl_explicit (BUILT_IN_REALLOC
),
7731 2, fold_convert (pvoid_type_node
, lse
.expr
),
7733 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7734 gfc_add_modify (block
, lse
.expr
, tmp
);
7735 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7736 gfc_add_expr_to_block (block
, tmp
);
7738 /* Update the lhs character length. */
7739 size
= string_length
;
7740 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7744 /* Check for assignments of the type
7748 to make sure we do not check for reallocation unneccessarily. */
7752 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7754 gfc_actual_arglist
*a
;
7757 switch (expr2
->expr_type
)
7760 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7763 if (expr2
->value
.function
.esym
7764 && expr2
->value
.function
.esym
->attr
.elemental
)
7766 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7769 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7774 else if (expr2
->value
.function
.isym
7775 && expr2
->value
.function
.isym
->elemental
)
7777 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7780 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7789 switch (expr2
->value
.op
.op
)
7792 case INTRINSIC_UPLUS
:
7793 case INTRINSIC_UMINUS
:
7794 case INTRINSIC_PARENTHESES
:
7795 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7797 case INTRINSIC_PLUS
:
7798 case INTRINSIC_MINUS
:
7799 case INTRINSIC_TIMES
:
7800 case INTRINSIC_DIVIDE
:
7801 case INTRINSIC_POWER
:
7805 case INTRINSIC_NEQV
:
7812 case INTRINSIC_EQ_OS
:
7813 case INTRINSIC_NE_OS
:
7814 case INTRINSIC_GT_OS
:
7815 case INTRINSIC_GE_OS
:
7816 case INTRINSIC_LT_OS
:
7817 case INTRINSIC_LE_OS
:
7819 e1
= expr2
->value
.op
.op1
;
7820 e2
= expr2
->value
.op
.op2
;
7822 if (e1
->rank
== 0 && e2
->rank
> 0)
7823 return is_runtime_conformable (expr1
, e2
);
7824 else if (e1
->rank
> 0 && e2
->rank
== 0)
7825 return is_runtime_conformable (expr1
, e1
);
7826 else if (e1
->rank
> 0 && e2
->rank
> 0)
7827 return is_runtime_conformable (expr1
, e1
)
7828 && is_runtime_conformable (expr1
, e2
);
7844 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7845 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7846 init_flag indicates initialization expressions and dealloc that no
7847 deallocate prior assignment is needed (if in doubt, set true). */
7850 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7856 gfc_ss
*lss_section
;
7863 bool scalar_to_array
;
7867 /* Assignment of the form lhs = rhs. */
7868 gfc_start_block (&block
);
7870 gfc_init_se (&lse
, NULL
);
7871 gfc_init_se (&rse
, NULL
);
7874 lss
= gfc_walk_expr (expr1
);
7875 if (gfc_is_reallocatable_lhs (expr1
)
7876 && !(expr2
->expr_type
== EXPR_FUNCTION
7877 && expr2
->value
.function
.isym
!= NULL
))
7878 lss
->is_alloc_lhs
= 1;
7880 if (lss
!= gfc_ss_terminator
)
7882 /* The assignment needs scalarization. */
7885 /* Find a non-scalar SS from the lhs. */
7886 while (lss_section
!= gfc_ss_terminator
7887 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7888 lss_section
= lss_section
->next
;
7890 gcc_assert (lss_section
!= gfc_ss_terminator
);
7892 /* Initialize the scalarizer. */
7893 gfc_init_loopinfo (&loop
);
7896 rss
= gfc_walk_expr (expr2
);
7897 if (rss
== gfc_ss_terminator
)
7898 /* The rhs is scalar. Add a ss for the expression. */
7899 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7901 /* Associate the SS with the loop. */
7902 gfc_add_ss_to_loop (&loop
, lss
);
7903 gfc_add_ss_to_loop (&loop
, rss
);
7905 /* Calculate the bounds of the scalarization. */
7906 gfc_conv_ss_startstride (&loop
);
7907 /* Enable loop reversal. */
7908 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7909 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7910 /* Resolve any data dependencies in the statement. */
7911 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7912 /* Setup the scalarizing loops. */
7913 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7915 /* Setup the gfc_se structures. */
7916 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7917 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7920 gfc_mark_ss_chain_used (rss
, 1);
7921 if (loop
.temp_ss
== NULL
)
7924 gfc_mark_ss_chain_used (lss
, 1);
7928 lse
.ss
= loop
.temp_ss
;
7929 gfc_mark_ss_chain_used (lss
, 3);
7930 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
7933 /* Allow the scalarizer to workshare array assignments. */
7934 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
7935 ompws_flags
|= OMPWS_SCALARIZER_WS
;
7937 /* Start the scalarized loop body. */
7938 gfc_start_scalarized_body (&loop
, &body
);
7941 gfc_init_block (&body
);
7943 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
7945 /* Translate the expression. */
7946 gfc_conv_expr (&rse
, expr2
);
7948 /* Stabilize a string length for temporaries. */
7949 if (expr2
->ts
.type
== BT_CHARACTER
)
7950 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
7952 string_length
= NULL_TREE
;
7956 gfc_conv_tmp_array_ref (&lse
);
7957 if (expr2
->ts
.type
== BT_CHARACTER
)
7958 lse
.string_length
= string_length
;
7961 gfc_conv_expr (&lse
, expr1
);
7963 /* Assignments of scalar derived types with allocatable components
7964 to arrays must be done with a deep copy and the rhs temporary
7965 must have its components deallocated afterwards. */
7966 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
7967 && expr2
->ts
.u
.derived
->attr
.alloc_comp
7968 && !expr_is_variable (expr2
)
7969 && !gfc_is_constant_expr (expr2
)
7970 && expr1
->rank
&& !expr2
->rank
);
7971 if (scalar_to_array
&& dealloc
)
7973 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
7974 gfc_add_expr_to_block (&loop
.post
, tmp
);
7977 /* When assigning a character function result to a deferred-length variable,
7978 the function call must happen before the (re)allocation of the lhs -
7979 otherwise the character length of the result is not known.
7980 NOTE: This relies on having the exact dependence of the length type
7981 parameter available to the caller; gfortran saves it in the .mod files. */
7982 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
7983 && expr1
->ts
.deferred
)
7984 gfc_add_block_to_block (&block
, &rse
.pre
);
7986 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7987 l_is_temp
|| init_flag
,
7988 expr_is_variable (expr2
) || scalar_to_array
7989 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
7990 gfc_add_expr_to_block (&body
, tmp
);
7992 if (lss
== gfc_ss_terminator
)
7994 /* F2003: Add the code for reallocation on assignment. */
7995 if (gfc_option
.flag_realloc_lhs
7996 && is_scalar_reallocatable_lhs (expr1
))
7997 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8000 /* Use the scalar assignment as is. */
8001 gfc_add_block_to_block (&block
, &body
);
8005 gcc_assert (lse
.ss
== gfc_ss_terminator
8006 && rse
.ss
== gfc_ss_terminator
);
8010 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8012 /* We need to copy the temporary to the actual lhs. */
8013 gfc_init_se (&lse
, NULL
);
8014 gfc_init_se (&rse
, NULL
);
8015 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8016 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8018 rse
.ss
= loop
.temp_ss
;
8021 gfc_conv_tmp_array_ref (&rse
);
8022 gfc_conv_expr (&lse
, expr1
);
8024 gcc_assert (lse
.ss
== gfc_ss_terminator
8025 && rse
.ss
== gfc_ss_terminator
);
8027 if (expr2
->ts
.type
== BT_CHARACTER
)
8028 rse
.string_length
= string_length
;
8030 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8031 false, false, dealloc
);
8032 gfc_add_expr_to_block (&body
, tmp
);
8035 /* F2003: Allocate or reallocate lhs of allocatable array. */
8036 if (gfc_option
.flag_realloc_lhs
8037 && gfc_is_reallocatable_lhs (expr1
)
8038 && !gfc_expr_attr (expr1
).codimension
8039 && !gfc_is_coindexed (expr1
)
8041 && !is_runtime_conformable (expr1
, expr2
))
8043 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8044 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8045 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8046 if (tmp
!= NULL_TREE
)
8047 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8050 /* Generate the copying loops. */
8051 gfc_trans_scalarizing_loops (&loop
, &body
);
8053 /* Wrap the whole thing up. */
8054 gfc_add_block_to_block (&block
, &loop
.pre
);
8055 gfc_add_block_to_block (&block
, &loop
.post
);
8057 gfc_cleanup_loop (&loop
);
8060 return gfc_finish_block (&block
);
8064 /* Check whether EXPR is a copyable array. */
8067 copyable_array_p (gfc_expr
* expr
)
8069 if (expr
->expr_type
!= EXPR_VARIABLE
)
8072 /* First check it's an array. */
8073 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8076 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8079 /* Next check that it's of a simple enough type. */
8080 switch (expr
->ts
.type
)
8092 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8101 /* Translate an assignment. */
8104 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8109 /* Special case a single function returning an array. */
8110 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8112 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8117 /* Special case assigning an array to zero. */
8118 if (copyable_array_p (expr1
)
8119 && is_zero_initializer_p (expr2
))
8121 tmp
= gfc_trans_zero_assign (expr1
);
8126 /* Special case copying one array to another. */
8127 if (copyable_array_p (expr1
)
8128 && copyable_array_p (expr2
)
8129 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8130 && !gfc_check_dependency (expr1
, expr2
, 0))
8132 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8137 /* Special case initializing an array from a constant array constructor. */
8138 if (copyable_array_p (expr1
)
8139 && expr2
->expr_type
== EXPR_ARRAY
8140 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8142 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8147 /* Fallback to the scalarizer to generate explicit loops. */
8148 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8152 gfc_trans_init_assign (gfc_code
* code
)
8154 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8158 gfc_trans_assign (gfc_code
* code
)
8160 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);