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;
73 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
74 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
75 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
76 gfc_get_dtype (type
));
77 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
79 /* Copy pointer address back - but only if it could have changed and
80 if the actual argument is a pointer and not, e.g., NULL(). */
81 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
82 gfc_add_modify (&se
->post
, scalar
,
83 fold_convert (TREE_TYPE (scalar
),
84 gfc_conv_descriptor_data_get (desc
)));
89 /* This is the seed for an eventual trans-class.c
91 The following parameters should not be used directly since they might
92 in future implementations. Use the corresponding APIs. */
93 #define CLASS_DATA_FIELD 0
94 #define CLASS_VPTR_FIELD 1
95 #define VTABLE_HASH_FIELD 0
96 #define VTABLE_SIZE_FIELD 1
97 #define VTABLE_EXTENDS_FIELD 2
98 #define VTABLE_DEF_INIT_FIELD 3
99 #define VTABLE_COPY_FIELD 4
100 #define VTABLE_FINAL_FIELD 5
104 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
108 vec
<constructor_elt
, va_gc
> *init
= NULL
;
110 field
= TYPE_FIELDS (TREE_TYPE (decl
));
111 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
112 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
114 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
115 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
117 return build_constructor (TREE_TYPE (decl
), init
);
122 gfc_class_data_get (tree decl
)
125 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
126 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
127 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
129 return fold_build3_loc (input_location
, COMPONENT_REF
,
130 TREE_TYPE (data
), decl
, data
,
136 gfc_class_vptr_get (tree decl
)
139 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
140 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
141 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
143 return fold_build3_loc (input_location
, COMPONENT_REF
,
144 TREE_TYPE (vptr
), decl
, vptr
,
150 gfc_vtable_field_get (tree decl
, int field
)
154 vptr
= gfc_class_vptr_get (decl
);
155 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
156 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
158 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
159 TREE_TYPE (size
), vptr
, size
,
161 /* Always return size as an array index type. */
162 if (field
== VTABLE_SIZE_FIELD
)
163 size
= fold_convert (gfc_array_index_type
, size
);
170 gfc_vtable_hash_get (tree decl
)
172 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
177 gfc_vtable_size_get (tree decl
)
179 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
184 gfc_vtable_extends_get (tree decl
)
186 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
191 gfc_vtable_def_init_get (tree decl
)
193 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
198 gfc_vtable_copy_get (tree decl
)
200 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
205 gfc_vtable_final_get (tree decl
)
207 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
211 #undef CLASS_DATA_FIELD
212 #undef CLASS_VPTR_FIELD
213 #undef VTABLE_HASH_FIELD
214 #undef VTABLE_SIZE_FIELD
215 #undef VTABLE_EXTENDS_FIELD
216 #undef VTABLE_DEF_INIT_FIELD
217 #undef VTABLE_COPY_FIELD
218 #undef VTABLE_FINAL_FIELD
221 /* Reset the vptr to the declared type, e.g. after deallocation. */
224 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
226 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
231 /* If we have a class array, we need go back to the class
233 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
234 && lhs
->ref
->next
->type
== REF_ARRAY
235 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
236 && lhs
->ref
->type
== REF_COMPONENT
237 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
239 gfc_free_ref_list (lhs
->ref
);
243 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
244 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
245 && ref
->next
->next
->type
== REF_ARRAY
246 && ref
->next
->next
->u
.ar
.type
== AR_FULL
247 && ref
->next
->type
== REF_COMPONENT
248 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
250 gfc_free_ref_list (ref
->next
);
254 gfc_add_vptr_component (lhs
);
256 if (UNLIMITED_POLY (e
))
257 rhs
= gfc_get_null_expr (NULL
);
260 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
261 rhs
= gfc_lval_expr_from_sym (vtab
);
263 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
264 gfc_add_expr_to_block (block
, tmp
);
270 /* Obtain the vptr of the last class reference in an expression.
271 Return NULL_TREE if no class reference is found. */
274 gfc_get_vptr_from_expr (tree expr
)
279 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
281 type
= TREE_TYPE (tmp
);
284 if (GFC_CLASS_TYPE_P (type
))
285 return gfc_class_vptr_get (tmp
);
286 if (type
!= TYPE_CANONICAL (type
))
287 type
= TYPE_CANONICAL (type
);
291 if (TREE_CODE (tmp
) == VAR_DECL
)
299 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
302 tree tmp
, tmp2
, type
;
304 gfc_conv_descriptor_data_set (block
, lhs_desc
,
305 gfc_conv_descriptor_data_get (rhs_desc
));
306 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
307 gfc_conv_descriptor_offset_get (rhs_desc
));
309 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
310 gfc_conv_descriptor_dtype (rhs_desc
));
312 /* Assign the dimension as range-ref. */
313 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
314 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
316 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
317 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
318 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
319 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
320 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
321 gfc_add_modify (block
, tmp
, tmp2
);
325 /* Takes a derived type expression and returns the address of a temporary
326 class object of the 'declared' type. If vptr is not NULL, this is
327 used for the temporary class object.
328 optional_alloc_ptr is false when the dummy is neither allocatable
329 nor a pointer; that's only relevant for the optional handling. */
331 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
332 gfc_typespec class_ts
, tree vptr
, bool optional
,
333 bool optional_alloc_ptr
)
336 tree cond_optional
= NULL_TREE
;
342 /* The derived type needs to be converted to a temporary
344 tmp
= gfc_typenode_for_spec (&class_ts
);
345 var
= gfc_create_var (tmp
, "class");
348 ctree
= gfc_class_vptr_get (var
);
350 if (vptr
!= NULL_TREE
)
352 /* Use the dynamic vptr. */
357 /* In this case the vtab corresponds to the derived type and the
358 vptr must point to it. */
359 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
361 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
363 gfc_add_modify (&parmse
->pre
, ctree
,
364 fold_convert (TREE_TYPE (ctree
), tmp
));
366 /* Now set the data field. */
367 ctree
= gfc_class_data_get (var
);
370 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
372 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
374 /* For an array reference in an elemental procedure call we need
375 to retain the ss to provide the scalarized array reference. */
376 gfc_conv_expr_reference (parmse
, e
);
377 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
379 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
381 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
382 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
387 ss
= gfc_walk_expr (e
);
388 if (ss
== gfc_ss_terminator
)
391 gfc_conv_expr_reference (parmse
, e
);
393 /* Scalar to an assumed-rank array. */
394 if (class_ts
.u
.derived
->components
->as
)
397 type
= get_scalar_to_descriptor_type (parmse
->expr
,
399 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
400 gfc_get_dtype (type
));
402 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
403 TREE_TYPE (parmse
->expr
),
404 cond_optional
, parmse
->expr
,
405 fold_convert (TREE_TYPE (parmse
->expr
),
407 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
411 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
413 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
415 fold_convert (TREE_TYPE (tmp
),
417 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
423 gfc_init_block (&block
);
426 gfc_conv_expr_descriptor (parmse
, e
);
428 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
430 gcc_assert (class_ts
.u
.derived
->components
->as
->type
432 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
436 if (gfc_expr_attr (e
).codimension
)
437 parmse
->expr
= fold_build1_loc (input_location
,
441 gfc_add_modify (&block
, ctree
, parmse
->expr
);
446 tmp
= gfc_finish_block (&block
);
448 gfc_init_block (&block
);
449 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
451 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
452 gfc_finish_block (&block
));
453 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
456 gfc_add_block_to_block (&parmse
->pre
, &block
);
460 /* Pass the address of the class object. */
461 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
463 if (optional
&& optional_alloc_ptr
)
464 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
465 TREE_TYPE (parmse
->expr
),
466 cond_optional
, parmse
->expr
,
467 fold_convert (TREE_TYPE (parmse
->expr
),
472 /* Create a new class container, which is required as scalar coarrays
473 have an array descriptor while normal scalars haven't. Optionally,
474 NULL pointer checks are added if the argument is OPTIONAL. */
477 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
478 gfc_typespec class_ts
, bool optional
)
480 tree var
, ctree
, tmp
;
485 gfc_init_block (&block
);
488 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
490 if (ref
->type
== REF_COMPONENT
491 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
495 if (class_ref
== NULL
496 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
497 tmp
= e
->symtree
->n
.sym
->backend_decl
;
500 /* Remove everything after the last class reference, convert the
501 expression and then recover its tailend once more. */
503 ref
= class_ref
->next
;
504 class_ref
->next
= NULL
;
505 gfc_init_se (&tmpse
, NULL
);
506 gfc_conv_expr (&tmpse
, e
);
507 class_ref
->next
= ref
;
511 var
= gfc_typenode_for_spec (&class_ts
);
512 var
= gfc_create_var (var
, "class");
514 ctree
= gfc_class_vptr_get (var
);
515 gfc_add_modify (&block
, ctree
,
516 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
518 ctree
= gfc_class_data_get (var
);
519 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
520 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
522 /* Pass the address of the class object. */
523 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
527 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
530 tmp
= gfc_finish_block (&block
);
532 gfc_init_block (&block
);
533 tmp2
= gfc_class_data_get (var
);
534 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
536 tmp2
= gfc_finish_block (&block
);
538 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
540 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
543 gfc_add_block_to_block (&parmse
->pre
, &block
);
547 /* Takes an intrinsic type expression and returns the address of a temporary
548 class object of the 'declared' type. */
550 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
551 gfc_typespec class_ts
)
559 /* The intrinsic type needs to be converted to a temporary
561 tmp
= gfc_typenode_for_spec (&class_ts
);
562 var
= gfc_create_var (tmp
, "class");
565 ctree
= gfc_class_vptr_get (var
);
567 vtab
= gfc_find_vtab (&e
->ts
);
569 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
570 gfc_add_modify (&parmse
->pre
, ctree
,
571 fold_convert (TREE_TYPE (ctree
), tmp
));
573 /* Now set the data field. */
574 ctree
= gfc_class_data_get (var
);
575 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
577 /* For an array reference in an elemental procedure call we need
578 to retain the ss to provide the scalarized array reference. */
579 gfc_conv_expr_reference (parmse
, e
);
580 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
581 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
585 ss
= gfc_walk_expr (e
);
586 if (ss
== gfc_ss_terminator
)
589 gfc_conv_expr_reference (parmse
, e
);
590 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
591 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
596 parmse
->use_offset
= 1;
597 gfc_conv_expr_descriptor (parmse
, e
);
598 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
602 /* Pass the address of the class object. */
603 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
607 /* Takes a scalarized class array expression and returns the
608 address of a temporary scalar class object of the 'declared'
610 OOP-TODO: This could be improved by adding code that branched on
611 the dynamic type being the same as the declared type. In this case
612 the original class expression can be passed directly.
613 optional_alloc_ptr is false when the dummy is neither allocatable
614 nor a pointer; that's relevant for the optional handling.
615 Set copyback to true if class container's _data and _vtab pointers
616 might get modified. */
619 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
620 bool elemental
, bool copyback
, bool optional
,
621 bool optional_alloc_ptr
)
627 tree cond
= NULL_TREE
;
631 bool full_array
= false;
633 gfc_init_block (&block
);
636 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
638 if (ref
->type
== REF_COMPONENT
639 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
642 if (ref
->next
== NULL
)
646 if ((ref
== NULL
|| class_ref
== ref
)
647 && (!class_ts
.u
.derived
->components
->as
648 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
651 /* Test for FULL_ARRAY. */
652 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
653 && gfc_expr_attr (e
).dimension
)
656 gfc_is_class_array_ref (e
, &full_array
);
658 /* The derived type needs to be converted to a temporary
660 tmp
= gfc_typenode_for_spec (&class_ts
);
661 var
= gfc_create_var (tmp
, "class");
664 ctree
= gfc_class_data_get (var
);
665 if (class_ts
.u
.derived
->components
->as
666 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
670 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
672 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
673 gfc_get_dtype (type
));
675 tmp
= gfc_class_data_get (parmse
->expr
);
676 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
677 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
679 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
682 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
686 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
687 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
688 TREE_TYPE (ctree
), parmse
->expr
);
689 gfc_add_modify (&block
, ctree
, parmse
->expr
);
692 /* Return the data component, except in the case of scalarized array
693 references, where nullification of the cannot occur and so there
695 if (!elemental
&& full_array
&& copyback
)
697 if (class_ts
.u
.derived
->components
->as
698 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
701 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
702 gfc_conv_descriptor_data_get (ctree
));
704 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
707 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
711 ctree
= gfc_class_vptr_get (var
);
713 /* The vptr is the second field of the actual argument.
714 First we have to find the corresponding class reference. */
717 if (class_ref
== NULL
718 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
719 tmp
= e
->symtree
->n
.sym
->backend_decl
;
722 /* Remove everything after the last class reference, convert the
723 expression and then recover its tailend once more. */
725 ref
= class_ref
->next
;
726 class_ref
->next
= NULL
;
727 gfc_init_se (&tmpse
, NULL
);
728 gfc_conv_expr (&tmpse
, e
);
729 class_ref
->next
= ref
;
733 gcc_assert (tmp
!= NULL_TREE
);
735 /* Dereference if needs be. */
736 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
737 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
739 vptr
= gfc_class_vptr_get (tmp
);
740 gfc_add_modify (&block
, ctree
,
741 fold_convert (TREE_TYPE (ctree
), vptr
));
743 /* Return the vptr component, except in the case of scalarized array
744 references, where the dynamic type cannot change. */
745 if (!elemental
&& full_array
&& copyback
)
746 gfc_add_modify (&parmse
->post
, vptr
,
747 fold_convert (TREE_TYPE (vptr
), ctree
));
753 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
754 tmp
= gfc_finish_block (&block
);
756 if (optional_alloc_ptr
)
757 tmp2
= build_empty_stmt (input_location
);
760 gfc_init_block (&block
);
762 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
763 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
765 tmp2
= gfc_finish_block (&block
);
768 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
770 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
773 gfc_add_block_to_block (&parmse
->pre
, &block
);
775 /* Pass the address of the class object. */
776 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
778 if (optional
&& optional_alloc_ptr
)
779 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
780 TREE_TYPE (parmse
->expr
),
782 fold_convert (TREE_TYPE (parmse
->expr
),
787 /* Given a class array declaration and an index, returns the address
788 of the referenced element. */
791 gfc_get_class_array_ref (tree index
, tree class_decl
)
793 tree data
= gfc_class_data_get (class_decl
);
794 tree size
= gfc_vtable_size_get (class_decl
);
795 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
796 gfc_array_index_type
,
799 data
= gfc_conv_descriptor_data_get (data
);
800 ptr
= fold_convert (pvoid_type_node
, data
);
801 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
802 return fold_convert (TREE_TYPE (data
), ptr
);
806 /* Copies one class expression to another, assuming that if either
807 'to' or 'from' are arrays they are packed. Should 'from' be
808 NULL_TREE, the initialization expression for 'to' is used, assuming
809 that the _vptr is set. */
812 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
820 vec
<tree
, va_gc
> *args
;
823 stmtblock_t loopbody
;
829 if (from
!= NULL_TREE
)
830 fcn
= gfc_vtable_copy_get (from
);
832 fcn
= gfc_vtable_copy_get (to
);
834 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
836 if (from
!= NULL_TREE
)
837 from_data
= gfc_class_data_get (from
);
839 from_data
= gfc_vtable_def_init_get (to
);
841 to_data
= gfc_class_data_get (to
);
843 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
845 gfc_init_block (&body
);
846 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
847 gfc_array_index_type
, nelems
,
849 nelems
= gfc_evaluate_now (tmp
, &body
);
850 index
= gfc_create_var (gfc_array_index_type
, "S");
852 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
854 from_ref
= gfc_get_class_array_ref (index
, from
);
855 vec_safe_push (args
, from_ref
);
858 vec_safe_push (args
, from_data
);
860 to_ref
= gfc_get_class_array_ref (index
, to
);
861 vec_safe_push (args
, to_ref
);
863 tmp
= build_call_vec (fcn_type
, fcn
, args
);
865 /* Build the body of the loop. */
866 gfc_init_block (&loopbody
);
867 gfc_add_expr_to_block (&loopbody
, tmp
);
869 /* Build the loop and return. */
870 gfc_init_loopinfo (&loop
);
872 loop
.from
[0] = gfc_index_zero_node
;
873 loop
.loopvar
[0] = index
;
875 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
876 gfc_add_block_to_block (&body
, &loop
.pre
);
877 tmp
= gfc_finish_block (&body
);
878 gfc_cleanup_loop (&loop
);
882 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
883 vec_safe_push (args
, from_data
);
884 vec_safe_push (args
, to_data
);
885 tmp
= build_call_vec (fcn_type
, fcn
, args
);
892 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
894 gfc_actual_arglist
*actual
;
899 actual
= gfc_get_actual_arglist ();
900 actual
->expr
= gfc_copy_expr (rhs
);
901 actual
->next
= gfc_get_actual_arglist ();
902 actual
->next
->expr
= gfc_copy_expr (lhs
);
903 ppc
= gfc_copy_expr (obj
);
904 gfc_add_vptr_component (ppc
);
905 gfc_add_component_ref (ppc
, "_copy");
906 ppc_code
= gfc_get_code (EXEC_CALL
);
907 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
908 /* Although '_copy' is set to be elemental in class.c, it is
909 not staying that way. Find out why, sometime.... */
910 ppc_code
->resolved_sym
->attr
.elemental
= 1;
911 ppc_code
->ext
.actual
= actual
;
912 ppc_code
->expr1
= ppc
;
913 /* Since '_copy' is elemental, the scalarizer will take care
914 of arrays in gfc_trans_call. */
915 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
916 gfc_free_statements (ppc_code
);
920 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
921 A MEMCPY is needed to copy the full data from the default initializer
922 of the dynamic type. */
925 gfc_trans_class_init_assign (gfc_code
*code
)
929 gfc_se dst
,src
,memsz
;
930 gfc_expr
*lhs
, *rhs
, *sz
;
932 gfc_start_block (&block
);
934 lhs
= gfc_copy_expr (code
->expr1
);
935 gfc_add_data_component (lhs
);
937 rhs
= gfc_copy_expr (code
->expr1
);
938 gfc_add_vptr_component (rhs
);
940 /* Make sure that the component backend_decls have been built, which
941 will not have happened if the derived types concerned have not
943 gfc_get_derived_type (rhs
->ts
.u
.derived
);
944 gfc_add_def_init_component (rhs
);
946 if (code
->expr1
->ts
.type
== BT_CLASS
947 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
948 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
951 sz
= gfc_copy_expr (code
->expr1
);
952 gfc_add_vptr_component (sz
);
953 gfc_add_size_component (sz
);
955 gfc_init_se (&dst
, NULL
);
956 gfc_init_se (&src
, NULL
);
957 gfc_init_se (&memsz
, NULL
);
958 gfc_conv_expr (&dst
, lhs
);
959 gfc_conv_expr (&src
, rhs
);
960 gfc_conv_expr (&memsz
, sz
);
961 gfc_add_block_to_block (&block
, &src
.pre
);
962 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
964 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
967 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
968 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
970 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
971 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
973 build_empty_stmt (input_location
));
976 gfc_add_expr_to_block (&block
, tmp
);
978 return gfc_finish_block (&block
);
982 /* Translate an assignment to a CLASS object
983 (pointer or ordinary assignment). */
986 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
994 gfc_start_block (&block
);
997 while (ref
&& ref
->next
)
1000 /* Class valued proc_pointer assignments do not need any further
1002 if (ref
&& ref
->type
== REF_COMPONENT
1003 && ref
->u
.c
.component
->attr
.proc_pointer
1004 && expr2
->expr_type
== EXPR_VARIABLE
1005 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1006 && op
== EXEC_POINTER_ASSIGN
)
1009 if (expr2
->ts
.type
!= BT_CLASS
)
1011 /* Insert an additional assignment which sets the '_vptr' field. */
1012 gfc_symbol
*vtab
= NULL
;
1015 lhs
= gfc_copy_expr (expr1
);
1016 gfc_add_vptr_component (lhs
);
1018 if (UNLIMITED_POLY (expr1
)
1019 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1021 rhs
= gfc_get_null_expr (&expr2
->where
);
1025 if (expr2
->expr_type
== EXPR_NULL
)
1026 vtab
= gfc_find_vtab (&expr1
->ts
);
1028 vtab
= gfc_find_vtab (&expr2
->ts
);
1031 rhs
= gfc_get_expr ();
1032 rhs
->expr_type
= EXPR_VARIABLE
;
1033 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1037 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1038 gfc_add_expr_to_block (&block
, tmp
);
1040 gfc_free_expr (lhs
);
1041 gfc_free_expr (rhs
);
1043 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1045 /* F2003:C717 only sequence and bind-C types can come here. */
1046 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1047 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1048 gfc_add_data_component (expr2
);
1051 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1053 /* Insert an additional assignment which sets the '_vptr' field. */
1054 lhs
= gfc_copy_expr (expr1
);
1055 gfc_add_vptr_component (lhs
);
1057 rhs
= gfc_copy_expr (expr2
);
1058 gfc_add_vptr_component (rhs
);
1060 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1061 gfc_add_expr_to_block (&block
, tmp
);
1063 gfc_free_expr (lhs
);
1064 gfc_free_expr (rhs
);
1067 /* Do the actual CLASS assignment. */
1068 if (expr2
->ts
.type
== BT_CLASS
1069 && !CLASS_DATA (expr2
)->attr
.dimension
)
1071 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1072 || !CLASS_DATA (expr2
)->attr
.dimension
)
1073 gfc_add_data_component (expr1
);
1077 if (op
== EXEC_ASSIGN
)
1078 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1079 else if (op
== EXEC_POINTER_ASSIGN
)
1080 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1084 gfc_add_expr_to_block (&block
, tmp
);
1086 return gfc_finish_block (&block
);
1090 /* End of prototype trans-class.c */
1094 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1096 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
1097 && gfc_option
.warn_realloc_lhs
)
1098 gfc_warning ("Code for reallocating the allocatable array at %L will "
1100 else if (gfc_option
.warn_realloc_lhs_all
)
1101 gfc_warning ("Code for reallocating the allocatable variable at %L "
1102 "will be added", where
);
1106 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1107 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1110 /* Copy the scalarization loop variables. */
1113 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1116 dest
->loop
= src
->loop
;
1120 /* Initialize a simple expression holder.
1122 Care must be taken when multiple se are created with the same parent.
1123 The child se must be kept in sync. The easiest way is to delay creation
1124 of a child se until after after the previous se has been translated. */
1127 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1129 memset (se
, 0, sizeof (gfc_se
));
1130 gfc_init_block (&se
->pre
);
1131 gfc_init_block (&se
->post
);
1133 se
->parent
= parent
;
1136 gfc_copy_se_loopvars (se
, parent
);
1140 /* Advances to the next SS in the chain. Use this rather than setting
1141 se->ss = se->ss->next because all the parents needs to be kept in sync.
1145 gfc_advance_se_ss_chain (gfc_se
* se
)
1150 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1153 /* Walk down the parent chain. */
1156 /* Simple consistency check. */
1157 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1158 || p
->parent
->ss
->nested_ss
== p
->ss
);
1160 /* If we were in a nested loop, the next scalarized expression can be
1161 on the parent ss' next pointer. Thus we should not take the next
1162 pointer blindly, but rather go up one nest level as long as next
1163 is the end of chain. */
1165 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1175 /* Ensures the result of the expression as either a temporary variable
1176 or a constant so that it can be used repeatedly. */
1179 gfc_make_safe_expr (gfc_se
* se
)
1183 if (CONSTANT_CLASS_P (se
->expr
))
1186 /* We need a temporary for this result. */
1187 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1188 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1193 /* Return an expression which determines if a dummy parameter is present.
1194 Also used for arguments to procedures with multiple entry points. */
1197 gfc_conv_expr_present (gfc_symbol
* sym
)
1201 gcc_assert (sym
->attr
.dummy
);
1202 decl
= gfc_get_symbol_decl (sym
);
1204 /* Intrinsic scalars with VALUE attribute which are passed by value
1205 use a hidden argument to denote the present status. */
1206 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1207 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1208 && !sym
->attr
.dimension
)
1210 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1213 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1215 strcpy (&name
[1], sym
->name
);
1216 tree_name
= get_identifier (name
);
1218 /* Walk function argument list to find hidden arg. */
1219 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1220 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1221 if (DECL_NAME (cond
) == tree_name
)
1228 if (TREE_CODE (decl
) != PARM_DECL
)
1230 /* Array parameters use a temporary descriptor, we want the real
1232 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1233 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1234 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1237 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1238 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1240 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1241 as actual argument to denote absent dummies. For array descriptors,
1242 we thus also need to check the array descriptor. For BT_CLASS, it
1243 can also occur for scalars and F2003 due to type->class wrapping and
1244 class->class wrapping. Note further that BT_CLASS always uses an
1245 array descriptor for arrays, also for explicit-shape/assumed-size. */
1247 if (!sym
->attr
.allocatable
1248 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1249 || (sym
->ts
.type
== BT_CLASS
1250 && !CLASS_DATA (sym
)->attr
.allocatable
1251 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1252 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1253 || sym
->ts
.type
== BT_CLASS
))
1257 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1258 || sym
->as
->type
== AS_ASSUMED_RANK
1259 || sym
->attr
.codimension
))
1260 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1262 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1263 if (sym
->ts
.type
== BT_CLASS
)
1264 tmp
= gfc_class_data_get (tmp
);
1265 tmp
= gfc_conv_array_data (tmp
);
1267 else if (sym
->ts
.type
== BT_CLASS
)
1268 tmp
= gfc_class_data_get (decl
);
1272 if (tmp
!= NULL_TREE
)
1274 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1275 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1276 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1277 boolean_type_node
, cond
, tmp
);
1285 /* Converts a missing, dummy argument into a null or zero. */
1288 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1293 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1297 /* Create a temporary and convert it to the correct type. */
1298 tmp
= gfc_get_int_type (kind
);
1299 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1302 /* Test for a NULL value. */
1303 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1304 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1305 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1306 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1310 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1312 build_zero_cst (TREE_TYPE (se
->expr
)));
1313 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1317 if (ts
.type
== BT_CHARACTER
)
1319 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1320 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1321 present
, se
->string_length
, tmp
);
1322 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1323 se
->string_length
= tmp
;
1329 /* Get the character length of an expression, looking through gfc_refs
1333 gfc_get_expr_charlen (gfc_expr
*e
)
1338 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1339 && e
->ts
.type
== BT_CHARACTER
);
1341 length
= NULL
; /* To silence compiler warning. */
1343 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1346 gfc_init_se (&tmpse
, NULL
);
1347 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1348 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1352 /* First candidate: if the variable is of type CHARACTER, the
1353 expression's length could be the length of the character
1355 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1356 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1358 /* Look through the reference chain for component references. */
1359 for (r
= e
->ref
; r
; r
= r
->next
)
1364 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1365 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1373 /* We should never got substring references here. These will be
1374 broken down by the scalarizer. */
1380 gcc_assert (length
!= NULL
);
1385 /* Return for an expression the backend decl of the coarray. */
1388 get_tree_for_caf_expr (gfc_expr
*expr
)
1390 tree caf_decl
= NULL_TREE
;
1393 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1394 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1395 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1397 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1398 if (ref
->type
== REF_COMPONENT
)
1400 gfc_component
*comp
= ref
->u
.c
.component
;
1401 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
1402 caf_decl
= NULL_TREE
;
1403 if (comp
->attr
.codimension
)
1404 caf_decl
= comp
->backend_decl
;
1407 gcc_assert (caf_decl
!= NULL_TREE
);
1412 /* For each character array constructor subexpression without a ts.u.cl->length,
1413 replace it by its first element (if there aren't any elements, the length
1414 should already be set to zero). */
1417 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1419 gfc_actual_arglist
* arg
;
1425 switch (e
->expr_type
)
1429 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1430 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1434 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1438 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1439 flatten_array_ctors_without_strlen (arg
->expr
);
1444 /* We've found what we're looking for. */
1445 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1450 gcc_assert (e
->value
.constructor
);
1452 c
= gfc_constructor_first (e
->value
.constructor
);
1456 flatten_array_ctors_without_strlen (new_expr
);
1457 gfc_replace_expr (e
, new_expr
);
1461 /* Otherwise, fall through to handle constructor elements. */
1462 case EXPR_STRUCTURE
:
1463 for (c
= gfc_constructor_first (e
->value
.constructor
);
1464 c
; c
= gfc_constructor_next (c
))
1465 flatten_array_ctors_without_strlen (c
->expr
);
1475 /* Generate code to initialize a string length variable. Returns the
1476 value. For array constructors, cl->length might be NULL and in this case,
1477 the first element of the constructor is needed. expr is the original
1478 expression so we can access it but can be NULL if this is not needed. */
1481 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1485 gfc_init_se (&se
, NULL
);
1489 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1492 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1493 "flatten" array constructors by taking their first element; all elements
1494 should be the same length or a cl->length should be present. */
1497 gfc_expr
* expr_flat
;
1499 expr_flat
= gfc_copy_expr (expr
);
1500 flatten_array_ctors_without_strlen (expr_flat
);
1501 gfc_resolve_expr (expr_flat
);
1503 gfc_conv_expr (&se
, expr_flat
);
1504 gfc_add_block_to_block (pblock
, &se
.pre
);
1505 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1507 gfc_free_expr (expr_flat
);
1511 /* Convert cl->length. */
1513 gcc_assert (cl
->length
);
1515 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1516 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1517 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1518 gfc_add_block_to_block (pblock
, &se
.pre
);
1520 if (cl
->backend_decl
)
1521 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1523 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1528 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1529 const char *name
, locus
*where
)
1539 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1540 type
= build_pointer_type (type
);
1542 gfc_init_se (&start
, se
);
1543 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1544 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1546 if (integer_onep (start
.expr
))
1547 gfc_conv_string_parameter (se
);
1552 /* Avoid multiple evaluation of substring start. */
1553 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1554 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1556 /* Change the start of the string. */
1557 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1560 tmp
= build_fold_indirect_ref_loc (input_location
,
1562 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1563 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1566 /* Length = end + 1 - start. */
1567 gfc_init_se (&end
, se
);
1568 if (ref
->u
.ss
.end
== NULL
)
1569 end
.expr
= se
->string_length
;
1572 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1573 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1577 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1578 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1580 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1582 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1583 boolean_type_node
, start
.expr
,
1586 /* Check lower bound. */
1587 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1589 build_int_cst (gfc_charlen_type_node
, 1));
1590 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1591 boolean_type_node
, nonempty
, fault
);
1593 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1594 "is less than one", name
);
1596 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1597 "is less than one");
1598 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1599 fold_convert (long_integer_type_node
,
1603 /* Check upper bound. */
1604 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1605 end
.expr
, se
->string_length
);
1606 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1607 boolean_type_node
, nonempty
, fault
);
1609 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1610 "exceeds string length (%%ld)", name
);
1612 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1613 "exceeds string length (%%ld)");
1614 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1615 fold_convert (long_integer_type_node
, end
.expr
),
1616 fold_convert (long_integer_type_node
,
1617 se
->string_length
));
1621 /* Try to calculate the length from the start and end expressions. */
1623 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1627 i_len
= mpz_get_si (length
) + 1;
1631 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1632 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1636 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1637 end
.expr
, start
.expr
);
1638 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1639 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1640 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1641 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1644 se
->string_length
= tmp
;
1648 /* Convert a derived type component reference. */
1651 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1658 c
= ref
->u
.c
.component
;
1660 gcc_assert (c
->backend_decl
);
1662 field
= c
->backend_decl
;
1663 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1666 /* Components can correspond to fields of different containing
1667 types, as components are created without context, whereas
1668 a concrete use of a component has the type of decl as context.
1669 So, if the type doesn't match, we search the corresponding
1670 FIELD_DECL in the parent type. To not waste too much time
1671 we cache this result in norestrict_decl. */
1673 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1675 tree f2
= c
->norestrict_decl
;
1676 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1677 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1678 if (TREE_CODE (f2
) == FIELD_DECL
1679 && DECL_NAME (f2
) == DECL_NAME (field
))
1682 c
->norestrict_decl
= f2
;
1686 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1687 decl
, field
, NULL_TREE
);
1691 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1693 tmp
= c
->ts
.u
.cl
->backend_decl
;
1694 /* Components must always be constant length. */
1695 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1696 se
->string_length
= tmp
;
1699 if (gfc_deferred_strlen (c
, &field
))
1701 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1703 decl
, field
, NULL_TREE
);
1704 se
->string_length
= tmp
;
1707 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1708 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1709 && c
->ts
.type
!= BT_CHARACTER
)
1710 || c
->attr
.proc_pointer
)
1711 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1716 /* This function deals with component references to components of the
1717 parent type for derived type extensions. */
1719 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1727 c
= ref
->u
.c
.component
;
1729 /* Return if the component is in the parent type. */
1730 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1731 if (strcmp (c
->name
, cmp
->name
) == 0)
1734 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1735 parent
.type
= REF_COMPONENT
;
1737 parent
.u
.c
.sym
= dt
;
1738 parent
.u
.c
.component
= dt
->components
;
1740 if (dt
->backend_decl
== NULL
)
1741 gfc_get_derived_type (dt
);
1743 /* Build the reference and call self. */
1744 gfc_conv_component_ref (se
, &parent
);
1745 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1746 parent
.u
.c
.component
= c
;
1747 conv_parent_component_references (se
, &parent
);
1750 /* Return the contents of a variable. Also handles reference/pointer
1751 variables (all Fortran pointer references are implicit). */
1754 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1759 tree parent_decl
= NULL_TREE
;
1762 bool alternate_entry
;
1765 sym
= expr
->symtree
->n
.sym
;
1769 gfc_ss_info
*ss_info
= ss
->info
;
1771 /* Check that something hasn't gone horribly wrong. */
1772 gcc_assert (ss
!= gfc_ss_terminator
);
1773 gcc_assert (ss_info
->expr
== expr
);
1775 /* A scalarized term. We already know the descriptor. */
1776 se
->expr
= ss_info
->data
.array
.descriptor
;
1777 se
->string_length
= ss_info
->string_length
;
1778 ref
= ss_info
->data
.array
.ref
;
1780 gcc_assert (ref
->type
== REF_ARRAY
1781 && ref
->u
.ar
.type
!= AR_ELEMENT
);
1783 gfc_conv_tmp_array_ref (se
);
1787 tree se_expr
= NULL_TREE
;
1789 se
->expr
= gfc_get_symbol_decl (sym
);
1791 /* Deal with references to a parent results or entries by storing
1792 the current_function_decl and moving to the parent_decl. */
1793 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1794 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1795 && sym
->result
== sym
;
1796 entry_master
= sym
->attr
.result
1797 && sym
->ns
->proc_name
->attr
.entry_master
1798 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1799 if (current_function_decl
)
1800 parent_decl
= DECL_CONTEXT (current_function_decl
);
1802 if ((se
->expr
== parent_decl
&& return_value
)
1803 || (sym
->ns
&& sym
->ns
->proc_name
1805 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1806 && (alternate_entry
|| entry_master
)))
1811 /* Special case for assigning the return value of a function.
1812 Self recursive functions must have an explicit return value. */
1813 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1814 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1816 /* Similarly for alternate entry points. */
1817 else if (alternate_entry
1818 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1821 gfc_entry_list
*el
= NULL
;
1823 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1826 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1831 else if (entry_master
1832 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1834 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1839 /* Procedure actual arguments. */
1840 else if (sym
->attr
.flavor
== FL_PROCEDURE
1841 && se
->expr
!= current_function_decl
)
1843 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1845 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1846 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1852 /* Dereference the expression, where needed. Since characters
1853 are entirely different from other types, they are treated
1855 if (sym
->ts
.type
== BT_CHARACTER
)
1857 /* Dereference character pointer dummy arguments
1859 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1861 || sym
->attr
.function
1862 || sym
->attr
.result
))
1863 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1867 else if (!sym
->attr
.value
)
1869 /* Dereference non-character scalar dummy arguments. */
1870 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1871 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1872 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1875 /* Dereference scalar hidden result. */
1876 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1877 && (sym
->attr
.function
|| sym
->attr
.result
)
1878 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1879 && !sym
->attr
.always_explicit
)
1880 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1883 /* Dereference non-character pointer variables.
1884 These must be dummies, results, or scalars. */
1885 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1886 || gfc_is_associate_pointer (sym
)
1887 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1889 || sym
->attr
.function
1891 || (!sym
->attr
.dimension
1892 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1893 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1900 /* For character variables, also get the length. */
1901 if (sym
->ts
.type
== BT_CHARACTER
)
1903 /* If the character length of an entry isn't set, get the length from
1904 the master function instead. */
1905 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1906 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1908 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1909 gcc_assert (se
->string_length
);
1917 /* Return the descriptor if that's what we want and this is an array
1918 section reference. */
1919 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1921 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1922 /* Return the descriptor for array pointers and allocations. */
1923 if (se
->want_pointer
1924 && ref
->next
== NULL
&& (se
->descriptor_only
))
1927 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
1928 /* Return a pointer to an element. */
1932 if (ref
->u
.c
.sym
->attr
.extension
)
1933 conv_parent_component_references (se
, ref
);
1935 gfc_conv_component_ref (se
, ref
);
1936 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
1937 && se
->want_pointer
&& se
->descriptor_only
)
1943 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1944 expr
->symtree
->name
, &expr
->where
);
1953 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1955 if (se
->want_pointer
)
1957 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1958 gfc_conv_string_parameter (se
);
1960 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1965 /* Unary ops are easy... Or they would be if ! was a valid op. */
1968 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1973 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1974 /* Initialize the operand. */
1975 gfc_init_se (&operand
, se
);
1976 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1977 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1979 type
= gfc_typenode_for_spec (&expr
->ts
);
1981 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1982 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1983 All other unary operators have an equivalent GIMPLE unary operator. */
1984 if (code
== TRUTH_NOT_EXPR
)
1985 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1986 build_int_cst (type
, 0));
1988 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1992 /* Expand power operator to optimal multiplications when a value is raised
1993 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1994 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1995 Programming", 3rd Edition, 1998. */
1997 /* This code is mostly duplicated from expand_powi in the backend.
1998 We establish the "optimal power tree" lookup table with the defined size.
1999 The items in the table are the exponents used to calculate the index
2000 exponents. Any integer n less than the value can get an "addition chain",
2001 with the first node being one. */
2002 #define POWI_TABLE_SIZE 256
2004 /* The table is from builtins.c. */
2005 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2007 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2008 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2009 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2010 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2011 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2012 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2013 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2014 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2015 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2016 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2017 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2018 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2019 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2020 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2021 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2022 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2023 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2024 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2025 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2026 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2027 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2028 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2029 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2030 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2031 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2032 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2033 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2034 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2035 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2036 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2037 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2038 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2041 /* If n is larger than lookup table's max index, we use the "window
2043 #define POWI_WINDOW_SIZE 3
2045 /* Recursive function to expand the power operator. The temporary
2046 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2048 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2055 if (n
< POWI_TABLE_SIZE
)
2060 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2061 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2065 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2066 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2067 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2071 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2075 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2076 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2078 if (n
< POWI_TABLE_SIZE
)
2085 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2086 return 1. Else return 0 and a call to runtime library functions
2087 will have to be built. */
2089 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2094 tree vartmp
[POWI_TABLE_SIZE
];
2096 unsigned HOST_WIDE_INT n
;
2099 /* If exponent is too large, we won't expand it anyway, so don't bother
2100 with large integer values. */
2101 if (!TREE_INT_CST (rhs
).fits_shwi ())
2104 m
= TREE_INT_CST (rhs
).to_shwi ();
2105 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2106 of the asymmetric range of the integer type. */
2107 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2109 type
= TREE_TYPE (lhs
);
2110 sgn
= tree_int_cst_sgn (rhs
);
2112 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2113 || optimize_size
) && (m
> 2 || m
< -1))
2119 se
->expr
= gfc_build_const (type
, integer_one_node
);
2123 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2124 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2126 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2127 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2128 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2129 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2132 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2135 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2136 boolean_type_node
, tmp
, cond
);
2137 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2138 tmp
, build_int_cst (type
, 1),
2139 build_int_cst (type
, 0));
2143 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2144 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2145 build_int_cst (type
, -1),
2146 build_int_cst (type
, 0));
2147 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2148 cond
, build_int_cst (type
, 1), tmp
);
2152 memset (vartmp
, 0, sizeof (vartmp
));
2156 tmp
= gfc_build_const (type
, integer_one_node
);
2157 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2161 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2167 /* Power op (**). Constant integer exponent has special handling. */
2170 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2172 tree gfc_int4_type_node
;
2175 int res_ikind_1
, res_ikind_2
;
2180 gfc_init_se (&lse
, se
);
2181 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2182 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2183 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2185 gfc_init_se (&rse
, se
);
2186 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2187 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2189 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2190 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2191 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2194 gfc_int4_type_node
= gfc_get_int_type (4);
2196 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2197 library routine. But in the end, we have to convert the result back
2198 if this case applies -- with res_ikind_K, we keep track whether operand K
2199 falls into this case. */
2203 kind
= expr
->value
.op
.op1
->ts
.kind
;
2204 switch (expr
->value
.op
.op2
->ts
.type
)
2207 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2212 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2213 res_ikind_2
= ikind
;
2235 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2237 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2264 switch (expr
->value
.op
.op1
->ts
.type
)
2267 if (kind
== 3) /* Case 16 was not handled properly above. */
2269 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2273 /* Use builtins for real ** int4. */
2279 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2283 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2287 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2291 /* Use the __builtin_powil() only if real(kind=16) is
2292 actually the C long double type. */
2293 if (!gfc_real16_is_float128
)
2294 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2302 /* If we don't have a good builtin for this, go for the
2303 library function. */
2305 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2309 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2318 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2322 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2330 se
->expr
= build_call_expr_loc (input_location
,
2331 fndecl
, 2, lse
.expr
, rse
.expr
);
2333 /* Convert the result back if it is of wrong integer kind. */
2334 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2336 /* We want the maximum of both operand kinds as result. */
2337 if (res_ikind_1
< res_ikind_2
)
2338 res_ikind_1
= res_ikind_2
;
2339 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2344 /* Generate code to allocate a string temporary. */
2347 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2352 if (gfc_can_put_var_on_stack (len
))
2354 /* Create a temporary variable to hold the result. */
2355 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2356 gfc_charlen_type_node
, len
,
2357 build_int_cst (gfc_charlen_type_node
, 1));
2358 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2360 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2361 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2363 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2365 var
= gfc_create_var (tmp
, "str");
2366 var
= gfc_build_addr_expr (type
, var
);
2370 /* Allocate a temporary to hold the result. */
2371 var
= gfc_create_var (type
, "pstr");
2372 gcc_assert (POINTER_TYPE_P (type
));
2373 tmp
= TREE_TYPE (type
);
2374 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2375 tmp
= TREE_TYPE (tmp
);
2376 tmp
= TYPE_SIZE_UNIT (tmp
);
2377 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2378 fold_convert (size_type_node
, len
),
2379 fold_convert (size_type_node
, tmp
));
2380 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2381 gfc_add_modify (&se
->pre
, var
, tmp
);
2383 /* Free the temporary afterwards. */
2384 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2385 gfc_add_expr_to_block (&se
->post
, tmp
);
2392 /* Handle a string concatenation operation. A temporary will be allocated to
2396 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2399 tree len
, type
, var
, tmp
, fndecl
;
2401 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2402 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2403 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2405 gfc_init_se (&lse
, se
);
2406 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2407 gfc_conv_string_parameter (&lse
);
2408 gfc_init_se (&rse
, se
);
2409 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2410 gfc_conv_string_parameter (&rse
);
2412 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2413 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2415 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2416 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2417 if (len
== NULL_TREE
)
2419 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2420 TREE_TYPE (lse
.string_length
),
2421 lse
.string_length
, rse
.string_length
);
2424 type
= build_pointer_type (type
);
2426 var
= gfc_conv_string_tmp (se
, type
, len
);
2428 /* Do the actual concatenation. */
2429 if (expr
->ts
.kind
== 1)
2430 fndecl
= gfor_fndecl_concat_string
;
2431 else if (expr
->ts
.kind
== 4)
2432 fndecl
= gfor_fndecl_concat_string_char4
;
2436 tmp
= build_call_expr_loc (input_location
,
2437 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2438 rse
.string_length
, rse
.expr
);
2439 gfc_add_expr_to_block (&se
->pre
, tmp
);
2441 /* Add the cleanup for the operands. */
2442 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2443 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2446 se
->string_length
= len
;
2449 /* Translates an op expression. Common (binary) cases are handled by this
2450 function, others are passed on. Recursion is used in either case.
2451 We use the fact that (op1.ts == op2.ts) (except for the power
2453 Operators need no special handling for scalarized expressions as long as
2454 they call gfc_conv_simple_val to get their operands.
2455 Character strings get special handling. */
2458 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2460 enum tree_code code
;
2469 switch (expr
->value
.op
.op
)
2471 case INTRINSIC_PARENTHESES
:
2472 if ((expr
->ts
.type
== BT_REAL
2473 || expr
->ts
.type
== BT_COMPLEX
)
2474 && gfc_option
.flag_protect_parens
)
2476 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2477 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2482 case INTRINSIC_UPLUS
:
2483 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2486 case INTRINSIC_UMINUS
:
2487 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2491 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2494 case INTRINSIC_PLUS
:
2498 case INTRINSIC_MINUS
:
2502 case INTRINSIC_TIMES
:
2506 case INTRINSIC_DIVIDE
:
2507 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2508 an integer, we must round towards zero, so we use a
2510 if (expr
->ts
.type
== BT_INTEGER
)
2511 code
= TRUNC_DIV_EXPR
;
2516 case INTRINSIC_POWER
:
2517 gfc_conv_power_op (se
, expr
);
2520 case INTRINSIC_CONCAT
:
2521 gfc_conv_concat_op (se
, expr
);
2525 code
= TRUTH_ANDIF_EXPR
;
2530 code
= TRUTH_ORIF_EXPR
;
2534 /* EQV and NEQV only work on logicals, but since we represent them
2535 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2537 case INTRINSIC_EQ_OS
:
2545 case INTRINSIC_NE_OS
:
2546 case INTRINSIC_NEQV
:
2553 case INTRINSIC_GT_OS
:
2560 case INTRINSIC_GE_OS
:
2567 case INTRINSIC_LT_OS
:
2574 case INTRINSIC_LE_OS
:
2580 case INTRINSIC_USER
:
2581 case INTRINSIC_ASSIGN
:
2582 /* These should be converted into function calls by the frontend. */
2586 fatal_error ("Unknown intrinsic op");
2590 /* The only exception to this is **, which is handled separately anyway. */
2591 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2593 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2597 gfc_init_se (&lse
, se
);
2598 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2599 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2602 gfc_init_se (&rse
, se
);
2603 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2604 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2608 gfc_conv_string_parameter (&lse
);
2609 gfc_conv_string_parameter (&rse
);
2611 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2612 rse
.string_length
, rse
.expr
,
2613 expr
->value
.op
.op1
->ts
.kind
,
2615 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2616 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2619 type
= gfc_typenode_for_spec (&expr
->ts
);
2623 /* The result of logical ops is always boolean_type_node. */
2624 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2625 lse
.expr
, rse
.expr
);
2626 se
->expr
= convert (type
, tmp
);
2629 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2631 /* Add the post blocks. */
2632 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2633 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2636 /* If a string's length is one, we convert it to a single character. */
2639 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2643 || !INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2644 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2647 if (TREE_INT_CST_LOW (len
) == 1)
2649 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2650 return build_fold_indirect_ref_loc (input_location
, str
);
2654 && TREE_CODE (str
) == ADDR_EXPR
2655 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2656 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2657 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2658 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2659 && TREE_INT_CST_LOW (len
) > 1
2660 && TREE_INT_CST_LOW (len
)
2661 == (unsigned HOST_WIDE_INT
)
2662 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2664 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2665 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2666 if (TREE_CODE (ret
) == INTEGER_CST
)
2668 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2669 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2670 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2672 for (i
= 1; i
< length
; i
++)
2685 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2688 if (sym
->backend_decl
)
2690 /* This becomes the nominal_type in
2691 function.c:assign_parm_find_data_types. */
2692 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2693 /* This becomes the passed_type in
2694 function.c:assign_parm_find_data_types. C promotes char to
2695 integer for argument passing. */
2696 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2698 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2703 /* If we have a constant character expression, make it into an
2705 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2710 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2711 (int)(*expr
)->value
.character
.string
[0]);
2712 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2714 /* The expr needs to be compatible with a C int. If the
2715 conversion fails, then the 2 causes an ICE. */
2716 ts
.type
= BT_INTEGER
;
2717 ts
.kind
= gfc_c_int_kind
;
2718 gfc_convert_type (*expr
, &ts
, 2);
2721 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2723 if ((*expr
)->ref
== NULL
)
2725 se
->expr
= gfc_string_to_single_character
2726 (build_int_cst (integer_type_node
, 1),
2727 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2729 ((*expr
)->symtree
->n
.sym
)),
2734 gfc_conv_variable (se
, *expr
);
2735 se
->expr
= gfc_string_to_single_character
2736 (build_int_cst (integer_type_node
, 1),
2737 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2745 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2746 if STR is a string literal, otherwise return -1. */
2749 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2752 && TREE_CODE (str
) == ADDR_EXPR
2753 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2754 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2755 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2756 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2757 && TREE_INT_CST_LOW (len
) >= 1
2758 && TREE_INT_CST_LOW (len
)
2759 == (unsigned HOST_WIDE_INT
)
2760 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2762 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2763 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2764 if (TREE_CODE (folded
) == INTEGER_CST
)
2766 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2767 int length
= TREE_STRING_LENGTH (string_cst
);
2768 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2770 for (; length
> 0; length
--)
2771 if (ptr
[length
- 1] != ' ')
2780 /* Helper to build a call to memcmp. */
2783 build_memcmp_call (tree s1
, tree s2
, tree n
)
2787 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
2788 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
2790 s1
= fold_convert (pvoid_type_node
, s1
);
2792 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
2793 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
2795 s2
= fold_convert (pvoid_type_node
, s2
);
2797 n
= fold_convert (size_type_node
, n
);
2799 tmp
= build_call_expr_loc (input_location
,
2800 builtin_decl_explicit (BUILT_IN_MEMCMP
),
2803 return fold_convert (integer_type_node
, tmp
);
2806 /* Compare two strings. If they are all single characters, the result is the
2807 subtraction of them. Otherwise, we build a library call. */
2810 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2811 enum tree_code code
)
2817 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2818 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2820 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2821 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2823 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2825 /* Deal with single character specially. */
2826 sc1
= fold_convert (integer_type_node
, sc1
);
2827 sc2
= fold_convert (integer_type_node
, sc2
);
2828 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2832 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2834 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2836 /* If one string is a string literal with LEN_TRIM longer
2837 than the length of the second string, the strings
2839 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2840 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2841 return integer_one_node
;
2842 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2843 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2844 return integer_one_node
;
2847 /* We can compare via memcpy if the strings are known to be equal
2848 in length and they are
2850 - kind=4 and the comparison is for (in)equality. */
2852 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
2853 && tree_int_cst_equal (len1
, len2
)
2854 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
2859 chartype
= gfc_get_char_type (kind
);
2860 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
2861 fold_convert (TREE_TYPE(len1
),
2862 TYPE_SIZE_UNIT(chartype
)),
2864 return build_memcmp_call (str1
, str2
, tmp
);
2867 /* Build a call for the comparison. */
2869 fndecl
= gfor_fndecl_compare_string
;
2871 fndecl
= gfor_fndecl_compare_string_char4
;
2875 return build_call_expr_loc (input_location
, fndecl
, 4,
2876 len1
, str1
, len2
, str2
);
2880 /* Return the backend_decl for a procedure pointer component. */
2883 get_proc_ptr_comp (gfc_expr
*e
)
2889 gfc_init_se (&comp_se
, NULL
);
2890 e2
= gfc_copy_expr (e
);
2891 /* We have to restore the expr type later so that gfc_free_expr frees
2892 the exact same thing that was allocated.
2893 TODO: This is ugly. */
2894 old_type
= e2
->expr_type
;
2895 e2
->expr_type
= EXPR_VARIABLE
;
2896 gfc_conv_expr (&comp_se
, e2
);
2897 e2
->expr_type
= old_type
;
2899 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2903 /* Convert a typebound function reference from a class object. */
2905 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2910 if (TREE_CODE (base_object
) != VAR_DECL
)
2912 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2913 gfc_add_modify (&se
->pre
, var
, base_object
);
2915 se
->expr
= gfc_class_vptr_get (base_object
);
2916 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2918 while (ref
&& ref
->next
)
2920 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2921 if (ref
->u
.c
.sym
->attr
.extension
)
2922 conv_parent_component_references (se
, ref
);
2923 gfc_conv_component_ref (se
, ref
);
2924 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2929 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2933 if (gfc_is_proc_ptr_comp (expr
))
2934 tmp
= get_proc_ptr_comp (expr
);
2935 else if (sym
->attr
.dummy
)
2937 tmp
= gfc_get_symbol_decl (sym
);
2938 if (sym
->attr
.proc_pointer
)
2939 tmp
= build_fold_indirect_ref_loc (input_location
,
2941 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2942 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2946 if (!sym
->backend_decl
)
2947 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2949 TREE_USED (sym
->backend_decl
) = 1;
2951 tmp
= sym
->backend_decl
;
2953 if (sym
->attr
.cray_pointee
)
2955 /* TODO - make the cray pointee a pointer to a procedure,
2956 assign the pointer to it and use it for the call. This
2958 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2959 gfc_get_symbol_decl (sym
->cp_pointer
));
2960 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2963 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2965 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2966 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2973 /* Initialize MAPPING. */
2976 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2978 mapping
->syms
= NULL
;
2979 mapping
->charlens
= NULL
;
2983 /* Free all memory held by MAPPING (but not MAPPING itself). */
2986 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2988 gfc_interface_sym_mapping
*sym
;
2989 gfc_interface_sym_mapping
*nextsym
;
2991 gfc_charlen
*nextcl
;
2993 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2995 nextsym
= sym
->next
;
2996 sym
->new_sym
->n
.sym
->formal
= NULL
;
2997 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2998 gfc_free_expr (sym
->expr
);
2999 free (sym
->new_sym
);
3002 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3005 gfc_free_expr (cl
->length
);
3011 /* Return a copy of gfc_charlen CL. Add the returned structure to
3012 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3014 static gfc_charlen
*
3015 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3018 gfc_charlen
*new_charlen
;
3020 new_charlen
= gfc_get_charlen ();
3021 new_charlen
->next
= mapping
->charlens
;
3022 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3024 mapping
->charlens
= new_charlen
;
3029 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3030 array variable that can be used as the actual argument for dummy
3031 argument SYM. Add any initialization code to BLOCK. PACKED is as
3032 for gfc_get_nodesc_array_type and DATA points to the first element
3033 in the passed array. */
3036 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3037 gfc_packed packed
, tree data
)
3042 type
= gfc_typenode_for_spec (&sym
->ts
);
3043 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3044 !sym
->attr
.target
&& !sym
->attr
.pointer
3045 && !sym
->attr
.proc_pointer
);
3047 var
= gfc_create_var (type
, "ifm");
3048 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3054 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3055 and offset of descriptorless array type TYPE given that it has the same
3056 size as DESC. Add any set-up code to BLOCK. */
3059 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3066 offset
= gfc_index_zero_node
;
3067 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3069 dim
= gfc_rank_cst
[n
];
3070 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3071 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3073 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3074 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3075 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3076 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3078 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3080 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3081 gfc_array_index_type
,
3082 gfc_conv_descriptor_ubound_get (desc
, dim
),
3083 gfc_conv_descriptor_lbound_get (desc
, dim
));
3084 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3085 gfc_array_index_type
,
3086 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3087 tmp
= gfc_evaluate_now (tmp
, block
);
3088 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3090 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3091 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3092 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3093 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3094 gfc_array_index_type
, offset
, tmp
);
3096 offset
= gfc_evaluate_now (offset
, block
);
3097 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3101 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3102 in SE. The caller may still use se->expr and se->string_length after
3103 calling this function. */
3106 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3107 gfc_symbol
* sym
, gfc_se
* se
,
3110 gfc_interface_sym_mapping
*sm
;
3114 gfc_symbol
*new_sym
;
3116 gfc_symtree
*new_symtree
;
3118 /* Create a new symbol to represent the actual argument. */
3119 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3120 new_sym
->ts
= sym
->ts
;
3121 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3122 new_sym
->attr
.referenced
= 1;
3123 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3124 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3125 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3126 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3127 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3128 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3129 new_sym
->attr
.function
= sym
->attr
.function
;
3131 /* Ensure that the interface is available and that
3132 descriptors are passed for array actual arguments. */
3133 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3135 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3136 new_sym
->attr
.always_explicit
3137 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3140 /* Create a fake symtree for it. */
3142 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3143 new_symtree
->n
.sym
= new_sym
;
3144 gcc_assert (new_symtree
== root
);
3146 /* Create a dummy->actual mapping. */
3147 sm
= XCNEW (gfc_interface_sym_mapping
);
3148 sm
->next
= mapping
->syms
;
3150 sm
->new_sym
= new_symtree
;
3151 sm
->expr
= gfc_copy_expr (expr
);
3154 /* Stabilize the argument's value. */
3155 if (!sym
->attr
.function
&& se
)
3156 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3158 if (sym
->ts
.type
== BT_CHARACTER
)
3160 /* Create a copy of the dummy argument's length. */
3161 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3162 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3164 /* If the length is specified as "*", record the length that
3165 the caller is passing. We should use the callee's length
3166 in all other cases. */
3167 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3169 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3170 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3177 /* Use the passed value as-is if the argument is a function. */
3178 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3181 /* If the argument is either a string or a pointer to a string,
3182 convert it to a boundless character type. */
3183 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3185 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3186 tmp
= build_pointer_type (tmp
);
3187 if (sym
->attr
.pointer
)
3188 value
= build_fold_indirect_ref_loc (input_location
,
3192 value
= fold_convert (tmp
, value
);
3195 /* If the argument is a scalar, a pointer to an array or an allocatable,
3197 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3198 value
= build_fold_indirect_ref_loc (input_location
,
3201 /* For character(*), use the actual argument's descriptor. */
3202 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3203 value
= build_fold_indirect_ref_loc (input_location
,
3206 /* If the argument is an array descriptor, use it to determine
3207 information about the actual argument's shape. */
3208 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3209 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3211 /* Get the actual argument's descriptor. */
3212 desc
= build_fold_indirect_ref_loc (input_location
,
3215 /* Create the replacement variable. */
3216 tmp
= gfc_conv_descriptor_data_get (desc
);
3217 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3220 /* Use DESC to work out the upper bounds, strides and offset. */
3221 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3224 /* Otherwise we have a packed array. */
3225 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3226 PACKED_FULL
, se
->expr
);
3228 new_sym
->backend_decl
= value
;
3232 /* Called once all dummy argument mappings have been added to MAPPING,
3233 but before the mapping is used to evaluate expressions. Pre-evaluate
3234 the length of each argument, adding any initialization code to PRE and
3235 any finalization code to POST. */
3238 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3239 stmtblock_t
* pre
, stmtblock_t
* post
)
3241 gfc_interface_sym_mapping
*sym
;
3245 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3246 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3247 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3249 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3250 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3251 gfc_init_se (&se
, NULL
);
3252 gfc_conv_expr (&se
, expr
);
3253 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3254 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3255 gfc_add_block_to_block (pre
, &se
.pre
);
3256 gfc_add_block_to_block (post
, &se
.post
);
3258 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3263 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3267 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3268 gfc_constructor_base base
)
3271 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3273 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3276 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3277 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3278 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3284 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3288 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3293 for (; ref
; ref
= ref
->next
)
3297 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3299 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3300 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3301 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3309 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3310 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3316 /* Convert intrinsic function calls into result expressions. */
3319 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3327 arg1
= expr
->value
.function
.actual
->expr
;
3328 if (expr
->value
.function
.actual
->next
)
3329 arg2
= expr
->value
.function
.actual
->next
->expr
;
3333 sym
= arg1
->symtree
->n
.sym
;
3335 if (sym
->attr
.dummy
)
3340 switch (expr
->value
.function
.isym
->id
)
3343 /* TODO figure out why this condition is necessary. */
3344 if (sym
->attr
.function
3345 && (arg1
->ts
.u
.cl
->length
== NULL
3346 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3347 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3350 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3354 if (!sym
->as
|| sym
->as
->rank
== 0)
3357 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3359 dup
= mpz_get_si (arg2
->value
.integer
);
3364 dup
= sym
->as
->rank
;
3368 for (; d
< dup
; d
++)
3372 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3374 gfc_free_expr (new_expr
);
3378 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3379 gfc_get_int_expr (gfc_default_integer_kind
,
3381 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3383 new_expr
= gfc_multiply (new_expr
, tmp
);
3389 case GFC_ISYM_LBOUND
:
3390 case GFC_ISYM_UBOUND
:
3391 /* TODO These implementations of lbound and ubound do not limit if
3392 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3394 if (!sym
->as
|| sym
->as
->rank
== 0)
3397 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3398 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3400 /* TODO: If the need arises, this could produce an array of
3404 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3406 if (sym
->as
->lower
[d
])
3407 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3411 if (sym
->as
->upper
[d
])
3412 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3420 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3424 gfc_replace_expr (expr
, new_expr
);
3430 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3431 gfc_interface_mapping
* mapping
)
3433 gfc_formal_arglist
*f
;
3434 gfc_actual_arglist
*actual
;
3436 actual
= expr
->value
.function
.actual
;
3437 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3439 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3444 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3447 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3452 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3454 for (d
= 0; d
< as
->rank
; d
++)
3456 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3457 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3460 expr
->value
.function
.esym
->as
= as
;
3463 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3465 expr
->value
.function
.esym
->ts
.u
.cl
->length
3466 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3468 gfc_apply_interface_mapping_to_expr (mapping
,
3469 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3474 /* EXPR is a copy of an expression that appeared in the interface
3475 associated with MAPPING. Walk it recursively looking for references to
3476 dummy arguments that MAPPING maps to actual arguments. Replace each such
3477 reference with a reference to the associated actual argument. */
3480 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3483 gfc_interface_sym_mapping
*sym
;
3484 gfc_actual_arglist
*actual
;
3489 /* Copying an expression does not copy its length, so do that here. */
3490 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3492 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3493 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3496 /* Apply the mapping to any references. */
3497 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3499 /* ...and to the expression's symbol, if it has one. */
3500 /* TODO Find out why the condition on expr->symtree had to be moved into
3501 the loop rather than being outside it, as originally. */
3502 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3503 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3505 if (sym
->new_sym
->n
.sym
->backend_decl
)
3506 expr
->symtree
= sym
->new_sym
;
3508 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3509 /* Replace base type for polymorphic arguments. */
3510 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3511 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3512 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3515 /* ...and to subexpressions in expr->value. */
3516 switch (expr
->expr_type
)
3521 case EXPR_SUBSTRING
:
3525 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3526 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3530 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3531 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3533 if (expr
->value
.function
.esym
== NULL
3534 && expr
->value
.function
.isym
!= NULL
3535 && expr
->value
.function
.actual
->expr
->symtree
3536 && gfc_map_intrinsic_function (expr
, mapping
))
3539 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3540 if (sym
->old
== expr
->value
.function
.esym
)
3542 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3543 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3544 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3549 case EXPR_STRUCTURE
:
3550 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3563 /* Evaluate interface expression EXPR using MAPPING. Store the result
3567 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3568 gfc_se
* se
, gfc_expr
* expr
)
3570 expr
= gfc_copy_expr (expr
);
3571 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3572 gfc_conv_expr (se
, expr
);
3573 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3574 gfc_free_expr (expr
);
3578 /* Returns a reference to a temporary array into which a component of
3579 an actual argument derived type array is copied and then returned
3580 after the function call. */
3582 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3583 sym_intent intent
, bool formal_ptr
)
3591 gfc_array_info
*info
;
3601 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3603 gfc_init_se (&lse
, NULL
);
3604 gfc_init_se (&rse
, NULL
);
3606 /* Walk the argument expression. */
3607 rss
= gfc_walk_expr (expr
);
3609 gcc_assert (rss
!= gfc_ss_terminator
);
3611 /* Initialize the scalarizer. */
3612 gfc_init_loopinfo (&loop
);
3613 gfc_add_ss_to_loop (&loop
, rss
);
3615 /* Calculate the bounds of the scalarization. */
3616 gfc_conv_ss_startstride (&loop
);
3618 /* Build an ss for the temporary. */
3619 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3620 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3622 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3623 if (GFC_ARRAY_TYPE_P (base_type
)
3624 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3625 base_type
= gfc_get_element_type (base_type
);
3627 if (expr
->ts
.type
== BT_CLASS
)
3628 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3630 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3631 ? expr
->ts
.u
.cl
->backend_decl
3635 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3637 /* Associate the SS with the loop. */
3638 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3640 /* Setup the scalarizing loops. */
3641 gfc_conv_loop_setup (&loop
, &expr
->where
);
3643 /* Pass the temporary descriptor back to the caller. */
3644 info
= &loop
.temp_ss
->info
->data
.array
;
3645 parmse
->expr
= info
->descriptor
;
3647 /* Setup the gfc_se structures. */
3648 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3649 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3652 lse
.ss
= loop
.temp_ss
;
3653 gfc_mark_ss_chain_used (rss
, 1);
3654 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3656 /* Start the scalarized loop body. */
3657 gfc_start_scalarized_body (&loop
, &body
);
3659 /* Translate the expression. */
3660 gfc_conv_expr (&rse
, expr
);
3662 gfc_conv_tmp_array_ref (&lse
);
3664 if (intent
!= INTENT_OUT
)
3666 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3667 gfc_add_expr_to_block (&body
, tmp
);
3668 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3669 gfc_trans_scalarizing_loops (&loop
, &body
);
3673 /* Make sure that the temporary declaration survives by merging
3674 all the loop declarations into the current context. */
3675 for (n
= 0; n
< loop
.dimen
; n
++)
3677 gfc_merge_block_scope (&body
);
3678 body
= loop
.code
[loop
.order
[n
]];
3680 gfc_merge_block_scope (&body
);
3683 /* Add the post block after the second loop, so that any
3684 freeing of allocated memory is done at the right time. */
3685 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3687 /**********Copy the temporary back again.*********/
3689 gfc_init_se (&lse
, NULL
);
3690 gfc_init_se (&rse
, NULL
);
3692 /* Walk the argument expression. */
3693 lss
= gfc_walk_expr (expr
);
3694 rse
.ss
= loop
.temp_ss
;
3697 /* Initialize the scalarizer. */
3698 gfc_init_loopinfo (&loop2
);
3699 gfc_add_ss_to_loop (&loop2
, lss
);
3701 /* Calculate the bounds of the scalarization. */
3702 gfc_conv_ss_startstride (&loop2
);
3704 /* Setup the scalarizing loops. */
3705 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3707 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3708 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3710 gfc_mark_ss_chain_used (lss
, 1);
3711 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3713 /* Declare the variable to hold the temporary offset and start the
3714 scalarized loop body. */
3715 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3716 gfc_start_scalarized_body (&loop2
, &body
);
3718 /* Build the offsets for the temporary from the loop variables. The
3719 temporary array has lbounds of zero and strides of one in all
3720 dimensions, so this is very simple. The offset is only computed
3721 outside the innermost loop, so the overall transfer could be
3722 optimized further. */
3723 info
= &rse
.ss
->info
->data
.array
;
3724 dimen
= rse
.ss
->dimen
;
3726 tmp_index
= gfc_index_zero_node
;
3727 for (n
= dimen
- 1; n
> 0; n
--)
3730 tmp
= rse
.loop
->loopvar
[n
];
3731 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3732 tmp
, rse
.loop
->from
[n
]);
3733 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3736 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3737 gfc_array_index_type
,
3738 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3739 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3740 gfc_array_index_type
,
3741 tmp_str
, gfc_index_one_node
);
3743 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3744 gfc_array_index_type
, tmp
, tmp_str
);
3747 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3748 gfc_array_index_type
,
3749 tmp_index
, rse
.loop
->from
[0]);
3750 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3752 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3753 gfc_array_index_type
,
3754 rse
.loop
->loopvar
[0], offset
);
3756 /* Now use the offset for the reference. */
3757 tmp
= build_fold_indirect_ref_loc (input_location
,
3759 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3761 if (expr
->ts
.type
== BT_CHARACTER
)
3762 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3764 gfc_conv_expr (&lse
, expr
);
3766 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3768 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3769 gfc_add_expr_to_block (&body
, tmp
);
3771 /* Generate the copying loops. */
3772 gfc_trans_scalarizing_loops (&loop2
, &body
);
3774 /* Wrap the whole thing up by adding the second loop to the post-block
3775 and following it by the post-block of the first loop. In this way,
3776 if the temporary needs freeing, it is done after use! */
3777 if (intent
!= INTENT_IN
)
3779 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3780 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3783 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3785 gfc_cleanup_loop (&loop
);
3786 gfc_cleanup_loop (&loop2
);
3788 /* Pass the string length to the argument expression. */
3789 if (expr
->ts
.type
== BT_CHARACTER
)
3790 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3792 /* Determine the offset for pointer formal arguments and set the
3796 size
= gfc_index_one_node
;
3797 offset
= gfc_index_zero_node
;
3798 for (n
= 0; n
< dimen
; n
++)
3800 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3802 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3803 gfc_array_index_type
, tmp
,
3804 gfc_index_one_node
);
3805 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3809 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3812 gfc_index_one_node
);
3813 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3814 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3815 gfc_array_index_type
,
3817 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3818 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3819 gfc_array_index_type
,
3820 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3821 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3822 gfc_array_index_type
,
3823 tmp
, gfc_index_one_node
);
3824 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3825 gfc_array_index_type
, size
, tmp
);
3828 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3832 /* We want either the address for the data or the address of the descriptor,
3833 depending on the mode of passing array arguments. */
3835 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3837 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3843 /* Generate the code for argument list functions. */
3846 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3848 /* Pass by value for g77 %VAL(arg), pass the address
3849 indirectly for %LOC, else by reference. Thus %REF
3850 is a "do-nothing" and %LOC is the same as an F95
3852 if (strncmp (name
, "%VAL", 4) == 0)
3853 gfc_conv_expr (se
, expr
);
3854 else if (strncmp (name
, "%LOC", 4) == 0)
3856 gfc_conv_expr_reference (se
, expr
);
3857 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3859 else if (strncmp (name
, "%REF", 4) == 0)
3860 gfc_conv_expr_reference (se
, expr
);
3862 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3866 /* Generate code for a procedure call. Note can return se->post != NULL.
3867 If se->direct_byref is set then se->expr contains the return parameter.
3868 Return nonzero, if the call has alternate specifiers.
3869 'expr' is only needed for procedure pointer components. */
3872 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3873 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3874 vec
<tree
, va_gc
> *append_args
)
3876 gfc_interface_mapping mapping
;
3877 vec
<tree
, va_gc
> *arglist
;
3878 vec
<tree
, va_gc
> *retargs
;
3882 gfc_array_info
*info
;
3889 vec
<tree
, va_gc
> *stringargs
;
3890 vec
<tree
, va_gc
> *optionalargs
;
3892 gfc_formal_arglist
*formal
;
3893 gfc_actual_arglist
*arg
;
3894 int has_alternate_specifier
= 0;
3895 bool need_interface_mapping
;
3902 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3903 gfc_component
*comp
= NULL
;
3909 optionalargs
= NULL
;
3914 comp
= gfc_get_proc_ptr_comp (expr
);
3918 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3920 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3921 if (se
->ss
->info
->useflags
)
3923 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3924 && sym
->result
->attr
.dimension
)
3925 || (comp
&& comp
->attr
.dimension
));
3926 gcc_assert (se
->loop
!= NULL
);
3928 /* Access the previously obtained result. */
3929 gfc_conv_tmp_array_ref (se
);
3933 info
= &se
->ss
->info
->data
.array
;
3938 gfc_init_block (&post
);
3939 gfc_init_interface_mapping (&mapping
);
3942 formal
= gfc_sym_get_dummy_args (sym
);
3943 need_interface_mapping
= sym
->attr
.dimension
||
3944 (sym
->ts
.type
== BT_CHARACTER
3945 && sym
->ts
.u
.cl
->length
3946 && sym
->ts
.u
.cl
->length
->expr_type
3951 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
3952 need_interface_mapping
= comp
->attr
.dimension
||
3953 (comp
->ts
.type
== BT_CHARACTER
3954 && comp
->ts
.u
.cl
->length
3955 && comp
->ts
.u
.cl
->length
->expr_type
3959 base_object
= NULL_TREE
;
3961 /* Evaluate the arguments. */
3962 for (arg
= args
; arg
!= NULL
;
3963 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3966 fsym
= formal
? formal
->sym
: NULL
;
3967 parm_kind
= MISSING
;
3969 /* Class array expressions are sometimes coming completely unadorned
3970 with either arrayspec or _data component. Correct that here.
3971 OOP-TODO: Move this to the frontend. */
3972 if (e
&& e
->expr_type
== EXPR_VARIABLE
3974 && e
->ts
.type
== BT_CLASS
3975 && (CLASS_DATA (e
)->attr
.codimension
3976 || CLASS_DATA (e
)->attr
.dimension
))
3978 gfc_typespec temp_ts
= e
->ts
;
3979 gfc_add_class_array_ref (e
);
3985 if (se
->ignore_optional
)
3987 /* Some intrinsics have already been resolved to the correct
3991 else if (arg
->label
)
3993 has_alternate_specifier
= 1;
3998 gfc_init_se (&parmse
, NULL
);
4000 /* For scalar arguments with VALUE attribute which are passed by
4001 value, pass "0" and a hidden argument gives the optional
4003 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4004 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4005 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4007 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4009 vec_safe_push (optionalargs
, boolean_false_node
);
4013 /* Pass a NULL pointer for an absent arg. */
4014 parmse
.expr
= null_pointer_node
;
4015 if (arg
->missing_arg_type
== BT_CHARACTER
)
4016 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4021 else if (arg
->expr
->expr_type
== EXPR_NULL
4022 && fsym
&& !fsym
->attr
.pointer
4023 && (fsym
->ts
.type
!= BT_CLASS
4024 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4026 /* Pass a NULL pointer to denote an absent arg. */
4027 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4028 && (fsym
->ts
.type
!= BT_CLASS
4029 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4030 gfc_init_se (&parmse
, NULL
);
4031 parmse
.expr
= null_pointer_node
;
4032 if (arg
->missing_arg_type
== BT_CHARACTER
)
4033 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4035 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4036 && e
->ts
.type
== BT_DERIVED
)
4038 /* The derived type needs to be converted to a temporary
4040 gfc_init_se (&parmse
, se
);
4041 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4043 && e
->expr_type
== EXPR_VARIABLE
4044 && e
->symtree
->n
.sym
->attr
.optional
,
4045 CLASS_DATA (fsym
)->attr
.class_pointer
4046 || CLASS_DATA (fsym
)->attr
.allocatable
);
4048 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4050 /* The intrinsic type needs to be converted to a temporary
4051 CLASS object for the unlimited polymorphic formal. */
4052 gfc_init_se (&parmse
, se
);
4053 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4055 else if (se
->ss
&& se
->ss
->info
->useflags
)
4061 /* An elemental function inside a scalarized loop. */
4062 gfc_init_se (&parmse
, se
);
4063 parm_kind
= ELEMENTAL
;
4065 if (fsym
&& fsym
->attr
.value
)
4066 gfc_conv_expr (&parmse
, e
);
4068 gfc_conv_expr_reference (&parmse
, e
);
4070 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4071 && e
->expr_type
== EXPR_FUNCTION
)
4072 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4075 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4076 && gfc_is_class_container_ref (e
))
4078 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4080 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4081 && e
->symtree
->n
.sym
->attr
.optional
)
4083 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4084 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4085 TREE_TYPE (parmse
.expr
),
4087 fold_convert (TREE_TYPE (parmse
.expr
),
4088 null_pointer_node
));
4092 /* If we are passing an absent array as optional dummy to an
4093 elemental procedure, make sure that we pass NULL when the data
4094 pointer is NULL. We need this extra conditional because of
4095 scalarization which passes arrays elements to the procedure,
4096 ignoring the fact that the array can be absent/unallocated/... */
4097 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4099 tree descriptor_data
;
4101 descriptor_data
= ss
->info
->data
.array
.data
;
4102 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4104 fold_convert (TREE_TYPE (descriptor_data
),
4105 null_pointer_node
));
4107 = fold_build3_loc (input_location
, COND_EXPR
,
4108 TREE_TYPE (parmse
.expr
),
4109 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4110 fold_convert (TREE_TYPE (parmse
.expr
),
4115 /* The scalarizer does not repackage the reference to a class
4116 array - instead it returns a pointer to the data element. */
4117 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4118 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4119 fsym
->attr
.intent
!= INTENT_IN
4120 && (CLASS_DATA (fsym
)->attr
.class_pointer
4121 || CLASS_DATA (fsym
)->attr
.allocatable
),
4123 && e
->expr_type
== EXPR_VARIABLE
4124 && e
->symtree
->n
.sym
->attr
.optional
,
4125 CLASS_DATA (fsym
)->attr
.class_pointer
4126 || CLASS_DATA (fsym
)->attr
.allocatable
);
4133 gfc_init_se (&parmse
, NULL
);
4135 /* Check whether the expression is a scalar or not; we cannot use
4136 e->rank as it can be nonzero for functions arguments. */
4137 argss
= gfc_walk_expr (e
);
4138 scalar
= argss
== gfc_ss_terminator
;
4140 gfc_free_ss_chain (argss
);
4142 /* Special handling for passing scalar polymorphic coarrays;
4143 otherwise one passes "class->_data.data" instead of "&class". */
4144 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4145 && fsym
&& fsym
->ts
.type
== BT_CLASS
4146 && CLASS_DATA (fsym
)->attr
.codimension
4147 && !CLASS_DATA (fsym
)->attr
.dimension
)
4149 gfc_add_class_array_ref (e
);
4150 parmse
.want_coarray
= 1;
4154 /* A scalar or transformational function. */
4157 if (e
->expr_type
== EXPR_VARIABLE
4158 && e
->symtree
->n
.sym
->attr
.cray_pointee
4159 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4161 /* The Cray pointer needs to be converted to a pointer to
4162 a type given by the expression. */
4163 gfc_conv_expr (&parmse
, e
);
4164 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4165 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4166 parmse
.expr
= convert (type
, tmp
);
4168 else if (fsym
&& fsym
->attr
.value
)
4170 if (fsym
->ts
.type
== BT_CHARACTER
4171 && fsym
->ts
.is_c_interop
4172 && fsym
->ns
->proc_name
!= NULL
4173 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4176 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4177 if (parmse
.expr
== NULL
)
4178 gfc_conv_expr (&parmse
, e
);
4182 gfc_conv_expr (&parmse
, e
);
4183 if (fsym
->attr
.optional
4184 && fsym
->ts
.type
!= BT_CLASS
4185 && fsym
->ts
.type
!= BT_DERIVED
)
4187 if (e
->expr_type
!= EXPR_VARIABLE
4188 || !e
->symtree
->n
.sym
->attr
.optional
4190 vec_safe_push (optionalargs
, boolean_true_node
);
4193 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4194 if (!e
->symtree
->n
.sym
->attr
.value
)
4196 = fold_build3_loc (input_location
, COND_EXPR
,
4197 TREE_TYPE (parmse
.expr
),
4199 fold_convert (TREE_TYPE (parmse
.expr
),
4200 integer_zero_node
));
4202 vec_safe_push (optionalargs
, tmp
);
4207 else if (arg
->name
&& arg
->name
[0] == '%')
4208 /* Argument list functions %VAL, %LOC and %REF are signalled
4209 through arg->name. */
4210 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4211 else if ((e
->expr_type
== EXPR_FUNCTION
)
4212 && ((e
->value
.function
.esym
4213 && e
->value
.function
.esym
->result
->attr
.pointer
)
4214 || (!e
->value
.function
.esym
4215 && e
->symtree
->n
.sym
->attr
.pointer
))
4216 && fsym
&& fsym
->attr
.target
)
4218 gfc_conv_expr (&parmse
, e
);
4219 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4221 else if (e
->expr_type
== EXPR_FUNCTION
4222 && e
->symtree
->n
.sym
->result
4223 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4224 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4226 /* Functions returning procedure pointers. */
4227 gfc_conv_expr (&parmse
, e
);
4228 if (fsym
&& fsym
->attr
.proc_pointer
)
4229 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4233 if (e
->ts
.type
== BT_CLASS
&& fsym
4234 && fsym
->ts
.type
== BT_CLASS
4235 && (!CLASS_DATA (fsym
)->as
4236 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4237 && CLASS_DATA (e
)->attr
.codimension
)
4239 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4240 gcc_assert (!CLASS_DATA (fsym
)->as
);
4241 gfc_add_class_array_ref (e
);
4242 parmse
.want_coarray
= 1;
4243 gfc_conv_expr_reference (&parmse
, e
);
4244 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4246 && e
->expr_type
== EXPR_VARIABLE
);
4249 gfc_conv_expr_reference (&parmse
, e
);
4251 /* Catch base objects that are not variables. */
4252 if (e
->ts
.type
== BT_CLASS
4253 && e
->expr_type
!= EXPR_VARIABLE
4254 && expr
&& e
== expr
->base_expr
)
4255 base_object
= build_fold_indirect_ref_loc (input_location
,
4258 /* A class array element needs converting back to be a
4259 class object, if the formal argument is a class object. */
4260 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4261 && e
->ts
.type
== BT_CLASS
4262 && ((CLASS_DATA (fsym
)->as
4263 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4264 || CLASS_DATA (e
)->attr
.dimension
))
4265 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4266 fsym
->attr
.intent
!= INTENT_IN
4267 && (CLASS_DATA (fsym
)->attr
.class_pointer
4268 || CLASS_DATA (fsym
)->attr
.allocatable
),
4270 && e
->expr_type
== EXPR_VARIABLE
4271 && e
->symtree
->n
.sym
->attr
.optional
,
4272 CLASS_DATA (fsym
)->attr
.class_pointer
4273 || CLASS_DATA (fsym
)->attr
.allocatable
);
4275 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4276 allocated on entry, it must be deallocated. */
4277 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4278 && (fsym
->attr
.allocatable
4279 || (fsym
->ts
.type
== BT_CLASS
4280 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4285 gfc_init_block (&block
);
4287 if (e
->ts
.type
== BT_CLASS
)
4288 ptr
= gfc_class_data_get (ptr
);
4290 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4292 gfc_add_expr_to_block (&block
, tmp
);
4293 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4294 void_type_node
, ptr
,
4296 gfc_add_expr_to_block (&block
, tmp
);
4298 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4300 gfc_add_modify (&block
, ptr
,
4301 fold_convert (TREE_TYPE (ptr
),
4302 null_pointer_node
));
4303 gfc_add_expr_to_block (&block
, tmp
);
4305 else if (fsym
->ts
.type
== BT_CLASS
)
4308 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4309 tmp
= gfc_get_symbol_decl (vtab
);
4310 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4311 ptr
= gfc_class_vptr_get (parmse
.expr
);
4312 gfc_add_modify (&block
, ptr
,
4313 fold_convert (TREE_TYPE (ptr
), tmp
));
4314 gfc_add_expr_to_block (&block
, tmp
);
4317 if (fsym
->attr
.optional
4318 && e
->expr_type
== EXPR_VARIABLE
4319 && e
->symtree
->n
.sym
->attr
.optional
)
4321 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4323 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4324 gfc_finish_block (&block
),
4325 build_empty_stmt (input_location
));
4328 tmp
= gfc_finish_block (&block
);
4330 gfc_add_expr_to_block (&se
->pre
, tmp
);
4333 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4334 || fsym
->ts
.type
== BT_ASSUMED
)
4335 && e
->ts
.type
== BT_CLASS
4336 && !CLASS_DATA (e
)->attr
.dimension
4337 && !CLASS_DATA (e
)->attr
.codimension
)
4338 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4340 /* Wrap scalar variable in a descriptor. We need to convert
4341 the address of a pointer back to the pointer itself before,
4342 we can assign it to the data field. */
4344 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4345 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4348 if (TREE_CODE (tmp
) == ADDR_EXPR
4349 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4350 tmp
= TREE_OPERAND (tmp
, 0);
4351 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4353 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4356 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4357 && ((fsym
->attr
.pointer
4358 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4359 || (fsym
->attr
.proc_pointer
4360 && !(e
->expr_type
== EXPR_VARIABLE
4361 && e
->symtree
->n
.sym
->attr
.dummy
))
4362 || (fsym
->attr
.proc_pointer
4363 && e
->expr_type
== EXPR_VARIABLE
4364 && gfc_is_proc_ptr_comp (e
))
4365 || (fsym
->attr
.allocatable
4366 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4368 /* Scalar pointer dummy args require an extra level of
4369 indirection. The null pointer already contains
4370 this level of indirection. */
4371 parm_kind
= SCALAR_POINTER
;
4372 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4376 else if (e
->ts
.type
== BT_CLASS
4377 && fsym
&& fsym
->ts
.type
== BT_CLASS
4378 && (CLASS_DATA (fsym
)->attr
.dimension
4379 || CLASS_DATA (fsym
)->attr
.codimension
))
4381 /* Pass a class array. */
4382 parmse
.use_offset
= 1;
4383 gfc_conv_expr_descriptor (&parmse
, e
);
4385 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4386 allocated on entry, it must be deallocated. */
4387 if (fsym
->attr
.intent
== INTENT_OUT
4388 && CLASS_DATA (fsym
)->attr
.allocatable
)
4393 gfc_init_block (&block
);
4395 ptr
= gfc_class_data_get (ptr
);
4397 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4398 NULL_TREE
, NULL_TREE
,
4401 gfc_add_expr_to_block (&block
, tmp
);
4402 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4403 void_type_node
, ptr
,
4405 gfc_add_expr_to_block (&block
, tmp
);
4406 gfc_reset_vptr (&block
, e
);
4408 if (fsym
->attr
.optional
4409 && e
->expr_type
== EXPR_VARIABLE
4411 || (e
->ref
->type
== REF_ARRAY
4412 && !e
->ref
->u
.ar
.type
!= AR_FULL
))
4413 && e
->symtree
->n
.sym
->attr
.optional
)
4415 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4417 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4418 gfc_finish_block (&block
),
4419 build_empty_stmt (input_location
));
4422 tmp
= gfc_finish_block (&block
);
4424 gfc_add_expr_to_block (&se
->pre
, tmp
);
4427 /* The conversion does not repackage the reference to a class
4428 array - _data descriptor. */
4429 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4430 fsym
->attr
.intent
!= INTENT_IN
4431 && (CLASS_DATA (fsym
)->attr
.class_pointer
4432 || CLASS_DATA (fsym
)->attr
.allocatable
),
4434 && e
->expr_type
== EXPR_VARIABLE
4435 && e
->symtree
->n
.sym
->attr
.optional
,
4436 CLASS_DATA (fsym
)->attr
.class_pointer
4437 || CLASS_DATA (fsym
)->attr
.allocatable
);
4441 /* If the procedure requires an explicit interface, the actual
4442 argument is passed according to the corresponding formal
4443 argument. If the corresponding formal argument is a POINTER,
4444 ALLOCATABLE or assumed shape, we do not use g77's calling
4445 convention, and pass the address of the array descriptor
4446 instead. Otherwise we use g77's calling convention. */
4449 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4450 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4451 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4453 f
= f
|| !comp
->attr
.always_explicit
;
4455 f
= f
|| !sym
->attr
.always_explicit
;
4457 /* If the argument is a function call that may not create
4458 a temporary for the result, we have to check that we
4459 can do it, i.e. that there is no alias between this
4460 argument and another one. */
4461 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4467 intent
= fsym
->attr
.intent
;
4469 intent
= INTENT_UNKNOWN
;
4471 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4473 parmse
.force_tmp
= 1;
4475 iarg
= e
->value
.function
.actual
->expr
;
4477 /* Temporary needed if aliasing due to host association. */
4478 if (sym
->attr
.contained
4480 && !sym
->attr
.implicit_pure
4481 && !sym
->attr
.use_assoc
4482 && iarg
->expr_type
== EXPR_VARIABLE
4483 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4484 parmse
.force_tmp
= 1;
4486 /* Ditto within module. */
4487 if (sym
->attr
.use_assoc
4489 && !sym
->attr
.implicit_pure
4490 && iarg
->expr_type
== EXPR_VARIABLE
4491 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4492 parmse
.force_tmp
= 1;
4495 if (e
->expr_type
== EXPR_VARIABLE
4496 && is_subref_array (e
))
4497 /* The actual argument is a component reference to an
4498 array of derived types. In this case, the argument
4499 is converted to a temporary, which is passed and then
4500 written back after the procedure call. */
4501 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4502 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4503 fsym
&& fsym
->attr
.pointer
);
4504 else if (gfc_is_class_array_ref (e
, NULL
)
4505 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4506 /* The actual argument is a component reference to an
4507 array of derived types. In this case, the argument
4508 is converted to a temporary, which is passed and then
4509 written back after the procedure call.
4510 OOP-TODO: Insert code so that if the dynamic type is
4511 the same as the declared type, copy-in/copy-out does
4513 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4514 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4515 fsym
&& fsym
->attr
.pointer
);
4517 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4519 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4520 allocated on entry, it must be deallocated. */
4521 if (fsym
&& fsym
->attr
.allocatable
4522 && fsym
->attr
.intent
== INTENT_OUT
)
4524 tmp
= build_fold_indirect_ref_loc (input_location
,
4526 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4527 if (fsym
->attr
.optional
4528 && e
->expr_type
== EXPR_VARIABLE
4529 && e
->symtree
->n
.sym
->attr
.optional
)
4530 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4532 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4533 tmp
, build_empty_stmt (input_location
));
4534 gfc_add_expr_to_block (&se
->pre
, tmp
);
4539 /* The case with fsym->attr.optional is that of a user subroutine
4540 with an interface indicating an optional argument. When we call
4541 an intrinsic subroutine, however, fsym is NULL, but we might still
4542 have an optional argument, so we proceed to the substitution
4544 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4546 /* If an optional argument is itself an optional dummy argument,
4547 check its presence and substitute a null if absent. This is
4548 only needed when passing an array to an elemental procedure
4549 as then array elements are accessed - or no NULL pointer is
4550 allowed and a "1" or "0" should be passed if not present.
4551 When passing a non-array-descriptor full array to a
4552 non-array-descriptor dummy, no check is needed. For
4553 array-descriptor actual to array-descriptor dummy, see
4554 PR 41911 for why a check has to be inserted.
4555 fsym == NULL is checked as intrinsics required the descriptor
4556 but do not always set fsym. */
4557 if (e
->expr_type
== EXPR_VARIABLE
4558 && e
->symtree
->n
.sym
->attr
.optional
4559 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4560 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4564 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4565 || fsym
->as
->type
== AS_ASSUMED_RANK
4566 || fsym
->as
->type
== AS_DEFERRED
))))))
4567 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4568 e
->representation
.length
);
4573 /* Obtain the character length of an assumed character length
4574 length procedure from the typespec. */
4575 if (fsym
->ts
.type
== BT_CHARACTER
4576 && parmse
.string_length
== NULL_TREE
4577 && e
->ts
.type
== BT_PROCEDURE
4578 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4579 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4580 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4582 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4583 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4587 if (fsym
&& need_interface_mapping
&& e
)
4588 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4590 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4591 gfc_add_block_to_block (&post
, &parmse
.post
);
4593 /* Allocated allocatable components of derived types must be
4594 deallocated for non-variable scalars. Non-variable arrays are
4595 dealt with in trans-array.c(gfc_conv_array_parameter). */
4596 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4597 && e
->ts
.u
.derived
->attr
.alloc_comp
4598 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4599 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4602 tmp
= build_fold_indirect_ref_loc (input_location
,
4604 parm_rank
= e
->rank
;
4612 case (SCALAR_POINTER
):
4613 tmp
= build_fold_indirect_ref_loc (input_location
,
4618 if (e
->expr_type
== EXPR_OP
4619 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4620 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4623 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4624 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4625 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4628 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4630 /* The derived type is passed to gfc_deallocate_alloc_comp.
4631 Therefore, class actuals can handled correctly but derived
4632 types passed to class formals need the _data component. */
4633 tmp
= gfc_class_data_get (tmp
);
4634 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4635 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4638 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4640 gfc_add_expr_to_block (&se
->post
, tmp
);
4643 /* Add argument checking of passing an unallocated/NULL actual to
4644 a nonallocatable/nonpointer dummy. */
4646 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4648 symbol_attribute attr
;
4652 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4653 attr
= gfc_expr_attr (e
);
4655 goto end_pointer_check
;
4657 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4658 allocatable to an optional dummy, cf. 12.5.2.12. */
4659 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4660 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4661 goto end_pointer_check
;
4665 /* If the actual argument is an optional pointer/allocatable and
4666 the formal argument takes an nonpointer optional value,
4667 it is invalid to pass a non-present argument on, even
4668 though there is no technical reason for this in gfortran.
4669 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4670 tree present
, null_ptr
, type
;
4672 if (attr
.allocatable
4673 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4674 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4675 "allocated or not present", e
->symtree
->n
.sym
->name
);
4676 else if (attr
.pointer
4677 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4678 asprintf (&msg
, "Pointer actual argument '%s' is not "
4679 "associated or not present",
4680 e
->symtree
->n
.sym
->name
);
4681 else if (attr
.proc_pointer
4682 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4683 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4684 "associated or not present",
4685 e
->symtree
->n
.sym
->name
);
4687 goto end_pointer_check
;
4689 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4690 type
= TREE_TYPE (present
);
4691 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4692 boolean_type_node
, present
,
4694 null_pointer_node
));
4695 type
= TREE_TYPE (parmse
.expr
);
4696 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4697 boolean_type_node
, parmse
.expr
,
4699 null_pointer_node
));
4700 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4701 boolean_type_node
, present
, null_ptr
);
4705 if (attr
.allocatable
4706 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4707 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4708 "allocated", e
->symtree
->n
.sym
->name
);
4709 else if (attr
.pointer
4710 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4711 asprintf (&msg
, "Pointer actual argument '%s' is not "
4712 "associated", e
->symtree
->n
.sym
->name
);
4713 else if (attr
.proc_pointer
4714 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4715 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4716 "associated", e
->symtree
->n
.sym
->name
);
4718 goto end_pointer_check
;
4722 /* If the argument is passed by value, we need to strip the
4724 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4725 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4727 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4728 boolean_type_node
, tmp
,
4729 fold_convert (TREE_TYPE (tmp
),
4730 null_pointer_node
));
4733 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4739 /* Deferred length dummies pass the character length by reference
4740 so that the value can be returned. */
4741 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4743 tmp
= parmse
.string_length
;
4744 if (TREE_CODE (tmp
) != VAR_DECL
)
4745 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4746 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4749 /* Character strings are passed as two parameters, a length and a
4750 pointer - except for Bind(c) which only passes the pointer.
4751 An unlimited polymorphic formal argument likewise does not
4753 if (parmse
.string_length
!= NULL_TREE
4754 && !sym
->attr
.is_bind_c
4755 && !(fsym
&& UNLIMITED_POLY (fsym
)))
4756 vec_safe_push (stringargs
, parmse
.string_length
);
4758 /* When calling __copy for character expressions to unlimited
4759 polymorphic entities, the dst argument needs a string length. */
4760 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
4761 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
4762 && arg
->next
&& arg
->next
->expr
4763 && arg
->next
->expr
->ts
.type
== BT_DERIVED
4764 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
4765 vec_safe_push (stringargs
, parmse
.string_length
);
4767 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4768 pass the token and the offset as additional arguments. */
4769 if (fsym
&& fsym
->attr
.codimension
4770 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4771 && !fsym
->attr
.allocatable
4774 /* Token and offset. */
4775 vec_safe_push (stringargs
, null_pointer_node
);
4776 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4777 gcc_assert (fsym
->attr
.optional
);
4779 else if (fsym
&& fsym
->attr
.codimension
4780 && !fsym
->attr
.allocatable
4781 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4783 tree caf_decl
, caf_type
;
4786 caf_decl
= get_tree_for_caf_expr (e
);
4787 caf_type
= TREE_TYPE (caf_decl
);
4789 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4790 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4791 tmp
= gfc_conv_descriptor_token (caf_decl
);
4792 else if (DECL_LANG_SPECIFIC (caf_decl
)
4793 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4794 tmp
= GFC_DECL_TOKEN (caf_decl
);
4797 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4798 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4799 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4802 vec_safe_push (stringargs
, tmp
);
4804 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4805 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4806 offset
= build_int_cst (gfc_array_index_type
, 0);
4807 else if (DECL_LANG_SPECIFIC (caf_decl
)
4808 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4809 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4810 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4811 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4813 offset
= build_int_cst (gfc_array_index_type
, 0);
4815 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4816 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4819 gcc_assert (POINTER_TYPE_P (caf_type
));
4823 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4824 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4825 && !fsym
->attr
.allocatable
))
4827 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4828 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4829 (TREE_TYPE (parmse
.expr
))));
4830 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4831 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4833 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4834 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4837 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4841 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4842 gfc_array_index_type
,
4843 fold_convert (gfc_array_index_type
, tmp2
),
4844 fold_convert (gfc_array_index_type
, tmp
));
4845 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4846 gfc_array_index_type
, offset
, tmp
);
4848 vec_safe_push (stringargs
, offset
);
4851 vec_safe_push (arglist
, parmse
.expr
);
4853 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4860 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4861 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4862 else if (ts
.type
== BT_CHARACTER
)
4864 if (ts
.u
.cl
->length
== NULL
)
4866 /* Assumed character length results are not allowed by 5.1.1.5 of the
4867 standard and are trapped in resolve.c; except in the case of SPREAD
4868 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4869 we take the character length of the first argument for the result.
4870 For dummies, we have to look through the formal argument list for
4871 this function and use the character length found there.*/
4873 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4874 else if (!sym
->attr
.dummy
)
4875 cl
.backend_decl
= (*stringargs
)[0];
4878 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
4879 for (; formal
; formal
= formal
->next
)
4880 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4881 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4883 len
= cl
.backend_decl
;
4889 /* Calculate the length of the returned string. */
4890 gfc_init_se (&parmse
, NULL
);
4891 if (need_interface_mapping
)
4892 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4894 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4895 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4896 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4898 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4899 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4900 gfc_charlen_type_node
, tmp
,
4901 build_int_cst (gfc_charlen_type_node
, 0));
4902 cl
.backend_decl
= tmp
;
4905 /* Set up a charlen structure for it. */
4910 len
= cl
.backend_decl
;
4913 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4914 || (!comp
&& gfc_return_by_reference (sym
));
4917 if (se
->direct_byref
)
4919 /* Sometimes, too much indirection can be applied; e.g. for
4920 function_result = array_valued_recursive_function. */
4921 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4922 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4923 && GFC_DESCRIPTOR_TYPE_P
4924 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4925 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4928 /* If the lhs of an assignment x = f(..) is allocatable and
4929 f2003 is allowed, we must do the automatic reallocation.
4930 TODO - deal with intrinsics, without using a temporary. */
4931 if (gfc_option
.flag_realloc_lhs
4932 && se
->ss
&& se
->ss
->loop_chain
4933 && se
->ss
->loop_chain
->is_alloc_lhs
4934 && !expr
->value
.function
.isym
4935 && sym
->result
->as
!= NULL
)
4937 /* Evaluate the bounds of the result, if known. */
4938 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4941 /* Perform the automatic reallocation. */
4942 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4944 gfc_add_expr_to_block (&se
->pre
, tmp
);
4946 /* Pass the temporary as the first argument. */
4947 result
= info
->descriptor
;
4950 result
= build_fold_indirect_ref_loc (input_location
,
4952 vec_safe_push (retargs
, se
->expr
);
4954 else if (comp
&& comp
->attr
.dimension
)
4956 gcc_assert (se
->loop
&& info
);
4958 /* Set the type of the array. */
4959 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4960 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4962 /* Evaluate the bounds of the result, if known. */
4963 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4965 /* If the lhs of an assignment x = f(..) is allocatable and
4966 f2003 is allowed, we must not generate the function call
4967 here but should just send back the results of the mapping.
4968 This is signalled by the function ss being flagged. */
4969 if (gfc_option
.flag_realloc_lhs
4970 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4972 gfc_free_interface_mapping (&mapping
);
4973 return has_alternate_specifier
;
4976 /* Create a temporary to store the result. In case the function
4977 returns a pointer, the temporary will be a shallow copy and
4978 mustn't be deallocated. */
4979 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4980 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4981 tmp
, NULL_TREE
, false,
4982 !comp
->attr
.pointer
, callee_alloc
,
4983 &se
->ss
->info
->expr
->where
);
4985 /* Pass the temporary as the first argument. */
4986 result
= info
->descriptor
;
4987 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4988 vec_safe_push (retargs
, tmp
);
4990 else if (!comp
&& sym
->result
->attr
.dimension
)
4992 gcc_assert (se
->loop
&& info
);
4994 /* Set the type of the array. */
4995 tmp
= gfc_typenode_for_spec (&ts
);
4996 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4998 /* Evaluate the bounds of the result, if known. */
4999 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5001 /* If the lhs of an assignment x = f(..) is allocatable and
5002 f2003 is allowed, we must not generate the function call
5003 here but should just send back the results of the mapping.
5004 This is signalled by the function ss being flagged. */
5005 if (gfc_option
.flag_realloc_lhs
5006 && se
->ss
&& se
->ss
->is_alloc_lhs
)
5008 gfc_free_interface_mapping (&mapping
);
5009 return has_alternate_specifier
;
5012 /* Create a temporary to store the result. In case the function
5013 returns a pointer, the temporary will be a shallow copy and
5014 mustn't be deallocated. */
5015 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5016 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5017 tmp
, NULL_TREE
, false,
5018 !sym
->attr
.pointer
, callee_alloc
,
5019 &se
->ss
->info
->expr
->where
);
5021 /* Pass the temporary as the first argument. */
5022 result
= info
->descriptor
;
5023 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5024 vec_safe_push (retargs
, tmp
);
5026 else if (ts
.type
== BT_CHARACTER
)
5028 /* Pass the string length. */
5029 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5030 type
= build_pointer_type (type
);
5032 /* Return an address to a char[0:len-1]* temporary for
5033 character pointers. */
5034 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5035 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5037 var
= gfc_create_var (type
, "pstr");
5039 if ((!comp
&& sym
->attr
.allocatable
)
5040 || (comp
&& comp
->attr
.allocatable
))
5042 gfc_add_modify (&se
->pre
, var
,
5043 fold_convert (TREE_TYPE (var
),
5044 null_pointer_node
));
5045 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5046 gfc_add_expr_to_block (&se
->post
, tmp
);
5049 /* Provide an address expression for the function arguments. */
5050 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5053 var
= gfc_conv_string_tmp (se
, type
, len
);
5055 vec_safe_push (retargs
, var
);
5059 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
5061 type
= gfc_get_complex_type (ts
.kind
);
5062 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5063 vec_safe_push (retargs
, var
);
5066 /* Add the string length to the argument list. */
5067 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5070 if (TREE_CODE (tmp
) != VAR_DECL
)
5071 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5072 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5073 vec_safe_push (retargs
, tmp
);
5075 else if (ts
.type
== BT_CHARACTER
)
5076 vec_safe_push (retargs
, len
);
5078 gfc_free_interface_mapping (&mapping
);
5080 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5081 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5082 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5083 vec_safe_reserve (retargs
, arglen
);
5085 /* Add the return arguments. */
5086 retargs
->splice (arglist
);
5088 /* Add the hidden present status for optional+value to the arguments. */
5089 retargs
->splice (optionalargs
);
5091 /* Add the hidden string length parameters to the arguments. */
5092 retargs
->splice (stringargs
);
5094 /* We may want to append extra arguments here. This is used e.g. for
5095 calls to libgfortran_matmul_??, which need extra information. */
5096 if (!vec_safe_is_empty (append_args
))
5097 retargs
->splice (append_args
);
5100 /* Generate the actual call. */
5101 if (base_object
== NULL_TREE
)
5102 conv_function_val (se
, sym
, expr
);
5104 conv_base_obj_fcn_val (se
, base_object
, expr
);
5106 /* If there are alternate return labels, function type should be
5107 integer. Can't modify the type in place though, since it can be shared
5108 with other functions. For dummy arguments, the typing is done to
5109 this result, even if it has to be repeated for each call. */
5110 if (has_alternate_specifier
5111 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5113 if (!sym
->attr
.dummy
)
5115 TREE_TYPE (sym
->backend_decl
)
5116 = build_function_type (integer_type_node
,
5117 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5118 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5121 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5124 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5125 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5127 /* If we have a pointer function, but we don't want a pointer, e.g.
5130 where f is pointer valued, we have to dereference the result. */
5131 if (!se
->want_pointer
&& !byref
5132 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5133 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5134 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5136 /* f2c calling conventions require a scalar default real function to
5137 return a double precision result. Convert this back to default
5138 real. We only care about the cases that can happen in Fortran 77.
5140 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
5141 && sym
->ts
.kind
== gfc_default_real_kind
5142 && !sym
->attr
.always_explicit
)
5143 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5145 /* A pure function may still have side-effects - it may modify its
5147 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5149 if (!sym
->attr
.pure
)
5150 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5155 /* Add the function call to the pre chain. There is no expression. */
5156 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5157 se
->expr
= NULL_TREE
;
5159 if (!se
->direct_byref
)
5161 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5163 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5165 /* Check the data pointer hasn't been modified. This would
5166 happen in a function returning a pointer. */
5167 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5168 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5171 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5174 se
->expr
= info
->descriptor
;
5175 /* Bundle in the string length. */
5176 se
->string_length
= len
;
5178 else if (ts
.type
== BT_CHARACTER
)
5180 /* Dereference for character pointer results. */
5181 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5182 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5183 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5187 se
->string_length
= len
;
5191 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5192 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5197 /* Follow the function call with the argument post block. */
5200 gfc_add_block_to_block (&se
->pre
, &post
);
5202 /* Transformational functions of derived types with allocatable
5203 components must have the result allocatable components copied. */
5204 arg
= expr
->value
.function
.actual
;
5205 if (result
&& arg
&& expr
->rank
5206 && expr
->value
.function
.isym
5207 && expr
->value
.function
.isym
->transformational
5208 && arg
->expr
->ts
.type
== BT_DERIVED
5209 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5212 /* Copy the allocatable components. We have to use a
5213 temporary here to prevent source allocatable components
5214 from being corrupted. */
5215 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5216 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5217 result
, tmp2
, expr
->rank
);
5218 gfc_add_expr_to_block (&se
->pre
, tmp
);
5219 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5221 gfc_add_expr_to_block (&se
->pre
, tmp
);
5223 /* Finally free the temporary's data field. */
5224 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5225 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5226 NULL_TREE
, NULL_TREE
, true,
5228 gfc_add_expr_to_block (&se
->pre
, tmp
);
5232 gfc_add_block_to_block (&se
->post
, &post
);
5234 return has_alternate_specifier
;
5238 /* Fill a character string with spaces. */
5241 fill_with_spaces (tree start
, tree type
, tree size
)
5243 stmtblock_t block
, loop
;
5244 tree i
, el
, exit_label
, cond
, tmp
;
5246 /* For a simple char type, we can call memset(). */
5247 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5248 return build_call_expr_loc (input_location
,
5249 builtin_decl_explicit (BUILT_IN_MEMSET
),
5251 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5252 lang_hooks
.to_target_charset (' ')),
5255 /* Otherwise, we use a loop:
5256 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5260 /* Initialize variables. */
5261 gfc_init_block (&block
);
5262 i
= gfc_create_var (sizetype
, "i");
5263 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5264 el
= gfc_create_var (build_pointer_type (type
), "el");
5265 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5266 exit_label
= gfc_build_label_decl (NULL_TREE
);
5267 TREE_USED (exit_label
) = 1;
5271 gfc_init_block (&loop
);
5273 /* Exit condition. */
5274 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5275 build_zero_cst (sizetype
));
5276 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5277 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5278 build_empty_stmt (input_location
));
5279 gfc_add_expr_to_block (&loop
, tmp
);
5282 gfc_add_modify (&loop
,
5283 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5284 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5286 /* Increment loop variables. */
5287 gfc_add_modify (&loop
, i
,
5288 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5289 TYPE_SIZE_UNIT (type
)));
5290 gfc_add_modify (&loop
, el
,
5291 fold_build_pointer_plus_loc (input_location
,
5292 el
, TYPE_SIZE_UNIT (type
)));
5294 /* Making the loop... actually loop! */
5295 tmp
= gfc_finish_block (&loop
);
5296 tmp
= build1_v (LOOP_EXPR
, tmp
);
5297 gfc_add_expr_to_block (&block
, tmp
);
5299 /* The exit label. */
5300 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5301 gfc_add_expr_to_block (&block
, tmp
);
5304 return gfc_finish_block (&block
);
5308 /* Generate code to copy a string. */
5311 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5312 int dkind
, tree slength
, tree src
, int skind
)
5314 tree tmp
, dlen
, slen
;
5323 stmtblock_t tempblock
;
5325 gcc_assert (dkind
== skind
);
5327 if (slength
!= NULL_TREE
)
5329 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5330 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5334 slen
= build_int_cst (size_type_node
, 1);
5338 if (dlength
!= NULL_TREE
)
5340 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5341 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5345 dlen
= build_int_cst (size_type_node
, 1);
5349 /* Assign directly if the types are compatible. */
5350 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5351 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5353 gfc_add_modify (block
, dsc
, ssc
);
5357 /* Do nothing if the destination length is zero. */
5358 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5359 build_int_cst (size_type_node
, 0));
5361 /* The following code was previously in _gfortran_copy_string:
5363 // The two strings may overlap so we use memmove.
5365 copy_string (GFC_INTEGER_4 destlen, char * dest,
5366 GFC_INTEGER_4 srclen, const char * src)
5368 if (srclen >= destlen)
5370 // This will truncate if too long.
5371 memmove (dest, src, destlen);
5375 memmove (dest, src, srclen);
5377 memset (&dest[srclen], ' ', destlen - srclen);
5381 We're now doing it here for better optimization, but the logic
5384 /* For non-default character kinds, we have to multiply the string
5385 length by the base type size. */
5386 chartype
= gfc_get_char_type (dkind
);
5387 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5388 fold_convert (size_type_node
, slen
),
5389 fold_convert (size_type_node
,
5390 TYPE_SIZE_UNIT (chartype
)));
5391 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5392 fold_convert (size_type_node
, dlen
),
5393 fold_convert (size_type_node
,
5394 TYPE_SIZE_UNIT (chartype
)));
5396 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5397 dest
= fold_convert (pvoid_type_node
, dest
);
5399 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5401 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5402 src
= fold_convert (pvoid_type_node
, src
);
5404 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5406 /* Truncate string if source is too long. */
5407 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5409 tmp2
= build_call_expr_loc (input_location
,
5410 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5411 3, dest
, src
, dlen
);
5413 /* Else copy and pad with spaces. */
5414 tmp3
= build_call_expr_loc (input_location
,
5415 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5416 3, dest
, src
, slen
);
5418 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5419 tmp4
= fill_with_spaces (tmp4
, chartype
,
5420 fold_build2_loc (input_location
, MINUS_EXPR
,
5421 TREE_TYPE(dlen
), dlen
, slen
));
5423 gfc_init_block (&tempblock
);
5424 gfc_add_expr_to_block (&tempblock
, tmp3
);
5425 gfc_add_expr_to_block (&tempblock
, tmp4
);
5426 tmp3
= gfc_finish_block (&tempblock
);
5428 /* The whole copy_string function is there. */
5429 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5431 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5432 build_empty_stmt (input_location
));
5433 gfc_add_expr_to_block (block
, tmp
);
5437 /* Translate a statement function.
5438 The value of a statement function reference is obtained by evaluating the
5439 expression using the values of the actual arguments for the values of the
5440 corresponding dummy arguments. */
5443 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5447 gfc_formal_arglist
*fargs
;
5448 gfc_actual_arglist
*args
;
5451 gfc_saved_var
*saved_vars
;
5457 sym
= expr
->symtree
->n
.sym
;
5458 args
= expr
->value
.function
.actual
;
5459 gfc_init_se (&lse
, NULL
);
5460 gfc_init_se (&rse
, NULL
);
5463 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5465 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5466 temp_vars
= XCNEWVEC (tree
, n
);
5468 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5469 fargs
= fargs
->next
, n
++)
5471 /* Each dummy shall be specified, explicitly or implicitly, to be
5473 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5476 if (fsym
->ts
.type
== BT_CHARACTER
)
5478 /* Copy string arguments. */
5481 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5482 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5484 /* Create a temporary to hold the value. */
5485 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5486 fsym
->ts
.u
.cl
->backend_decl
5487 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5489 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5490 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5492 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5494 gfc_conv_expr (&rse
, args
->expr
);
5495 gfc_conv_string_parameter (&rse
);
5496 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5497 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5499 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5500 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5501 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5502 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5506 /* For everything else, just evaluate the expression. */
5508 /* Create a temporary to hold the value. */
5509 type
= gfc_typenode_for_spec (&fsym
->ts
);
5510 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5512 gfc_conv_expr (&lse
, args
->expr
);
5514 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5515 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5516 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5522 /* Use the temporary variables in place of the real ones. */
5523 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5524 fargs
= fargs
->next
, n
++)
5525 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5527 gfc_conv_expr (se
, sym
->value
);
5529 if (sym
->ts
.type
== BT_CHARACTER
)
5531 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5533 /* Force the expression to the correct length. */
5534 if (!INTEGER_CST_P (se
->string_length
)
5535 || tree_int_cst_lt (se
->string_length
,
5536 sym
->ts
.u
.cl
->backend_decl
))
5538 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5539 tmp
= gfc_create_var (type
, sym
->name
);
5540 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5541 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5542 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5546 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5549 /* Restore the original variables. */
5550 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5551 fargs
= fargs
->next
, n
++)
5552 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5558 /* Translate a function expression. */
5561 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5565 if (expr
->value
.function
.isym
)
5567 gfc_conv_intrinsic_function (se
, expr
);
5571 /* expr.value.function.esym is the resolved (specific) function symbol for
5572 most functions. However this isn't set for dummy procedures. */
5573 sym
= expr
->value
.function
.esym
;
5575 sym
= expr
->symtree
->n
.sym
;
5577 /* We distinguish statement functions from general functions to improve
5578 runtime performance. */
5579 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5581 gfc_conv_statement_function (se
, expr
);
5585 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5590 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5593 is_zero_initializer_p (gfc_expr
* expr
)
5595 if (expr
->expr_type
!= EXPR_CONSTANT
)
5598 /* We ignore constants with prescribed memory representations for now. */
5599 if (expr
->representation
.string
)
5602 switch (expr
->ts
.type
)
5605 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5608 return mpfr_zero_p (expr
->value
.real
)
5609 && MPFR_SIGN (expr
->value
.real
) >= 0;
5612 return expr
->value
.logical
== 0;
5615 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5616 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5617 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5618 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5628 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5633 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5634 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5636 gfc_conv_tmp_array_ref (se
);
5640 /* Build a static initializer. EXPR is the expression for the initial value.
5641 The other parameters describe the variable of the component being
5642 initialized. EXPR may be null. */
5645 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5646 bool array
, bool pointer
, bool procptr
)
5650 if (!(expr
|| pointer
|| procptr
))
5653 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5654 (these are the only two iso_c_binding derived types that can be
5655 used as initialization expressions). If so, we need to modify
5656 the 'expr' to be that for a (void *). */
5657 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5658 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5660 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5662 /* The derived symbol has already been converted to a (void *). Use
5664 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5665 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5667 gfc_init_se (&se
, NULL
);
5668 gfc_conv_constant (&se
, expr
);
5669 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5673 if (array
&& !procptr
)
5676 /* Arrays need special handling. */
5678 ctor
= gfc_build_null_descriptor (type
);
5679 /* Special case assigning an array to zero. */
5680 else if (is_zero_initializer_p (expr
))
5681 ctor
= build_constructor (type
, NULL
);
5683 ctor
= gfc_conv_array_initializer (type
, expr
);
5684 TREE_STATIC (ctor
) = 1;
5687 else if (pointer
|| procptr
)
5689 if (ts
->type
== BT_CLASS
&& !procptr
)
5691 gfc_init_se (&se
, NULL
);
5692 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5693 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5694 TREE_STATIC (se
.expr
) = 1;
5697 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5698 return fold_convert (type
, null_pointer_node
);
5701 gfc_init_se (&se
, NULL
);
5702 se
.want_pointer
= 1;
5703 gfc_conv_expr (&se
, expr
);
5704 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5714 gfc_init_se (&se
, NULL
);
5715 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5716 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5718 gfc_conv_structure (&se
, expr
, 1);
5719 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5720 TREE_STATIC (se
.expr
) = 1;
5725 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5726 TREE_STATIC (ctor
) = 1;
5731 gfc_init_se (&se
, NULL
);
5732 gfc_conv_constant (&se
, expr
);
5733 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5740 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5746 gfc_array_info
*lss_array
;
5753 gfc_start_block (&block
);
5755 /* Initialize the scalarizer. */
5756 gfc_init_loopinfo (&loop
);
5758 gfc_init_se (&lse
, NULL
);
5759 gfc_init_se (&rse
, NULL
);
5762 rss
= gfc_walk_expr (expr
);
5763 if (rss
== gfc_ss_terminator
)
5764 /* The rhs is scalar. Add a ss for the expression. */
5765 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5767 /* Create a SS for the destination. */
5768 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5770 lss_array
= &lss
->info
->data
.array
;
5771 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5772 lss_array
->descriptor
= dest
;
5773 lss_array
->data
= gfc_conv_array_data (dest
);
5774 lss_array
->offset
= gfc_conv_array_offset (dest
);
5775 for (n
= 0; n
< cm
->as
->rank
; n
++)
5777 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5778 lss_array
->stride
[n
] = gfc_index_one_node
;
5780 mpz_init (lss_array
->shape
[n
]);
5781 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5782 cm
->as
->lower
[n
]->value
.integer
);
5783 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5786 /* Associate the SS with the loop. */
5787 gfc_add_ss_to_loop (&loop
, lss
);
5788 gfc_add_ss_to_loop (&loop
, rss
);
5790 /* Calculate the bounds of the scalarization. */
5791 gfc_conv_ss_startstride (&loop
);
5793 /* Setup the scalarizing loops. */
5794 gfc_conv_loop_setup (&loop
, &expr
->where
);
5796 /* Setup the gfc_se structures. */
5797 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5798 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5801 gfc_mark_ss_chain_used (rss
, 1);
5803 gfc_mark_ss_chain_used (lss
, 1);
5805 /* Start the scalarized loop body. */
5806 gfc_start_scalarized_body (&loop
, &body
);
5808 gfc_conv_tmp_array_ref (&lse
);
5809 if (cm
->ts
.type
== BT_CHARACTER
)
5810 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5812 gfc_conv_expr (&rse
, expr
);
5814 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5815 gfc_add_expr_to_block (&body
, tmp
);
5817 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5819 /* Generate the copying loops. */
5820 gfc_trans_scalarizing_loops (&loop
, &body
);
5822 /* Wrap the whole thing up. */
5823 gfc_add_block_to_block (&block
, &loop
.pre
);
5824 gfc_add_block_to_block (&block
, &loop
.post
);
5826 gcc_assert (lss_array
->shape
!= NULL
);
5827 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5828 gfc_cleanup_loop (&loop
);
5830 return gfc_finish_block (&block
);
5835 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5845 gfc_expr
*arg
= NULL
;
5847 gfc_start_block (&block
);
5848 gfc_init_se (&se
, NULL
);
5850 /* Get the descriptor for the expressions. */
5851 se
.want_pointer
= 0;
5852 gfc_conv_expr_descriptor (&se
, expr
);
5853 gfc_add_block_to_block (&block
, &se
.pre
);
5854 gfc_add_modify (&block
, dest
, se
.expr
);
5856 /* Deal with arrays of derived types with allocatable components. */
5857 if (cm
->ts
.type
== BT_DERIVED
5858 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5859 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5863 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5864 TREE_TYPE(cm
->backend_decl
),
5867 gfc_add_expr_to_block (&block
, tmp
);
5868 gfc_add_block_to_block (&block
, &se
.post
);
5870 if (expr
->expr_type
!= EXPR_VARIABLE
)
5871 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5874 /* We need to know if the argument of a conversion function is a
5875 variable, so that the correct lower bound can be used. */
5876 if (expr
->expr_type
== EXPR_FUNCTION
5877 && expr
->value
.function
.isym
5878 && expr
->value
.function
.isym
->conversion
5879 && expr
->value
.function
.actual
->expr
5880 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5881 arg
= expr
->value
.function
.actual
->expr
;
5883 /* Obtain the array spec of full array references. */
5885 as
= gfc_get_full_arrayspec_from_expr (arg
);
5887 as
= gfc_get_full_arrayspec_from_expr (expr
);
5889 /* Shift the lbound and ubound of temporaries to being unity,
5890 rather than zero, based. Always calculate the offset. */
5891 offset
= gfc_conv_descriptor_offset_get (dest
);
5892 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5893 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5895 for (n
= 0; n
< expr
->rank
; n
++)
5900 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5901 TODO It looks as if gfc_conv_expr_descriptor should return
5902 the correct bounds and that the following should not be
5903 necessary. This would simplify gfc_conv_intrinsic_bound
5905 if (as
&& as
->lower
[n
])
5908 gfc_init_se (&lbse
, NULL
);
5909 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5910 gfc_add_block_to_block (&block
, &lbse
.pre
);
5911 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5915 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5916 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5920 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5923 lbound
= gfc_index_one_node
;
5925 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5927 /* Shift the bounds and set the offset accordingly. */
5928 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5929 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5930 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5931 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5933 gfc_conv_descriptor_ubound_set (&block
, dest
,
5934 gfc_rank_cst
[n
], tmp
);
5935 gfc_conv_descriptor_lbound_set (&block
, dest
,
5936 gfc_rank_cst
[n
], lbound
);
5938 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5939 gfc_conv_descriptor_lbound_get (dest
,
5941 gfc_conv_descriptor_stride_get (dest
,
5943 gfc_add_modify (&block
, tmp2
, tmp
);
5944 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5946 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5951 /* If a conversion expression has a null data pointer
5952 argument, nullify the allocatable component. */
5956 if (arg
->symtree
->n
.sym
->attr
.allocatable
5957 || arg
->symtree
->n
.sym
->attr
.pointer
)
5959 non_null_expr
= gfc_finish_block (&block
);
5960 gfc_start_block (&block
);
5961 gfc_conv_descriptor_data_set (&block
, dest
,
5963 null_expr
= gfc_finish_block (&block
);
5964 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5965 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5966 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5967 return build3_v (COND_EXPR
, tmp
,
5968 null_expr
, non_null_expr
);
5972 return gfc_finish_block (&block
);
5976 /* Assign a single component of a derived type constructor. */
5979 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5986 gfc_start_block (&block
);
5988 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5990 gfc_init_se (&se
, NULL
);
5991 /* Pointer component. */
5992 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5994 /* Array pointer. */
5995 if (expr
->expr_type
== EXPR_NULL
)
5996 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5999 se
.direct_byref
= 1;
6001 gfc_conv_expr_descriptor (&se
, expr
);
6002 gfc_add_block_to_block (&block
, &se
.pre
);
6003 gfc_add_block_to_block (&block
, &se
.post
);
6008 /* Scalar pointers. */
6009 se
.want_pointer
= 1;
6010 gfc_conv_expr (&se
, expr
);
6011 gfc_add_block_to_block (&block
, &se
.pre
);
6013 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6014 && expr
->symtree
->n
.sym
->attr
.dummy
)
6015 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6017 gfc_add_modify (&block
, dest
,
6018 fold_convert (TREE_TYPE (dest
), se
.expr
));
6019 gfc_add_block_to_block (&block
, &se
.post
);
6022 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6024 /* NULL initialization for CLASS components. */
6025 tmp
= gfc_trans_structure_assign (dest
,
6026 gfc_class_initializer (&cm
->ts
, expr
));
6027 gfc_add_expr_to_block (&block
, tmp
);
6029 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
6031 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6032 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6033 else if (cm
->attr
.allocatable
)
6035 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6036 gfc_add_expr_to_block (&block
, tmp
);
6040 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6041 gfc_add_expr_to_block (&block
, tmp
);
6044 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6046 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6048 gfc_init_se (&se
, NULL
);
6049 gfc_conv_expr (&se
, expr
);
6050 gfc_add_block_to_block (&block
, &se
.pre
);
6051 gfc_add_modify (&block
, dest
,
6052 fold_convert (TREE_TYPE (dest
), se
.expr
));
6053 gfc_add_block_to_block (&block
, &se
.post
);
6057 /* Nested constructors. */
6058 tmp
= gfc_trans_structure_assign (dest
, expr
);
6059 gfc_add_expr_to_block (&block
, tmp
);
6062 else if (gfc_deferred_strlen (cm
, &tmp
))
6066 gcc_assert (strlen
);
6067 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6069 TREE_OPERAND (dest
, 0),
6072 if (expr
->expr_type
== EXPR_NULL
)
6074 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6075 gfc_add_modify (&block
, dest
, tmp
);
6076 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6077 gfc_add_modify (&block
, strlen
, tmp
);
6082 gfc_init_se (&se
, NULL
);
6083 gfc_conv_expr (&se
, expr
);
6084 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6085 tmp
= build_call_expr_loc (input_location
,
6086 builtin_decl_explicit (BUILT_IN_MALLOC
),
6088 gfc_add_modify (&block
, dest
,
6089 fold_convert (TREE_TYPE (dest
), tmp
));
6090 gfc_add_modify (&block
, strlen
, se
.string_length
);
6091 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6092 gfc_add_expr_to_block (&block
, tmp
);
6095 else if (!cm
->attr
.deferred_parameter
)
6097 /* Scalar component (excluding deferred parameters). */
6098 gfc_init_se (&se
, NULL
);
6099 gfc_init_se (&lse
, NULL
);
6101 gfc_conv_expr (&se
, expr
);
6102 if (cm
->ts
.type
== BT_CHARACTER
)
6103 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6105 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6106 gfc_add_expr_to_block (&block
, tmp
);
6108 return gfc_finish_block (&block
);
6111 /* Assign a derived type constructor to a variable. */
6114 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6122 gfc_start_block (&block
);
6123 cm
= expr
->ts
.u
.derived
->components
;
6125 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6126 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6127 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6131 gcc_assert (cm
->backend_decl
== NULL
);
6132 gfc_init_se (&se
, NULL
);
6133 gfc_init_se (&lse
, NULL
);
6134 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6136 gfc_add_modify (&block
, lse
.expr
,
6137 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6139 return gfc_finish_block (&block
);
6142 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6143 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6145 /* Skip absent members in default initializers. */
6149 field
= cm
->backend_decl
;
6150 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6151 dest
, field
, NULL_TREE
);
6152 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6153 gfc_add_expr_to_block (&block
, tmp
);
6155 return gfc_finish_block (&block
);
6158 /* Build an expression for a constructor. If init is nonzero then
6159 this is part of a static variable initializer. */
6162 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6169 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6171 gcc_assert (se
->ss
== NULL
);
6172 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6173 type
= gfc_typenode_for_spec (&expr
->ts
);
6177 /* Create a temporary variable and fill it in. */
6178 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6179 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6180 gfc_add_expr_to_block (&se
->pre
, tmp
);
6184 cm
= expr
->ts
.u
.derived
->components
;
6186 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6187 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6189 /* Skip absent members in default initializers and allocatable
6190 components. Although the latter have a default initializer
6191 of EXPR_NULL,... by default, the static nullify is not needed
6192 since this is done every time we come into scope. */
6193 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6196 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6197 && strcmp (cm
->name
, "_extends") == 0
6198 && cm
->initializer
->symtree
)
6202 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6203 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6204 vtab
= unshare_expr_without_location (vtab
);
6205 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6207 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6209 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6210 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6214 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6215 TREE_TYPE (cm
->backend_decl
),
6216 cm
->attr
.dimension
, cm
->attr
.pointer
,
6217 cm
->attr
.proc_pointer
);
6218 val
= unshare_expr_without_location (val
);
6220 /* Append it to the constructor list. */
6221 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6224 se
->expr
= build_constructor (type
, v
);
6226 TREE_CONSTANT (se
->expr
) = 1;
6230 /* Translate a substring expression. */
6233 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6239 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6241 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6242 expr
->value
.character
.length
,
6243 expr
->value
.character
.string
);
6245 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6246 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6249 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6253 /* Entry point for expression translation. Evaluates a scalar quantity.
6254 EXPR is the expression to be translated, and SE is the state structure if
6255 called from within the scalarized. */
6258 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6263 if (ss
&& ss
->info
->expr
== expr
6264 && (ss
->info
->type
== GFC_SS_SCALAR
6265 || ss
->info
->type
== GFC_SS_REFERENCE
))
6267 gfc_ss_info
*ss_info
;
6270 /* Substitute a scalar expression evaluated outside the scalarization
6272 se
->expr
= ss_info
->data
.scalar
.value
;
6273 /* If the reference can be NULL, the value field contains the reference,
6274 not the value the reference points to (see gfc_add_loop_ss_code). */
6275 if (ss_info
->can_be_null_ref
)
6276 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6278 se
->string_length
= ss_info
->string_length
;
6279 gfc_advance_se_ss_chain (se
);
6283 /* We need to convert the expressions for the iso_c_binding derived types.
6284 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6285 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6286 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6287 updated to be an integer with a kind equal to the size of a (void *). */
6288 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6290 if (expr
->expr_type
== EXPR_VARIABLE
6291 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6292 || expr
->symtree
->n
.sym
->intmod_sym_id
6293 == ISOCBINDING_NULL_FUNPTR
))
6295 /* Set expr_type to EXPR_NULL, which will result in
6296 null_pointer_node being used below. */
6297 expr
->expr_type
= EXPR_NULL
;
6301 /* Update the type/kind of the expression to be what the new
6302 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6303 expr
->ts
.type
= BT_INTEGER
;
6304 expr
->ts
.f90_type
= BT_VOID
;
6305 expr
->ts
.kind
= gfc_index_integer_kind
;
6309 gfc_fix_class_refs (expr
);
6311 switch (expr
->expr_type
)
6314 gfc_conv_expr_op (se
, expr
);
6318 gfc_conv_function_expr (se
, expr
);
6322 gfc_conv_constant (se
, expr
);
6326 gfc_conv_variable (se
, expr
);
6330 se
->expr
= null_pointer_node
;
6333 case EXPR_SUBSTRING
:
6334 gfc_conv_substring_expr (se
, expr
);
6337 case EXPR_STRUCTURE
:
6338 gfc_conv_structure (se
, expr
, 0);
6342 gfc_conv_array_constructor_expr (se
, expr
);
6351 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6352 of an assignment. */
6354 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6356 gfc_conv_expr (se
, expr
);
6357 /* All numeric lvalues should have empty post chains. If not we need to
6358 figure out a way of rewriting an lvalue so that it has no post chain. */
6359 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6362 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6363 numeric expressions. Used for scalar values where inserting cleanup code
6366 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6370 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6371 gfc_conv_expr (se
, expr
);
6374 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6375 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6377 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6381 /* Helper to translate an expression and convert it to a particular type. */
6383 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6385 gfc_conv_expr_val (se
, expr
);
6386 se
->expr
= convert (type
, se
->expr
);
6390 /* Converts an expression so that it can be passed by reference. Scalar
6394 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6400 if (ss
&& ss
->info
->expr
== expr
6401 && ss
->info
->type
== GFC_SS_REFERENCE
)
6403 /* Returns a reference to the scalar evaluated outside the loop
6405 gfc_conv_expr (se
, expr
);
6407 if (expr
->ts
.type
== BT_CHARACTER
6408 && expr
->expr_type
!= EXPR_FUNCTION
)
6409 gfc_conv_string_parameter (se
);
6411 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6416 if (expr
->ts
.type
== BT_CHARACTER
)
6418 gfc_conv_expr (se
, expr
);
6419 gfc_conv_string_parameter (se
);
6423 if (expr
->expr_type
== EXPR_VARIABLE
)
6425 se
->want_pointer
= 1;
6426 gfc_conv_expr (se
, expr
);
6429 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6430 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6431 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6437 if (expr
->expr_type
== EXPR_FUNCTION
6438 && ((expr
->value
.function
.esym
6439 && expr
->value
.function
.esym
->result
->attr
.pointer
6440 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6441 || (!expr
->value
.function
.esym
&& !expr
->ref
6442 && expr
->symtree
->n
.sym
->attr
.pointer
6443 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6445 se
->want_pointer
= 1;
6446 gfc_conv_expr (se
, expr
);
6447 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6448 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6453 gfc_conv_expr (se
, expr
);
6455 /* Create a temporary var to hold the value. */
6456 if (TREE_CONSTANT (se
->expr
))
6458 tree tmp
= se
->expr
;
6459 STRIP_TYPE_NOPS (tmp
);
6460 var
= build_decl (input_location
,
6461 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6462 DECL_INITIAL (var
) = tmp
;
6463 TREE_STATIC (var
) = 1;
6468 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6469 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6471 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6473 /* Take the address of that value. */
6474 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6479 gfc_trans_pointer_assign (gfc_code
* code
)
6481 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6485 /* Generate code for a pointer assignment. */
6488 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6490 gfc_expr
*expr1_vptr
= NULL
;
6500 gfc_start_block (&block
);
6502 gfc_init_se (&lse
, NULL
);
6504 /* Check whether the expression is a scalar or not; we cannot use
6505 expr1->rank as it can be nonzero for proc pointers. */
6506 ss
= gfc_walk_expr (expr1
);
6507 scalar
= ss
== gfc_ss_terminator
;
6509 gfc_free_ss_chain (ss
);
6511 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6512 && expr2
->expr_type
!= EXPR_FUNCTION
)
6514 gfc_add_data_component (expr2
);
6515 /* The following is required as gfc_add_data_component doesn't
6516 update ts.type if there is a tailing REF_ARRAY. */
6517 expr2
->ts
.type
= BT_DERIVED
;
6522 /* Scalar pointers. */
6523 lse
.want_pointer
= 1;
6524 gfc_conv_expr (&lse
, expr1
);
6525 gfc_init_se (&rse
, NULL
);
6526 rse
.want_pointer
= 1;
6527 gfc_conv_expr (&rse
, expr2
);
6529 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6530 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6531 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6534 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6535 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6536 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6539 gfc_add_block_to_block (&block
, &lse
.pre
);
6540 gfc_add_block_to_block (&block
, &rse
.pre
);
6542 /* Check character lengths if character expression. The test is only
6543 really added if -fbounds-check is enabled. Exclude deferred
6544 character length lefthand sides. */
6545 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6546 && !expr1
->ts
.deferred
6547 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6548 && !gfc_is_proc_ptr_comp (expr1
))
6550 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6551 gcc_assert (lse
.string_length
&& rse
.string_length
);
6552 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6553 lse
.string_length
, rse
.string_length
,
6557 /* The assignment to an deferred character length sets the string
6558 length to that of the rhs. */
6559 if (expr1
->ts
.deferred
)
6561 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6562 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6563 else if (lse
.string_length
!= NULL
)
6564 gfc_add_modify (&block
, lse
.string_length
,
6565 build_int_cst (gfc_charlen_type_node
, 0));
6568 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6569 rse
.expr
= gfc_class_data_get (rse
.expr
);
6571 gfc_add_modify (&block
, lse
.expr
,
6572 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6574 gfc_add_block_to_block (&block
, &rse
.post
);
6575 gfc_add_block_to_block (&block
, &lse
.post
);
6582 tree strlen_rhs
= NULL_TREE
;
6584 /* Array pointer. Find the last reference on the LHS and if it is an
6585 array section ref, we're dealing with bounds remapping. In this case,
6586 set it to AR_FULL so that gfc_conv_expr_descriptor does
6587 not see it and process the bounds remapping afterwards explicitly. */
6588 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6589 if (!remap
->next
&& remap
->type
== REF_ARRAY
6590 && remap
->u
.ar
.type
== AR_SECTION
)
6592 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6594 gfc_init_se (&lse
, NULL
);
6596 lse
.descriptor_only
= 1;
6597 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6598 && expr1
->ts
.type
== BT_CLASS
)
6599 expr1_vptr
= gfc_copy_expr (expr1
);
6600 gfc_conv_expr_descriptor (&lse
, expr1
);
6601 strlen_lhs
= lse
.string_length
;
6604 if (expr2
->expr_type
== EXPR_NULL
)
6606 /* Just set the data pointer to null. */
6607 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6609 else if (rank_remap
)
6611 /* If we are rank-remapping, just get the RHS's descriptor and
6612 process this later on. */
6613 gfc_init_se (&rse
, NULL
);
6614 rse
.direct_byref
= 1;
6615 rse
.byref_noassign
= 1;
6617 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6619 gfc_conv_function_expr (&rse
, expr2
);
6621 if (expr1
->ts
.type
!= BT_CLASS
)
6622 rse
.expr
= gfc_class_data_get (rse
.expr
);
6625 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6626 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6628 gfc_add_vptr_component (expr1_vptr
);
6629 gfc_init_se (&rse
, NULL
);
6630 rse
.want_pointer
= 1;
6631 gfc_conv_expr (&rse
, expr1_vptr
);
6632 gfc_add_modify (&lse
.pre
, rse
.expr
,
6633 fold_convert (TREE_TYPE (rse
.expr
),
6634 gfc_class_vptr_get (tmp
)));
6635 rse
.expr
= gfc_class_data_get (tmp
);
6638 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6640 tree bound
[GFC_MAX_DIMENSIONS
];
6643 for (i
= 0; i
< expr2
->rank
; i
++)
6644 bound
[i
] = NULL_TREE
;
6645 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6646 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6648 GFC_ARRAY_POINTER_CONT
, false);
6649 tmp
= gfc_create_var (tmp
, "ptrtemp");
6651 lse
.direct_byref
= 1;
6652 gfc_conv_expr_descriptor (&lse
, expr2
);
6653 strlen_rhs
= lse
.string_length
;
6658 gfc_conv_expr_descriptor (&rse
, expr2
);
6659 strlen_rhs
= rse
.string_length
;
6662 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6664 /* Assign directly to the LHS's descriptor. */
6665 lse
.direct_byref
= 1;
6666 gfc_conv_expr_descriptor (&lse
, expr2
);
6667 strlen_rhs
= lse
.string_length
;
6669 /* If this is a subreference array pointer assignment, use the rhs
6670 descriptor element size for the lhs span. */
6671 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6673 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6674 gfc_init_se (&rse
, NULL
);
6675 rse
.descriptor_only
= 1;
6676 gfc_conv_expr (&rse
, expr2
);
6677 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6678 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6679 if (!INTEGER_CST_P (tmp
))
6680 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6681 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6684 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6686 gfc_init_se (&rse
, NULL
);
6687 rse
.want_pointer
= 1;
6688 gfc_conv_function_expr (&rse
, expr2
);
6689 if (expr1
->ts
.type
!= BT_CLASS
)
6691 rse
.expr
= gfc_class_data_get (rse
.expr
);
6692 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6696 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6697 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6699 gfc_add_vptr_component (expr1_vptr
);
6700 gfc_init_se (&rse
, NULL
);
6701 rse
.want_pointer
= 1;
6702 gfc_conv_expr (&rse
, expr1_vptr
);
6703 gfc_add_modify (&lse
.pre
, rse
.expr
,
6704 fold_convert (TREE_TYPE (rse
.expr
),
6705 gfc_class_vptr_get (tmp
)));
6706 rse
.expr
= gfc_class_data_get (tmp
);
6707 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
6712 /* Assign to a temporary descriptor and then copy that
6713 temporary to the pointer. */
6714 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6716 lse
.direct_byref
= 1;
6717 gfc_conv_expr_descriptor (&lse
, expr2
);
6718 strlen_rhs
= lse
.string_length
;
6719 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6723 gfc_free_expr (expr1_vptr
);
6725 gfc_add_block_to_block (&block
, &lse
.pre
);
6727 gfc_add_block_to_block (&block
, &rse
.pre
);
6729 /* If we do bounds remapping, update LHS descriptor accordingly. */
6733 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6737 /* Do rank remapping. We already have the RHS's descriptor
6738 converted in rse and now have to build the correct LHS
6739 descriptor for it. */
6743 tree lbound
, ubound
;
6746 dtype
= gfc_conv_descriptor_dtype (desc
);
6747 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6748 gfc_add_modify (&block
, dtype
, tmp
);
6750 /* Copy data pointer. */
6751 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6752 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6754 /* Copy offset but adjust it such that it would correspond
6755 to a lbound of zero. */
6756 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6757 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6759 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6761 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6763 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6764 gfc_array_index_type
, stride
, lbound
);
6765 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6766 gfc_array_index_type
, offs
, tmp
);
6768 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6770 /* Set the bounds as declared for the LHS and calculate strides as
6771 well as another offset update accordingly. */
6772 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6774 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6779 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6781 /* Convert declared bounds. */
6782 gfc_init_se (&lower_se
, NULL
);
6783 gfc_init_se (&upper_se
, NULL
);
6784 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6785 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6787 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6788 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6790 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6791 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6793 lbound
= gfc_evaluate_now (lbound
, &block
);
6794 ubound
= gfc_evaluate_now (ubound
, &block
);
6796 gfc_add_block_to_block (&block
, &lower_se
.post
);
6797 gfc_add_block_to_block (&block
, &upper_se
.post
);
6799 /* Set bounds in descriptor. */
6800 gfc_conv_descriptor_lbound_set (&block
, desc
,
6801 gfc_rank_cst
[dim
], lbound
);
6802 gfc_conv_descriptor_ubound_set (&block
, desc
,
6803 gfc_rank_cst
[dim
], ubound
);
6806 stride
= gfc_evaluate_now (stride
, &block
);
6807 gfc_conv_descriptor_stride_set (&block
, desc
,
6808 gfc_rank_cst
[dim
], stride
);
6810 /* Update offset. */
6811 offs
= gfc_conv_descriptor_offset_get (desc
);
6812 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6813 gfc_array_index_type
, lbound
, stride
);
6814 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6815 gfc_array_index_type
, offs
, tmp
);
6816 offs
= gfc_evaluate_now (offs
, &block
);
6817 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6819 /* Update stride. */
6820 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6821 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6822 gfc_array_index_type
, stride
, tmp
);
6827 /* Bounds remapping. Just shift the lower bounds. */
6829 gcc_assert (expr1
->rank
== expr2
->rank
);
6831 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6835 gcc_assert (remap
->u
.ar
.start
[dim
]);
6836 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6837 gfc_init_se (&lbound_se
, NULL
);
6838 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6840 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6841 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6842 dim
, lbound_se
.expr
);
6843 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6848 /* Check string lengths if applicable. The check is only really added
6849 to the output code if -fbounds-check is enabled. */
6850 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6852 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6853 gcc_assert (strlen_lhs
&& strlen_rhs
);
6854 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6855 strlen_lhs
, strlen_rhs
, &block
);
6858 /* If rank remapping was done, check with -fcheck=bounds that
6859 the target is at least as large as the pointer. */
6860 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6866 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6867 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6869 lsize
= gfc_evaluate_now (lsize
, &block
);
6870 rsize
= gfc_evaluate_now (rsize
, &block
);
6871 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6874 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6875 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6879 gfc_add_block_to_block (&block
, &lse
.post
);
6881 gfc_add_block_to_block (&block
, &rse
.post
);
6884 return gfc_finish_block (&block
);
6888 /* Makes sure se is suitable for passing as a function string parameter. */
6889 /* TODO: Need to check all callers of this function. It may be abused. */
6892 gfc_conv_string_parameter (gfc_se
* se
)
6896 if (TREE_CODE (se
->expr
) == STRING_CST
)
6898 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6899 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6903 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6905 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6907 type
= TREE_TYPE (se
->expr
);
6908 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6912 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6914 type
= build_pointer_type (type
);
6915 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6919 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6923 /* Generate code for assignment of scalar variables. Includes character
6924 strings and derived types with allocatable components.
6925 If you know that the LHS has no allocations, set dealloc to false.
6927 DEEP_COPY has no effect if the typespec TS is not a derived type with
6928 allocatable components. Otherwise, if it is set, an explicit copy of each
6929 allocatable component is made. This is necessary as a simple copy of the
6930 whole object would copy array descriptors as is, so that the lhs's
6931 allocatable components would point to the rhs's after the assignment.
6932 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6933 necessary if the rhs is a non-pointer function, as the allocatable components
6934 are not accessible by other means than the function's result after the
6935 function has returned. It is even more subtle when temporaries are involved,
6936 as the two following examples show:
6937 1. When we evaluate an array constructor, a temporary is created. Thus
6938 there is theoretically no alias possible. However, no deep copy is
6939 made for this temporary, so that if the constructor is made of one or
6940 more variable with allocatable components, those components still point
6941 to the variable's: DEEP_COPY should be set for the assignment from the
6942 temporary to the lhs in that case.
6943 2. When assigning a scalar to an array, we evaluate the scalar value out
6944 of the loop, store it into a temporary variable, and assign from that.
6945 In that case, deep copying when assigning to the temporary would be a
6946 waste of resources; however deep copies should happen when assigning from
6947 the temporary to each array element: again DEEP_COPY should be set for
6948 the assignment from the temporary to the lhs. */
6951 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6952 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6958 gfc_init_block (&block
);
6960 if (ts
.type
== BT_CHARACTER
)
6965 if (lse
->string_length
!= NULL_TREE
)
6967 gfc_conv_string_parameter (lse
);
6968 gfc_add_block_to_block (&block
, &lse
->pre
);
6969 llen
= lse
->string_length
;
6972 if (rse
->string_length
!= NULL_TREE
)
6974 gcc_assert (rse
->string_length
!= NULL_TREE
);
6975 gfc_conv_string_parameter (rse
);
6976 gfc_add_block_to_block (&block
, &rse
->pre
);
6977 rlen
= rse
->string_length
;
6980 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6981 rse
->expr
, ts
.kind
);
6983 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6985 tree tmp_var
= NULL_TREE
;
6988 /* Are the rhs and the lhs the same? */
6991 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6992 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6993 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6994 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6997 /* Deallocate the lhs allocated components as long as it is not
6998 the same as the rhs. This must be done following the assignment
6999 to prevent deallocating data that could be used in the rhs
7001 if (!l_is_temp
&& dealloc
)
7003 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7004 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7006 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7008 gfc_add_expr_to_block (&lse
->post
, tmp
);
7011 gfc_add_block_to_block (&block
, &rse
->pre
);
7012 gfc_add_block_to_block (&block
, &lse
->pre
);
7014 gfc_add_modify (&block
, lse
->expr
,
7015 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7017 /* Restore pointer address of coarray components. */
7018 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7020 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7021 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7023 gfc_add_expr_to_block (&block
, tmp
);
7026 /* Do a deep copy if the rhs is a variable, if it is not the
7030 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7031 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7033 gfc_add_expr_to_block (&block
, tmp
);
7036 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7038 gfc_add_block_to_block (&block
, &lse
->pre
);
7039 gfc_add_block_to_block (&block
, &rse
->pre
);
7040 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7041 TREE_TYPE (lse
->expr
), rse
->expr
);
7042 gfc_add_modify (&block
, lse
->expr
, tmp
);
7046 gfc_add_block_to_block (&block
, &lse
->pre
);
7047 gfc_add_block_to_block (&block
, &rse
->pre
);
7049 gfc_add_modify (&block
, lse
->expr
,
7050 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7053 gfc_add_block_to_block (&block
, &lse
->post
);
7054 gfc_add_block_to_block (&block
, &rse
->post
);
7056 return gfc_finish_block (&block
);
7060 /* There are quite a lot of restrictions on the optimisation in using an
7061 array function assign without a temporary. */
7064 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7067 bool seen_array_ref
;
7069 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7071 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7072 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7075 /* Elemental functions are scalarized so that they don't need a
7076 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7077 they would need special treatment in gfc_trans_arrayfunc_assign. */
7078 if (expr2
->value
.function
.esym
!= NULL
7079 && expr2
->value
.function
.esym
->attr
.elemental
)
7082 /* Need a temporary if rhs is not FULL or a contiguous section. */
7083 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7086 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7087 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7090 /* Functions returning pointers or allocatables need temporaries. */
7091 c
= expr2
->value
.function
.esym
7092 ? (expr2
->value
.function
.esym
->attr
.pointer
7093 || expr2
->value
.function
.esym
->attr
.allocatable
)
7094 : (expr2
->symtree
->n
.sym
->attr
.pointer
7095 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7099 /* Character array functions need temporaries unless the
7100 character lengths are the same. */
7101 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7103 if (expr1
->ts
.u
.cl
->length
== NULL
7104 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7107 if (expr2
->ts
.u
.cl
->length
== NULL
7108 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7111 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7112 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7116 /* Check that no LHS component references appear during an array
7117 reference. This is needed because we do not have the means to
7118 span any arbitrary stride with an array descriptor. This check
7119 is not needed for the rhs because the function result has to be
7121 seen_array_ref
= false;
7122 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7124 if (ref
->type
== REF_ARRAY
)
7125 seen_array_ref
= true;
7126 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7130 /* Check for a dependency. */
7131 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7132 expr2
->value
.function
.esym
,
7133 expr2
->value
.function
.actual
,
7137 /* If we have reached here with an intrinsic function, we do not
7138 need a temporary except in the particular case that reallocation
7139 on assignment is active and the lhs is allocatable and a target. */
7140 if (expr2
->value
.function
.isym
)
7141 return (gfc_option
.flag_realloc_lhs
7142 && sym
->attr
.allocatable
7143 && sym
->attr
.target
);
7145 /* If the LHS is a dummy, we need a temporary if it is not
7147 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7150 /* If the lhs has been host_associated, is in common, a pointer or is
7151 a target and the function is not using a RESULT variable, aliasing
7152 can occur and a temporary is needed. */
7153 if ((sym
->attr
.host_assoc
7154 || sym
->attr
.in_common
7155 || sym
->attr
.pointer
7156 || sym
->attr
.cray_pointee
7157 || sym
->attr
.target
)
7158 && expr2
->symtree
!= NULL
7159 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7162 /* A PURE function can unconditionally be called without a temporary. */
7163 if (expr2
->value
.function
.esym
!= NULL
7164 && expr2
->value
.function
.esym
->attr
.pure
)
7167 /* Implicit_pure functions are those which could legally be declared
7169 if (expr2
->value
.function
.esym
!= NULL
7170 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7173 if (!sym
->attr
.use_assoc
7174 && !sym
->attr
.in_common
7175 && !sym
->attr
.pointer
7176 && !sym
->attr
.target
7177 && !sym
->attr
.cray_pointee
7178 && expr2
->value
.function
.esym
)
7180 /* A temporary is not needed if the function is not contained and
7181 the variable is local or host associated and not a pointer or
7183 if (!expr2
->value
.function
.esym
->attr
.contained
)
7186 /* A temporary is not needed if the lhs has never been host
7187 associated and the procedure is contained. */
7188 else if (!sym
->attr
.host_assoc
)
7191 /* A temporary is not needed if the variable is local and not
7192 a pointer, a target or a result. */
7194 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7198 /* Default to temporary use. */
7203 /* Provide the loop info so that the lhs descriptor can be built for
7204 reallocatable assignments from extrinsic function calls. */
7207 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7210 /* Signal that the function call should not be made by
7211 gfc_conv_loop_setup. */
7212 se
->ss
->is_alloc_lhs
= 1;
7213 gfc_init_loopinfo (loop
);
7214 gfc_add_ss_to_loop (loop
, *ss
);
7215 gfc_add_ss_to_loop (loop
, se
->ss
);
7216 gfc_conv_ss_startstride (loop
);
7217 gfc_conv_loop_setup (loop
, where
);
7218 gfc_copy_loopinfo_to_se (se
, loop
);
7219 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7220 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7221 se
->ss
->is_alloc_lhs
= 0;
7225 /* For assignment to a reallocatable lhs from intrinsic functions,
7226 replace the se.expr (ie. the result) with a temporary descriptor.
7227 Null the data field so that the library allocates space for the
7228 result. Free the data of the original descriptor after the function,
7229 in case it appears in an argument expression and transfer the
7230 result to the original descriptor. */
7233 fcncall_realloc_result (gfc_se
*se
, int rank
)
7242 /* Use the allocation done by the library. Substitute the lhs
7243 descriptor with a copy, whose data field is nulled.*/
7244 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7245 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7246 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7248 /* Unallocated, the descriptor does not have a dtype. */
7249 tmp
= gfc_conv_descriptor_dtype (desc
);
7250 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7252 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7253 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7254 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
7256 /* Free the lhs after the function call and copy the result data to
7257 the lhs descriptor. */
7258 tmp
= gfc_conv_descriptor_data_get (desc
);
7259 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7260 boolean_type_node
, tmp
,
7261 build_int_cst (TREE_TYPE (tmp
), 0));
7262 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7263 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7264 gfc_add_expr_to_block (&se
->post
, tmp
);
7266 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7267 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7269 /* Check that the shapes are the same between lhs and expression. */
7270 for (n
= 0 ; n
< rank
; n
++)
7273 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7274 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7275 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7276 gfc_array_index_type
, tmp
, tmp1
);
7277 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7278 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7279 gfc_array_index_type
, tmp
, tmp1
);
7280 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7281 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7282 gfc_array_index_type
, tmp
, tmp1
);
7283 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7284 boolean_type_node
, tmp
,
7285 gfc_index_zero_node
);
7286 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7287 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7288 boolean_type_node
, tmp
,
7292 /* 'zero_cond' being true is equal to lhs not being allocated or the
7293 shapes being different. */
7294 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7296 /* Now reset the bounds returned from the function call to bounds based
7297 on the lhs lbounds, except where the lhs is not allocated or the shapes
7298 of 'variable and 'expr' are different. Set the offset accordingly. */
7299 offset
= gfc_index_zero_node
;
7300 for (n
= 0 ; n
< rank
; n
++)
7304 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7305 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7306 gfc_array_index_type
, zero_cond
,
7307 gfc_index_one_node
, lbound
);
7308 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7310 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7311 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7312 gfc_array_index_type
, tmp
, lbound
);
7313 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7314 gfc_rank_cst
[n
], lbound
);
7315 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7316 gfc_rank_cst
[n
], tmp
);
7318 /* Set stride and accumulate the offset. */
7319 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7320 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7321 gfc_rank_cst
[n
], tmp
);
7322 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7323 gfc_array_index_type
, lbound
, tmp
);
7324 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7325 gfc_array_index_type
, offset
, tmp
);
7326 offset
= gfc_evaluate_now (offset
, &se
->post
);
7329 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7334 /* Try to translate array(:) = func (...), where func is a transformational
7335 array function, without using a temporary. Returns NULL if this isn't the
7339 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7343 gfc_component
*comp
= NULL
;
7346 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7349 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7351 comp
= gfc_get_proc_ptr_comp (expr2
);
7352 gcc_assert (expr2
->value
.function
.isym
7353 || (comp
&& comp
->attr
.dimension
)
7354 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7355 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7357 gfc_init_se (&se
, NULL
);
7358 gfc_start_block (&se
.pre
);
7359 se
.want_pointer
= 1;
7361 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7363 if (expr1
->ts
.type
== BT_DERIVED
7364 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7367 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7369 gfc_add_expr_to_block (&se
.pre
, tmp
);
7372 se
.direct_byref
= 1;
7373 se
.ss
= gfc_walk_expr (expr2
);
7374 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7376 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7377 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7378 Clearly, this cannot be done for an allocatable function result, since
7379 the shape of the result is unknown and, in any case, the function must
7380 correctly take care of the reallocation internally. For intrinsic
7381 calls, the array data is freed and the library takes care of allocation.
7382 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7384 if (gfc_option
.flag_realloc_lhs
7385 && gfc_is_reallocatable_lhs (expr1
)
7386 && !gfc_expr_attr (expr1
).codimension
7387 && !gfc_is_coindexed (expr1
)
7388 && !(expr2
->value
.function
.esym
7389 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7391 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7393 if (!expr2
->value
.function
.isym
)
7395 ss
= gfc_walk_expr (expr1
);
7396 gcc_assert (ss
!= gfc_ss_terminator
);
7398 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7399 ss
->is_alloc_lhs
= 1;
7402 fcncall_realloc_result (&se
, expr1
->rank
);
7405 gfc_conv_function_expr (&se
, expr2
);
7406 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7409 gfc_cleanup_loop (&loop
);
7411 gfc_free_ss_chain (se
.ss
);
7413 return gfc_finish_block (&se
.pre
);
7417 /* Try to efficiently translate array(:) = 0. Return NULL if this
7421 gfc_trans_zero_assign (gfc_expr
* expr
)
7423 tree dest
, len
, type
;
7427 sym
= expr
->symtree
->n
.sym
;
7428 dest
= gfc_get_symbol_decl (sym
);
7430 type
= TREE_TYPE (dest
);
7431 if (POINTER_TYPE_P (type
))
7432 type
= TREE_TYPE (type
);
7433 if (!GFC_ARRAY_TYPE_P (type
))
7436 /* Determine the length of the array. */
7437 len
= GFC_TYPE_ARRAY_SIZE (type
);
7438 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7441 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7442 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7443 fold_convert (gfc_array_index_type
, tmp
));
7445 /* If we are zeroing a local array avoid taking its address by emitting
7447 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7448 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7449 dest
, build_constructor (TREE_TYPE (dest
),
7452 /* Convert arguments to the correct types. */
7453 dest
= fold_convert (pvoid_type_node
, dest
);
7454 len
= fold_convert (size_type_node
, len
);
7456 /* Construct call to __builtin_memset. */
7457 tmp
= build_call_expr_loc (input_location
,
7458 builtin_decl_explicit (BUILT_IN_MEMSET
),
7459 3, dest
, integer_zero_node
, len
);
7460 return fold_convert (void_type_node
, tmp
);
7464 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7465 that constructs the call to __builtin_memcpy. */
7468 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7472 /* Convert arguments to the correct types. */
7473 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7474 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7476 dst
= fold_convert (pvoid_type_node
, dst
);
7478 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7479 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7481 src
= fold_convert (pvoid_type_node
, src
);
7483 len
= fold_convert (size_type_node
, len
);
7485 /* Construct call to __builtin_memcpy. */
7486 tmp
= build_call_expr_loc (input_location
,
7487 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7489 return fold_convert (void_type_node
, tmp
);
7493 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7494 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7495 source/rhs, both are gfc_full_array_ref_p which have been checked for
7499 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7501 tree dst
, dlen
, dtype
;
7502 tree src
, slen
, stype
;
7505 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7506 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7508 dtype
= TREE_TYPE (dst
);
7509 if (POINTER_TYPE_P (dtype
))
7510 dtype
= TREE_TYPE (dtype
);
7511 stype
= TREE_TYPE (src
);
7512 if (POINTER_TYPE_P (stype
))
7513 stype
= TREE_TYPE (stype
);
7515 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7518 /* Determine the lengths of the arrays. */
7519 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7520 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7522 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7523 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7524 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7526 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7527 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7529 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7530 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7531 slen
, fold_convert (gfc_array_index_type
, tmp
));
7533 /* Sanity check that they are the same. This should always be
7534 the case, as we should already have checked for conformance. */
7535 if (!tree_int_cst_equal (slen
, dlen
))
7538 return gfc_build_memcpy_call (dst
, src
, dlen
);
7542 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7543 this can't be done. EXPR1 is the destination/lhs for which
7544 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7547 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7549 unsigned HOST_WIDE_INT nelem
;
7555 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7559 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7560 dtype
= TREE_TYPE (dst
);
7561 if (POINTER_TYPE_P (dtype
))
7562 dtype
= TREE_TYPE (dtype
);
7563 if (!GFC_ARRAY_TYPE_P (dtype
))
7566 /* Determine the lengths of the array. */
7567 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7568 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7571 /* Confirm that the constructor is the same size. */
7572 if (compare_tree_int (len
, nelem
) != 0)
7575 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7576 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7577 fold_convert (gfc_array_index_type
, tmp
));
7579 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7580 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7582 stype
= TREE_TYPE (src
);
7583 if (POINTER_TYPE_P (stype
))
7584 stype
= TREE_TYPE (stype
);
7586 return gfc_build_memcpy_call (dst
, src
, len
);
7590 /* Tells whether the expression is to be treated as a variable reference. */
7593 expr_is_variable (gfc_expr
*expr
)
7596 gfc_component
*comp
;
7597 gfc_symbol
*func_ifc
;
7599 if (expr
->expr_type
== EXPR_VARIABLE
)
7602 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7605 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7606 return expr_is_variable (arg
);
7609 /* A data-pointer-returning function should be considered as a variable
7611 if (expr
->expr_type
== EXPR_FUNCTION
7612 && expr
->ref
== NULL
)
7614 if (expr
->value
.function
.isym
!= NULL
)
7617 if (expr
->value
.function
.esym
!= NULL
)
7619 func_ifc
= expr
->value
.function
.esym
;
7624 gcc_assert (expr
->symtree
);
7625 func_ifc
= expr
->symtree
->n
.sym
;
7632 comp
= gfc_get_proc_ptr_comp (expr
);
7633 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7636 func_ifc
= comp
->ts
.interface
;
7640 if (expr
->expr_type
== EXPR_COMPCALL
)
7642 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7643 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7650 gcc_assert (func_ifc
->attr
.function
7651 && func_ifc
->result
!= NULL
);
7652 return func_ifc
->result
->attr
.pointer
;
7656 /* Is the lhs OK for automatic reallocation? */
7659 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7663 /* An allocatable variable with no reference. */
7664 if (expr
->symtree
->n
.sym
->attr
.allocatable
7668 /* All that can be left are allocatable components. */
7669 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7670 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7671 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7674 /* Find an allocatable component ref last. */
7675 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7676 if (ref
->type
== REF_COMPONENT
7678 && ref
->u
.c
.component
->attr
.allocatable
)
7685 /* Allocate or reallocate scalar lhs, as necessary. */
7688 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7702 if (!expr1
|| expr1
->rank
)
7705 if (!expr2
|| expr2
->rank
)
7708 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7710 /* Since this is a scalar lhs, we can afford to do this. That is,
7711 there is no risk of side effects being repeated. */
7712 gfc_init_se (&lse
, NULL
);
7713 lse
.want_pointer
= 1;
7714 gfc_conv_expr (&lse
, expr1
);
7716 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7717 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7719 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7720 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7721 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7723 tmp
= build3_v (COND_EXPR
, cond
,
7724 build1_v (GOTO_EXPR
, jump_label1
),
7725 build_empty_stmt (input_location
));
7726 gfc_add_expr_to_block (block
, tmp
);
7728 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7730 /* Use the rhs string length and the lhs element size. */
7731 size
= string_length
;
7732 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7733 tmp
= TYPE_SIZE_UNIT (tmp
);
7734 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7735 TREE_TYPE (tmp
), tmp
,
7736 fold_convert (TREE_TYPE (tmp
), size
));
7740 /* Otherwise use the length in bytes of the rhs. */
7741 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7742 size_in_bytes
= size
;
7745 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
7746 size_in_bytes
, size_one_node
);
7748 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7750 tmp
= build_call_expr_loc (input_location
,
7751 builtin_decl_explicit (BUILT_IN_CALLOC
),
7752 2, build_one_cst (size_type_node
),
7754 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7755 gfc_add_modify (block
, lse
.expr
, tmp
);
7759 tmp
= build_call_expr_loc (input_location
,
7760 builtin_decl_explicit (BUILT_IN_MALLOC
),
7762 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7763 gfc_add_modify (block
, lse
.expr
, tmp
);
7766 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7768 /* Deferred characters need checking for lhs and rhs string
7769 length. Other deferred parameter variables will have to
7771 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7772 gfc_add_expr_to_block (block
, tmp
);
7774 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7775 gfc_add_expr_to_block (block
, tmp
);
7777 /* For a deferred length character, reallocate if lengths of lhs and
7778 rhs are different. */
7779 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7781 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7782 expr1
->ts
.u
.cl
->backend_decl
, size
);
7783 /* Jump past the realloc if the lengths are the same. */
7784 tmp
= build3_v (COND_EXPR
, cond
,
7785 build1_v (GOTO_EXPR
, jump_label2
),
7786 build_empty_stmt (input_location
));
7787 gfc_add_expr_to_block (block
, tmp
);
7788 tmp
= build_call_expr_loc (input_location
,
7789 builtin_decl_explicit (BUILT_IN_REALLOC
),
7790 2, fold_convert (pvoid_type_node
, lse
.expr
),
7792 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7793 gfc_add_modify (block
, lse
.expr
, tmp
);
7794 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7795 gfc_add_expr_to_block (block
, tmp
);
7797 /* Update the lhs character length. */
7798 size
= string_length
;
7799 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
7800 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7802 gfc_add_modify (block
, lse
.string_length
, size
);
7806 /* Check for assignments of the type
7810 to make sure we do not check for reallocation unneccessarily. */
7814 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
7816 gfc_actual_arglist
*a
;
7819 switch (expr2
->expr_type
)
7822 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
7825 if (expr2
->value
.function
.esym
7826 && expr2
->value
.function
.esym
->attr
.elemental
)
7828 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7831 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7836 else if (expr2
->value
.function
.isym
7837 && expr2
->value
.function
.isym
->elemental
)
7839 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
7842 if (e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
7851 switch (expr2
->value
.op
.op
)
7854 case INTRINSIC_UPLUS
:
7855 case INTRINSIC_UMINUS
:
7856 case INTRINSIC_PARENTHESES
:
7857 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
7859 case INTRINSIC_PLUS
:
7860 case INTRINSIC_MINUS
:
7861 case INTRINSIC_TIMES
:
7862 case INTRINSIC_DIVIDE
:
7863 case INTRINSIC_POWER
:
7867 case INTRINSIC_NEQV
:
7874 case INTRINSIC_EQ_OS
:
7875 case INTRINSIC_NE_OS
:
7876 case INTRINSIC_GT_OS
:
7877 case INTRINSIC_GE_OS
:
7878 case INTRINSIC_LT_OS
:
7879 case INTRINSIC_LE_OS
:
7881 e1
= expr2
->value
.op
.op1
;
7882 e2
= expr2
->value
.op
.op2
;
7884 if (e1
->rank
== 0 && e2
->rank
> 0)
7885 return is_runtime_conformable (expr1
, e2
);
7886 else if (e1
->rank
> 0 && e2
->rank
== 0)
7887 return is_runtime_conformable (expr1
, e1
);
7888 else if (e1
->rank
> 0 && e2
->rank
> 0)
7889 return is_runtime_conformable (expr1
, e1
)
7890 && is_runtime_conformable (expr1
, e2
);
7906 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7907 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7908 init_flag indicates initialization expressions and dealloc that no
7909 deallocate prior assignment is needed (if in doubt, set true). */
7912 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7918 gfc_ss
*lss_section
;
7925 bool scalar_to_array
;
7929 /* Assignment of the form lhs = rhs. */
7930 gfc_start_block (&block
);
7932 gfc_init_se (&lse
, NULL
);
7933 gfc_init_se (&rse
, NULL
);
7936 lss
= gfc_walk_expr (expr1
);
7937 if (gfc_is_reallocatable_lhs (expr1
)
7938 && !(expr2
->expr_type
== EXPR_FUNCTION
7939 && expr2
->value
.function
.isym
!= NULL
))
7940 lss
->is_alloc_lhs
= 1;
7942 if (lss
!= gfc_ss_terminator
)
7944 /* The assignment needs scalarization. */
7947 /* Find a non-scalar SS from the lhs. */
7948 while (lss_section
!= gfc_ss_terminator
7949 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7950 lss_section
= lss_section
->next
;
7952 gcc_assert (lss_section
!= gfc_ss_terminator
);
7954 /* Initialize the scalarizer. */
7955 gfc_init_loopinfo (&loop
);
7958 rss
= gfc_walk_expr (expr2
);
7959 if (rss
== gfc_ss_terminator
)
7960 /* The rhs is scalar. Add a ss for the expression. */
7961 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7963 /* Associate the SS with the loop. */
7964 gfc_add_ss_to_loop (&loop
, lss
);
7965 gfc_add_ss_to_loop (&loop
, rss
);
7967 /* Calculate the bounds of the scalarization. */
7968 gfc_conv_ss_startstride (&loop
);
7969 /* Enable loop reversal. */
7970 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7971 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7972 /* Resolve any data dependencies in the statement. */
7973 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7974 /* Setup the scalarizing loops. */
7975 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7977 /* Setup the gfc_se structures. */
7978 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7979 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7982 gfc_mark_ss_chain_used (rss
, 1);
7983 if (loop
.temp_ss
== NULL
)
7986 gfc_mark_ss_chain_used (lss
, 1);
7990 lse
.ss
= loop
.temp_ss
;
7991 gfc_mark_ss_chain_used (lss
, 3);
7992 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
7995 /* Allow the scalarizer to workshare array assignments. */
7996 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
7997 ompws_flags
|= OMPWS_SCALARIZER_WS
;
7999 /* Start the scalarized loop body. */
8000 gfc_start_scalarized_body (&loop
, &body
);
8003 gfc_init_block (&body
);
8005 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8007 /* Translate the expression. */
8008 gfc_conv_expr (&rse
, expr2
);
8010 /* Stabilize a string length for temporaries. */
8011 if (expr2
->ts
.type
== BT_CHARACTER
)
8012 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8014 string_length
= NULL_TREE
;
8018 gfc_conv_tmp_array_ref (&lse
);
8019 if (expr2
->ts
.type
== BT_CHARACTER
)
8020 lse
.string_length
= string_length
;
8023 gfc_conv_expr (&lse
, expr1
);
8025 /* Assignments of scalar derived types with allocatable components
8026 to arrays must be done with a deep copy and the rhs temporary
8027 must have its components deallocated afterwards. */
8028 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8029 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8030 && !expr_is_variable (expr2
)
8031 && !gfc_is_constant_expr (expr2
)
8032 && expr1
->rank
&& !expr2
->rank
);
8033 if (scalar_to_array
&& dealloc
)
8035 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8036 gfc_add_expr_to_block (&loop
.post
, tmp
);
8039 /* When assigning a character function result to a deferred-length variable,
8040 the function call must happen before the (re)allocation of the lhs -
8041 otherwise the character length of the result is not known.
8042 NOTE: This relies on having the exact dependence of the length type
8043 parameter available to the caller; gfortran saves it in the .mod files. */
8044 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
8045 && expr1
->ts
.deferred
)
8046 gfc_add_block_to_block (&block
, &rse
.pre
);
8048 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8049 l_is_temp
|| init_flag
,
8050 expr_is_variable (expr2
) || scalar_to_array
8051 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8052 gfc_add_expr_to_block (&body
, tmp
);
8054 if (lss
== gfc_ss_terminator
)
8056 /* F2003: Add the code for reallocation on assignment. */
8057 if (gfc_option
.flag_realloc_lhs
8058 && is_scalar_reallocatable_lhs (expr1
))
8059 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8062 /* Use the scalar assignment as is. */
8063 gfc_add_block_to_block (&block
, &body
);
8067 gcc_assert (lse
.ss
== gfc_ss_terminator
8068 && rse
.ss
== gfc_ss_terminator
);
8072 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8074 /* We need to copy the temporary to the actual lhs. */
8075 gfc_init_se (&lse
, NULL
);
8076 gfc_init_se (&rse
, NULL
);
8077 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8078 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8080 rse
.ss
= loop
.temp_ss
;
8083 gfc_conv_tmp_array_ref (&rse
);
8084 gfc_conv_expr (&lse
, expr1
);
8086 gcc_assert (lse
.ss
== gfc_ss_terminator
8087 && rse
.ss
== gfc_ss_terminator
);
8089 if (expr2
->ts
.type
== BT_CHARACTER
)
8090 rse
.string_length
= string_length
;
8092 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8093 false, false, dealloc
);
8094 gfc_add_expr_to_block (&body
, tmp
);
8097 /* F2003: Allocate or reallocate lhs of allocatable array. */
8098 if (gfc_option
.flag_realloc_lhs
8099 && gfc_is_reallocatable_lhs (expr1
)
8100 && !gfc_expr_attr (expr1
).codimension
8101 && !gfc_is_coindexed (expr1
)
8103 && !is_runtime_conformable (expr1
, expr2
))
8105 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8106 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8107 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8108 if (tmp
!= NULL_TREE
)
8109 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8112 /* Generate the copying loops. */
8113 gfc_trans_scalarizing_loops (&loop
, &body
);
8115 /* Wrap the whole thing up. */
8116 gfc_add_block_to_block (&block
, &loop
.pre
);
8117 gfc_add_block_to_block (&block
, &loop
.post
);
8119 gfc_cleanup_loop (&loop
);
8122 return gfc_finish_block (&block
);
8126 /* Check whether EXPR is a copyable array. */
8129 copyable_array_p (gfc_expr
* expr
)
8131 if (expr
->expr_type
!= EXPR_VARIABLE
)
8134 /* First check it's an array. */
8135 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8138 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8141 /* Next check that it's of a simple enough type. */
8142 switch (expr
->ts
.type
)
8154 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8163 /* Translate an assignment. */
8166 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8171 /* Special case a single function returning an array. */
8172 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8174 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8179 /* Special case assigning an array to zero. */
8180 if (copyable_array_p (expr1
)
8181 && is_zero_initializer_p (expr2
))
8183 tmp
= gfc_trans_zero_assign (expr1
);
8188 /* Special case copying one array to another. */
8189 if (copyable_array_p (expr1
)
8190 && copyable_array_p (expr2
)
8191 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8192 && !gfc_check_dependency (expr1
, expr2
, 0))
8194 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8199 /* Special case initializing an array from a constant array constructor. */
8200 if (copyable_array_p (expr1
)
8201 && expr2
->expr_type
== EXPR_ARRAY
8202 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8204 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8209 /* Fallback to the scalarizer to generate explicit loops. */
8210 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8214 gfc_trans_init_assign (gfc_code
* code
)
8216 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8220 gfc_trans_assign (gfc_code
* code
)
8222 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);