1 /* Expression translation
2 Copyright (C) 2002-2015 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"
31 #include "double-int.h"
39 #include "fold-const.h"
40 #include "stringpool.h"
41 #include "diagnostic-core.h" /* For fatal_error. */
42 #include "langhooks.h"
45 #include "constructor.h"
47 #include "trans-const.h"
48 #include "trans-types.h"
49 #include "trans-array.h"
50 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
51 #include "trans-stmt.h"
52 #include "dependency.h"
55 /* Convert a scalar to an array descriptor. To be used for assumed-rank
59 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
61 enum gfc_array_kind akind
;
64 akind
= GFC_ARRAY_POINTER_CONT
;
65 else if (attr
.allocatable
)
66 akind
= GFC_ARRAY_ALLOCATABLE
;
68 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
70 if (POINTER_TYPE_P (TREE_TYPE (scalar
)))
71 scalar
= TREE_TYPE (scalar
);
72 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
73 akind
, !(attr
.pointer
|| attr
.target
));
77 gfc_conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
81 type
= get_scalar_to_descriptor_type (scalar
, attr
);
82 desc
= gfc_create_var (type
, "desc");
83 DECL_ARTIFICIAL (desc
) = 1;
85 if (!POINTER_TYPE_P (TREE_TYPE (scalar
)))
86 scalar
= gfc_build_addr_expr (NULL_TREE
, scalar
);
87 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
88 gfc_get_dtype (type
));
89 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr
.pointer
|| attr
.allocatable
) && attr
.intent
!= INTENT_IN
)
94 gfc_add_modify (&se
->post
, scalar
,
95 fold_convert (TREE_TYPE (scalar
),
96 gfc_conv_descriptor_data_get (desc
)));
101 /* This is the seed for an eventual trans-class.c
103 The following parameters should not be used directly since they might
104 in future implementations. Use the corresponding APIs. */
105 #define CLASS_DATA_FIELD 0
106 #define CLASS_VPTR_FIELD 1
107 #define VTABLE_HASH_FIELD 0
108 #define VTABLE_SIZE_FIELD 1
109 #define VTABLE_EXTENDS_FIELD 2
110 #define VTABLE_DEF_INIT_FIELD 3
111 #define VTABLE_COPY_FIELD 4
112 #define VTABLE_FINAL_FIELD 5
116 gfc_class_set_static_fields (tree decl
, tree vptr
, tree data
)
120 vec
<constructor_elt
, va_gc
> *init
= NULL
;
122 field
= TYPE_FIELDS (TREE_TYPE (decl
));
123 tmp
= gfc_advance_chain (field
, CLASS_DATA_FIELD
);
124 CONSTRUCTOR_APPEND_ELT (init
, tmp
, data
);
126 tmp
= gfc_advance_chain (field
, CLASS_VPTR_FIELD
);
127 CONSTRUCTOR_APPEND_ELT (init
, tmp
, vptr
);
129 return build_constructor (TREE_TYPE (decl
), init
);
134 gfc_class_data_get (tree decl
)
137 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
138 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
139 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
141 return fold_build3_loc (input_location
, COMPONENT_REF
,
142 TREE_TYPE (data
), decl
, data
,
148 gfc_class_vptr_get (tree decl
)
151 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
152 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
153 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
155 return fold_build3_loc (input_location
, COMPONENT_REF
,
156 TREE_TYPE (vptr
), decl
, vptr
,
162 gfc_vtable_field_get (tree decl
, int field
)
166 vptr
= gfc_class_vptr_get (decl
);
167 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
168 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
170 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
171 TREE_TYPE (size
), vptr
, size
,
173 /* Always return size as an array index type. */
174 if (field
== VTABLE_SIZE_FIELD
)
175 size
= fold_convert (gfc_array_index_type
, size
);
182 gfc_vtable_hash_get (tree decl
)
184 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
189 gfc_vtable_size_get (tree decl
)
191 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
196 gfc_vtable_extends_get (tree decl
)
198 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
203 gfc_vtable_def_init_get (tree decl
)
205 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
210 gfc_vtable_copy_get (tree decl
)
212 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
217 gfc_vtable_final_get (tree decl
)
219 return gfc_vtable_field_get (decl
, VTABLE_FINAL_FIELD
);
223 #undef CLASS_DATA_FIELD
224 #undef CLASS_VPTR_FIELD
225 #undef VTABLE_HASH_FIELD
226 #undef VTABLE_SIZE_FIELD
227 #undef VTABLE_EXTENDS_FIELD
228 #undef VTABLE_DEF_INIT_FIELD
229 #undef VTABLE_COPY_FIELD
230 #undef VTABLE_FINAL_FIELD
233 /* Reset the vptr to the declared type, e.g. after deallocation. */
236 gfc_reset_vptr (stmtblock_t
*block
, gfc_expr
*e
)
238 gfc_expr
*rhs
, *lhs
= gfc_copy_expr (e
);
243 /* If we have a class array, we need go back to the class
245 if (lhs
->ref
&& lhs
->ref
->next
&& !lhs
->ref
->next
->next
246 && lhs
->ref
->next
->type
== REF_ARRAY
247 && lhs
->ref
->next
->u
.ar
.type
== AR_FULL
248 && lhs
->ref
->type
== REF_COMPONENT
249 && strcmp (lhs
->ref
->u
.c
.component
->name
, "_data") == 0)
251 gfc_free_ref_list (lhs
->ref
);
255 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
256 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
257 && ref
->next
->next
->type
== REF_ARRAY
258 && ref
->next
->next
->u
.ar
.type
== AR_FULL
259 && ref
->next
->type
== REF_COMPONENT
260 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
262 gfc_free_ref_list (ref
->next
);
266 gfc_add_vptr_component (lhs
);
268 if (UNLIMITED_POLY (e
))
269 rhs
= gfc_get_null_expr (NULL
);
272 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
273 rhs
= gfc_lval_expr_from_sym (vtab
);
275 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
276 gfc_add_expr_to_block (block
, tmp
);
282 /* Obtain the vptr of the last class reference in an expression.
283 Return NULL_TREE if no class reference is found. */
286 gfc_get_vptr_from_expr (tree expr
)
291 for (tmp
= expr
; tmp
; tmp
= TREE_OPERAND (tmp
, 0))
293 type
= TREE_TYPE (tmp
);
296 if (GFC_CLASS_TYPE_P (type
))
297 return gfc_class_vptr_get (tmp
);
298 if (type
!= TYPE_CANONICAL (type
))
299 type
= TYPE_CANONICAL (type
);
303 if (TREE_CODE (tmp
) == VAR_DECL
)
311 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
314 tree tmp
, tmp2
, type
;
316 gfc_conv_descriptor_data_set (block
, lhs_desc
,
317 gfc_conv_descriptor_data_get (rhs_desc
));
318 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
319 gfc_conv_descriptor_offset_get (rhs_desc
));
321 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
322 gfc_conv_descriptor_dtype (rhs_desc
));
324 /* Assign the dimension as range-ref. */
325 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
326 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
328 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
329 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
330 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
331 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
332 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
333 gfc_add_modify (block
, tmp
, tmp2
);
337 /* Takes a derived type expression and returns the address of a temporary
338 class object of the 'declared' type. If vptr is not NULL, this is
339 used for the temporary class object.
340 optional_alloc_ptr is false when the dummy is neither allocatable
341 nor a pointer; that's only relevant for the optional handling. */
343 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
344 gfc_typespec class_ts
, tree vptr
, bool optional
,
345 bool optional_alloc_ptr
)
348 tree cond_optional
= NULL_TREE
;
354 /* The derived type needs to be converted to a temporary
356 tmp
= gfc_typenode_for_spec (&class_ts
);
357 var
= gfc_create_var (tmp
, "class");
360 ctree
= gfc_class_vptr_get (var
);
362 if (vptr
!= NULL_TREE
)
364 /* Use the dynamic vptr. */
369 /* In this case the vtab corresponds to the derived type and the
370 vptr must point to it. */
371 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
373 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
375 gfc_add_modify (&parmse
->pre
, ctree
,
376 fold_convert (TREE_TYPE (ctree
), tmp
));
378 /* Now set the data field. */
379 ctree
= gfc_class_data_get (var
);
382 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
384 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
386 /* For an array reference in an elemental procedure call we need
387 to retain the ss to provide the scalarized array reference. */
388 gfc_conv_expr_reference (parmse
, e
);
389 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
391 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
393 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
394 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
399 ss
= gfc_walk_expr (e
);
400 if (ss
== gfc_ss_terminator
)
403 gfc_conv_expr_reference (parmse
, e
);
405 /* Scalar to an assumed-rank array. */
406 if (class_ts
.u
.derived
->components
->as
)
409 type
= get_scalar_to_descriptor_type (parmse
->expr
,
411 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
412 gfc_get_dtype (type
));
414 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
415 TREE_TYPE (parmse
->expr
),
416 cond_optional
, parmse
->expr
,
417 fold_convert (TREE_TYPE (parmse
->expr
),
419 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
423 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
425 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
427 fold_convert (TREE_TYPE (tmp
),
429 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
435 gfc_init_block (&block
);
438 gfc_conv_expr_descriptor (parmse
, e
);
440 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
442 gcc_assert (class_ts
.u
.derived
->components
->as
->type
444 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
448 if (gfc_expr_attr (e
).codimension
)
449 parmse
->expr
= fold_build1_loc (input_location
,
453 gfc_add_modify (&block
, ctree
, parmse
->expr
);
458 tmp
= gfc_finish_block (&block
);
460 gfc_init_block (&block
);
461 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
463 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
464 gfc_finish_block (&block
));
465 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
468 gfc_add_block_to_block (&parmse
->pre
, &block
);
472 /* Pass the address of the class object. */
473 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
475 if (optional
&& optional_alloc_ptr
)
476 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
477 TREE_TYPE (parmse
->expr
),
478 cond_optional
, parmse
->expr
,
479 fold_convert (TREE_TYPE (parmse
->expr
),
484 /* Create a new class container, which is required as scalar coarrays
485 have an array descriptor while normal scalars haven't. Optionally,
486 NULL pointer checks are added if the argument is OPTIONAL. */
489 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
490 gfc_typespec class_ts
, bool optional
)
492 tree var
, ctree
, tmp
;
497 gfc_init_block (&block
);
500 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
502 if (ref
->type
== REF_COMPONENT
503 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
507 if (class_ref
== NULL
508 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
509 tmp
= e
->symtree
->n
.sym
->backend_decl
;
512 /* Remove everything after the last class reference, convert the
513 expression and then recover its tailend once more. */
515 ref
= class_ref
->next
;
516 class_ref
->next
= NULL
;
517 gfc_init_se (&tmpse
, NULL
);
518 gfc_conv_expr (&tmpse
, e
);
519 class_ref
->next
= ref
;
523 var
= gfc_typenode_for_spec (&class_ts
);
524 var
= gfc_create_var (var
, "class");
526 ctree
= gfc_class_vptr_get (var
);
527 gfc_add_modify (&block
, ctree
,
528 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
530 ctree
= gfc_class_data_get (var
);
531 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
532 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
534 /* Pass the address of the class object. */
535 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
539 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
542 tmp
= gfc_finish_block (&block
);
544 gfc_init_block (&block
);
545 tmp2
= gfc_class_data_get (var
);
546 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
548 tmp2
= gfc_finish_block (&block
);
550 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
552 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
555 gfc_add_block_to_block (&parmse
->pre
, &block
);
559 /* Takes an intrinsic type expression and returns the address of a temporary
560 class object of the 'declared' type. */
562 gfc_conv_intrinsic_to_class (gfc_se
*parmse
, gfc_expr
*e
,
563 gfc_typespec class_ts
)
571 /* The intrinsic type needs to be converted to a temporary
573 tmp
= gfc_typenode_for_spec (&class_ts
);
574 var
= gfc_create_var (tmp
, "class");
577 ctree
= gfc_class_vptr_get (var
);
579 vtab
= gfc_find_vtab (&e
->ts
);
581 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
582 gfc_add_modify (&parmse
->pre
, ctree
,
583 fold_convert (TREE_TYPE (ctree
), tmp
));
585 /* Now set the data field. */
586 ctree
= gfc_class_data_get (var
);
587 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
589 /* For an array reference in an elemental procedure call we need
590 to retain the ss to provide the scalarized array reference. */
591 gfc_conv_expr_reference (parmse
, e
);
592 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
593 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
597 ss
= gfc_walk_expr (e
);
598 if (ss
== gfc_ss_terminator
)
601 gfc_conv_expr_reference (parmse
, e
);
602 if (class_ts
.u
.derived
->components
->as
603 && class_ts
.u
.derived
->components
->as
->type
== AS_ASSUMED_RANK
)
605 tmp
= gfc_conv_scalar_to_descriptor (parmse
, parmse
->expr
,
607 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
608 TREE_TYPE (ctree
), tmp
);
611 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
612 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
617 parmse
->use_offset
= 1;
618 gfc_conv_expr_descriptor (parmse
, e
);
619 if (class_ts
.u
.derived
->components
->as
->rank
!= e
->rank
)
621 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
622 TREE_TYPE (ctree
), parmse
->expr
);
623 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
626 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
630 /* Pass the address of the class object. */
631 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
635 /* Takes a scalarized class array expression and returns the
636 address of a temporary scalar class object of the 'declared'
638 OOP-TODO: This could be improved by adding code that branched on
639 the dynamic type being the same as the declared type. In this case
640 the original class expression can be passed directly.
641 optional_alloc_ptr is false when the dummy is neither allocatable
642 nor a pointer; that's relevant for the optional handling.
643 Set copyback to true if class container's _data and _vtab pointers
644 might get modified. */
647 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
648 bool elemental
, bool copyback
, bool optional
,
649 bool optional_alloc_ptr
)
655 tree cond
= NULL_TREE
;
659 bool full_array
= false;
661 gfc_init_block (&block
);
664 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
666 if (ref
->type
== REF_COMPONENT
667 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
670 if (ref
->next
== NULL
)
674 if ((ref
== NULL
|| class_ref
== ref
)
675 && (!class_ts
.u
.derived
->components
->as
676 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
679 /* Test for FULL_ARRAY. */
680 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
681 && gfc_expr_attr (e
).dimension
)
684 gfc_is_class_array_ref (e
, &full_array
);
686 /* The derived type needs to be converted to a temporary
688 tmp
= gfc_typenode_for_spec (&class_ts
);
689 var
= gfc_create_var (tmp
, "class");
692 ctree
= gfc_class_data_get (var
);
693 if (class_ts
.u
.derived
->components
->as
694 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
698 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
700 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
701 gfc_get_dtype (type
));
703 tmp
= gfc_class_data_get (parmse
->expr
);
704 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
705 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
707 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
710 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
714 if (TREE_TYPE (parmse
->expr
) != TREE_TYPE (ctree
))
715 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
716 TREE_TYPE (ctree
), parmse
->expr
);
717 gfc_add_modify (&block
, ctree
, parmse
->expr
);
720 /* Return the data component, except in the case of scalarized array
721 references, where nullification of the cannot occur and so there
723 if (!elemental
&& full_array
&& copyback
)
725 if (class_ts
.u
.derived
->components
->as
726 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
729 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
730 gfc_conv_descriptor_data_get (ctree
));
732 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
735 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
739 ctree
= gfc_class_vptr_get (var
);
741 /* The vptr is the second field of the actual argument.
742 First we have to find the corresponding class reference. */
745 if (class_ref
== NULL
746 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
747 tmp
= e
->symtree
->n
.sym
->backend_decl
;
750 /* Remove everything after the last class reference, convert the
751 expression and then recover its tailend once more. */
753 ref
= class_ref
->next
;
754 class_ref
->next
= NULL
;
755 gfc_init_se (&tmpse
, NULL
);
756 gfc_conv_expr (&tmpse
, e
);
757 class_ref
->next
= ref
;
761 gcc_assert (tmp
!= NULL_TREE
);
763 /* Dereference if needs be. */
764 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
765 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
767 vptr
= gfc_class_vptr_get (tmp
);
768 gfc_add_modify (&block
, ctree
,
769 fold_convert (TREE_TYPE (ctree
), vptr
));
771 /* Return the vptr component, except in the case of scalarized array
772 references, where the dynamic type cannot change. */
773 if (!elemental
&& full_array
&& copyback
)
774 gfc_add_modify (&parmse
->post
, vptr
,
775 fold_convert (TREE_TYPE (vptr
), ctree
));
781 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
782 tmp
= gfc_finish_block (&block
);
784 if (optional_alloc_ptr
)
785 tmp2
= build_empty_stmt (input_location
);
788 gfc_init_block (&block
);
790 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
791 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
793 tmp2
= gfc_finish_block (&block
);
796 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
798 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
801 gfc_add_block_to_block (&parmse
->pre
, &block
);
803 /* Pass the address of the class object. */
804 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
806 if (optional
&& optional_alloc_ptr
)
807 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
808 TREE_TYPE (parmse
->expr
),
810 fold_convert (TREE_TYPE (parmse
->expr
),
815 /* Given a class array declaration and an index, returns the address
816 of the referenced element. */
819 gfc_get_class_array_ref (tree index
, tree class_decl
)
821 tree data
= gfc_class_data_get (class_decl
);
822 tree size
= gfc_vtable_size_get (class_decl
);
823 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
824 gfc_array_index_type
,
827 data
= gfc_conv_descriptor_data_get (data
);
828 ptr
= fold_convert (pvoid_type_node
, data
);
829 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
830 return fold_convert (TREE_TYPE (data
), ptr
);
834 /* Copies one class expression to another, assuming that if either
835 'to' or 'from' are arrays they are packed. Should 'from' be
836 NULL_TREE, the initialization expression for 'to' is used, assuming
837 that the _vptr is set. */
840 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
848 vec
<tree
, va_gc
> *args
;
851 stmtblock_t loopbody
;
857 if (from
!= NULL_TREE
)
858 fcn
= gfc_vtable_copy_get (from
);
860 fcn
= gfc_vtable_copy_get (to
);
862 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
864 if (from
!= NULL_TREE
)
865 from_data
= gfc_class_data_get (from
);
867 from_data
= gfc_vtable_def_init_get (to
);
869 to_data
= gfc_class_data_get (to
);
871 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
873 gfc_init_block (&body
);
874 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
875 gfc_array_index_type
, nelems
,
877 nelems
= gfc_evaluate_now (tmp
, &body
);
878 index
= gfc_create_var (gfc_array_index_type
, "S");
880 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
882 from_ref
= gfc_get_class_array_ref (index
, from
);
883 vec_safe_push (args
, from_ref
);
886 vec_safe_push (args
, from_data
);
888 to_ref
= gfc_get_class_array_ref (index
, to
);
889 vec_safe_push (args
, to_ref
);
891 tmp
= build_call_vec (fcn_type
, fcn
, args
);
893 /* Build the body of the loop. */
894 gfc_init_block (&loopbody
);
895 gfc_add_expr_to_block (&loopbody
, tmp
);
897 /* Build the loop and return. */
898 gfc_init_loopinfo (&loop
);
900 loop
.from
[0] = gfc_index_zero_node
;
901 loop
.loopvar
[0] = index
;
903 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
904 gfc_add_block_to_block (&body
, &loop
.pre
);
905 tmp
= gfc_finish_block (&body
);
906 gfc_cleanup_loop (&loop
);
910 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
911 vec_safe_push (args
, from_data
);
912 vec_safe_push (args
, to_data
);
913 tmp
= build_call_vec (fcn_type
, fcn
, args
);
920 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
922 gfc_actual_arglist
*actual
;
927 actual
= gfc_get_actual_arglist ();
928 actual
->expr
= gfc_copy_expr (rhs
);
929 actual
->next
= gfc_get_actual_arglist ();
930 actual
->next
->expr
= gfc_copy_expr (lhs
);
931 ppc
= gfc_copy_expr (obj
);
932 gfc_add_vptr_component (ppc
);
933 gfc_add_component_ref (ppc
, "_copy");
934 ppc_code
= gfc_get_code (EXEC_CALL
);
935 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
936 /* Although '_copy' is set to be elemental in class.c, it is
937 not staying that way. Find out why, sometime.... */
938 ppc_code
->resolved_sym
->attr
.elemental
= 1;
939 ppc_code
->ext
.actual
= actual
;
940 ppc_code
->expr1
= ppc
;
941 /* Since '_copy' is elemental, the scalarizer will take care
942 of arrays in gfc_trans_call. */
943 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
944 gfc_free_statements (ppc_code
);
946 if (UNLIMITED_POLY(obj
))
948 /* Check if rhs is non-NULL. */
950 gfc_init_se (&src
, NULL
);
951 gfc_conv_expr (&src
, rhs
);
952 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
953 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
954 src
.expr
, fold_convert (TREE_TYPE (src
.expr
),
956 res
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (res
), cond
, res
,
957 build_empty_stmt (input_location
));
963 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
964 A MEMCPY is needed to copy the full data from the default initializer
965 of the dynamic type. */
968 gfc_trans_class_init_assign (gfc_code
*code
)
972 gfc_se dst
,src
,memsz
;
973 gfc_expr
*lhs
, *rhs
, *sz
;
975 gfc_start_block (&block
);
977 lhs
= gfc_copy_expr (code
->expr1
);
978 gfc_add_data_component (lhs
);
980 rhs
= gfc_copy_expr (code
->expr1
);
981 gfc_add_vptr_component (rhs
);
983 /* Make sure that the component backend_decls have been built, which
984 will not have happened if the derived types concerned have not
986 gfc_get_derived_type (rhs
->ts
.u
.derived
);
987 gfc_add_def_init_component (rhs
);
989 if (code
->expr1
->ts
.type
== BT_CLASS
990 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
991 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
994 sz
= gfc_copy_expr (code
->expr1
);
995 gfc_add_vptr_component (sz
);
996 gfc_add_size_component (sz
);
998 gfc_init_se (&dst
, NULL
);
999 gfc_init_se (&src
, NULL
);
1000 gfc_init_se (&memsz
, NULL
);
1001 gfc_conv_expr (&dst
, lhs
);
1002 gfc_conv_expr (&src
, rhs
);
1003 gfc_conv_expr (&memsz
, sz
);
1004 gfc_add_block_to_block (&block
, &src
.pre
);
1005 src
.expr
= gfc_build_addr_expr (NULL_TREE
, src
.expr
);
1007 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
1009 if (UNLIMITED_POLY(code
->expr1
))
1011 /* Check if _def_init is non-NULL. */
1012 tree cond
= fold_build2_loc (input_location
, NE_EXPR
,
1013 boolean_type_node
, src
.expr
,
1014 fold_convert (TREE_TYPE (src
.expr
),
1015 null_pointer_node
));
1016 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), cond
,
1017 tmp
, build_empty_stmt (input_location
));
1021 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
1022 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
1024 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
1025 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
1027 build_empty_stmt (input_location
));
1030 gfc_add_expr_to_block (&block
, tmp
);
1032 return gfc_finish_block (&block
);
1036 /* Translate an assignment to a CLASS object
1037 (pointer or ordinary assignment). */
1040 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
1048 gfc_start_block (&block
);
1051 while (ref
&& ref
->next
)
1054 /* Class valued proc_pointer assignments do not need any further
1056 if (ref
&& ref
->type
== REF_COMPONENT
1057 && ref
->u
.c
.component
->attr
.proc_pointer
1058 && expr2
->expr_type
== EXPR_VARIABLE
1059 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1060 && op
== EXEC_POINTER_ASSIGN
)
1063 if (expr2
->ts
.type
!= BT_CLASS
)
1065 /* Insert an additional assignment which sets the '_vptr' field. */
1066 gfc_symbol
*vtab
= NULL
;
1069 lhs
= gfc_copy_expr (expr1
);
1070 gfc_add_vptr_component (lhs
);
1072 if (UNLIMITED_POLY (expr1
)
1073 && expr2
->expr_type
== EXPR_NULL
&& expr2
->ts
.type
== BT_UNKNOWN
)
1075 rhs
= gfc_get_null_expr (&expr2
->where
);
1079 if (expr2
->expr_type
== EXPR_NULL
)
1080 vtab
= gfc_find_vtab (&expr1
->ts
);
1082 vtab
= gfc_find_vtab (&expr2
->ts
);
1085 rhs
= gfc_get_expr ();
1086 rhs
->expr_type
= EXPR_VARIABLE
;
1087 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
1091 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1092 gfc_add_expr_to_block (&block
, tmp
);
1094 gfc_free_expr (lhs
);
1095 gfc_free_expr (rhs
);
1097 else if (expr1
->ts
.type
== BT_DERIVED
&& UNLIMITED_POLY (expr2
))
1099 /* F2003:C717 only sequence and bind-C types can come here. */
1100 gcc_assert (expr1
->ts
.u
.derived
->attr
.sequence
1101 || expr1
->ts
.u
.derived
->attr
.is_bind_c
);
1102 gfc_add_data_component (expr2
);
1105 else if (CLASS_DATA (expr2
)->attr
.dimension
&& expr2
->expr_type
!= EXPR_FUNCTION
)
1107 /* Insert an additional assignment which sets the '_vptr' field. */
1108 lhs
= gfc_copy_expr (expr1
);
1109 gfc_add_vptr_component (lhs
);
1111 rhs
= gfc_copy_expr (expr2
);
1112 gfc_add_vptr_component (rhs
);
1114 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
1115 gfc_add_expr_to_block (&block
, tmp
);
1117 gfc_free_expr (lhs
);
1118 gfc_free_expr (rhs
);
1121 /* Do the actual CLASS assignment. */
1122 if (expr2
->ts
.type
== BT_CLASS
1123 && !CLASS_DATA (expr2
)->attr
.dimension
)
1125 else if (expr2
->expr_type
!= EXPR_FUNCTION
|| expr2
->ts
.type
!= BT_CLASS
1126 || !CLASS_DATA (expr2
)->attr
.dimension
)
1127 gfc_add_data_component (expr1
);
1131 if (op
== EXEC_ASSIGN
)
1132 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
1133 else if (op
== EXEC_POINTER_ASSIGN
)
1134 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
1138 gfc_add_expr_to_block (&block
, tmp
);
1140 return gfc_finish_block (&block
);
1144 /* End of prototype trans-class.c */
1148 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
1150 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
&& warn_realloc_lhs
)
1151 gfc_warning (OPT_Wrealloc_lhs
,
1152 "Code for reallocating the allocatable array at %L will "
1154 else if (warn_realloc_lhs_all
)
1155 gfc_warning (OPT_Wrealloc_lhs_all
,
1156 "Code for reallocating the allocatable variable at %L "
1157 "will be added", where
);
1161 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
1162 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
1165 /* Copy the scalarization loop variables. */
1168 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
1171 dest
->loop
= src
->loop
;
1175 /* Initialize a simple expression holder.
1177 Care must be taken when multiple se are created with the same parent.
1178 The child se must be kept in sync. The easiest way is to delay creation
1179 of a child se until after after the previous se has been translated. */
1182 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
1184 memset (se
, 0, sizeof (gfc_se
));
1185 gfc_init_block (&se
->pre
);
1186 gfc_init_block (&se
->post
);
1188 se
->parent
= parent
;
1191 gfc_copy_se_loopvars (se
, parent
);
1195 /* Advances to the next SS in the chain. Use this rather than setting
1196 se->ss = se->ss->next because all the parents needs to be kept in sync.
1200 gfc_advance_se_ss_chain (gfc_se
* se
)
1205 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1208 /* Walk down the parent chain. */
1211 /* Simple consistency check. */
1212 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
1213 || p
->parent
->ss
->nested_ss
== p
->ss
);
1215 /* If we were in a nested loop, the next scalarized expression can be
1216 on the parent ss' next pointer. Thus we should not take the next
1217 pointer blindly, but rather go up one nest level as long as next
1218 is the end of chain. */
1220 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1230 /* Ensures the result of the expression as either a temporary variable
1231 or a constant so that it can be used repeatedly. */
1234 gfc_make_safe_expr (gfc_se
* se
)
1238 if (CONSTANT_CLASS_P (se
->expr
))
1241 /* We need a temporary for this result. */
1242 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1243 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1248 /* Return an expression which determines if a dummy parameter is present.
1249 Also used for arguments to procedures with multiple entry points. */
1252 gfc_conv_expr_present (gfc_symbol
* sym
)
1256 gcc_assert (sym
->attr
.dummy
);
1257 decl
= gfc_get_symbol_decl (sym
);
1259 /* Intrinsic scalars with VALUE attribute which are passed by value
1260 use a hidden argument to denote the present status. */
1261 if (sym
->attr
.value
&& sym
->ts
.type
!= BT_CHARACTER
1262 && sym
->ts
.type
!= BT_CLASS
&& sym
->ts
.type
!= BT_DERIVED
1263 && !sym
->attr
.dimension
)
1265 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1268 gcc_assert (TREE_CODE (decl
) == PARM_DECL
);
1270 strcpy (&name
[1], sym
->name
);
1271 tree_name
= get_identifier (name
);
1273 /* Walk function argument list to find hidden arg. */
1274 cond
= DECL_ARGUMENTS (DECL_CONTEXT (decl
));
1275 for ( ; cond
!= NULL_TREE
; cond
= TREE_CHAIN (cond
))
1276 if (DECL_NAME (cond
) == tree_name
)
1283 if (TREE_CODE (decl
) != PARM_DECL
)
1285 /* Array parameters use a temporary descriptor, we want the real
1287 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1288 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1289 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1292 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1293 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1295 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1296 as actual argument to denote absent dummies. For array descriptors,
1297 we thus also need to check the array descriptor. For BT_CLASS, it
1298 can also occur for scalars and F2003 due to type->class wrapping and
1299 class->class wrapping. Note further that BT_CLASS always uses an
1300 array descriptor for arrays, also for explicit-shape/assumed-size. */
1302 if (!sym
->attr
.allocatable
1303 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1304 || (sym
->ts
.type
== BT_CLASS
1305 && !CLASS_DATA (sym
)->attr
.allocatable
1306 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1307 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1308 || sym
->ts
.type
== BT_CLASS
))
1312 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1313 || sym
->as
->type
== AS_ASSUMED_RANK
1314 || sym
->attr
.codimension
))
1315 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1317 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1318 if (sym
->ts
.type
== BT_CLASS
)
1319 tmp
= gfc_class_data_get (tmp
);
1320 tmp
= gfc_conv_array_data (tmp
);
1322 else if (sym
->ts
.type
== BT_CLASS
)
1323 tmp
= gfc_class_data_get (decl
);
1327 if (tmp
!= NULL_TREE
)
1329 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1330 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1331 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1332 boolean_type_node
, cond
, tmp
);
1340 /* Converts a missing, dummy argument into a null or zero. */
1343 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1348 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1352 /* Create a temporary and convert it to the correct type. */
1353 tmp
= gfc_get_int_type (kind
);
1354 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1357 /* Test for a NULL value. */
1358 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1359 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1360 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1361 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1365 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1367 build_zero_cst (TREE_TYPE (se
->expr
)));
1368 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1372 if (ts
.type
== BT_CHARACTER
)
1374 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1375 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1376 present
, se
->string_length
, tmp
);
1377 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1378 se
->string_length
= tmp
;
1384 /* Get the character length of an expression, looking through gfc_refs
1388 gfc_get_expr_charlen (gfc_expr
*e
)
1393 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1394 && e
->ts
.type
== BT_CHARACTER
);
1396 length
= NULL
; /* To silence compiler warning. */
1398 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1401 gfc_init_se (&tmpse
, NULL
);
1402 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1403 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1407 /* First candidate: if the variable is of type CHARACTER, the
1408 expression's length could be the length of the character
1410 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1411 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1413 /* Look through the reference chain for component references. */
1414 for (r
= e
->ref
; r
; r
= r
->next
)
1419 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1420 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1428 /* We should never got substring references here. These will be
1429 broken down by the scalarizer. */
1435 gcc_assert (length
!= NULL
);
1440 /* Return for an expression the backend decl of the coarray. */
1443 gfc_get_tree_for_caf_expr (gfc_expr
*expr
)
1449 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1451 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1452 gcc_assert (caf_decl
);
1453 if (expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
1454 caf_decl
= gfc_class_data_get (caf_decl
);
1455 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1458 /* The following code assumes that the coarray is a component reachable via
1459 only scalar components/variables; the Fortran standard guarantees this. */
1461 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1462 if (ref
->type
== REF_COMPONENT
)
1464 gfc_component
*comp
= ref
->u
.c
.component
;
1466 if (POINTER_TYPE_P (TREE_TYPE (caf_decl
)))
1467 caf_decl
= build_fold_indirect_ref_loc (input_location
, caf_decl
);
1468 caf_decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
1469 TREE_TYPE (comp
->backend_decl
), caf_decl
,
1470 comp
->backend_decl
, NULL_TREE
);
1471 if (comp
->ts
.type
== BT_CLASS
)
1472 caf_decl
= gfc_class_data_get (caf_decl
);
1473 if (comp
->attr
.codimension
)
1479 gcc_assert (found
&& caf_decl
);
1484 /* Obtain the Coarray token - and optionally also the offset. */
1487 gfc_get_caf_token_offset (tree
*token
, tree
*offset
, tree caf_decl
, tree se_expr
,
1492 /* Coarray token. */
1493 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1495 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
))
1496 == GFC_ARRAY_ALLOCATABLE
1497 || expr
->symtree
->n
.sym
->attr
.select_type_temporary
);
1498 *token
= gfc_conv_descriptor_token (caf_decl
);
1500 else if (DECL_LANG_SPECIFIC (caf_decl
)
1501 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1502 *token
= GFC_DECL_TOKEN (caf_decl
);
1505 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl
))
1506 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
)) != NULL_TREE
);
1507 *token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl
));
1513 /* Offset between the coarray base address and the address wanted. */
1514 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
))
1515 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_ALLOCATABLE
1516 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl
)) == GFC_ARRAY_POINTER
))
1517 *offset
= build_int_cst (gfc_array_index_type
, 0);
1518 else if (DECL_LANG_SPECIFIC (caf_decl
)
1519 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
1520 *offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
1521 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
)) != NULL_TREE
)
1522 *offset
= GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl
));
1524 *offset
= build_int_cst (gfc_array_index_type
, 0);
1526 if (POINTER_TYPE_P (TREE_TYPE (se_expr
))
1527 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr
))))
1529 tmp
= build_fold_indirect_ref_loc (input_location
, se_expr
);
1530 tmp
= gfc_conv_descriptor_data_get (tmp
);
1532 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr
)))
1533 tmp
= gfc_conv_descriptor_data_get (se_expr
);
1536 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr
)));
1540 *offset
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
1541 *offset
, fold_convert (gfc_array_index_type
, tmp
));
1543 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl
)))
1544 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
1547 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl
)));
1551 *offset
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1552 fold_convert (gfc_array_index_type
, *offset
),
1553 fold_convert (gfc_array_index_type
, tmp
));
1557 /* Convert the coindex of a coarray into an image index; the result is
1558 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
1559 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
1562 gfc_caf_get_image_index (stmtblock_t
*block
, gfc_expr
*e
, tree desc
)
1565 tree lbound
, ubound
, extent
, tmp
, img_idx
;
1569 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1570 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
1572 gcc_assert (ref
!= NULL
);
1574 img_idx
= integer_zero_node
;
1575 extent
= integer_one_node
;
1576 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc
)))
1577 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1579 gfc_init_se (&se
, NULL
);
1580 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1581 gfc_add_block_to_block (block
, &se
.pre
);
1582 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1583 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1584 integer_type_node
, se
.expr
,
1585 fold_convert(integer_type_node
, lbound
));
1586 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1588 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1590 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1592 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1593 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1594 tmp
= fold_convert (integer_type_node
, tmp
);
1595 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1596 integer_type_node
, extent
, tmp
);
1600 for (i
= ref
->u
.ar
.dimen
; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
1602 gfc_init_se (&se
, NULL
);
1603 gfc_conv_expr_type (&se
, ref
->u
.ar
.start
[i
], integer_type_node
);
1604 gfc_add_block_to_block (block
, &se
.pre
);
1605 lbound
= GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc
), i
);
1606 lbound
= fold_convert (integer_type_node
, lbound
);
1607 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1608 integer_type_node
, se
.expr
, lbound
);
1609 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, integer_type_node
,
1611 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1613 if (i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
- 1)
1615 ubound
= GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc
), i
);
1616 ubound
= fold_convert (integer_type_node
, ubound
);
1617 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1618 integer_type_node
, ubound
, lbound
);
1619 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1620 tmp
, integer_one_node
);
1621 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1622 integer_type_node
, extent
, tmp
);
1625 img_idx
= fold_build2_loc (input_location
, PLUS_EXPR
, integer_type_node
,
1626 img_idx
, integer_one_node
);
1631 /* For each character array constructor subexpression without a ts.u.cl->length,
1632 replace it by its first element (if there aren't any elements, the length
1633 should already be set to zero). */
1636 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1638 gfc_actual_arglist
* arg
;
1644 switch (e
->expr_type
)
1648 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1649 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1653 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1657 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1658 flatten_array_ctors_without_strlen (arg
->expr
);
1663 /* We've found what we're looking for. */
1664 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1669 gcc_assert (e
->value
.constructor
);
1671 c
= gfc_constructor_first (e
->value
.constructor
);
1675 flatten_array_ctors_without_strlen (new_expr
);
1676 gfc_replace_expr (e
, new_expr
);
1680 /* Otherwise, fall through to handle constructor elements. */
1681 case EXPR_STRUCTURE
:
1682 for (c
= gfc_constructor_first (e
->value
.constructor
);
1683 c
; c
= gfc_constructor_next (c
))
1684 flatten_array_ctors_without_strlen (c
->expr
);
1694 /* Generate code to initialize a string length variable. Returns the
1695 value. For array constructors, cl->length might be NULL and in this case,
1696 the first element of the constructor is needed. expr is the original
1697 expression so we can access it but can be NULL if this is not needed. */
1700 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1704 gfc_init_se (&se
, NULL
);
1708 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1711 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1712 "flatten" array constructors by taking their first element; all elements
1713 should be the same length or a cl->length should be present. */
1716 gfc_expr
* expr_flat
;
1718 expr_flat
= gfc_copy_expr (expr
);
1719 flatten_array_ctors_without_strlen (expr_flat
);
1720 gfc_resolve_expr (expr_flat
);
1722 gfc_conv_expr (&se
, expr_flat
);
1723 gfc_add_block_to_block (pblock
, &se
.pre
);
1724 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1726 gfc_free_expr (expr_flat
);
1730 /* Convert cl->length. */
1732 gcc_assert (cl
->length
);
1734 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1735 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1736 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1737 gfc_add_block_to_block (pblock
, &se
.pre
);
1739 if (cl
->backend_decl
)
1740 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1742 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1747 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1748 const char *name
, locus
*where
)
1758 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1759 type
= build_pointer_type (type
);
1761 gfc_init_se (&start
, se
);
1762 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1763 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1765 if (integer_onep (start
.expr
))
1766 gfc_conv_string_parameter (se
);
1771 /* Avoid multiple evaluation of substring start. */
1772 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1773 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1775 /* Change the start of the string. */
1776 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1779 tmp
= build_fold_indirect_ref_loc (input_location
,
1781 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1782 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1785 /* Length = end + 1 - start. */
1786 gfc_init_se (&end
, se
);
1787 if (ref
->u
.ss
.end
== NULL
)
1788 end
.expr
= se
->string_length
;
1791 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1792 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1796 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1797 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1799 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1801 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1802 boolean_type_node
, start
.expr
,
1805 /* Check lower bound. */
1806 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1808 build_int_cst (gfc_charlen_type_node
, 1));
1809 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1810 boolean_type_node
, nonempty
, fault
);
1812 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
1813 "is less than one", name
);
1815 msg
= xasprintf ("Substring out of bounds: lower bound (%%ld)"
1816 "is less than one");
1817 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1818 fold_convert (long_integer_type_node
,
1822 /* Check upper bound. */
1823 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1824 end
.expr
, se
->string_length
);
1825 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1826 boolean_type_node
, nonempty
, fault
);
1828 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
1829 "exceeds string length (%%ld)", name
);
1831 msg
= xasprintf ("Substring out of bounds: upper bound (%%ld) "
1832 "exceeds string length (%%ld)");
1833 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1834 fold_convert (long_integer_type_node
, end
.expr
),
1835 fold_convert (long_integer_type_node
,
1836 se
->string_length
));
1840 /* Try to calculate the length from the start and end expressions. */
1842 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &length
))
1846 i_len
= mpz_get_si (length
) + 1;
1850 tmp
= build_int_cst (gfc_charlen_type_node
, i_len
);
1851 mpz_clear (length
); /* Was initialized by gfc_dep_difference. */
1855 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1856 end
.expr
, start
.expr
);
1857 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1858 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1859 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1860 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1863 se
->string_length
= tmp
;
1867 /* Convert a derived type component reference. */
1870 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1877 c
= ref
->u
.c
.component
;
1879 gcc_assert (c
->backend_decl
);
1881 field
= c
->backend_decl
;
1882 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1885 /* Components can correspond to fields of different containing
1886 types, as components are created without context, whereas
1887 a concrete use of a component has the type of decl as context.
1888 So, if the type doesn't match, we search the corresponding
1889 FIELD_DECL in the parent type. To not waste too much time
1890 we cache this result in norestrict_decl. */
1892 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1894 tree f2
= c
->norestrict_decl
;
1895 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1896 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1897 if (TREE_CODE (f2
) == FIELD_DECL
1898 && DECL_NAME (f2
) == DECL_NAME (field
))
1901 c
->norestrict_decl
= f2
;
1905 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1906 decl
, field
, NULL_TREE
);
1910 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1912 tmp
= c
->ts
.u
.cl
->backend_decl
;
1913 /* Components must always be constant length. */
1914 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1915 se
->string_length
= tmp
;
1918 if (gfc_deferred_strlen (c
, &field
))
1920 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
1922 decl
, field
, NULL_TREE
);
1923 se
->string_length
= tmp
;
1926 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1927 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1928 && c
->ts
.type
!= BT_CHARACTER
)
1929 || c
->attr
.proc_pointer
)
1930 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1935 /* This function deals with component references to components of the
1936 parent type for derived type extensions. */
1938 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1946 c
= ref
->u
.c
.component
;
1948 /* Return if the component is in the parent type. */
1949 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1950 if (strcmp (c
->name
, cmp
->name
) == 0)
1953 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1954 parent
.type
= REF_COMPONENT
;
1956 parent
.u
.c
.sym
= dt
;
1957 parent
.u
.c
.component
= dt
->components
;
1959 if (dt
->backend_decl
== NULL
)
1960 gfc_get_derived_type (dt
);
1962 /* Build the reference and call self. */
1963 gfc_conv_component_ref (se
, &parent
);
1964 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1965 parent
.u
.c
.component
= c
;
1966 conv_parent_component_references (se
, &parent
);
1969 /* Return the contents of a variable. Also handles reference/pointer
1970 variables (all Fortran pointer references are implicit). */
1973 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1978 tree parent_decl
= NULL_TREE
;
1981 bool alternate_entry
;
1984 sym
= expr
->symtree
->n
.sym
;
1988 gfc_ss_info
*ss_info
= ss
->info
;
1990 /* Check that something hasn't gone horribly wrong. */
1991 gcc_assert (ss
!= gfc_ss_terminator
);
1992 gcc_assert (ss_info
->expr
== expr
);
1994 /* A scalarized term. We already know the descriptor. */
1995 se
->expr
= ss_info
->data
.array
.descriptor
;
1996 se
->string_length
= ss_info
->string_length
;
1997 ref
= ss_info
->data
.array
.ref
;
1999 gcc_assert (ref
->type
== REF_ARRAY
2000 && ref
->u
.ar
.type
!= AR_ELEMENT
);
2002 gfc_conv_tmp_array_ref (se
);
2006 tree se_expr
= NULL_TREE
;
2008 se
->expr
= gfc_get_symbol_decl (sym
);
2010 /* Deal with references to a parent results or entries by storing
2011 the current_function_decl and moving to the parent_decl. */
2012 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
2013 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
2014 && sym
->result
== sym
;
2015 entry_master
= sym
->attr
.result
2016 && sym
->ns
->proc_name
->attr
.entry_master
2017 && !gfc_return_by_reference (sym
->ns
->proc_name
);
2018 if (current_function_decl
)
2019 parent_decl
= DECL_CONTEXT (current_function_decl
);
2021 if ((se
->expr
== parent_decl
&& return_value
)
2022 || (sym
->ns
&& sym
->ns
->proc_name
2024 && sym
->ns
->proc_name
->backend_decl
== parent_decl
2025 && (alternate_entry
|| entry_master
)))
2030 /* Special case for assigning the return value of a function.
2031 Self recursive functions must have an explicit return value. */
2032 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
2033 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2035 /* Similarly for alternate entry points. */
2036 else if (alternate_entry
2037 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2040 gfc_entry_list
*el
= NULL
;
2042 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2045 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2050 else if (entry_master
2051 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
2053 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
2058 /* Procedure actual arguments. */
2059 else if (sym
->attr
.flavor
== FL_PROCEDURE
2060 && se
->expr
!= current_function_decl
)
2062 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
2064 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
2065 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2071 /* Dereference the expression, where needed. Since characters
2072 are entirely different from other types, they are treated
2074 if (sym
->ts
.type
== BT_CHARACTER
)
2076 /* Dereference character pointer dummy arguments
2078 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2080 || sym
->attr
.function
2081 || sym
->attr
.result
))
2082 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2086 else if (!sym
->attr
.value
)
2088 /* Dereference non-character scalar dummy arguments. */
2089 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
2090 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
2091 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2094 /* Dereference scalar hidden result. */
2095 if (flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
2096 && (sym
->attr
.function
|| sym
->attr
.result
)
2097 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
2098 && !sym
->attr
.always_explicit
)
2099 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2102 /* Dereference non-character pointer variables.
2103 These must be dummies, results, or scalars. */
2104 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
2105 || gfc_is_associate_pointer (sym
)
2106 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
2108 || sym
->attr
.function
2110 || (!sym
->attr
.dimension
2111 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
2112 se
->expr
= build_fold_indirect_ref_loc (input_location
,
2119 /* For character variables, also get the length. */
2120 if (sym
->ts
.type
== BT_CHARACTER
)
2122 /* If the character length of an entry isn't set, get the length from
2123 the master function instead. */
2124 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
2125 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
2127 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
2128 gcc_assert (se
->string_length
);
2136 /* Return the descriptor if that's what we want and this is an array
2137 section reference. */
2138 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
2140 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2141 /* Return the descriptor for array pointers and allocations. */
2142 if (se
->want_pointer
2143 && ref
->next
== NULL
&& (se
->descriptor_only
))
2146 gfc_conv_array_ref (se
, &ref
->u
.ar
, expr
, &expr
->where
);
2147 /* Return a pointer to an element. */
2151 if (ref
->u
.c
.sym
->attr
.extension
)
2152 conv_parent_component_references (se
, ref
);
2154 gfc_conv_component_ref (se
, ref
);
2155 if (!ref
->next
&& ref
->u
.c
.sym
->attr
.codimension
2156 && se
->want_pointer
&& se
->descriptor_only
)
2162 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
2163 expr
->symtree
->name
, &expr
->where
);
2172 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2174 if (se
->want_pointer
)
2176 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
2177 gfc_conv_string_parameter (se
);
2179 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
2184 /* Unary ops are easy... Or they would be if ! was a valid op. */
2187 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
2192 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2193 /* Initialize the operand. */
2194 gfc_init_se (&operand
, se
);
2195 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
2196 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
2198 type
= gfc_typenode_for_spec (&expr
->ts
);
2200 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2201 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2202 All other unary operators have an equivalent GIMPLE unary operator. */
2203 if (code
== TRUTH_NOT_EXPR
)
2204 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
2205 build_int_cst (type
, 0));
2207 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
2211 /* Expand power operator to optimal multiplications when a value is raised
2212 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2213 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2214 Programming", 3rd Edition, 1998. */
2216 /* This code is mostly duplicated from expand_powi in the backend.
2217 We establish the "optimal power tree" lookup table with the defined size.
2218 The items in the table are the exponents used to calculate the index
2219 exponents. Any integer n less than the value can get an "addition chain",
2220 with the first node being one. */
2221 #define POWI_TABLE_SIZE 256
2223 /* The table is from builtins.c. */
2224 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
2226 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2227 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2228 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2229 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2230 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2231 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2232 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2233 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2234 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2235 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2236 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2237 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2238 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2239 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2240 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2241 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2242 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2243 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2244 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2245 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2246 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2247 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2248 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2249 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2250 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2251 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2252 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2253 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2254 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2255 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2256 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2257 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2260 /* If n is larger than lookup table's max index, we use the "window
2262 #define POWI_WINDOW_SIZE 3
2264 /* Recursive function to expand the power operator. The temporary
2265 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2267 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
2274 if (n
< POWI_TABLE_SIZE
)
2279 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
2280 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
2284 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
2285 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
2286 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
2290 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
2294 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
2295 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2297 if (n
< POWI_TABLE_SIZE
)
2304 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2305 return 1. Else return 0 and a call to runtime library functions
2306 will have to be built. */
2308 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
2313 tree vartmp
[POWI_TABLE_SIZE
];
2315 unsigned HOST_WIDE_INT n
;
2317 wide_int wrhs
= rhs
;
2319 /* If exponent is too large, we won't expand it anyway, so don't bother
2320 with large integer values. */
2321 if (!wi::fits_shwi_p (wrhs
))
2324 m
= wrhs
.to_shwi ();
2325 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
2326 of the asymmetric range of the integer type. */
2327 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
2329 type
= TREE_TYPE (lhs
);
2330 sgn
= tree_int_cst_sgn (rhs
);
2332 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
2333 || optimize_size
) && (m
> 2 || m
< -1))
2339 se
->expr
= gfc_build_const (type
, integer_one_node
);
2343 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2344 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
2346 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2347 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
2348 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
2349 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
2352 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2355 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
2356 boolean_type_node
, tmp
, cond
);
2357 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2358 tmp
, build_int_cst (type
, 1),
2359 build_int_cst (type
, 0));
2363 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2364 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
2365 build_int_cst (type
, -1),
2366 build_int_cst (type
, 0));
2367 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
2368 cond
, build_int_cst (type
, 1), tmp
);
2372 memset (vartmp
, 0, sizeof (vartmp
));
2376 tmp
= gfc_build_const (type
, integer_one_node
);
2377 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
2381 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
2387 /* Power op (**). Constant integer exponent has special handling. */
2390 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
2392 tree gfc_int4_type_node
;
2395 int res_ikind_1
, res_ikind_2
;
2400 gfc_init_se (&lse
, se
);
2401 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
2402 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
2403 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2405 gfc_init_se (&rse
, se
);
2406 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
2407 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2409 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
2410 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
2411 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
2414 gfc_int4_type_node
= gfc_get_int_type (4);
2416 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
2417 library routine. But in the end, we have to convert the result back
2418 if this case applies -- with res_ikind_K, we keep track whether operand K
2419 falls into this case. */
2423 kind
= expr
->value
.op
.op1
->ts
.kind
;
2424 switch (expr
->value
.op
.op2
->ts
.type
)
2427 ikind
= expr
->value
.op
.op2
->ts
.kind
;
2432 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
2433 res_ikind_2
= ikind
;
2455 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2457 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2484 switch (expr
->value
.op
.op1
->ts
.type
)
2487 if (kind
== 3) /* Case 16 was not handled properly above. */
2489 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2493 /* Use builtins for real ** int4. */
2499 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2503 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2507 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2511 /* Use the __builtin_powil() only if real(kind=16) is
2512 actually the C long double type. */
2513 if (!gfc_real16_is_float128
)
2514 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2522 /* If we don't have a good builtin for this, go for the
2523 library function. */
2525 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2529 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2538 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2542 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2550 se
->expr
= build_call_expr_loc (input_location
,
2551 fndecl
, 2, lse
.expr
, rse
.expr
);
2553 /* Convert the result back if it is of wrong integer kind. */
2554 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2556 /* We want the maximum of both operand kinds as result. */
2557 if (res_ikind_1
< res_ikind_2
)
2558 res_ikind_1
= res_ikind_2
;
2559 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2564 /* Generate code to allocate a string temporary. */
2567 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2572 if (gfc_can_put_var_on_stack (len
))
2574 /* Create a temporary variable to hold the result. */
2575 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2576 gfc_charlen_type_node
, len
,
2577 build_int_cst (gfc_charlen_type_node
, 1));
2578 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2580 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2581 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2583 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2585 var
= gfc_create_var (tmp
, "str");
2586 var
= gfc_build_addr_expr (type
, var
);
2590 /* Allocate a temporary to hold the result. */
2591 var
= gfc_create_var (type
, "pstr");
2592 gcc_assert (POINTER_TYPE_P (type
));
2593 tmp
= TREE_TYPE (type
);
2594 if (TREE_CODE (tmp
) == ARRAY_TYPE
)
2595 tmp
= TREE_TYPE (tmp
);
2596 tmp
= TYPE_SIZE_UNIT (tmp
);
2597 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
2598 fold_convert (size_type_node
, len
),
2599 fold_convert (size_type_node
, tmp
));
2600 tmp
= gfc_call_malloc (&se
->pre
, type
, tmp
);
2601 gfc_add_modify (&se
->pre
, var
, tmp
);
2603 /* Free the temporary afterwards. */
2604 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2605 gfc_add_expr_to_block (&se
->post
, tmp
);
2612 /* Handle a string concatenation operation. A temporary will be allocated to
2616 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2619 tree len
, type
, var
, tmp
, fndecl
;
2621 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2622 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2623 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2625 gfc_init_se (&lse
, se
);
2626 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2627 gfc_conv_string_parameter (&lse
);
2628 gfc_init_se (&rse
, se
);
2629 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2630 gfc_conv_string_parameter (&rse
);
2632 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2633 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2635 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2636 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2637 if (len
== NULL_TREE
)
2639 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2640 TREE_TYPE (lse
.string_length
),
2641 lse
.string_length
, rse
.string_length
);
2644 type
= build_pointer_type (type
);
2646 var
= gfc_conv_string_tmp (se
, type
, len
);
2648 /* Do the actual concatenation. */
2649 if (expr
->ts
.kind
== 1)
2650 fndecl
= gfor_fndecl_concat_string
;
2651 else if (expr
->ts
.kind
== 4)
2652 fndecl
= gfor_fndecl_concat_string_char4
;
2656 tmp
= build_call_expr_loc (input_location
,
2657 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2658 rse
.string_length
, rse
.expr
);
2659 gfc_add_expr_to_block (&se
->pre
, tmp
);
2661 /* Add the cleanup for the operands. */
2662 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2663 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2666 se
->string_length
= len
;
2669 /* Translates an op expression. Common (binary) cases are handled by this
2670 function, others are passed on. Recursion is used in either case.
2671 We use the fact that (op1.ts == op2.ts) (except for the power
2673 Operators need no special handling for scalarized expressions as long as
2674 they call gfc_conv_simple_val to get their operands.
2675 Character strings get special handling. */
2678 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2680 enum tree_code code
;
2689 switch (expr
->value
.op
.op
)
2691 case INTRINSIC_PARENTHESES
:
2692 if ((expr
->ts
.type
== BT_REAL
|| expr
->ts
.type
== BT_COMPLEX
)
2693 && flag_protect_parens
)
2695 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2696 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2701 case INTRINSIC_UPLUS
:
2702 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2705 case INTRINSIC_UMINUS
:
2706 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2710 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2713 case INTRINSIC_PLUS
:
2717 case INTRINSIC_MINUS
:
2721 case INTRINSIC_TIMES
:
2725 case INTRINSIC_DIVIDE
:
2726 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2727 an integer, we must round towards zero, so we use a
2729 if (expr
->ts
.type
== BT_INTEGER
)
2730 code
= TRUNC_DIV_EXPR
;
2735 case INTRINSIC_POWER
:
2736 gfc_conv_power_op (se
, expr
);
2739 case INTRINSIC_CONCAT
:
2740 gfc_conv_concat_op (se
, expr
);
2744 code
= TRUTH_ANDIF_EXPR
;
2749 code
= TRUTH_ORIF_EXPR
;
2753 /* EQV and NEQV only work on logicals, but since we represent them
2754 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2756 case INTRINSIC_EQ_OS
:
2764 case INTRINSIC_NE_OS
:
2765 case INTRINSIC_NEQV
:
2772 case INTRINSIC_GT_OS
:
2779 case INTRINSIC_GE_OS
:
2786 case INTRINSIC_LT_OS
:
2793 case INTRINSIC_LE_OS
:
2799 case INTRINSIC_USER
:
2800 case INTRINSIC_ASSIGN
:
2801 /* These should be converted into function calls by the frontend. */
2805 fatal_error ("Unknown intrinsic op");
2809 /* The only exception to this is **, which is handled separately anyway. */
2810 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2812 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2816 gfc_init_se (&lse
, se
);
2817 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2818 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2821 gfc_init_se (&rse
, se
);
2822 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2823 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2827 gfc_conv_string_parameter (&lse
);
2828 gfc_conv_string_parameter (&rse
);
2830 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2831 rse
.string_length
, rse
.expr
,
2832 expr
->value
.op
.op1
->ts
.kind
,
2834 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2835 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2838 type
= gfc_typenode_for_spec (&expr
->ts
);
2842 /* The result of logical ops is always boolean_type_node. */
2843 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2844 lse
.expr
, rse
.expr
);
2845 se
->expr
= convert (type
, tmp
);
2848 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2850 /* Add the post blocks. */
2851 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2852 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2855 /* If a string's length is one, we convert it to a single character. */
2858 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2862 || !tree_fits_uhwi_p (len
)
2863 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2866 if (TREE_INT_CST_LOW (len
) == 1)
2868 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2869 return build_fold_indirect_ref_loc (input_location
, str
);
2873 && TREE_CODE (str
) == ADDR_EXPR
2874 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2875 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2876 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2877 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2878 && TREE_INT_CST_LOW (len
) > 1
2879 && TREE_INT_CST_LOW (len
)
2880 == (unsigned HOST_WIDE_INT
)
2881 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2883 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2884 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2885 if (TREE_CODE (ret
) == INTEGER_CST
)
2887 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2888 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2889 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2891 for (i
= 1; i
< length
; i
++)
2904 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2907 if (sym
->backend_decl
)
2909 /* This becomes the nominal_type in
2910 function.c:assign_parm_find_data_types. */
2911 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2912 /* This becomes the passed_type in
2913 function.c:assign_parm_find_data_types. C promotes char to
2914 integer for argument passing. */
2915 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2917 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2922 /* If we have a constant character expression, make it into an
2924 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2929 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2930 (int)(*expr
)->value
.character
.string
[0]);
2931 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2933 /* The expr needs to be compatible with a C int. If the
2934 conversion fails, then the 2 causes an ICE. */
2935 ts
.type
= BT_INTEGER
;
2936 ts
.kind
= gfc_c_int_kind
;
2937 gfc_convert_type (*expr
, &ts
, 2);
2940 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2942 if ((*expr
)->ref
== NULL
)
2944 se
->expr
= gfc_string_to_single_character
2945 (build_int_cst (integer_type_node
, 1),
2946 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2948 ((*expr
)->symtree
->n
.sym
)),
2953 gfc_conv_variable (se
, *expr
);
2954 se
->expr
= gfc_string_to_single_character
2955 (build_int_cst (integer_type_node
, 1),
2956 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2964 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2965 if STR is a string literal, otherwise return -1. */
2968 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2971 && TREE_CODE (str
) == ADDR_EXPR
2972 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2973 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2974 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2975 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2976 && tree_fits_uhwi_p (len
)
2977 && tree_to_uhwi (len
) >= 1
2978 && tree_to_uhwi (len
)
2979 == (unsigned HOST_WIDE_INT
)
2980 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2982 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2983 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2984 if (TREE_CODE (folded
) == INTEGER_CST
)
2986 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2987 int length
= TREE_STRING_LENGTH (string_cst
);
2988 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2990 for (; length
> 0; length
--)
2991 if (ptr
[length
- 1] != ' ')
3000 /* Helper to build a call to memcmp. */
3003 build_memcmp_call (tree s1
, tree s2
, tree n
)
3007 if (!POINTER_TYPE_P (TREE_TYPE (s1
)))
3008 s1
= gfc_build_addr_expr (pvoid_type_node
, s1
);
3010 s1
= fold_convert (pvoid_type_node
, s1
);
3012 if (!POINTER_TYPE_P (TREE_TYPE (s2
)))
3013 s2
= gfc_build_addr_expr (pvoid_type_node
, s2
);
3015 s2
= fold_convert (pvoid_type_node
, s2
);
3017 n
= fold_convert (size_type_node
, n
);
3019 tmp
= build_call_expr_loc (input_location
,
3020 builtin_decl_explicit (BUILT_IN_MEMCMP
),
3023 return fold_convert (integer_type_node
, tmp
);
3026 /* Compare two strings. If they are all single characters, the result is the
3027 subtraction of them. Otherwise, we build a library call. */
3030 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
3031 enum tree_code code
)
3037 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
3038 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
3040 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
3041 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
3043 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
3045 /* Deal with single character specially. */
3046 sc1
= fold_convert (integer_type_node
, sc1
);
3047 sc2
= fold_convert (integer_type_node
, sc2
);
3048 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
3052 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
3054 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
3056 /* If one string is a string literal with LEN_TRIM longer
3057 than the length of the second string, the strings
3059 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
3060 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
3061 return integer_one_node
;
3062 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
3063 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
3064 return integer_one_node
;
3067 /* We can compare via memcpy if the strings are known to be equal
3068 in length and they are
3070 - kind=4 and the comparison is for (in)equality. */
3072 if (INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
)
3073 && tree_int_cst_equal (len1
, len2
)
3074 && (kind
== 1 || code
== EQ_EXPR
|| code
== NE_EXPR
))
3079 chartype
= gfc_get_char_type (kind
);
3080 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE(len1
),
3081 fold_convert (TREE_TYPE(len1
),
3082 TYPE_SIZE_UNIT(chartype
)),
3084 return build_memcmp_call (str1
, str2
, tmp
);
3087 /* Build a call for the comparison. */
3089 fndecl
= gfor_fndecl_compare_string
;
3091 fndecl
= gfor_fndecl_compare_string_char4
;
3095 return build_call_expr_loc (input_location
, fndecl
, 4,
3096 len1
, str1
, len2
, str2
);
3100 /* Return the backend_decl for a procedure pointer component. */
3103 get_proc_ptr_comp (gfc_expr
*e
)
3109 gfc_init_se (&comp_se
, NULL
);
3110 e2
= gfc_copy_expr (e
);
3111 /* We have to restore the expr type later so that gfc_free_expr frees
3112 the exact same thing that was allocated.
3113 TODO: This is ugly. */
3114 old_type
= e2
->expr_type
;
3115 e2
->expr_type
= EXPR_VARIABLE
;
3116 gfc_conv_expr (&comp_se
, e2
);
3117 e2
->expr_type
= old_type
;
3119 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
3123 /* Convert a typebound function reference from a class object. */
3125 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
3130 if (TREE_CODE (base_object
) != VAR_DECL
)
3132 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
3133 gfc_add_modify (&se
->pre
, var
, base_object
);
3135 se
->expr
= gfc_class_vptr_get (base_object
);
3136 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
3138 while (ref
&& ref
->next
)
3140 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
3141 if (ref
->u
.c
.sym
->attr
.extension
)
3142 conv_parent_component_references (se
, ref
);
3143 gfc_conv_component_ref (se
, ref
);
3144 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
3149 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
3153 if (gfc_is_proc_ptr_comp (expr
))
3154 tmp
= get_proc_ptr_comp (expr
);
3155 else if (sym
->attr
.dummy
)
3157 tmp
= gfc_get_symbol_decl (sym
);
3158 if (sym
->attr
.proc_pointer
)
3159 tmp
= build_fold_indirect_ref_loc (input_location
,
3161 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3162 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
3166 if (!sym
->backend_decl
)
3167 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
3169 TREE_USED (sym
->backend_decl
) = 1;
3171 tmp
= sym
->backend_decl
;
3173 if (sym
->attr
.cray_pointee
)
3175 /* TODO - make the cray pointee a pointer to a procedure,
3176 assign the pointer to it and use it for the call. This
3178 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
3179 gfc_get_symbol_decl (sym
->cp_pointer
));
3180 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3183 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
3185 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
3186 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3193 /* Initialize MAPPING. */
3196 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
3198 mapping
->syms
= NULL
;
3199 mapping
->charlens
= NULL
;
3203 /* Free all memory held by MAPPING (but not MAPPING itself). */
3206 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
3208 gfc_interface_sym_mapping
*sym
;
3209 gfc_interface_sym_mapping
*nextsym
;
3211 gfc_charlen
*nextcl
;
3213 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
3215 nextsym
= sym
->next
;
3216 sym
->new_sym
->n
.sym
->formal
= NULL
;
3217 gfc_free_symbol (sym
->new_sym
->n
.sym
);
3218 gfc_free_expr (sym
->expr
);
3219 free (sym
->new_sym
);
3222 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
3225 gfc_free_expr (cl
->length
);
3231 /* Return a copy of gfc_charlen CL. Add the returned structure to
3232 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3234 static gfc_charlen
*
3235 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
3238 gfc_charlen
*new_charlen
;
3240 new_charlen
= gfc_get_charlen ();
3241 new_charlen
->next
= mapping
->charlens
;
3242 new_charlen
->length
= gfc_copy_expr (cl
->length
);
3244 mapping
->charlens
= new_charlen
;
3249 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3250 array variable that can be used as the actual argument for dummy
3251 argument SYM. Add any initialization code to BLOCK. PACKED is as
3252 for gfc_get_nodesc_array_type and DATA points to the first element
3253 in the passed array. */
3256 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
3257 gfc_packed packed
, tree data
)
3262 type
= gfc_typenode_for_spec (&sym
->ts
);
3263 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
3264 !sym
->attr
.target
&& !sym
->attr
.pointer
3265 && !sym
->attr
.proc_pointer
);
3267 var
= gfc_create_var (type
, "ifm");
3268 gfc_add_modify (block
, var
, fold_convert (type
, data
));
3274 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3275 and offset of descriptorless array type TYPE given that it has the same
3276 size as DESC. Add any set-up code to BLOCK. */
3279 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
3286 offset
= gfc_index_zero_node
;
3287 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
3289 dim
= gfc_rank_cst
[n
];
3290 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
3291 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
3293 GFC_TYPE_ARRAY_LBOUND (type
, n
)
3294 = gfc_conv_descriptor_lbound_get (desc
, dim
);
3295 GFC_TYPE_ARRAY_UBOUND (type
, n
)
3296 = gfc_conv_descriptor_ubound_get (desc
, dim
);
3298 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
3300 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3301 gfc_array_index_type
,
3302 gfc_conv_descriptor_ubound_get (desc
, dim
),
3303 gfc_conv_descriptor_lbound_get (desc
, dim
));
3304 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3305 gfc_array_index_type
,
3306 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
3307 tmp
= gfc_evaluate_now (tmp
, block
);
3308 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
3310 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3311 GFC_TYPE_ARRAY_LBOUND (type
, n
),
3312 GFC_TYPE_ARRAY_STRIDE (type
, n
));
3313 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3314 gfc_array_index_type
, offset
, tmp
);
3316 offset
= gfc_evaluate_now (offset
, block
);
3317 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
3321 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3322 in SE. The caller may still use se->expr and se->string_length after
3323 calling this function. */
3326 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
3327 gfc_symbol
* sym
, gfc_se
* se
,
3330 gfc_interface_sym_mapping
*sm
;
3334 gfc_symbol
*new_sym
;
3336 gfc_symtree
*new_symtree
;
3338 /* Create a new symbol to represent the actual argument. */
3339 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
3340 new_sym
->ts
= sym
->ts
;
3341 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
3342 new_sym
->attr
.referenced
= 1;
3343 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
3344 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
3345 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
3346 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
3347 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
3348 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
3349 new_sym
->attr
.function
= sym
->attr
.function
;
3351 /* Ensure that the interface is available and that
3352 descriptors are passed for array actual arguments. */
3353 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3355 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
3356 new_sym
->attr
.always_explicit
3357 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
3360 /* Create a fake symtree for it. */
3362 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
3363 new_symtree
->n
.sym
= new_sym
;
3364 gcc_assert (new_symtree
== root
);
3366 /* Create a dummy->actual mapping. */
3367 sm
= XCNEW (gfc_interface_sym_mapping
);
3368 sm
->next
= mapping
->syms
;
3370 sm
->new_sym
= new_symtree
;
3371 sm
->expr
= gfc_copy_expr (expr
);
3374 /* Stabilize the argument's value. */
3375 if (!sym
->attr
.function
&& se
)
3376 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3378 if (sym
->ts
.type
== BT_CHARACTER
)
3380 /* Create a copy of the dummy argument's length. */
3381 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
3382 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
3384 /* If the length is specified as "*", record the length that
3385 the caller is passing. We should use the callee's length
3386 in all other cases. */
3387 if (!new_sym
->ts
.u
.cl
->length
&& se
)
3389 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
3390 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
3397 /* Use the passed value as-is if the argument is a function. */
3398 if (sym
->attr
.flavor
== FL_PROCEDURE
)
3401 /* If the argument is either a string or a pointer to a string,
3402 convert it to a boundless character type. */
3403 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
3405 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
3406 tmp
= build_pointer_type (tmp
);
3407 if (sym
->attr
.pointer
)
3408 value
= build_fold_indirect_ref_loc (input_location
,
3412 value
= fold_convert (tmp
, value
);
3415 /* If the argument is a scalar, a pointer to an array or an allocatable,
3417 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3418 value
= build_fold_indirect_ref_loc (input_location
,
3421 /* For character(*), use the actual argument's descriptor. */
3422 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
3423 value
= build_fold_indirect_ref_loc (input_location
,
3426 /* If the argument is an array descriptor, use it to determine
3427 information about the actual argument's shape. */
3428 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
3429 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
3431 /* Get the actual argument's descriptor. */
3432 desc
= build_fold_indirect_ref_loc (input_location
,
3435 /* Create the replacement variable. */
3436 tmp
= gfc_conv_descriptor_data_get (desc
);
3437 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3440 /* Use DESC to work out the upper bounds, strides and offset. */
3441 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
3444 /* Otherwise we have a packed array. */
3445 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
3446 PACKED_FULL
, se
->expr
);
3448 new_sym
->backend_decl
= value
;
3452 /* Called once all dummy argument mappings have been added to MAPPING,
3453 but before the mapping is used to evaluate expressions. Pre-evaluate
3454 the length of each argument, adding any initialization code to PRE and
3455 any finalization code to POST. */
3458 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
3459 stmtblock_t
* pre
, stmtblock_t
* post
)
3461 gfc_interface_sym_mapping
*sym
;
3465 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3466 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
3467 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
3469 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
3470 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3471 gfc_init_se (&se
, NULL
);
3472 gfc_conv_expr (&se
, expr
);
3473 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
3474 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
3475 gfc_add_block_to_block (pre
, &se
.pre
);
3476 gfc_add_block_to_block (post
, &se
.post
);
3478 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
3483 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3487 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
3488 gfc_constructor_base base
)
3491 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3493 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3496 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3497 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3498 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3504 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3508 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3513 for (; ref
; ref
= ref
->next
)
3517 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3519 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3520 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3521 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3529 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3530 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3536 /* Convert intrinsic function calls into result expressions. */
3539 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3547 arg1
= expr
->value
.function
.actual
->expr
;
3548 if (expr
->value
.function
.actual
->next
)
3549 arg2
= expr
->value
.function
.actual
->next
->expr
;
3553 sym
= arg1
->symtree
->n
.sym
;
3555 if (sym
->attr
.dummy
)
3560 switch (expr
->value
.function
.isym
->id
)
3563 /* TODO figure out why this condition is necessary. */
3564 if (sym
->attr
.function
3565 && (arg1
->ts
.u
.cl
->length
== NULL
3566 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3567 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3570 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3574 if (!sym
->as
|| sym
->as
->rank
== 0)
3577 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3579 dup
= mpz_get_si (arg2
->value
.integer
);
3584 dup
= sym
->as
->rank
;
3588 for (; d
< dup
; d
++)
3592 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3594 gfc_free_expr (new_expr
);
3598 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3599 gfc_get_int_expr (gfc_default_integer_kind
,
3601 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3603 new_expr
= gfc_multiply (new_expr
, tmp
);
3609 case GFC_ISYM_LBOUND
:
3610 case GFC_ISYM_UBOUND
:
3611 /* TODO These implementations of lbound and ubound do not limit if
3612 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3614 if (!sym
->as
|| sym
->as
->rank
== 0)
3617 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3618 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3620 /* TODO: If the need arises, this could produce an array of
3624 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3626 if (sym
->as
->lower
[d
])
3627 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3631 if (sym
->as
->upper
[d
])
3632 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3640 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3644 gfc_replace_expr (expr
, new_expr
);
3650 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3651 gfc_interface_mapping
* mapping
)
3653 gfc_formal_arglist
*f
;
3654 gfc_actual_arglist
*actual
;
3656 actual
= expr
->value
.function
.actual
;
3657 f
= gfc_sym_get_dummy_args (map_expr
->symtree
->n
.sym
);
3659 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3664 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3667 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3672 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3674 for (d
= 0; d
< as
->rank
; d
++)
3676 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3677 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3680 expr
->value
.function
.esym
->as
= as
;
3683 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3685 expr
->value
.function
.esym
->ts
.u
.cl
->length
3686 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3688 gfc_apply_interface_mapping_to_expr (mapping
,
3689 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3694 /* EXPR is a copy of an expression that appeared in the interface
3695 associated with MAPPING. Walk it recursively looking for references to
3696 dummy arguments that MAPPING maps to actual arguments. Replace each such
3697 reference with a reference to the associated actual argument. */
3700 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3703 gfc_interface_sym_mapping
*sym
;
3704 gfc_actual_arglist
*actual
;
3709 /* Copying an expression does not copy its length, so do that here. */
3710 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3712 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3713 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3716 /* Apply the mapping to any references. */
3717 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3719 /* ...and to the expression's symbol, if it has one. */
3720 /* TODO Find out why the condition on expr->symtree had to be moved into
3721 the loop rather than being outside it, as originally. */
3722 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3723 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3725 if (sym
->new_sym
->n
.sym
->backend_decl
)
3726 expr
->symtree
= sym
->new_sym
;
3728 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3729 /* Replace base type for polymorphic arguments. */
3730 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3731 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3732 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3735 /* ...and to subexpressions in expr->value. */
3736 switch (expr
->expr_type
)
3741 case EXPR_SUBSTRING
:
3745 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3746 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3750 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3751 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3753 if (expr
->value
.function
.esym
== NULL
3754 && expr
->value
.function
.isym
!= NULL
3755 && expr
->value
.function
.actual
->expr
->symtree
3756 && gfc_map_intrinsic_function (expr
, mapping
))
3759 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3760 if (sym
->old
== expr
->value
.function
.esym
)
3762 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3763 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3764 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3769 case EXPR_STRUCTURE
:
3770 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3783 /* Evaluate interface expression EXPR using MAPPING. Store the result
3787 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3788 gfc_se
* se
, gfc_expr
* expr
)
3790 expr
= gfc_copy_expr (expr
);
3791 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3792 gfc_conv_expr (se
, expr
);
3793 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3794 gfc_free_expr (expr
);
3798 /* Returns a reference to a temporary array into which a component of
3799 an actual argument derived type array is copied and then returned
3800 after the function call. */
3802 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3803 sym_intent intent
, bool formal_ptr
)
3811 gfc_array_info
*info
;
3821 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3823 gfc_init_se (&lse
, NULL
);
3824 gfc_init_se (&rse
, NULL
);
3826 /* Walk the argument expression. */
3827 rss
= gfc_walk_expr (expr
);
3829 gcc_assert (rss
!= gfc_ss_terminator
);
3831 /* Initialize the scalarizer. */
3832 gfc_init_loopinfo (&loop
);
3833 gfc_add_ss_to_loop (&loop
, rss
);
3835 /* Calculate the bounds of the scalarization. */
3836 gfc_conv_ss_startstride (&loop
);
3838 /* Build an ss for the temporary. */
3839 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3840 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3842 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3843 if (GFC_ARRAY_TYPE_P (base_type
)
3844 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3845 base_type
= gfc_get_element_type (base_type
);
3847 if (expr
->ts
.type
== BT_CLASS
)
3848 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3850 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3851 ? expr
->ts
.u
.cl
->backend_decl
3855 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3857 /* Associate the SS with the loop. */
3858 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3860 /* Setup the scalarizing loops. */
3861 gfc_conv_loop_setup (&loop
, &expr
->where
);
3863 /* Pass the temporary descriptor back to the caller. */
3864 info
= &loop
.temp_ss
->info
->data
.array
;
3865 parmse
->expr
= info
->descriptor
;
3867 /* Setup the gfc_se structures. */
3868 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3869 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3872 lse
.ss
= loop
.temp_ss
;
3873 gfc_mark_ss_chain_used (rss
, 1);
3874 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3876 /* Start the scalarized loop body. */
3877 gfc_start_scalarized_body (&loop
, &body
);
3879 /* Translate the expression. */
3880 gfc_conv_expr (&rse
, expr
);
3882 gfc_conv_tmp_array_ref (&lse
);
3884 if (intent
!= INTENT_OUT
)
3886 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3887 gfc_add_expr_to_block (&body
, tmp
);
3888 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3889 gfc_trans_scalarizing_loops (&loop
, &body
);
3893 /* Make sure that the temporary declaration survives by merging
3894 all the loop declarations into the current context. */
3895 for (n
= 0; n
< loop
.dimen
; n
++)
3897 gfc_merge_block_scope (&body
);
3898 body
= loop
.code
[loop
.order
[n
]];
3900 gfc_merge_block_scope (&body
);
3903 /* Add the post block after the second loop, so that any
3904 freeing of allocated memory is done at the right time. */
3905 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3907 /**********Copy the temporary back again.*********/
3909 gfc_init_se (&lse
, NULL
);
3910 gfc_init_se (&rse
, NULL
);
3912 /* Walk the argument expression. */
3913 lss
= gfc_walk_expr (expr
);
3914 rse
.ss
= loop
.temp_ss
;
3917 /* Initialize the scalarizer. */
3918 gfc_init_loopinfo (&loop2
);
3919 gfc_add_ss_to_loop (&loop2
, lss
);
3921 /* Calculate the bounds of the scalarization. */
3922 gfc_conv_ss_startstride (&loop2
);
3924 /* Setup the scalarizing loops. */
3925 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3927 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3928 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3930 gfc_mark_ss_chain_used (lss
, 1);
3931 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3933 /* Declare the variable to hold the temporary offset and start the
3934 scalarized loop body. */
3935 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3936 gfc_start_scalarized_body (&loop2
, &body
);
3938 /* Build the offsets for the temporary from the loop variables. The
3939 temporary array has lbounds of zero and strides of one in all
3940 dimensions, so this is very simple. The offset is only computed
3941 outside the innermost loop, so the overall transfer could be
3942 optimized further. */
3943 info
= &rse
.ss
->info
->data
.array
;
3944 dimen
= rse
.ss
->dimen
;
3946 tmp_index
= gfc_index_zero_node
;
3947 for (n
= dimen
- 1; n
> 0; n
--)
3950 tmp
= rse
.loop
->loopvar
[n
];
3951 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3952 tmp
, rse
.loop
->from
[n
]);
3953 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3956 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3957 gfc_array_index_type
,
3958 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3959 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3960 gfc_array_index_type
,
3961 tmp_str
, gfc_index_one_node
);
3963 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3964 gfc_array_index_type
, tmp
, tmp_str
);
3967 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3968 gfc_array_index_type
,
3969 tmp_index
, rse
.loop
->from
[0]);
3970 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3972 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3973 gfc_array_index_type
,
3974 rse
.loop
->loopvar
[0], offset
);
3976 /* Now use the offset for the reference. */
3977 tmp
= build_fold_indirect_ref_loc (input_location
,
3979 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3981 if (expr
->ts
.type
== BT_CHARACTER
)
3982 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3984 gfc_conv_expr (&lse
, expr
);
3986 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3988 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3989 gfc_add_expr_to_block (&body
, tmp
);
3991 /* Generate the copying loops. */
3992 gfc_trans_scalarizing_loops (&loop2
, &body
);
3994 /* Wrap the whole thing up by adding the second loop to the post-block
3995 and following it by the post-block of the first loop. In this way,
3996 if the temporary needs freeing, it is done after use! */
3997 if (intent
!= INTENT_IN
)
3999 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
4000 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
4003 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
4005 gfc_cleanup_loop (&loop
);
4006 gfc_cleanup_loop (&loop2
);
4008 /* Pass the string length to the argument expression. */
4009 if (expr
->ts
.type
== BT_CHARACTER
)
4010 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
4012 /* Determine the offset for pointer formal arguments and set the
4016 size
= gfc_index_one_node
;
4017 offset
= gfc_index_zero_node
;
4018 for (n
= 0; n
< dimen
; n
++)
4020 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
4022 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4023 gfc_array_index_type
, tmp
,
4024 gfc_index_one_node
);
4025 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
4029 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
4032 gfc_index_one_node
);
4033 size
= gfc_evaluate_now (size
, &parmse
->pre
);
4034 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
4035 gfc_array_index_type
,
4037 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
4038 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4039 gfc_array_index_type
,
4040 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
4041 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4042 gfc_array_index_type
,
4043 tmp
, gfc_index_one_node
);
4044 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4045 gfc_array_index_type
, size
, tmp
);
4048 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
4052 /* We want either the address for the data or the address of the descriptor,
4053 depending on the mode of passing array arguments. */
4055 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
4057 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
4063 /* Generate the code for argument list functions. */
4066 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
4068 /* Pass by value for g77 %VAL(arg), pass the address
4069 indirectly for %LOC, else by reference. Thus %REF
4070 is a "do-nothing" and %LOC is the same as an F95
4072 if (strncmp (name
, "%VAL", 4) == 0)
4073 gfc_conv_expr (se
, expr
);
4074 else if (strncmp (name
, "%LOC", 4) == 0)
4076 gfc_conv_expr_reference (se
, expr
);
4077 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
4079 else if (strncmp (name
, "%REF", 4) == 0)
4080 gfc_conv_expr_reference (se
, expr
);
4082 gfc_error ("Unknown argument list function at %L", &expr
->where
);
4086 /* Generate code for a procedure call. Note can return se->post != NULL.
4087 If se->direct_byref is set then se->expr contains the return parameter.
4088 Return nonzero, if the call has alternate specifiers.
4089 'expr' is only needed for procedure pointer components. */
4092 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
4093 gfc_actual_arglist
* args
, gfc_expr
* expr
,
4094 vec
<tree
, va_gc
> *append_args
)
4096 gfc_interface_mapping mapping
;
4097 vec
<tree
, va_gc
> *arglist
;
4098 vec
<tree
, va_gc
> *retargs
;
4102 gfc_array_info
*info
;
4109 vec
<tree
, va_gc
> *stringargs
;
4110 vec
<tree
, va_gc
> *optionalargs
;
4112 gfc_formal_arglist
*formal
;
4113 gfc_actual_arglist
*arg
;
4114 int has_alternate_specifier
= 0;
4115 bool need_interface_mapping
;
4122 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
4123 gfc_component
*comp
= NULL
;
4129 optionalargs
= NULL
;
4134 comp
= gfc_get_proc_ptr_comp (expr
);
4138 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
4140 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
4141 if (se
->ss
->info
->useflags
)
4143 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
4144 && sym
->result
->attr
.dimension
)
4145 || (comp
&& comp
->attr
.dimension
));
4146 gcc_assert (se
->loop
!= NULL
);
4148 /* Access the previously obtained result. */
4149 gfc_conv_tmp_array_ref (se
);
4153 info
= &se
->ss
->info
->data
.array
;
4158 gfc_init_block (&post
);
4159 gfc_init_interface_mapping (&mapping
);
4162 formal
= gfc_sym_get_dummy_args (sym
);
4163 need_interface_mapping
= sym
->attr
.dimension
||
4164 (sym
->ts
.type
== BT_CHARACTER
4165 && sym
->ts
.u
.cl
->length
4166 && sym
->ts
.u
.cl
->length
->expr_type
4171 formal
= comp
->ts
.interface
? comp
->ts
.interface
->formal
: NULL
;
4172 need_interface_mapping
= comp
->attr
.dimension
||
4173 (comp
->ts
.type
== BT_CHARACTER
4174 && comp
->ts
.u
.cl
->length
4175 && comp
->ts
.u
.cl
->length
->expr_type
4179 base_object
= NULL_TREE
;
4181 /* Evaluate the arguments. */
4182 for (arg
= args
; arg
!= NULL
;
4183 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
4186 fsym
= formal
? formal
->sym
: NULL
;
4187 parm_kind
= MISSING
;
4189 /* Class array expressions are sometimes coming completely unadorned
4190 with either arrayspec or _data component. Correct that here.
4191 OOP-TODO: Move this to the frontend. */
4192 if (e
&& e
->expr_type
== EXPR_VARIABLE
4194 && e
->ts
.type
== BT_CLASS
4195 && (CLASS_DATA (e
)->attr
.codimension
4196 || CLASS_DATA (e
)->attr
.dimension
))
4198 gfc_typespec temp_ts
= e
->ts
;
4199 gfc_add_class_array_ref (e
);
4205 if (se
->ignore_optional
)
4207 /* Some intrinsics have already been resolved to the correct
4211 else if (arg
->label
)
4213 has_alternate_specifier
= 1;
4218 gfc_init_se (&parmse
, NULL
);
4220 /* For scalar arguments with VALUE attribute which are passed by
4221 value, pass "0" and a hidden argument gives the optional
4223 if (fsym
&& fsym
->attr
.optional
&& fsym
->attr
.value
4224 && !fsym
->attr
.dimension
&& fsym
->ts
.type
!= BT_CHARACTER
4225 && fsym
->ts
.type
!= BT_CLASS
&& fsym
->ts
.type
!= BT_DERIVED
)
4227 parmse
.expr
= fold_convert (gfc_sym_type (fsym
),
4229 vec_safe_push (optionalargs
, boolean_false_node
);
4233 /* Pass a NULL pointer for an absent arg. */
4234 parmse
.expr
= null_pointer_node
;
4235 if (arg
->missing_arg_type
== BT_CHARACTER
)
4236 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
,
4241 else if (arg
->expr
->expr_type
== EXPR_NULL
4242 && fsym
&& !fsym
->attr
.pointer
4243 && (fsym
->ts
.type
!= BT_CLASS
4244 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
4246 /* Pass a NULL pointer to denote an absent arg. */
4247 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
4248 && (fsym
->ts
.type
!= BT_CLASS
4249 || !CLASS_DATA (fsym
)->attr
.allocatable
));
4250 gfc_init_se (&parmse
, NULL
);
4251 parmse
.expr
= null_pointer_node
;
4252 if (arg
->missing_arg_type
== BT_CHARACTER
)
4253 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
4255 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
4256 && e
->ts
.type
== BT_DERIVED
)
4258 /* The derived type needs to be converted to a temporary
4260 gfc_init_se (&parmse
, se
);
4261 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
4263 && e
->expr_type
== EXPR_VARIABLE
4264 && e
->symtree
->n
.sym
->attr
.optional
,
4265 CLASS_DATA (fsym
)->attr
.class_pointer
4266 || CLASS_DATA (fsym
)->attr
.allocatable
);
4268 else if (UNLIMITED_POLY (fsym
) && e
->ts
.type
!= BT_CLASS
)
4270 /* The intrinsic type needs to be converted to a temporary
4271 CLASS object for the unlimited polymorphic formal. */
4272 gfc_init_se (&parmse
, se
);
4273 gfc_conv_intrinsic_to_class (&parmse
, e
, fsym
->ts
);
4275 else if (se
->ss
&& se
->ss
->info
->useflags
)
4281 /* An elemental function inside a scalarized loop. */
4282 gfc_init_se (&parmse
, se
);
4283 parm_kind
= ELEMENTAL
;
4285 if (fsym
&& fsym
->attr
.value
)
4286 gfc_conv_expr (&parmse
, e
);
4288 gfc_conv_expr_reference (&parmse
, e
);
4290 if (e
->ts
.type
== BT_CHARACTER
&& !e
->rank
4291 && e
->expr_type
== EXPR_FUNCTION
)
4292 parmse
.expr
= build_fold_indirect_ref_loc (input_location
,
4295 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4296 && gfc_is_class_container_ref (e
))
4298 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4300 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4301 && e
->symtree
->n
.sym
->attr
.optional
)
4303 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4304 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4305 TREE_TYPE (parmse
.expr
),
4307 fold_convert (TREE_TYPE (parmse
.expr
),
4308 null_pointer_node
));
4312 /* If we are passing an absent array as optional dummy to an
4313 elemental procedure, make sure that we pass NULL when the data
4314 pointer is NULL. We need this extra conditional because of
4315 scalarization which passes arrays elements to the procedure,
4316 ignoring the fact that the array can be absent/unallocated/... */
4317 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4319 tree descriptor_data
;
4321 descriptor_data
= ss
->info
->data
.array
.data
;
4322 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4324 fold_convert (TREE_TYPE (descriptor_data
),
4325 null_pointer_node
));
4327 = fold_build3_loc (input_location
, COND_EXPR
,
4328 TREE_TYPE (parmse
.expr
),
4329 gfc_unlikely (tmp
, PRED_FORTRAN_ABSENT_DUMMY
),
4330 fold_convert (TREE_TYPE (parmse
.expr
),
4335 /* The scalarizer does not repackage the reference to a class
4336 array - instead it returns a pointer to the data element. */
4337 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4338 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4339 fsym
->attr
.intent
!= INTENT_IN
4340 && (CLASS_DATA (fsym
)->attr
.class_pointer
4341 || CLASS_DATA (fsym
)->attr
.allocatable
),
4343 && e
->expr_type
== EXPR_VARIABLE
4344 && e
->symtree
->n
.sym
->attr
.optional
,
4345 CLASS_DATA (fsym
)->attr
.class_pointer
4346 || CLASS_DATA (fsym
)->attr
.allocatable
);
4353 gfc_init_se (&parmse
, NULL
);
4355 /* Check whether the expression is a scalar or not; we cannot use
4356 e->rank as it can be nonzero for functions arguments. */
4357 argss
= gfc_walk_expr (e
);
4358 scalar
= argss
== gfc_ss_terminator
;
4360 gfc_free_ss_chain (argss
);
4362 /* Special handling for passing scalar polymorphic coarrays;
4363 otherwise one passes "class->_data.data" instead of "&class". */
4364 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4365 && fsym
&& fsym
->ts
.type
== BT_CLASS
4366 && CLASS_DATA (fsym
)->attr
.codimension
4367 && !CLASS_DATA (fsym
)->attr
.dimension
)
4369 gfc_add_class_array_ref (e
);
4370 parmse
.want_coarray
= 1;
4374 /* A scalar or transformational function. */
4377 if (e
->expr_type
== EXPR_VARIABLE
4378 && e
->symtree
->n
.sym
->attr
.cray_pointee
4379 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4381 /* The Cray pointer needs to be converted to a pointer to
4382 a type given by the expression. */
4383 gfc_conv_expr (&parmse
, e
);
4384 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4385 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4386 parmse
.expr
= convert (type
, tmp
);
4388 else if (fsym
&& fsym
->attr
.value
)
4390 if (fsym
->ts
.type
== BT_CHARACTER
4391 && fsym
->ts
.is_c_interop
4392 && fsym
->ns
->proc_name
!= NULL
4393 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4396 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4397 if (parmse
.expr
== NULL
)
4398 gfc_conv_expr (&parmse
, e
);
4402 gfc_conv_expr (&parmse
, e
);
4403 if (fsym
->attr
.optional
4404 && fsym
->ts
.type
!= BT_CLASS
4405 && fsym
->ts
.type
!= BT_DERIVED
)
4407 if (e
->expr_type
!= EXPR_VARIABLE
4408 || !e
->symtree
->n
.sym
->attr
.optional
4410 vec_safe_push (optionalargs
, boolean_true_node
);
4413 tmp
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4414 if (!e
->symtree
->n
.sym
->attr
.value
)
4416 = fold_build3_loc (input_location
, COND_EXPR
,
4417 TREE_TYPE (parmse
.expr
),
4419 fold_convert (TREE_TYPE (parmse
.expr
),
4420 integer_zero_node
));
4422 vec_safe_push (optionalargs
, tmp
);
4427 else if (arg
->name
&& arg
->name
[0] == '%')
4428 /* Argument list functions %VAL, %LOC and %REF are signalled
4429 through arg->name. */
4430 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4431 else if ((e
->expr_type
== EXPR_FUNCTION
)
4432 && ((e
->value
.function
.esym
4433 && e
->value
.function
.esym
->result
->attr
.pointer
)
4434 || (!e
->value
.function
.esym
4435 && e
->symtree
->n
.sym
->attr
.pointer
))
4436 && fsym
&& fsym
->attr
.target
)
4438 gfc_conv_expr (&parmse
, e
);
4439 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4441 else if (e
->expr_type
== EXPR_FUNCTION
4442 && e
->symtree
->n
.sym
->result
4443 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4444 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4446 /* Functions returning procedure pointers. */
4447 gfc_conv_expr (&parmse
, e
);
4448 if (fsym
&& fsym
->attr
.proc_pointer
)
4449 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4453 if (e
->ts
.type
== BT_CLASS
&& fsym
4454 && fsym
->ts
.type
== BT_CLASS
4455 && (!CLASS_DATA (fsym
)->as
4456 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4457 && CLASS_DATA (e
)->attr
.codimension
)
4459 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4460 gcc_assert (!CLASS_DATA (fsym
)->as
);
4461 gfc_add_class_array_ref (e
);
4462 parmse
.want_coarray
= 1;
4463 gfc_conv_expr_reference (&parmse
, e
);
4464 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4466 && e
->expr_type
== EXPR_VARIABLE
);
4468 else if (e
->ts
.type
== BT_CLASS
&& fsym
4469 && fsym
->ts
.type
== BT_CLASS
4470 && !CLASS_DATA (fsym
)->as
4471 && !CLASS_DATA (e
)->as
4472 && (CLASS_DATA (fsym
)->attr
.class_pointer
4473 != CLASS_DATA (e
)->attr
.class_pointer
4474 || CLASS_DATA (fsym
)->attr
.allocatable
4475 != CLASS_DATA (e
)->attr
.allocatable
))
4477 type
= gfc_typenode_for_spec (&fsym
->ts
);
4478 var
= gfc_create_var (type
, fsym
->name
);
4479 gfc_conv_expr (&parmse
, e
);
4480 if (fsym
->attr
.optional
4481 && e
->expr_type
== EXPR_VARIABLE
4482 && e
->symtree
->n
.sym
->attr
.optional
)
4486 tmp
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4487 cond
= fold_build2_loc (input_location
, NE_EXPR
,
4488 boolean_type_node
, tmp
,
4489 fold_convert (TREE_TYPE (tmp
),
4490 null_pointer_node
));
4491 gfc_start_block (&block
);
4492 gfc_add_modify (&block
, var
,
4493 fold_build1_loc (input_location
,
4495 type
, parmse
.expr
));
4496 gfc_add_expr_to_block (&parmse
.pre
,
4497 fold_build3_loc (input_location
,
4498 COND_EXPR
, void_type_node
,
4499 cond
, gfc_finish_block (&block
),
4500 build_empty_stmt (input_location
)));
4501 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4502 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4503 TREE_TYPE (parmse
.expr
),
4505 fold_convert (TREE_TYPE (parmse
.expr
),
4506 null_pointer_node
));
4510 gfc_add_modify (&parmse
.pre
, var
,
4511 fold_build1_loc (input_location
,
4513 type
, parmse
.expr
));
4514 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4518 gfc_conv_expr_reference (&parmse
, e
);
4520 /* Catch base objects that are not variables. */
4521 if (e
->ts
.type
== BT_CLASS
4522 && e
->expr_type
!= EXPR_VARIABLE
4523 && expr
&& e
== expr
->base_expr
)
4524 base_object
= build_fold_indirect_ref_loc (input_location
,
4527 /* A class array element needs converting back to be a
4528 class object, if the formal argument is a class object. */
4529 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4530 && e
->ts
.type
== BT_CLASS
4531 && ((CLASS_DATA (fsym
)->as
4532 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4533 || CLASS_DATA (e
)->attr
.dimension
))
4534 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4535 fsym
->attr
.intent
!= INTENT_IN
4536 && (CLASS_DATA (fsym
)->attr
.class_pointer
4537 || CLASS_DATA (fsym
)->attr
.allocatable
),
4539 && e
->expr_type
== EXPR_VARIABLE
4540 && e
->symtree
->n
.sym
->attr
.optional
,
4541 CLASS_DATA (fsym
)->attr
.class_pointer
4542 || CLASS_DATA (fsym
)->attr
.allocatable
);
4544 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4545 allocated on entry, it must be deallocated. */
4546 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4547 && (fsym
->attr
.allocatable
4548 || (fsym
->ts
.type
== BT_CLASS
4549 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4554 gfc_init_block (&block
);
4556 if (e
->ts
.type
== BT_CLASS
)
4557 ptr
= gfc_class_data_get (ptr
);
4559 tmp
= gfc_deallocate_scalar_with_status (ptr
, NULL_TREE
,
4561 gfc_add_expr_to_block (&block
, tmp
);
4562 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4563 void_type_node
, ptr
,
4565 gfc_add_expr_to_block (&block
, tmp
);
4567 if (fsym
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (fsym
))
4569 gfc_add_modify (&block
, ptr
,
4570 fold_convert (TREE_TYPE (ptr
),
4571 null_pointer_node
));
4572 gfc_add_expr_to_block (&block
, tmp
);
4574 else if (fsym
->ts
.type
== BT_CLASS
)
4577 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4578 tmp
= gfc_get_symbol_decl (vtab
);
4579 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4580 ptr
= gfc_class_vptr_get (parmse
.expr
);
4581 gfc_add_modify (&block
, ptr
,
4582 fold_convert (TREE_TYPE (ptr
), tmp
));
4583 gfc_add_expr_to_block (&block
, tmp
);
4586 if (fsym
->attr
.optional
4587 && e
->expr_type
== EXPR_VARIABLE
4588 && e
->symtree
->n
.sym
->attr
.optional
)
4590 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4592 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4593 gfc_finish_block (&block
),
4594 build_empty_stmt (input_location
));
4597 tmp
= gfc_finish_block (&block
);
4599 gfc_add_expr_to_block (&se
->pre
, tmp
);
4602 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4603 || fsym
->ts
.type
== BT_ASSUMED
)
4604 && e
->ts
.type
== BT_CLASS
4605 && !CLASS_DATA (e
)->attr
.dimension
4606 && !CLASS_DATA (e
)->attr
.codimension
)
4607 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4609 /* Wrap scalar variable in a descriptor. We need to convert
4610 the address of a pointer back to the pointer itself before,
4611 we can assign it to the data field. */
4613 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4614 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4617 if (TREE_CODE (tmp
) == ADDR_EXPR
4618 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4619 tmp
= TREE_OPERAND (tmp
, 0);
4620 parmse
.expr
= gfc_conv_scalar_to_descriptor (&parmse
, tmp
,
4622 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4625 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4626 && ((fsym
->attr
.pointer
4627 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4628 || (fsym
->attr
.proc_pointer
4629 && !(e
->expr_type
== EXPR_VARIABLE
4630 && e
->symtree
->n
.sym
->attr
.dummy
))
4631 || (fsym
->attr
.proc_pointer
4632 && e
->expr_type
== EXPR_VARIABLE
4633 && gfc_is_proc_ptr_comp (e
))
4634 || (fsym
->attr
.allocatable
4635 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4637 /* Scalar pointer dummy args require an extra level of
4638 indirection. The null pointer already contains
4639 this level of indirection. */
4640 parm_kind
= SCALAR_POINTER
;
4641 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4645 else if (e
->ts
.type
== BT_CLASS
4646 && fsym
&& fsym
->ts
.type
== BT_CLASS
4647 && (CLASS_DATA (fsym
)->attr
.dimension
4648 || CLASS_DATA (fsym
)->attr
.codimension
))
4650 /* Pass a class array. */
4651 parmse
.use_offset
= 1;
4652 gfc_conv_expr_descriptor (&parmse
, e
);
4654 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4655 allocated on entry, it must be deallocated. */
4656 if (fsym
->attr
.intent
== INTENT_OUT
4657 && CLASS_DATA (fsym
)->attr
.allocatable
)
4662 gfc_init_block (&block
);
4664 ptr
= gfc_class_data_get (ptr
);
4666 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4667 NULL_TREE
, NULL_TREE
,
4670 gfc_add_expr_to_block (&block
, tmp
);
4671 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4672 void_type_node
, ptr
,
4674 gfc_add_expr_to_block (&block
, tmp
);
4675 gfc_reset_vptr (&block
, e
);
4677 if (fsym
->attr
.optional
4678 && e
->expr_type
== EXPR_VARIABLE
4680 || (e
->ref
->type
== REF_ARRAY
4681 && e
->ref
->u
.ar
.type
!= AR_FULL
))
4682 && e
->symtree
->n
.sym
->attr
.optional
)
4684 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4686 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4687 gfc_finish_block (&block
),
4688 build_empty_stmt (input_location
));
4691 tmp
= gfc_finish_block (&block
);
4693 gfc_add_expr_to_block (&se
->pre
, tmp
);
4696 /* The conversion does not repackage the reference to a class
4697 array - _data descriptor. */
4698 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4699 fsym
->attr
.intent
!= INTENT_IN
4700 && (CLASS_DATA (fsym
)->attr
.class_pointer
4701 || CLASS_DATA (fsym
)->attr
.allocatable
),
4703 && e
->expr_type
== EXPR_VARIABLE
4704 && e
->symtree
->n
.sym
->attr
.optional
,
4705 CLASS_DATA (fsym
)->attr
.class_pointer
4706 || CLASS_DATA (fsym
)->attr
.allocatable
);
4710 /* If the procedure requires an explicit interface, the actual
4711 argument is passed according to the corresponding formal
4712 argument. If the corresponding formal argument is a POINTER,
4713 ALLOCATABLE or assumed shape, we do not use g77's calling
4714 convention, and pass the address of the array descriptor
4715 instead. Otherwise we use g77's calling convention. */
4718 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4719 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4720 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4722 f
= f
|| !comp
->attr
.always_explicit
;
4724 f
= f
|| !sym
->attr
.always_explicit
;
4726 /* If the argument is a function call that may not create
4727 a temporary for the result, we have to check that we
4728 can do it, i.e. that there is no alias between this
4729 argument and another one. */
4730 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4736 intent
= fsym
->attr
.intent
;
4738 intent
= INTENT_UNKNOWN
;
4740 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4742 parmse
.force_tmp
= 1;
4744 iarg
= e
->value
.function
.actual
->expr
;
4746 /* Temporary needed if aliasing due to host association. */
4747 if (sym
->attr
.contained
4749 && !sym
->attr
.implicit_pure
4750 && !sym
->attr
.use_assoc
4751 && iarg
->expr_type
== EXPR_VARIABLE
4752 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4753 parmse
.force_tmp
= 1;
4755 /* Ditto within module. */
4756 if (sym
->attr
.use_assoc
4758 && !sym
->attr
.implicit_pure
4759 && iarg
->expr_type
== EXPR_VARIABLE
4760 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4761 parmse
.force_tmp
= 1;
4764 if (e
->expr_type
== EXPR_VARIABLE
4765 && is_subref_array (e
))
4766 /* The actual argument is a component reference to an
4767 array of derived types. In this case, the argument
4768 is converted to a temporary, which is passed and then
4769 written back after the procedure call. */
4770 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4771 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4772 fsym
&& fsym
->attr
.pointer
);
4773 else if (gfc_is_class_array_ref (e
, NULL
)
4774 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4775 /* The actual argument is a component reference to an
4776 array of derived types. In this case, the argument
4777 is converted to a temporary, which is passed and then
4778 written back after the procedure call.
4779 OOP-TODO: Insert code so that if the dynamic type is
4780 the same as the declared type, copy-in/copy-out does
4782 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4783 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4784 fsym
&& fsym
->attr
.pointer
);
4786 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4788 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4789 allocated on entry, it must be deallocated. */
4790 if (fsym
&& fsym
->attr
.allocatable
4791 && fsym
->attr
.intent
== INTENT_OUT
)
4793 tmp
= build_fold_indirect_ref_loc (input_location
,
4795 tmp
= gfc_trans_dealloc_allocated (tmp
, false, e
);
4796 if (fsym
->attr
.optional
4797 && e
->expr_type
== EXPR_VARIABLE
4798 && e
->symtree
->n
.sym
->attr
.optional
)
4799 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4801 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4802 tmp
, build_empty_stmt (input_location
));
4803 gfc_add_expr_to_block (&se
->pre
, tmp
);
4808 /* The case with fsym->attr.optional is that of a user subroutine
4809 with an interface indicating an optional argument. When we call
4810 an intrinsic subroutine, however, fsym is NULL, but we might still
4811 have an optional argument, so we proceed to the substitution
4813 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4815 /* If an optional argument is itself an optional dummy argument,
4816 check its presence and substitute a null if absent. This is
4817 only needed when passing an array to an elemental procedure
4818 as then array elements are accessed - or no NULL pointer is
4819 allowed and a "1" or "0" should be passed if not present.
4820 When passing a non-array-descriptor full array to a
4821 non-array-descriptor dummy, no check is needed. For
4822 array-descriptor actual to array-descriptor dummy, see
4823 PR 41911 for why a check has to be inserted.
4824 fsym == NULL is checked as intrinsics required the descriptor
4825 but do not always set fsym. */
4826 if (e
->expr_type
== EXPR_VARIABLE
4827 && e
->symtree
->n
.sym
->attr
.optional
4828 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4829 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4833 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4834 || fsym
->as
->type
== AS_ASSUMED_RANK
4835 || fsym
->as
->type
== AS_DEFERRED
))))))
4836 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4837 e
->representation
.length
);
4842 /* Obtain the character length of an assumed character length
4843 length procedure from the typespec. */
4844 if (fsym
->ts
.type
== BT_CHARACTER
4845 && parmse
.string_length
== NULL_TREE
4846 && e
->ts
.type
== BT_PROCEDURE
4847 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4848 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4849 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4851 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4852 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4856 if (fsym
&& need_interface_mapping
&& e
)
4857 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4859 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4860 gfc_add_block_to_block (&post
, &parmse
.post
);
4862 /* Allocated allocatable components of derived types must be
4863 deallocated for non-variable scalars. Non-variable arrays are
4864 dealt with in trans-array.c(gfc_conv_array_parameter). */
4865 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4866 && e
->ts
.u
.derived
->attr
.alloc_comp
4867 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4868 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4871 tmp
= build_fold_indirect_ref_loc (input_location
,
4873 parm_rank
= e
->rank
;
4881 case (SCALAR_POINTER
):
4882 tmp
= build_fold_indirect_ref_loc (input_location
,
4887 if (e
->expr_type
== EXPR_OP
4888 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4889 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4892 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4893 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4894 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4897 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4899 /* The derived type is passed to gfc_deallocate_alloc_comp.
4900 Therefore, class actuals can handled correctly but derived
4901 types passed to class formals need the _data component. */
4902 tmp
= gfc_class_data_get (tmp
);
4903 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4904 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4907 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4909 gfc_add_expr_to_block (&se
->post
, tmp
);
4912 /* Add argument checking of passing an unallocated/NULL actual to
4913 a nonallocatable/nonpointer dummy. */
4915 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4917 symbol_attribute attr
;
4921 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4922 attr
= gfc_expr_attr (e
);
4924 goto end_pointer_check
;
4926 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4927 allocatable to an optional dummy, cf. 12.5.2.12. */
4928 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4929 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4930 goto end_pointer_check
;
4934 /* If the actual argument is an optional pointer/allocatable and
4935 the formal argument takes an nonpointer optional value,
4936 it is invalid to pass a non-present argument on, even
4937 though there is no technical reason for this in gfortran.
4938 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4939 tree present
, null_ptr
, type
;
4941 if (attr
.allocatable
4942 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4943 msg
= xasprintf ("Allocatable actual argument '%s' is not "
4944 "allocated or not present",
4945 e
->symtree
->n
.sym
->name
);
4946 else if (attr
.pointer
4947 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4948 msg
= xasprintf ("Pointer actual argument '%s' is not "
4949 "associated or not present",
4950 e
->symtree
->n
.sym
->name
);
4951 else if (attr
.proc_pointer
4952 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4953 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
4954 "associated or not present",
4955 e
->symtree
->n
.sym
->name
);
4957 goto end_pointer_check
;
4959 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4960 type
= TREE_TYPE (present
);
4961 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4962 boolean_type_node
, present
,
4964 null_pointer_node
));
4965 type
= TREE_TYPE (parmse
.expr
);
4966 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4967 boolean_type_node
, parmse
.expr
,
4969 null_pointer_node
));
4970 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4971 boolean_type_node
, present
, null_ptr
);
4975 if (attr
.allocatable
4976 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4977 msg
= xasprintf ("Allocatable actual argument '%s' is not "
4978 "allocated", e
->symtree
->n
.sym
->name
);
4979 else if (attr
.pointer
4980 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4981 msg
= xasprintf ("Pointer actual argument '%s' is not "
4982 "associated", e
->symtree
->n
.sym
->name
);
4983 else if (attr
.proc_pointer
4984 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4985 msg
= xasprintf ("Proc-pointer actual argument '%s' is not "
4986 "associated", e
->symtree
->n
.sym
->name
);
4988 goto end_pointer_check
;
4992 /* If the argument is passed by value, we need to strip the
4994 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4995 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4997 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4998 boolean_type_node
, tmp
,
4999 fold_convert (TREE_TYPE (tmp
),
5000 null_pointer_node
));
5003 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
5009 /* Deferred length dummies pass the character length by reference
5010 so that the value can be returned. */
5011 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
5013 tmp
= parmse
.string_length
;
5014 if (TREE_CODE (tmp
) != VAR_DECL
)
5015 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
5016 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5019 /* Character strings are passed as two parameters, a length and a
5020 pointer - except for Bind(c) which only passes the pointer.
5021 An unlimited polymorphic formal argument likewise does not
5023 if (parmse
.string_length
!= NULL_TREE
5024 && !sym
->attr
.is_bind_c
5025 && !(fsym
&& UNLIMITED_POLY (fsym
)))
5026 vec_safe_push (stringargs
, parmse
.string_length
);
5028 /* When calling __copy for character expressions to unlimited
5029 polymorphic entities, the dst argument needs a string length. */
5030 if (sym
->name
[0] == '_' && e
&& e
->ts
.type
== BT_CHARACTER
5031 && strncmp (sym
->name
, "__vtab_CHARACTER", 16) == 0
5032 && arg
->next
&& arg
->next
->expr
5033 && arg
->next
->expr
->ts
.type
== BT_DERIVED
5034 && arg
->next
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5035 vec_safe_push (stringargs
, parmse
.string_length
);
5037 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5038 pass the token and the offset as additional arguments. */
5039 if (fsym
&& e
== NULL
&& flag_coarray
== GFC_FCOARRAY_LIB
5040 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5041 && !fsym
->attr
.allocatable
)
5042 || (fsym
->ts
.type
== BT_CLASS
5043 && CLASS_DATA (fsym
)->attr
.codimension
5044 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5046 /* Token and offset. */
5047 vec_safe_push (stringargs
, null_pointer_node
);
5048 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
5049 gcc_assert (fsym
->attr
.optional
);
5051 else if (fsym
&& flag_coarray
== GFC_FCOARRAY_LIB
5052 && ((fsym
->ts
.type
!= BT_CLASS
&& fsym
->attr
.codimension
5053 && !fsym
->attr
.allocatable
)
5054 || (fsym
->ts
.type
== BT_CLASS
5055 && CLASS_DATA (fsym
)->attr
.codimension
5056 && !CLASS_DATA (fsym
)->attr
.allocatable
)))
5058 tree caf_decl
, caf_type
;
5061 caf_decl
= gfc_get_tree_for_caf_expr (e
);
5062 caf_type
= TREE_TYPE (caf_decl
);
5064 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5065 && (GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
5066 || GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_POINTER
))
5067 tmp
= gfc_conv_descriptor_token (caf_decl
);
5068 else if (DECL_LANG_SPECIFIC (caf_decl
)
5069 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
5070 tmp
= GFC_DECL_TOKEN (caf_decl
);
5073 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
5074 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
5075 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
5078 vec_safe_push (stringargs
, tmp
);
5080 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
5081 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
5082 offset
= build_int_cst (gfc_array_index_type
, 0);
5083 else if (DECL_LANG_SPECIFIC (caf_decl
)
5084 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
5085 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
5086 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
5087 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
5089 offset
= build_int_cst (gfc_array_index_type
, 0);
5091 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
5092 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
5095 gcc_assert (POINTER_TYPE_P (caf_type
));
5099 tmp2
= fsym
->ts
.type
== BT_CLASS
5100 ? gfc_class_data_get (parmse
.expr
) : parmse
.expr
;
5101 if ((fsym
->ts
.type
!= BT_CLASS
5102 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
5103 || fsym
->as
->type
== AS_ASSUMED_RANK
))
5104 || (fsym
->ts
.type
== BT_CLASS
5105 && (CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_SHAPE
5106 || CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)))
5108 if (fsym
->ts
.type
== BT_CLASS
)
5109 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5112 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5113 tmp2
= build_fold_indirect_ref_loc (input_location
, tmp2
);
5115 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)));
5116 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5118 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2
)))
5119 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
5122 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2
)));
5125 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5126 gfc_array_index_type
,
5127 fold_convert (gfc_array_index_type
, tmp2
),
5128 fold_convert (gfc_array_index_type
, tmp
));
5129 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
5130 gfc_array_index_type
, offset
, tmp
);
5132 vec_safe_push (stringargs
, offset
);
5135 vec_safe_push (arglist
, parmse
.expr
);
5137 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
5144 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
5145 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
5146 else if (ts
.type
== BT_CHARACTER
)
5148 if (ts
.u
.cl
->length
== NULL
)
5150 /* Assumed character length results are not allowed by 5.1.1.5 of the
5151 standard and are trapped in resolve.c; except in the case of SPREAD
5152 (and other intrinsics?) and dummy functions. In the case of SPREAD,
5153 we take the character length of the first argument for the result.
5154 For dummies, we have to look through the formal argument list for
5155 this function and use the character length found there.*/
5157 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
5158 else if (!sym
->attr
.dummy
)
5159 cl
.backend_decl
= (*stringargs
)[0];
5162 formal
= gfc_sym_get_dummy_args (sym
->ns
->proc_name
);
5163 for (; formal
; formal
= formal
->next
)
5164 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
5165 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
5167 len
= cl
.backend_decl
;
5173 /* Calculate the length of the returned string. */
5174 gfc_init_se (&parmse
, NULL
);
5175 if (need_interface_mapping
)
5176 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
5178 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
5179 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
5180 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
5182 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
5183 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
5184 gfc_charlen_type_node
, tmp
,
5185 build_int_cst (gfc_charlen_type_node
, 0));
5186 cl
.backend_decl
= tmp
;
5189 /* Set up a charlen structure for it. */
5194 len
= cl
.backend_decl
;
5197 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
5198 || (!comp
&& gfc_return_by_reference (sym
));
5201 if (se
->direct_byref
)
5203 /* Sometimes, too much indirection can be applied; e.g. for
5204 function_result = array_valued_recursive_function. */
5205 if (TREE_TYPE (TREE_TYPE (se
->expr
))
5206 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
5207 && GFC_DESCRIPTOR_TYPE_P
5208 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
5209 se
->expr
= build_fold_indirect_ref_loc (input_location
,
5212 /* If the lhs of an assignment x = f(..) is allocatable and
5213 f2003 is allowed, we must do the automatic reallocation.
5214 TODO - deal with intrinsics, without using a temporary. */
5215 if (flag_realloc_lhs
5216 && se
->ss
&& se
->ss
->loop_chain
5217 && se
->ss
->loop_chain
->is_alloc_lhs
5218 && !expr
->value
.function
.isym
5219 && sym
->result
->as
!= NULL
)
5221 /* Evaluate the bounds of the result, if known. */
5222 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
5225 /* Perform the automatic reallocation. */
5226 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
5228 gfc_add_expr_to_block (&se
->pre
, tmp
);
5230 /* Pass the temporary as the first argument. */
5231 result
= info
->descriptor
;
5234 result
= build_fold_indirect_ref_loc (input_location
,
5236 vec_safe_push (retargs
, se
->expr
);
5238 else if (comp
&& comp
->attr
.dimension
)
5240 gcc_assert (se
->loop
&& info
);
5242 /* Set the type of the array. */
5243 tmp
= gfc_typenode_for_spec (&comp
->ts
);
5244 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5246 /* Evaluate the bounds of the result, if known. */
5247 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
5249 /* If the lhs of an assignment x = f(..) is allocatable and
5250 f2003 is allowed, we must not generate the function call
5251 here but should just send back the results of the mapping.
5252 This is signalled by the function ss being flagged. */
5253 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5255 gfc_free_interface_mapping (&mapping
);
5256 return has_alternate_specifier
;
5259 /* Create a temporary to store the result. In case the function
5260 returns a pointer, the temporary will be a shallow copy and
5261 mustn't be deallocated. */
5262 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
5263 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5264 tmp
, NULL_TREE
, false,
5265 !comp
->attr
.pointer
, callee_alloc
,
5266 &se
->ss
->info
->expr
->where
);
5268 /* Pass the temporary as the first argument. */
5269 result
= info
->descriptor
;
5270 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5271 vec_safe_push (retargs
, tmp
);
5273 else if (!comp
&& sym
->result
->attr
.dimension
)
5275 gcc_assert (se
->loop
&& info
);
5277 /* Set the type of the array. */
5278 tmp
= gfc_typenode_for_spec (&ts
);
5279 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
5281 /* Evaluate the bounds of the result, if known. */
5282 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
5284 /* If the lhs of an assignment x = f(..) is allocatable and
5285 f2003 is allowed, we must not generate the function call
5286 here but should just send back the results of the mapping.
5287 This is signalled by the function ss being flagged. */
5288 if (flag_realloc_lhs
&& se
->ss
&& se
->ss
->is_alloc_lhs
)
5290 gfc_free_interface_mapping (&mapping
);
5291 return has_alternate_specifier
;
5294 /* Create a temporary to store the result. In case the function
5295 returns a pointer, the temporary will be a shallow copy and
5296 mustn't be deallocated. */
5297 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
5298 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
5299 tmp
, NULL_TREE
, false,
5300 !sym
->attr
.pointer
, callee_alloc
,
5301 &se
->ss
->info
->expr
->where
);
5303 /* Pass the temporary as the first argument. */
5304 result
= info
->descriptor
;
5305 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
5306 vec_safe_push (retargs
, tmp
);
5308 else if (ts
.type
== BT_CHARACTER
)
5310 /* Pass the string length. */
5311 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
5312 type
= build_pointer_type (type
);
5314 /* Return an address to a char[0:len-1]* temporary for
5315 character pointers. */
5316 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5317 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5319 var
= gfc_create_var (type
, "pstr");
5321 if ((!comp
&& sym
->attr
.allocatable
)
5322 || (comp
&& comp
->attr
.allocatable
))
5324 gfc_add_modify (&se
->pre
, var
,
5325 fold_convert (TREE_TYPE (var
),
5326 null_pointer_node
));
5327 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
5328 gfc_add_expr_to_block (&se
->post
, tmp
);
5331 /* Provide an address expression for the function arguments. */
5332 var
= gfc_build_addr_expr (NULL_TREE
, var
);
5335 var
= gfc_conv_string_tmp (se
, type
, len
);
5337 vec_safe_push (retargs
, var
);
5341 gcc_assert (flag_f2c
&& ts
.type
== BT_COMPLEX
);
5343 type
= gfc_get_complex_type (ts
.kind
);
5344 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
5345 vec_safe_push (retargs
, var
);
5348 /* Add the string length to the argument list. */
5349 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
5352 if (TREE_CODE (tmp
) != VAR_DECL
)
5353 tmp
= gfc_evaluate_now (len
, &se
->pre
);
5354 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
5355 vec_safe_push (retargs
, tmp
);
5357 else if (ts
.type
== BT_CHARACTER
)
5358 vec_safe_push (retargs
, len
);
5360 gfc_free_interface_mapping (&mapping
);
5362 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
5363 arglen
= (vec_safe_length (arglist
) + vec_safe_length (optionalargs
)
5364 + vec_safe_length (stringargs
) + vec_safe_length (append_args
));
5365 vec_safe_reserve (retargs
, arglen
);
5367 /* Add the return arguments. */
5368 retargs
->splice (arglist
);
5370 /* Add the hidden present status for optional+value to the arguments. */
5371 retargs
->splice (optionalargs
);
5373 /* Add the hidden string length parameters to the arguments. */
5374 retargs
->splice (stringargs
);
5376 /* We may want to append extra arguments here. This is used e.g. for
5377 calls to libgfortran_matmul_??, which need extra information. */
5378 if (!vec_safe_is_empty (append_args
))
5379 retargs
->splice (append_args
);
5382 /* Generate the actual call. */
5383 if (base_object
== NULL_TREE
)
5384 conv_function_val (se
, sym
, expr
);
5386 conv_base_obj_fcn_val (se
, base_object
, expr
);
5388 /* If there are alternate return labels, function type should be
5389 integer. Can't modify the type in place though, since it can be shared
5390 with other functions. For dummy arguments, the typing is done to
5391 this result, even if it has to be repeated for each call. */
5392 if (has_alternate_specifier
5393 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
5395 if (!sym
->attr
.dummy
)
5397 TREE_TYPE (sym
->backend_decl
)
5398 = build_function_type (integer_type_node
,
5399 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
5400 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
5403 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
5406 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
5407 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
5409 /* If we have a pointer function, but we don't want a pointer, e.g.
5412 where f is pointer valued, we have to dereference the result. */
5413 if (!se
->want_pointer
&& !byref
5414 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5415 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
5416 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5418 /* f2c calling conventions require a scalar default real function to
5419 return a double precision result. Convert this back to default
5420 real. We only care about the cases that can happen in Fortran 77.
5422 if (flag_f2c
&& sym
->ts
.type
== BT_REAL
5423 && sym
->ts
.kind
== gfc_default_real_kind
5424 && !sym
->attr
.always_explicit
)
5425 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
5427 /* A pure function may still have side-effects - it may modify its
5429 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5431 if (!sym
->attr
.pure
)
5432 TREE_SIDE_EFFECTS (se
->expr
) = 1;
5437 /* Add the function call to the pre chain. There is no expression. */
5438 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5439 se
->expr
= NULL_TREE
;
5441 if (!se
->direct_byref
)
5443 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5445 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5447 /* Check the data pointer hasn't been modified. This would
5448 happen in a function returning a pointer. */
5449 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5450 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5453 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5456 se
->expr
= info
->descriptor
;
5457 /* Bundle in the string length. */
5458 se
->string_length
= len
;
5460 else if (ts
.type
== BT_CHARACTER
)
5462 /* Dereference for character pointer results. */
5463 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5464 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5465 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5469 se
->string_length
= len
;
5473 gcc_assert (ts
.type
== BT_COMPLEX
&& flag_f2c
);
5474 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5479 /* Follow the function call with the argument post block. */
5482 gfc_add_block_to_block (&se
->pre
, &post
);
5484 /* Transformational functions of derived types with allocatable
5485 components must have the result allocatable components copied. */
5486 arg
= expr
->value
.function
.actual
;
5487 if (result
&& arg
&& expr
->rank
5488 && expr
->value
.function
.isym
5489 && expr
->value
.function
.isym
->transformational
5490 && arg
->expr
->ts
.type
== BT_DERIVED
5491 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5494 /* Copy the allocatable components. We have to use a
5495 temporary here to prevent source allocatable components
5496 from being corrupted. */
5497 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5498 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5499 result
, tmp2
, expr
->rank
);
5500 gfc_add_expr_to_block (&se
->pre
, tmp
);
5501 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5503 gfc_add_expr_to_block (&se
->pre
, tmp
);
5505 /* Finally free the temporary's data field. */
5506 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5507 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5508 NULL_TREE
, NULL_TREE
, true,
5510 gfc_add_expr_to_block (&se
->pre
, tmp
);
5514 gfc_add_block_to_block (&se
->post
, &post
);
5516 return has_alternate_specifier
;
5520 /* Fill a character string with spaces. */
5523 fill_with_spaces (tree start
, tree type
, tree size
)
5525 stmtblock_t block
, loop
;
5526 tree i
, el
, exit_label
, cond
, tmp
;
5528 /* For a simple char type, we can call memset(). */
5529 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5530 return build_call_expr_loc (input_location
,
5531 builtin_decl_explicit (BUILT_IN_MEMSET
),
5533 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5534 lang_hooks
.to_target_charset (' ')),
5537 /* Otherwise, we use a loop:
5538 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5542 /* Initialize variables. */
5543 gfc_init_block (&block
);
5544 i
= gfc_create_var (sizetype
, "i");
5545 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5546 el
= gfc_create_var (build_pointer_type (type
), "el");
5547 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5548 exit_label
= gfc_build_label_decl (NULL_TREE
);
5549 TREE_USED (exit_label
) = 1;
5553 gfc_init_block (&loop
);
5555 /* Exit condition. */
5556 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5557 build_zero_cst (sizetype
));
5558 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5559 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5560 build_empty_stmt (input_location
));
5561 gfc_add_expr_to_block (&loop
, tmp
);
5564 gfc_add_modify (&loop
,
5565 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5566 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5568 /* Increment loop variables. */
5569 gfc_add_modify (&loop
, i
,
5570 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5571 TYPE_SIZE_UNIT (type
)));
5572 gfc_add_modify (&loop
, el
,
5573 fold_build_pointer_plus_loc (input_location
,
5574 el
, TYPE_SIZE_UNIT (type
)));
5576 /* Making the loop... actually loop! */
5577 tmp
= gfc_finish_block (&loop
);
5578 tmp
= build1_v (LOOP_EXPR
, tmp
);
5579 gfc_add_expr_to_block (&block
, tmp
);
5581 /* The exit label. */
5582 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5583 gfc_add_expr_to_block (&block
, tmp
);
5586 return gfc_finish_block (&block
);
5590 /* Generate code to copy a string. */
5593 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5594 int dkind
, tree slength
, tree src
, int skind
)
5596 tree tmp
, dlen
, slen
;
5605 stmtblock_t tempblock
;
5607 gcc_assert (dkind
== skind
);
5609 if (slength
!= NULL_TREE
)
5611 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5612 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5616 slen
= build_int_cst (size_type_node
, 1);
5620 if (dlength
!= NULL_TREE
)
5622 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5623 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5627 dlen
= build_int_cst (size_type_node
, 1);
5631 /* Assign directly if the types are compatible. */
5632 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5633 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5635 gfc_add_modify (block
, dsc
, ssc
);
5639 /* Do nothing if the destination length is zero. */
5640 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5641 build_int_cst (size_type_node
, 0));
5643 /* The following code was previously in _gfortran_copy_string:
5645 // The two strings may overlap so we use memmove.
5647 copy_string (GFC_INTEGER_4 destlen, char * dest,
5648 GFC_INTEGER_4 srclen, const char * src)
5650 if (srclen >= destlen)
5652 // This will truncate if too long.
5653 memmove (dest, src, destlen);
5657 memmove (dest, src, srclen);
5659 memset (&dest[srclen], ' ', destlen - srclen);
5663 We're now doing it here for better optimization, but the logic
5666 /* For non-default character kinds, we have to multiply the string
5667 length by the base type size. */
5668 chartype
= gfc_get_char_type (dkind
);
5669 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5670 fold_convert (size_type_node
, slen
),
5671 fold_convert (size_type_node
,
5672 TYPE_SIZE_UNIT (chartype
)));
5673 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5674 fold_convert (size_type_node
, dlen
),
5675 fold_convert (size_type_node
,
5676 TYPE_SIZE_UNIT (chartype
)));
5678 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5679 dest
= fold_convert (pvoid_type_node
, dest
);
5681 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5683 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5684 src
= fold_convert (pvoid_type_node
, src
);
5686 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5688 /* Truncate string if source is too long. */
5689 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5691 tmp2
= build_call_expr_loc (input_location
,
5692 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5693 3, dest
, src
, dlen
);
5695 /* Else copy and pad with spaces. */
5696 tmp3
= build_call_expr_loc (input_location
,
5697 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5698 3, dest
, src
, slen
);
5700 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5701 tmp4
= fill_with_spaces (tmp4
, chartype
,
5702 fold_build2_loc (input_location
, MINUS_EXPR
,
5703 TREE_TYPE(dlen
), dlen
, slen
));
5705 gfc_init_block (&tempblock
);
5706 gfc_add_expr_to_block (&tempblock
, tmp3
);
5707 gfc_add_expr_to_block (&tempblock
, tmp4
);
5708 tmp3
= gfc_finish_block (&tempblock
);
5710 /* The whole copy_string function is there. */
5711 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5713 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5714 build_empty_stmt (input_location
));
5715 gfc_add_expr_to_block (block
, tmp
);
5719 /* Translate a statement function.
5720 The value of a statement function reference is obtained by evaluating the
5721 expression using the values of the actual arguments for the values of the
5722 corresponding dummy arguments. */
5725 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5729 gfc_formal_arglist
*fargs
;
5730 gfc_actual_arglist
*args
;
5733 gfc_saved_var
*saved_vars
;
5739 sym
= expr
->symtree
->n
.sym
;
5740 args
= expr
->value
.function
.actual
;
5741 gfc_init_se (&lse
, NULL
);
5742 gfc_init_se (&rse
, NULL
);
5745 for (fargs
= gfc_sym_get_dummy_args (sym
); fargs
; fargs
= fargs
->next
)
5747 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5748 temp_vars
= XCNEWVEC (tree
, n
);
5750 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5751 fargs
= fargs
->next
, n
++)
5753 /* Each dummy shall be specified, explicitly or implicitly, to be
5755 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5758 if (fsym
->ts
.type
== BT_CHARACTER
)
5760 /* Copy string arguments. */
5763 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5764 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5766 /* Create a temporary to hold the value. */
5767 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5768 fsym
->ts
.u
.cl
->backend_decl
5769 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5771 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5772 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5774 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5776 gfc_conv_expr (&rse
, args
->expr
);
5777 gfc_conv_string_parameter (&rse
);
5778 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5779 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5781 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5782 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5783 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5784 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5788 /* For everything else, just evaluate the expression. */
5790 /* Create a temporary to hold the value. */
5791 type
= gfc_typenode_for_spec (&fsym
->ts
);
5792 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5794 gfc_conv_expr (&lse
, args
->expr
);
5796 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5797 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5798 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5804 /* Use the temporary variables in place of the real ones. */
5805 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5806 fargs
= fargs
->next
, n
++)
5807 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5809 gfc_conv_expr (se
, sym
->value
);
5811 if (sym
->ts
.type
== BT_CHARACTER
)
5813 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5815 /* Force the expression to the correct length. */
5816 if (!INTEGER_CST_P (se
->string_length
)
5817 || tree_int_cst_lt (se
->string_length
,
5818 sym
->ts
.u
.cl
->backend_decl
))
5820 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5821 tmp
= gfc_create_var (type
, sym
->name
);
5822 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5823 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5824 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5828 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5831 /* Restore the original variables. */
5832 for (fargs
= gfc_sym_get_dummy_args (sym
), n
= 0; fargs
;
5833 fargs
= fargs
->next
, n
++)
5834 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5840 /* Translate a function expression. */
5843 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5847 if (expr
->value
.function
.isym
)
5849 gfc_conv_intrinsic_function (se
, expr
);
5853 /* expr.value.function.esym is the resolved (specific) function symbol for
5854 most functions. However this isn't set for dummy procedures. */
5855 sym
= expr
->value
.function
.esym
;
5857 sym
= expr
->symtree
->n
.sym
;
5859 /* The IEEE_ARITHMETIC functions are caught here. */
5860 if (sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
5861 if (gfc_conv_ieee_arithmetic_function (se
, expr
))
5864 /* We distinguish statement functions from general functions to improve
5865 runtime performance. */
5866 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
5868 gfc_conv_statement_function (se
, expr
);
5872 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5877 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5880 is_zero_initializer_p (gfc_expr
* expr
)
5882 if (expr
->expr_type
!= EXPR_CONSTANT
)
5885 /* We ignore constants with prescribed memory representations for now. */
5886 if (expr
->representation
.string
)
5889 switch (expr
->ts
.type
)
5892 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5895 return mpfr_zero_p (expr
->value
.real
)
5896 && MPFR_SIGN (expr
->value
.real
) >= 0;
5899 return expr
->value
.logical
== 0;
5902 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5903 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5904 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5905 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5915 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5920 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5921 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5923 gfc_conv_tmp_array_ref (se
);
5927 /* Build a static initializer. EXPR is the expression for the initial value.
5928 The other parameters describe the variable of the component being
5929 initialized. EXPR may be null. */
5932 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5933 bool array
, bool pointer
, bool procptr
)
5937 if (!(expr
|| pointer
|| procptr
))
5940 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5941 (these are the only two iso_c_binding derived types that can be
5942 used as initialization expressions). If so, we need to modify
5943 the 'expr' to be that for a (void *). */
5944 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5945 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5947 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5949 /* The derived symbol has already been converted to a (void *). Use
5951 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5952 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5954 gfc_init_se (&se
, NULL
);
5955 gfc_conv_constant (&se
, expr
);
5956 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5960 if (array
&& !procptr
)
5963 /* Arrays need special handling. */
5965 ctor
= gfc_build_null_descriptor (type
);
5966 /* Special case assigning an array to zero. */
5967 else if (is_zero_initializer_p (expr
))
5968 ctor
= build_constructor (type
, NULL
);
5970 ctor
= gfc_conv_array_initializer (type
, expr
);
5971 TREE_STATIC (ctor
) = 1;
5974 else if (pointer
|| procptr
)
5976 if (ts
->type
== BT_CLASS
&& !procptr
)
5978 gfc_init_se (&se
, NULL
);
5979 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
5980 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5981 TREE_STATIC (se
.expr
) = 1;
5984 else if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5985 return fold_convert (type
, null_pointer_node
);
5988 gfc_init_se (&se
, NULL
);
5989 se
.want_pointer
= 1;
5990 gfc_conv_expr (&se
, expr
);
5991 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6001 gfc_init_se (&se
, NULL
);
6002 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6003 gfc_conv_structure (&se
, gfc_class_initializer (ts
, expr
), 1);
6005 gfc_conv_structure (&se
, expr
, 1);
6006 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
6007 TREE_STATIC (se
.expr
) = 1;
6012 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
6013 TREE_STATIC (ctor
) = 1;
6018 gfc_init_se (&se
, NULL
);
6019 gfc_conv_constant (&se
, expr
);
6020 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
6027 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6033 gfc_array_info
*lss_array
;
6040 gfc_start_block (&block
);
6042 /* Initialize the scalarizer. */
6043 gfc_init_loopinfo (&loop
);
6045 gfc_init_se (&lse
, NULL
);
6046 gfc_init_se (&rse
, NULL
);
6049 rss
= gfc_walk_expr (expr
);
6050 if (rss
== gfc_ss_terminator
)
6051 /* The rhs is scalar. Add a ss for the expression. */
6052 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
6054 /* Create a SS for the destination. */
6055 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
6057 lss_array
= &lss
->info
->data
.array
;
6058 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
6059 lss_array
->descriptor
= dest
;
6060 lss_array
->data
= gfc_conv_array_data (dest
);
6061 lss_array
->offset
= gfc_conv_array_offset (dest
);
6062 for (n
= 0; n
< cm
->as
->rank
; n
++)
6064 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
6065 lss_array
->stride
[n
] = gfc_index_one_node
;
6067 mpz_init (lss_array
->shape
[n
]);
6068 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
6069 cm
->as
->lower
[n
]->value
.integer
);
6070 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
6073 /* Associate the SS with the loop. */
6074 gfc_add_ss_to_loop (&loop
, lss
);
6075 gfc_add_ss_to_loop (&loop
, rss
);
6077 /* Calculate the bounds of the scalarization. */
6078 gfc_conv_ss_startstride (&loop
);
6080 /* Setup the scalarizing loops. */
6081 gfc_conv_loop_setup (&loop
, &expr
->where
);
6083 /* Setup the gfc_se structures. */
6084 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6085 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6088 gfc_mark_ss_chain_used (rss
, 1);
6090 gfc_mark_ss_chain_used (lss
, 1);
6092 /* Start the scalarized loop body. */
6093 gfc_start_scalarized_body (&loop
, &body
);
6095 gfc_conv_tmp_array_ref (&lse
);
6096 if (cm
->ts
.type
== BT_CHARACTER
)
6097 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6099 gfc_conv_expr (&rse
, expr
);
6101 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
6102 gfc_add_expr_to_block (&body
, tmp
);
6104 gcc_assert (rse
.ss
== gfc_ss_terminator
);
6106 /* Generate the copying loops. */
6107 gfc_trans_scalarizing_loops (&loop
, &body
);
6109 /* Wrap the whole thing up. */
6110 gfc_add_block_to_block (&block
, &loop
.pre
);
6111 gfc_add_block_to_block (&block
, &loop
.post
);
6113 gcc_assert (lss_array
->shape
!= NULL
);
6114 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
6115 gfc_cleanup_loop (&loop
);
6117 return gfc_finish_block (&block
);
6122 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
6132 gfc_expr
*arg
= NULL
;
6134 gfc_start_block (&block
);
6135 gfc_init_se (&se
, NULL
);
6137 /* Get the descriptor for the expressions. */
6138 se
.want_pointer
= 0;
6139 gfc_conv_expr_descriptor (&se
, expr
);
6140 gfc_add_block_to_block (&block
, &se
.pre
);
6141 gfc_add_modify (&block
, dest
, se
.expr
);
6143 /* Deal with arrays of derived types with allocatable components. */
6144 if (cm
->ts
.type
== BT_DERIVED
6145 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
6146 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
6150 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
6151 TREE_TYPE(cm
->backend_decl
),
6154 gfc_add_expr_to_block (&block
, tmp
);
6155 gfc_add_block_to_block (&block
, &se
.post
);
6157 if (expr
->expr_type
!= EXPR_VARIABLE
)
6158 gfc_conv_descriptor_data_set (&block
, se
.expr
,
6161 /* We need to know if the argument of a conversion function is a
6162 variable, so that the correct lower bound can be used. */
6163 if (expr
->expr_type
== EXPR_FUNCTION
6164 && expr
->value
.function
.isym
6165 && expr
->value
.function
.isym
->conversion
6166 && expr
->value
.function
.actual
->expr
6167 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
6168 arg
= expr
->value
.function
.actual
->expr
;
6170 /* Obtain the array spec of full array references. */
6172 as
= gfc_get_full_arrayspec_from_expr (arg
);
6174 as
= gfc_get_full_arrayspec_from_expr (expr
);
6176 /* Shift the lbound and ubound of temporaries to being unity,
6177 rather than zero, based. Always calculate the offset. */
6178 offset
= gfc_conv_descriptor_offset_get (dest
);
6179 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
6180 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
6182 for (n
= 0; n
< expr
->rank
; n
++)
6187 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
6188 TODO It looks as if gfc_conv_expr_descriptor should return
6189 the correct bounds and that the following should not be
6190 necessary. This would simplify gfc_conv_intrinsic_bound
6192 if (as
&& as
->lower
[n
])
6195 gfc_init_se (&lbse
, NULL
);
6196 gfc_conv_expr (&lbse
, as
->lower
[n
]);
6197 gfc_add_block_to_block (&block
, &lbse
.pre
);
6198 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
6202 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
6203 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
6207 lbound
= gfc_conv_descriptor_lbound_get (dest
,
6210 lbound
= gfc_index_one_node
;
6212 lbound
= fold_convert (gfc_array_index_type
, lbound
);
6214 /* Shift the bounds and set the offset accordingly. */
6215 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
6216 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6217 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
6218 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
6220 gfc_conv_descriptor_ubound_set (&block
, dest
,
6221 gfc_rank_cst
[n
], tmp
);
6222 gfc_conv_descriptor_lbound_set (&block
, dest
,
6223 gfc_rank_cst
[n
], lbound
);
6225 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6226 gfc_conv_descriptor_lbound_get (dest
,
6228 gfc_conv_descriptor_stride_get (dest
,
6230 gfc_add_modify (&block
, tmp2
, tmp
);
6231 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
6233 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
6238 /* If a conversion expression has a null data pointer
6239 argument, nullify the allocatable component. */
6243 if (arg
->symtree
->n
.sym
->attr
.allocatable
6244 || arg
->symtree
->n
.sym
->attr
.pointer
)
6246 non_null_expr
= gfc_finish_block (&block
);
6247 gfc_start_block (&block
);
6248 gfc_conv_descriptor_data_set (&block
, dest
,
6250 null_expr
= gfc_finish_block (&block
);
6251 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
6252 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6253 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6254 return build3_v (COND_EXPR
, tmp
,
6255 null_expr
, non_null_expr
);
6259 return gfc_finish_block (&block
);
6263 /* Assign a single component of a derived type constructor. */
6266 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
6273 gfc_start_block (&block
);
6275 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
6277 gfc_init_se (&se
, NULL
);
6278 /* Pointer component. */
6279 if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6280 && !cm
->attr
.proc_pointer
)
6282 /* Array pointer. */
6283 if (expr
->expr_type
== EXPR_NULL
)
6284 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6287 se
.direct_byref
= 1;
6289 gfc_conv_expr_descriptor (&se
, expr
);
6290 gfc_add_block_to_block (&block
, &se
.pre
);
6291 gfc_add_block_to_block (&block
, &se
.post
);
6296 /* Scalar pointers. */
6297 se
.want_pointer
= 1;
6298 gfc_conv_expr (&se
, expr
);
6299 gfc_add_block_to_block (&block
, &se
.pre
);
6301 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
6302 && expr
->symtree
->n
.sym
->attr
.dummy
)
6303 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
6305 gfc_add_modify (&block
, dest
,
6306 fold_convert (TREE_TYPE (dest
), se
.expr
));
6307 gfc_add_block_to_block (&block
, &se
.post
);
6310 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
6312 /* NULL initialization for CLASS components. */
6313 tmp
= gfc_trans_structure_assign (dest
,
6314 gfc_class_initializer (&cm
->ts
, expr
));
6315 gfc_add_expr_to_block (&block
, tmp
);
6317 else if ((cm
->attr
.dimension
|| cm
->attr
.codimension
)
6318 && !cm
->attr
.proc_pointer
)
6320 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
6321 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
6322 else if (cm
->attr
.allocatable
)
6324 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
6325 gfc_add_expr_to_block (&block
, tmp
);
6329 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
6330 gfc_add_expr_to_block (&block
, tmp
);
6333 else if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.f90_type
!= BT_VOID
)
6335 if (expr
->expr_type
!= EXPR_STRUCTURE
)
6337 gfc_init_se (&se
, NULL
);
6338 gfc_conv_expr (&se
, expr
);
6339 gfc_add_block_to_block (&block
, &se
.pre
);
6340 gfc_add_modify (&block
, dest
,
6341 fold_convert (TREE_TYPE (dest
), se
.expr
));
6342 gfc_add_block_to_block (&block
, &se
.post
);
6346 /* Nested constructors. */
6347 tmp
= gfc_trans_structure_assign (dest
, expr
);
6348 gfc_add_expr_to_block (&block
, tmp
);
6351 else if (gfc_deferred_strlen (cm
, &tmp
))
6355 gcc_assert (strlen
);
6356 strlen
= fold_build3_loc (input_location
, COMPONENT_REF
,
6358 TREE_OPERAND (dest
, 0),
6361 if (expr
->expr_type
== EXPR_NULL
)
6363 tmp
= build_int_cst (TREE_TYPE (cm
->backend_decl
), 0);
6364 gfc_add_modify (&block
, dest
, tmp
);
6365 tmp
= build_int_cst (TREE_TYPE (strlen
), 0);
6366 gfc_add_modify (&block
, strlen
, tmp
);
6371 gfc_init_se (&se
, NULL
);
6372 gfc_conv_expr (&se
, expr
);
6373 size
= size_of_string_in_bytes (cm
->ts
.kind
, se
.string_length
);
6374 tmp
= build_call_expr_loc (input_location
,
6375 builtin_decl_explicit (BUILT_IN_MALLOC
),
6377 gfc_add_modify (&block
, dest
,
6378 fold_convert (TREE_TYPE (dest
), tmp
));
6379 gfc_add_modify (&block
, strlen
, se
.string_length
);
6380 tmp
= gfc_build_memcpy_call (dest
, se
.expr
, size
);
6381 gfc_add_expr_to_block (&block
, tmp
);
6384 else if (!cm
->attr
.deferred_parameter
)
6386 /* Scalar component (excluding deferred parameters). */
6387 gfc_init_se (&se
, NULL
);
6388 gfc_init_se (&lse
, NULL
);
6390 gfc_conv_expr (&se
, expr
);
6391 if (cm
->ts
.type
== BT_CHARACTER
)
6392 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
6394 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
6395 gfc_add_expr_to_block (&block
, tmp
);
6397 return gfc_finish_block (&block
);
6400 /* Assign a derived type constructor to a variable. */
6403 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
6411 gfc_start_block (&block
);
6412 cm
= expr
->ts
.u
.derived
->components
;
6414 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
6415 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
6416 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
6420 gcc_assert (cm
->backend_decl
== NULL
);
6421 gfc_init_se (&se
, NULL
);
6422 gfc_init_se (&lse
, NULL
);
6423 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
6425 gfc_add_modify (&block
, lse
.expr
,
6426 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
6428 return gfc_finish_block (&block
);
6431 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6432 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6434 /* Skip absent members in default initializers. */
6438 field
= cm
->backend_decl
;
6439 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
6440 dest
, field
, NULL_TREE
);
6441 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
6442 gfc_add_expr_to_block (&block
, tmp
);
6444 return gfc_finish_block (&block
);
6447 /* Build an expression for a constructor. If init is nonzero then
6448 this is part of a static variable initializer. */
6451 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
6458 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6460 gcc_assert (se
->ss
== NULL
);
6461 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
6462 type
= gfc_typenode_for_spec (&expr
->ts
);
6466 /* Create a temporary variable and fill it in. */
6467 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
6468 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
6469 gfc_add_expr_to_block (&se
->pre
, tmp
);
6473 cm
= expr
->ts
.u
.derived
->components
;
6475 for (c
= gfc_constructor_first (expr
->value
.constructor
);
6476 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
6478 /* Skip absent members in default initializers and allocatable
6479 components. Although the latter have a default initializer
6480 of EXPR_NULL,... by default, the static nullify is not needed
6481 since this is done every time we come into scope. */
6482 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
6485 if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6486 && strcmp (cm
->name
, "_extends") == 0
6487 && cm
->initializer
->symtree
)
6491 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6492 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6493 vtab
= unshare_expr_without_location (vtab
);
6494 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6496 else if (cm
->ts
.u
.derived
&& strcmp (cm
->name
, "_size") == 0)
6498 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
6499 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
,
6500 fold_convert (TREE_TYPE (cm
->backend_decl
),
6505 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6506 TREE_TYPE (cm
->backend_decl
),
6507 cm
->attr
.dimension
, cm
->attr
.pointer
,
6508 cm
->attr
.proc_pointer
);
6509 val
= unshare_expr_without_location (val
);
6511 /* Append it to the constructor list. */
6512 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6515 se
->expr
= build_constructor (type
, v
);
6517 TREE_CONSTANT (se
->expr
) = 1;
6521 /* Translate a substring expression. */
6524 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6530 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6532 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6533 expr
->value
.character
.length
,
6534 expr
->value
.character
.string
);
6536 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6537 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6540 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6544 /* Entry point for expression translation. Evaluates a scalar quantity.
6545 EXPR is the expression to be translated, and SE is the state structure if
6546 called from within the scalarized. */
6549 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6554 if (ss
&& ss
->info
->expr
== expr
6555 && (ss
->info
->type
== GFC_SS_SCALAR
6556 || ss
->info
->type
== GFC_SS_REFERENCE
))
6558 gfc_ss_info
*ss_info
;
6561 /* Substitute a scalar expression evaluated outside the scalarization
6563 se
->expr
= ss_info
->data
.scalar
.value
;
6564 /* If the reference can be NULL, the value field contains the reference,
6565 not the value the reference points to (see gfc_add_loop_ss_code). */
6566 if (ss_info
->can_be_null_ref
)
6567 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6569 se
->string_length
= ss_info
->string_length
;
6570 gfc_advance_se_ss_chain (se
);
6574 /* We need to convert the expressions for the iso_c_binding derived types.
6575 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6576 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6577 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6578 updated to be an integer with a kind equal to the size of a (void *). */
6579 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
6581 if (expr
->expr_type
== EXPR_VARIABLE
6582 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6583 || expr
->symtree
->n
.sym
->intmod_sym_id
6584 == ISOCBINDING_NULL_FUNPTR
))
6586 /* Set expr_type to EXPR_NULL, which will result in
6587 null_pointer_node being used below. */
6588 expr
->expr_type
= EXPR_NULL
;
6592 /* Update the type/kind of the expression to be what the new
6593 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6594 expr
->ts
.type
= BT_INTEGER
;
6595 expr
->ts
.f90_type
= BT_VOID
;
6596 expr
->ts
.kind
= gfc_index_integer_kind
;
6600 gfc_fix_class_refs (expr
);
6602 switch (expr
->expr_type
)
6605 gfc_conv_expr_op (se
, expr
);
6609 gfc_conv_function_expr (se
, expr
);
6613 gfc_conv_constant (se
, expr
);
6617 gfc_conv_variable (se
, expr
);
6621 se
->expr
= null_pointer_node
;
6624 case EXPR_SUBSTRING
:
6625 gfc_conv_substring_expr (se
, expr
);
6628 case EXPR_STRUCTURE
:
6629 gfc_conv_structure (se
, expr
, 0);
6633 gfc_conv_array_constructor_expr (se
, expr
);
6642 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6643 of an assignment. */
6645 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6647 gfc_conv_expr (se
, expr
);
6648 /* All numeric lvalues should have empty post chains. If not we need to
6649 figure out a way of rewriting an lvalue so that it has no post chain. */
6650 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6653 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6654 numeric expressions. Used for scalar values where inserting cleanup code
6657 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6661 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6662 gfc_conv_expr (se
, expr
);
6665 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6666 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6668 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6672 /* Helper to translate an expression and convert it to a particular type. */
6674 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6676 gfc_conv_expr_val (se
, expr
);
6677 se
->expr
= convert (type
, se
->expr
);
6681 /* Converts an expression so that it can be passed by reference. Scalar
6685 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6691 if (ss
&& ss
->info
->expr
== expr
6692 && ss
->info
->type
== GFC_SS_REFERENCE
)
6694 /* Returns a reference to the scalar evaluated outside the loop
6696 gfc_conv_expr (se
, expr
);
6698 if (expr
->ts
.type
== BT_CHARACTER
6699 && expr
->expr_type
!= EXPR_FUNCTION
)
6700 gfc_conv_string_parameter (se
);
6702 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6707 if (expr
->ts
.type
== BT_CHARACTER
)
6709 gfc_conv_expr (se
, expr
);
6710 gfc_conv_string_parameter (se
);
6714 if (expr
->expr_type
== EXPR_VARIABLE
)
6716 se
->want_pointer
= 1;
6717 gfc_conv_expr (se
, expr
);
6720 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6721 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6722 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6728 if (expr
->expr_type
== EXPR_FUNCTION
6729 && ((expr
->value
.function
.esym
6730 && expr
->value
.function
.esym
->result
->attr
.pointer
6731 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6732 || (!expr
->value
.function
.esym
&& !expr
->ref
6733 && expr
->symtree
->n
.sym
->attr
.pointer
6734 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6736 se
->want_pointer
= 1;
6737 gfc_conv_expr (se
, expr
);
6738 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6739 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6744 gfc_conv_expr (se
, expr
);
6746 /* Create a temporary var to hold the value. */
6747 if (TREE_CONSTANT (se
->expr
))
6749 tree tmp
= se
->expr
;
6750 STRIP_TYPE_NOPS (tmp
);
6751 var
= build_decl (input_location
,
6752 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6753 DECL_INITIAL (var
) = tmp
;
6754 TREE_STATIC (var
) = 1;
6759 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6760 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6762 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6764 /* Take the address of that value. */
6765 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6766 if (expr
->ts
.type
== BT_DERIVED
&& expr
->rank
6767 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
)
6768 && expr
->ts
.u
.derived
->attr
.alloc_comp
6769 && expr
->expr_type
!= EXPR_VARIABLE
)
6773 tmp
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6774 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
, expr
->rank
);
6776 /* The components shall be deallocated before
6777 their containing entity. */
6778 gfc_prepend_expr_to_block (&se
->post
, tmp
);
6784 gfc_trans_pointer_assign (gfc_code
* code
)
6786 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6790 /* Generate code for a pointer assignment. */
6793 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6795 gfc_expr
*expr1_vptr
= NULL
;
6805 gfc_start_block (&block
);
6807 gfc_init_se (&lse
, NULL
);
6809 /* Check whether the expression is a scalar or not; we cannot use
6810 expr1->rank as it can be nonzero for proc pointers. */
6811 ss
= gfc_walk_expr (expr1
);
6812 scalar
= ss
== gfc_ss_terminator
;
6814 gfc_free_ss_chain (ss
);
6816 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
6817 && expr2
->expr_type
!= EXPR_FUNCTION
)
6819 gfc_add_data_component (expr2
);
6820 /* The following is required as gfc_add_data_component doesn't
6821 update ts.type if there is a tailing REF_ARRAY. */
6822 expr2
->ts
.type
= BT_DERIVED
;
6827 /* Scalar pointers. */
6828 lse
.want_pointer
= 1;
6829 gfc_conv_expr (&lse
, expr1
);
6830 gfc_init_se (&rse
, NULL
);
6831 rse
.want_pointer
= 1;
6832 gfc_conv_expr (&rse
, expr2
);
6834 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6835 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6836 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6839 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6840 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6841 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6844 gfc_add_block_to_block (&block
, &lse
.pre
);
6845 gfc_add_block_to_block (&block
, &rse
.pre
);
6847 /* Check character lengths if character expression. The test is only
6848 really added if -fbounds-check is enabled. Exclude deferred
6849 character length lefthand sides. */
6850 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6851 && !expr1
->ts
.deferred
6852 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6853 && !gfc_is_proc_ptr_comp (expr1
))
6855 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6856 gcc_assert (lse
.string_length
&& rse
.string_length
);
6857 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6858 lse
.string_length
, rse
.string_length
,
6862 /* The assignment to an deferred character length sets the string
6863 length to that of the rhs. */
6864 if (expr1
->ts
.deferred
)
6866 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6867 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6868 else if (lse
.string_length
!= NULL
)
6869 gfc_add_modify (&block
, lse
.string_length
,
6870 build_int_cst (gfc_charlen_type_node
, 0));
6873 if (expr1
->ts
.type
== BT_DERIVED
&& expr2
->ts
.type
== BT_CLASS
)
6874 rse
.expr
= gfc_class_data_get (rse
.expr
);
6876 gfc_add_modify (&block
, lse
.expr
,
6877 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6879 gfc_add_block_to_block (&block
, &rse
.post
);
6880 gfc_add_block_to_block (&block
, &lse
.post
);
6887 tree strlen_rhs
= NULL_TREE
;
6889 /* Array pointer. Find the last reference on the LHS and if it is an
6890 array section ref, we're dealing with bounds remapping. In this case,
6891 set it to AR_FULL so that gfc_conv_expr_descriptor does
6892 not see it and process the bounds remapping afterwards explicitly. */
6893 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6894 if (!remap
->next
&& remap
->type
== REF_ARRAY
6895 && remap
->u
.ar
.type
== AR_SECTION
)
6897 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6899 gfc_init_se (&lse
, NULL
);
6901 lse
.descriptor_only
= 1;
6902 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
6903 && expr1
->ts
.type
== BT_CLASS
)
6904 expr1_vptr
= gfc_copy_expr (expr1
);
6905 gfc_conv_expr_descriptor (&lse
, expr1
);
6906 strlen_lhs
= lse
.string_length
;
6909 if (expr2
->expr_type
== EXPR_NULL
)
6911 /* Just set the data pointer to null. */
6912 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6914 else if (rank_remap
)
6916 /* If we are rank-remapping, just get the RHS's descriptor and
6917 process this later on. */
6918 gfc_init_se (&rse
, NULL
);
6919 rse
.direct_byref
= 1;
6920 rse
.byref_noassign
= 1;
6922 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6924 gfc_conv_function_expr (&rse
, expr2
);
6926 if (expr1
->ts
.type
!= BT_CLASS
)
6927 rse
.expr
= gfc_class_data_get (rse
.expr
);
6930 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
6931 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
6933 gfc_add_vptr_component (expr1_vptr
);
6934 gfc_init_se (&rse
, NULL
);
6935 rse
.want_pointer
= 1;
6936 gfc_conv_expr (&rse
, expr1_vptr
);
6937 gfc_add_modify (&lse
.pre
, rse
.expr
,
6938 fold_convert (TREE_TYPE (rse
.expr
),
6939 gfc_class_vptr_get (tmp
)));
6940 rse
.expr
= gfc_class_data_get (tmp
);
6943 else if (expr2
->expr_type
== EXPR_FUNCTION
)
6945 tree bound
[GFC_MAX_DIMENSIONS
];
6948 for (i
= 0; i
< expr2
->rank
; i
++)
6949 bound
[i
] = NULL_TREE
;
6950 tmp
= gfc_typenode_for_spec (&expr2
->ts
);
6951 tmp
= gfc_get_array_type_bounds (tmp
, expr2
->rank
, 0,
6953 GFC_ARRAY_POINTER_CONT
, false);
6954 tmp
= gfc_create_var (tmp
, "ptrtemp");
6956 lse
.direct_byref
= 1;
6957 gfc_conv_expr_descriptor (&lse
, expr2
);
6958 strlen_rhs
= lse
.string_length
;
6963 gfc_conv_expr_descriptor (&rse
, expr2
);
6964 strlen_rhs
= rse
.string_length
;
6967 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6969 /* Assign directly to the LHS's descriptor. */
6970 lse
.direct_byref
= 1;
6971 gfc_conv_expr_descriptor (&lse
, expr2
);
6972 strlen_rhs
= lse
.string_length
;
6974 /* If this is a subreference array pointer assignment, use the rhs
6975 descriptor element size for the lhs span. */
6976 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6978 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6979 gfc_init_se (&rse
, NULL
);
6980 rse
.descriptor_only
= 1;
6981 gfc_conv_expr (&rse
, expr2
);
6982 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6983 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6984 if (!INTEGER_CST_P (tmp
))
6985 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6986 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6989 else if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->ts
.type
== BT_CLASS
)
6991 gfc_init_se (&rse
, NULL
);
6992 rse
.want_pointer
= 1;
6993 gfc_conv_function_expr (&rse
, expr2
);
6994 if (expr1
->ts
.type
!= BT_CLASS
)
6996 rse
.expr
= gfc_class_data_get (rse
.expr
);
6997 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7001 tmp
= gfc_create_var (TREE_TYPE (rse
.expr
), "ptrtemp");
7002 gfc_add_modify (&lse
.pre
, tmp
, rse
.expr
);
7004 gfc_add_vptr_component (expr1_vptr
);
7005 gfc_init_se (&rse
, NULL
);
7006 rse
.want_pointer
= 1;
7007 gfc_conv_expr (&rse
, expr1_vptr
);
7008 gfc_add_modify (&lse
.pre
, rse
.expr
,
7009 fold_convert (TREE_TYPE (rse
.expr
),
7010 gfc_class_vptr_get (tmp
)));
7011 rse
.expr
= gfc_class_data_get (tmp
);
7012 gfc_add_modify (&lse
.pre
, desc
, rse
.expr
);
7017 /* Assign to a temporary descriptor and then copy that
7018 temporary to the pointer. */
7019 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
7021 lse
.direct_byref
= 1;
7022 gfc_conv_expr_descriptor (&lse
, expr2
);
7023 strlen_rhs
= lse
.string_length
;
7024 gfc_add_modify (&lse
.pre
, desc
, tmp
);
7028 gfc_free_expr (expr1_vptr
);
7030 gfc_add_block_to_block (&block
, &lse
.pre
);
7032 gfc_add_block_to_block (&block
, &rse
.pre
);
7034 /* If we do bounds remapping, update LHS descriptor accordingly. */
7038 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
7042 /* Do rank remapping. We already have the RHS's descriptor
7043 converted in rse and now have to build the correct LHS
7044 descriptor for it. */
7048 tree lbound
, ubound
;
7051 dtype
= gfc_conv_descriptor_dtype (desc
);
7052 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
7053 gfc_add_modify (&block
, dtype
, tmp
);
7055 /* Copy data pointer. */
7056 data
= gfc_conv_descriptor_data_get (rse
.expr
);
7057 gfc_conv_descriptor_data_set (&block
, desc
, data
);
7059 /* Copy offset but adjust it such that it would correspond
7060 to a lbound of zero. */
7061 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
7062 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
7064 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7066 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
7068 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7069 gfc_array_index_type
, stride
, lbound
);
7070 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
7071 gfc_array_index_type
, offs
, tmp
);
7073 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7075 /* Set the bounds as declared for the LHS and calculate strides as
7076 well as another offset update accordingly. */
7077 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
7079 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
7084 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
7086 /* Convert declared bounds. */
7087 gfc_init_se (&lower_se
, NULL
);
7088 gfc_init_se (&upper_se
, NULL
);
7089 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
7090 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
7092 gfc_add_block_to_block (&block
, &lower_se
.pre
);
7093 gfc_add_block_to_block (&block
, &upper_se
.pre
);
7095 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
7096 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
7098 lbound
= gfc_evaluate_now (lbound
, &block
);
7099 ubound
= gfc_evaluate_now (ubound
, &block
);
7101 gfc_add_block_to_block (&block
, &lower_se
.post
);
7102 gfc_add_block_to_block (&block
, &upper_se
.post
);
7104 /* Set bounds in descriptor. */
7105 gfc_conv_descriptor_lbound_set (&block
, desc
,
7106 gfc_rank_cst
[dim
], lbound
);
7107 gfc_conv_descriptor_ubound_set (&block
, desc
,
7108 gfc_rank_cst
[dim
], ubound
);
7111 stride
= gfc_evaluate_now (stride
, &block
);
7112 gfc_conv_descriptor_stride_set (&block
, desc
,
7113 gfc_rank_cst
[dim
], stride
);
7115 /* Update offset. */
7116 offs
= gfc_conv_descriptor_offset_get (desc
);
7117 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7118 gfc_array_index_type
, lbound
, stride
);
7119 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
7120 gfc_array_index_type
, offs
, tmp
);
7121 offs
= gfc_evaluate_now (offs
, &block
);
7122 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
7124 /* Update stride. */
7125 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
7126 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
7127 gfc_array_index_type
, stride
, tmp
);
7132 /* Bounds remapping. Just shift the lower bounds. */
7134 gcc_assert (expr1
->rank
== expr2
->rank
);
7136 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
7140 gcc_assert (remap
->u
.ar
.start
[dim
]);
7141 gcc_assert (!remap
->u
.ar
.end
[dim
]);
7142 gfc_init_se (&lbound_se
, NULL
);
7143 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
7145 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
7146 gfc_conv_shift_descriptor_lbound (&block
, desc
,
7147 dim
, lbound_se
.expr
);
7148 gfc_add_block_to_block (&block
, &lbound_se
.post
);
7153 /* Check string lengths if applicable. The check is only really added
7154 to the output code if -fbounds-check is enabled. */
7155 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
7157 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
7158 gcc_assert (strlen_lhs
&& strlen_rhs
);
7159 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
7160 strlen_lhs
, strlen_rhs
, &block
);
7163 /* If rank remapping was done, check with -fcheck=bounds that
7164 the target is at least as large as the pointer. */
7165 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
7171 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
7172 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
7174 lsize
= gfc_evaluate_now (lsize
, &block
);
7175 rsize
= gfc_evaluate_now (rsize
, &block
);
7176 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
7179 msg
= _("Target of rank remapping is too small (%ld < %ld)");
7180 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
7184 gfc_add_block_to_block (&block
, &lse
.post
);
7186 gfc_add_block_to_block (&block
, &rse
.post
);
7189 return gfc_finish_block (&block
);
7193 /* Makes sure se is suitable for passing as a function string parameter. */
7194 /* TODO: Need to check all callers of this function. It may be abused. */
7197 gfc_conv_string_parameter (gfc_se
* se
)
7201 if (TREE_CODE (se
->expr
) == STRING_CST
)
7203 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
7204 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7208 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
7210 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
7212 type
= TREE_TYPE (se
->expr
);
7213 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
7217 type
= gfc_get_character_type_len (gfc_default_character_kind
,
7219 type
= build_pointer_type (type
);
7220 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
7224 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
7228 /* Generate code for assignment of scalar variables. Includes character
7229 strings and derived types with allocatable components.
7230 If you know that the LHS has no allocations, set dealloc to false.
7232 DEEP_COPY has no effect if the typespec TS is not a derived type with
7233 allocatable components. Otherwise, if it is set, an explicit copy of each
7234 allocatable component is made. This is necessary as a simple copy of the
7235 whole object would copy array descriptors as is, so that the lhs's
7236 allocatable components would point to the rhs's after the assignment.
7237 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
7238 necessary if the rhs is a non-pointer function, as the allocatable components
7239 are not accessible by other means than the function's result after the
7240 function has returned. It is even more subtle when temporaries are involved,
7241 as the two following examples show:
7242 1. When we evaluate an array constructor, a temporary is created. Thus
7243 there is theoretically no alias possible. However, no deep copy is
7244 made for this temporary, so that if the constructor is made of one or
7245 more variable with allocatable components, those components still point
7246 to the variable's: DEEP_COPY should be set for the assignment from the
7247 temporary to the lhs in that case.
7248 2. When assigning a scalar to an array, we evaluate the scalar value out
7249 of the loop, store it into a temporary variable, and assign from that.
7250 In that case, deep copying when assigning to the temporary would be a
7251 waste of resources; however deep copies should happen when assigning from
7252 the temporary to each array element: again DEEP_COPY should be set for
7253 the assignment from the temporary to the lhs. */
7256 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
7257 bool l_is_temp
, bool deep_copy
, bool dealloc
)
7263 gfc_init_block (&block
);
7265 if (ts
.type
== BT_CHARACTER
)
7270 if (lse
->string_length
!= NULL_TREE
)
7272 gfc_conv_string_parameter (lse
);
7273 gfc_add_block_to_block (&block
, &lse
->pre
);
7274 llen
= lse
->string_length
;
7277 if (rse
->string_length
!= NULL_TREE
)
7279 gcc_assert (rse
->string_length
!= NULL_TREE
);
7280 gfc_conv_string_parameter (rse
);
7281 gfc_add_block_to_block (&block
, &rse
->pre
);
7282 rlen
= rse
->string_length
;
7285 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
7286 rse
->expr
, ts
.kind
);
7288 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
7290 tree tmp_var
= NULL_TREE
;
7293 /* Are the rhs and the lhs the same? */
7296 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7297 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
7298 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
7299 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
7302 /* Deallocate the lhs allocated components as long as it is not
7303 the same as the rhs. This must be done following the assignment
7304 to prevent deallocating data that could be used in the rhs
7306 if (!l_is_temp
&& dealloc
)
7308 tmp_var
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
7309 tmp
= gfc_deallocate_alloc_comp_no_caf (ts
.u
.derived
, tmp_var
, 0);
7311 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7313 gfc_add_expr_to_block (&lse
->post
, tmp
);
7316 gfc_add_block_to_block (&block
, &rse
->pre
);
7317 gfc_add_block_to_block (&block
, &lse
->pre
);
7319 gfc_add_modify (&block
, lse
->expr
,
7320 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7322 /* Restore pointer address of coarray components. */
7323 if (ts
.u
.derived
->attr
.coarray_comp
&& deep_copy
&& tmp_var
!= NULL_TREE
)
7325 tmp
= gfc_reassign_alloc_comp_caf (ts
.u
.derived
, tmp_var
, lse
->expr
);
7326 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7328 gfc_add_expr_to_block (&block
, tmp
);
7331 /* Do a deep copy if the rhs is a variable, if it is not the
7335 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
7336 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
7338 gfc_add_expr_to_block (&block
, tmp
);
7341 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
7343 gfc_add_block_to_block (&block
, &lse
->pre
);
7344 gfc_add_block_to_block (&block
, &rse
->pre
);
7345 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
7346 TREE_TYPE (lse
->expr
), rse
->expr
);
7347 gfc_add_modify (&block
, lse
->expr
, tmp
);
7351 gfc_add_block_to_block (&block
, &lse
->pre
);
7352 gfc_add_block_to_block (&block
, &rse
->pre
);
7354 gfc_add_modify (&block
, lse
->expr
,
7355 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
7358 gfc_add_block_to_block (&block
, &lse
->post
);
7359 gfc_add_block_to_block (&block
, &rse
->post
);
7361 return gfc_finish_block (&block
);
7365 /* There are quite a lot of restrictions on the optimisation in using an
7366 array function assign without a temporary. */
7369 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
7372 bool seen_array_ref
;
7374 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
7376 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
7377 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
7380 /* Elemental functions are scalarized so that they don't need a
7381 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
7382 they would need special treatment in gfc_trans_arrayfunc_assign. */
7383 if (expr2
->value
.function
.esym
!= NULL
7384 && expr2
->value
.function
.esym
->attr
.elemental
)
7387 /* Need a temporary if rhs is not FULL or a contiguous section. */
7388 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
7391 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
7392 if (gfc_ref_needs_temporary_p (expr1
->ref
))
7395 /* Functions returning pointers or allocatables need temporaries. */
7396 c
= expr2
->value
.function
.esym
7397 ? (expr2
->value
.function
.esym
->attr
.pointer
7398 || expr2
->value
.function
.esym
->attr
.allocatable
)
7399 : (expr2
->symtree
->n
.sym
->attr
.pointer
7400 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
7404 /* Character array functions need temporaries unless the
7405 character lengths are the same. */
7406 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
7408 if (expr1
->ts
.u
.cl
->length
== NULL
7409 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7412 if (expr2
->ts
.u
.cl
->length
== NULL
7413 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
7416 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
7417 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
7421 /* Check that no LHS component references appear during an array
7422 reference. This is needed because we do not have the means to
7423 span any arbitrary stride with an array descriptor. This check
7424 is not needed for the rhs because the function result has to be
7426 seen_array_ref
= false;
7427 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
7429 if (ref
->type
== REF_ARRAY
)
7430 seen_array_ref
= true;
7431 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
7435 /* Check for a dependency. */
7436 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
7437 expr2
->value
.function
.esym
,
7438 expr2
->value
.function
.actual
,
7442 /* If we have reached here with an intrinsic function, we do not
7443 need a temporary except in the particular case that reallocation
7444 on assignment is active and the lhs is allocatable and a target. */
7445 if (expr2
->value
.function
.isym
)
7446 return (flag_realloc_lhs
&& sym
->attr
.allocatable
&& sym
->attr
.target
);
7448 /* If the LHS is a dummy, we need a temporary if it is not
7450 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
7453 /* If the lhs has been host_associated, is in common, a pointer or is
7454 a target and the function is not using a RESULT variable, aliasing
7455 can occur and a temporary is needed. */
7456 if ((sym
->attr
.host_assoc
7457 || sym
->attr
.in_common
7458 || sym
->attr
.pointer
7459 || sym
->attr
.cray_pointee
7460 || sym
->attr
.target
)
7461 && expr2
->symtree
!= NULL
7462 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
7465 /* A PURE function can unconditionally be called without a temporary. */
7466 if (expr2
->value
.function
.esym
!= NULL
7467 && expr2
->value
.function
.esym
->attr
.pure
)
7470 /* Implicit_pure functions are those which could legally be declared
7472 if (expr2
->value
.function
.esym
!= NULL
7473 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
7476 if (!sym
->attr
.use_assoc
7477 && !sym
->attr
.in_common
7478 && !sym
->attr
.pointer
7479 && !sym
->attr
.target
7480 && !sym
->attr
.cray_pointee
7481 && expr2
->value
.function
.esym
)
7483 /* A temporary is not needed if the function is not contained and
7484 the variable is local or host associated and not a pointer or
7486 if (!expr2
->value
.function
.esym
->attr
.contained
)
7489 /* A temporary is not needed if the lhs has never been host
7490 associated and the procedure is contained. */
7491 else if (!sym
->attr
.host_assoc
)
7494 /* A temporary is not needed if the variable is local and not
7495 a pointer, a target or a result. */
7497 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
7501 /* Default to temporary use. */
7506 /* Provide the loop info so that the lhs descriptor can be built for
7507 reallocatable assignments from extrinsic function calls. */
7510 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
7513 /* Signal that the function call should not be made by
7514 gfc_conv_loop_setup. */
7515 se
->ss
->is_alloc_lhs
= 1;
7516 gfc_init_loopinfo (loop
);
7517 gfc_add_ss_to_loop (loop
, *ss
);
7518 gfc_add_ss_to_loop (loop
, se
->ss
);
7519 gfc_conv_ss_startstride (loop
);
7520 gfc_conv_loop_setup (loop
, where
);
7521 gfc_copy_loopinfo_to_se (se
, loop
);
7522 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
7523 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
7524 se
->ss
->is_alloc_lhs
= 0;
7528 /* For assignment to a reallocatable lhs from intrinsic functions,
7529 replace the se.expr (ie. the result) with a temporary descriptor.
7530 Null the data field so that the library allocates space for the
7531 result. Free the data of the original descriptor after the function,
7532 in case it appears in an argument expression and transfer the
7533 result to the original descriptor. */
7536 fcncall_realloc_result (gfc_se
*se
, int rank
)
7545 /* Use the allocation done by the library. Substitute the lhs
7546 descriptor with a copy, whose data field is nulled.*/
7547 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
7548 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
7549 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
7551 /* Unallocated, the descriptor does not have a dtype. */
7552 tmp
= gfc_conv_descriptor_dtype (desc
);
7553 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
7555 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
7556 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
7557 se
->expr
= gfc_build_addr_expr (NULL_TREE
, res_desc
);
7559 /* Free the lhs after the function call and copy the result data to
7560 the lhs descriptor. */
7561 tmp
= gfc_conv_descriptor_data_get (desc
);
7562 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
7563 boolean_type_node
, tmp
,
7564 build_int_cst (TREE_TYPE (tmp
), 0));
7565 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7566 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
7567 gfc_add_expr_to_block (&se
->post
, tmp
);
7569 tmp
= gfc_conv_descriptor_data_get (res_desc
);
7570 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
7572 /* Check that the shapes are the same between lhs and expression. */
7573 for (n
= 0 ; n
< rank
; n
++)
7576 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7577 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
7578 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7579 gfc_array_index_type
, tmp
, tmp1
);
7580 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
7581 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
7582 gfc_array_index_type
, tmp
, tmp1
);
7583 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7584 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7585 gfc_array_index_type
, tmp
, tmp1
);
7586 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
7587 boolean_type_node
, tmp
,
7588 gfc_index_zero_node
);
7589 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
7590 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
7591 boolean_type_node
, tmp
,
7595 /* 'zero_cond' being true is equal to lhs not being allocated or the
7596 shapes being different. */
7597 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
7599 /* Now reset the bounds returned from the function call to bounds based
7600 on the lhs lbounds, except where the lhs is not allocated or the shapes
7601 of 'variable and 'expr' are different. Set the offset accordingly. */
7602 offset
= gfc_index_zero_node
;
7603 for (n
= 0 ; n
< rank
; n
++)
7607 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
7608 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
7609 gfc_array_index_type
, zero_cond
,
7610 gfc_index_one_node
, lbound
);
7611 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7613 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7614 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7615 gfc_array_index_type
, tmp
, lbound
);
7616 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7617 gfc_rank_cst
[n
], lbound
);
7618 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7619 gfc_rank_cst
[n
], tmp
);
7621 /* Set stride and accumulate the offset. */
7622 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7623 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7624 gfc_rank_cst
[n
], tmp
);
7625 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7626 gfc_array_index_type
, lbound
, tmp
);
7627 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7628 gfc_array_index_type
, offset
, tmp
);
7629 offset
= gfc_evaluate_now (offset
, &se
->post
);
7632 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7637 /* Try to translate array(:) = func (...), where func is a transformational
7638 array function, without using a temporary. Returns NULL if this isn't the
7642 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7646 gfc_component
*comp
= NULL
;
7649 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7652 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7654 comp
= gfc_get_proc_ptr_comp (expr2
);
7655 gcc_assert (expr2
->value
.function
.isym
7656 || (comp
&& comp
->attr
.dimension
)
7657 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7658 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7660 gfc_init_se (&se
, NULL
);
7661 gfc_start_block (&se
.pre
);
7662 se
.want_pointer
= 1;
7664 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7666 if (expr1
->ts
.type
== BT_DERIVED
7667 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7670 tmp
= gfc_deallocate_alloc_comp_no_caf (expr1
->ts
.u
.derived
, se
.expr
,
7672 gfc_add_expr_to_block (&se
.pre
, tmp
);
7675 se
.direct_byref
= 1;
7676 se
.ss
= gfc_walk_expr (expr2
);
7677 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7679 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7680 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7681 Clearly, this cannot be done for an allocatable function result, since
7682 the shape of the result is unknown and, in any case, the function must
7683 correctly take care of the reallocation internally. For intrinsic
7684 calls, the array data is freed and the library takes care of allocation.
7685 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7687 if (flag_realloc_lhs
7688 && gfc_is_reallocatable_lhs (expr1
)
7689 && !gfc_expr_attr (expr1
).codimension
7690 && !gfc_is_coindexed (expr1
)
7691 && !(expr2
->value
.function
.esym
7692 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7694 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7696 if (!expr2
->value
.function
.isym
)
7698 ss
= gfc_walk_expr (expr1
);
7699 gcc_assert (ss
!= gfc_ss_terminator
);
7701 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7702 ss
->is_alloc_lhs
= 1;
7705 fcncall_realloc_result (&se
, expr1
->rank
);
7708 gfc_conv_function_expr (&se
, expr2
);
7709 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7712 gfc_cleanup_loop (&loop
);
7714 gfc_free_ss_chain (se
.ss
);
7716 return gfc_finish_block (&se
.pre
);
7720 /* Try to efficiently translate array(:) = 0. Return NULL if this
7724 gfc_trans_zero_assign (gfc_expr
* expr
)
7726 tree dest
, len
, type
;
7730 sym
= expr
->symtree
->n
.sym
;
7731 dest
= gfc_get_symbol_decl (sym
);
7733 type
= TREE_TYPE (dest
);
7734 if (POINTER_TYPE_P (type
))
7735 type
= TREE_TYPE (type
);
7736 if (!GFC_ARRAY_TYPE_P (type
))
7739 /* Determine the length of the array. */
7740 len
= GFC_TYPE_ARRAY_SIZE (type
);
7741 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7744 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7745 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7746 fold_convert (gfc_array_index_type
, tmp
));
7748 /* If we are zeroing a local array avoid taking its address by emitting
7750 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7751 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7752 dest
, build_constructor (TREE_TYPE (dest
),
7755 /* Convert arguments to the correct types. */
7756 dest
= fold_convert (pvoid_type_node
, dest
);
7757 len
= fold_convert (size_type_node
, len
);
7759 /* Construct call to __builtin_memset. */
7760 tmp
= build_call_expr_loc (input_location
,
7761 builtin_decl_explicit (BUILT_IN_MEMSET
),
7762 3, dest
, integer_zero_node
, len
);
7763 return fold_convert (void_type_node
, tmp
);
7767 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7768 that constructs the call to __builtin_memcpy. */
7771 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7775 /* Convert arguments to the correct types. */
7776 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7777 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7779 dst
= fold_convert (pvoid_type_node
, dst
);
7781 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7782 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7784 src
= fold_convert (pvoid_type_node
, src
);
7786 len
= fold_convert (size_type_node
, len
);
7788 /* Construct call to __builtin_memcpy. */
7789 tmp
= build_call_expr_loc (input_location
,
7790 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7792 return fold_convert (void_type_node
, tmp
);
7796 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7797 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7798 source/rhs, both are gfc_full_array_ref_p which have been checked for
7802 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7804 tree dst
, dlen
, dtype
;
7805 tree src
, slen
, stype
;
7808 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7809 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7811 dtype
= TREE_TYPE (dst
);
7812 if (POINTER_TYPE_P (dtype
))
7813 dtype
= TREE_TYPE (dtype
);
7814 stype
= TREE_TYPE (src
);
7815 if (POINTER_TYPE_P (stype
))
7816 stype
= TREE_TYPE (stype
);
7818 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7821 /* Determine the lengths of the arrays. */
7822 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7823 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7825 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7826 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7827 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7829 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7830 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7832 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7833 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7834 slen
, fold_convert (gfc_array_index_type
, tmp
));
7836 /* Sanity check that they are the same. This should always be
7837 the case, as we should already have checked for conformance. */
7838 if (!tree_int_cst_equal (slen
, dlen
))
7841 return gfc_build_memcpy_call (dst
, src
, dlen
);
7845 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7846 this can't be done. EXPR1 is the destination/lhs for which
7847 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7850 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7852 unsigned HOST_WIDE_INT nelem
;
7858 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7862 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7863 dtype
= TREE_TYPE (dst
);
7864 if (POINTER_TYPE_P (dtype
))
7865 dtype
= TREE_TYPE (dtype
);
7866 if (!GFC_ARRAY_TYPE_P (dtype
))
7869 /* Determine the lengths of the array. */
7870 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7871 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7874 /* Confirm that the constructor is the same size. */
7875 if (compare_tree_int (len
, nelem
) != 0)
7878 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7879 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7880 fold_convert (gfc_array_index_type
, tmp
));
7882 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7883 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7885 stype
= TREE_TYPE (src
);
7886 if (POINTER_TYPE_P (stype
))
7887 stype
= TREE_TYPE (stype
);
7889 return gfc_build_memcpy_call (dst
, src
, len
);
7893 /* Tells whether the expression is to be treated as a variable reference. */
7896 expr_is_variable (gfc_expr
*expr
)
7899 gfc_component
*comp
;
7900 gfc_symbol
*func_ifc
;
7902 if (expr
->expr_type
== EXPR_VARIABLE
)
7905 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7908 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7909 return expr_is_variable (arg
);
7912 /* A data-pointer-returning function should be considered as a variable
7914 if (expr
->expr_type
== EXPR_FUNCTION
7915 && expr
->ref
== NULL
)
7917 if (expr
->value
.function
.isym
!= NULL
)
7920 if (expr
->value
.function
.esym
!= NULL
)
7922 func_ifc
= expr
->value
.function
.esym
;
7927 gcc_assert (expr
->symtree
);
7928 func_ifc
= expr
->symtree
->n
.sym
;
7935 comp
= gfc_get_proc_ptr_comp (expr
);
7936 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7939 func_ifc
= comp
->ts
.interface
;
7943 if (expr
->expr_type
== EXPR_COMPCALL
)
7945 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7946 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7953 gcc_assert (func_ifc
->attr
.function
7954 && func_ifc
->result
!= NULL
);
7955 return func_ifc
->result
->attr
.pointer
;
7959 /* Is the lhs OK for automatic reallocation? */
7962 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7966 /* An allocatable variable with no reference. */
7967 if (expr
->symtree
->n
.sym
->attr
.allocatable
7971 /* All that can be left are allocatable components. */
7972 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7973 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7974 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7977 /* Find an allocatable component ref last. */
7978 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7979 if (ref
->type
== REF_COMPONENT
7981 && ref
->u
.c
.component
->attr
.allocatable
)
7988 /* Allocate or reallocate scalar lhs, as necessary. */
7991 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
8005 if (!expr1
|| expr1
->rank
)
8008 if (!expr2
|| expr2
->rank
)
8011 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
8013 /* Since this is a scalar lhs, we can afford to do this. That is,
8014 there is no risk of side effects being repeated. */
8015 gfc_init_se (&lse
, NULL
);
8016 lse
.want_pointer
= 1;
8017 gfc_conv_expr (&lse
, expr1
);
8019 jump_label1
= gfc_build_label_decl (NULL_TREE
);
8020 jump_label2
= gfc_build_label_decl (NULL_TREE
);
8022 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
8023 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
8024 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
8026 tmp
= build3_v (COND_EXPR
, cond
,
8027 build1_v (GOTO_EXPR
, jump_label1
),
8028 build_empty_stmt (input_location
));
8029 gfc_add_expr_to_block (block
, tmp
);
8031 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8033 /* Use the rhs string length and the lhs element size. */
8034 size
= string_length
;
8035 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
8036 tmp
= TYPE_SIZE_UNIT (tmp
);
8037 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
8038 TREE_TYPE (tmp
), tmp
,
8039 fold_convert (TREE_TYPE (tmp
), size
));
8043 /* Otherwise use the length in bytes of the rhs. */
8044 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
8045 size_in_bytes
= size
;
8048 size_in_bytes
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
8049 size_in_bytes
, size_one_node
);
8051 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
8053 tmp
= build_call_expr_loc (input_location
,
8054 builtin_decl_explicit (BUILT_IN_CALLOC
),
8055 2, build_one_cst (size_type_node
),
8057 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8058 gfc_add_modify (block
, lse
.expr
, tmp
);
8062 tmp
= build_call_expr_loc (input_location
,
8063 builtin_decl_explicit (BUILT_IN_MALLOC
),
8065 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8066 gfc_add_modify (block
, lse
.expr
, tmp
);
8069 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8071 /* Deferred characters need checking for lhs and rhs string
8072 length. Other deferred parameter variables will have to
8074 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
8075 gfc_add_expr_to_block (block
, tmp
);
8077 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
8078 gfc_add_expr_to_block (block
, tmp
);
8080 /* For a deferred length character, reallocate if lengths of lhs and
8081 rhs are different. */
8082 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8084 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
8085 expr1
->ts
.u
.cl
->backend_decl
, size
);
8086 /* Jump past the realloc if the lengths are the same. */
8087 tmp
= build3_v (COND_EXPR
, cond
,
8088 build1_v (GOTO_EXPR
, jump_label2
),
8089 build_empty_stmt (input_location
));
8090 gfc_add_expr_to_block (block
, tmp
);
8091 tmp
= build_call_expr_loc (input_location
,
8092 builtin_decl_explicit (BUILT_IN_REALLOC
),
8093 2, fold_convert (pvoid_type_node
, lse
.expr
),
8095 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
8096 gfc_add_modify (block
, lse
.expr
, tmp
);
8097 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
8098 gfc_add_expr_to_block (block
, tmp
);
8100 /* Update the lhs character length. */
8101 size
= string_length
;
8102 if (TREE_CODE (expr1
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
8103 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
8105 gfc_add_modify (block
, lse
.string_length
, size
);
8109 /* Check for assignments of the type
8113 to make sure we do not check for reallocation unneccessarily. */
8117 is_runtime_conformable (gfc_expr
*expr1
, gfc_expr
*expr2
)
8119 gfc_actual_arglist
*a
;
8122 switch (expr2
->expr_type
)
8125 return gfc_dep_compare_expr (expr1
, expr2
) == 0;
8128 if (expr2
->value
.function
.esym
8129 && expr2
->value
.function
.esym
->attr
.elemental
)
8131 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8134 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8139 else if (expr2
->value
.function
.isym
8140 && expr2
->value
.function
.isym
->elemental
)
8142 for (a
= expr2
->value
.function
.actual
; a
!= NULL
; a
= a
->next
)
8145 if (e1
&& e1
->rank
> 0 && !is_runtime_conformable (expr1
, e1
))
8154 switch (expr2
->value
.op
.op
)
8157 case INTRINSIC_UPLUS
:
8158 case INTRINSIC_UMINUS
:
8159 case INTRINSIC_PARENTHESES
:
8160 return is_runtime_conformable (expr1
, expr2
->value
.op
.op1
);
8162 case INTRINSIC_PLUS
:
8163 case INTRINSIC_MINUS
:
8164 case INTRINSIC_TIMES
:
8165 case INTRINSIC_DIVIDE
:
8166 case INTRINSIC_POWER
:
8170 case INTRINSIC_NEQV
:
8177 case INTRINSIC_EQ_OS
:
8178 case INTRINSIC_NE_OS
:
8179 case INTRINSIC_GT_OS
:
8180 case INTRINSIC_GE_OS
:
8181 case INTRINSIC_LT_OS
:
8182 case INTRINSIC_LE_OS
:
8184 e1
= expr2
->value
.op
.op1
;
8185 e2
= expr2
->value
.op
.op2
;
8187 if (e1
->rank
== 0 && e2
->rank
> 0)
8188 return is_runtime_conformable (expr1
, e2
);
8189 else if (e1
->rank
> 0 && e2
->rank
== 0)
8190 return is_runtime_conformable (expr1
, e1
);
8191 else if (e1
->rank
> 0 && e2
->rank
> 0)
8192 return is_runtime_conformable (expr1
, e1
)
8193 && is_runtime_conformable (expr1
, e2
);
8209 /* Subroutine of gfc_trans_assignment that actually scalarizes the
8210 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
8211 init_flag indicates initialization expressions and dealloc that no
8212 deallocate prior assignment is needed (if in doubt, set true). */
8215 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8221 gfc_ss
*lss_section
;
8228 bool scalar_to_array
;
8232 /* Assignment of the form lhs = rhs. */
8233 gfc_start_block (&block
);
8235 gfc_init_se (&lse
, NULL
);
8236 gfc_init_se (&rse
, NULL
);
8239 lss
= gfc_walk_expr (expr1
);
8240 if (gfc_is_reallocatable_lhs (expr1
)
8241 && !(expr2
->expr_type
== EXPR_FUNCTION
8242 && expr2
->value
.function
.isym
!= NULL
))
8243 lss
->is_alloc_lhs
= 1;
8245 if (lss
!= gfc_ss_terminator
)
8247 /* The assignment needs scalarization. */
8250 /* Find a non-scalar SS from the lhs. */
8251 while (lss_section
!= gfc_ss_terminator
8252 && lss_section
->info
->type
!= GFC_SS_SECTION
)
8253 lss_section
= lss_section
->next
;
8255 gcc_assert (lss_section
!= gfc_ss_terminator
);
8257 /* Initialize the scalarizer. */
8258 gfc_init_loopinfo (&loop
);
8261 rss
= gfc_walk_expr (expr2
);
8262 if (rss
== gfc_ss_terminator
)
8263 /* The rhs is scalar. Add a ss for the expression. */
8264 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
8266 /* Associate the SS with the loop. */
8267 gfc_add_ss_to_loop (&loop
, lss
);
8268 gfc_add_ss_to_loop (&loop
, rss
);
8270 /* Calculate the bounds of the scalarization. */
8271 gfc_conv_ss_startstride (&loop
);
8272 /* Enable loop reversal. */
8273 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
8274 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
8275 /* Resolve any data dependencies in the statement. */
8276 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
8277 /* Setup the scalarizing loops. */
8278 gfc_conv_loop_setup (&loop
, &expr2
->where
);
8280 /* Setup the gfc_se structures. */
8281 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8282 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8285 gfc_mark_ss_chain_used (rss
, 1);
8286 if (loop
.temp_ss
== NULL
)
8289 gfc_mark_ss_chain_used (lss
, 1);
8293 lse
.ss
= loop
.temp_ss
;
8294 gfc_mark_ss_chain_used (lss
, 3);
8295 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
8298 /* Allow the scalarizer to workshare array assignments. */
8299 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
8300 ompws_flags
|= OMPWS_SCALARIZER_WS
;
8302 /* Start the scalarized loop body. */
8303 gfc_start_scalarized_body (&loop
, &body
);
8306 gfc_init_block (&body
);
8308 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
8310 /* Translate the expression. */
8311 gfc_conv_expr (&rse
, expr2
);
8313 /* Stabilize a string length for temporaries. */
8314 if (expr2
->ts
.type
== BT_CHARACTER
)
8315 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
8317 string_length
= NULL_TREE
;
8321 gfc_conv_tmp_array_ref (&lse
);
8322 if (expr2
->ts
.type
== BT_CHARACTER
)
8323 lse
.string_length
= string_length
;
8326 gfc_conv_expr (&lse
, expr1
);
8328 /* Assignments of scalar derived types with allocatable components
8329 to arrays must be done with a deep copy and the rhs temporary
8330 must have its components deallocated afterwards. */
8331 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
8332 && expr2
->ts
.u
.derived
->attr
.alloc_comp
8333 && !expr_is_variable (expr2
)
8334 && !gfc_is_constant_expr (expr2
)
8335 && expr1
->rank
&& !expr2
->rank
);
8336 if (scalar_to_array
&& dealloc
)
8338 tmp
= gfc_deallocate_alloc_comp_no_caf (expr2
->ts
.u
.derived
, rse
.expr
, 0);
8339 gfc_add_expr_to_block (&loop
.post
, tmp
);
8342 /* When assigning a character function result to a deferred-length variable,
8343 the function call must happen before the (re)allocation of the lhs -
8344 otherwise the character length of the result is not known.
8345 NOTE: This relies on having the exact dependence of the length type
8346 parameter available to the caller; gfortran saves it in the .mod files. */
8347 if (flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
8348 gfc_add_block_to_block (&block
, &rse
.pre
);
8350 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8351 l_is_temp
|| init_flag
,
8352 expr_is_variable (expr2
) || scalar_to_array
8353 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
8354 gfc_add_expr_to_block (&body
, tmp
);
8356 if (lss
== gfc_ss_terminator
)
8358 /* F2003: Add the code for reallocation on assignment. */
8359 if (flag_realloc_lhs
&& is_scalar_reallocatable_lhs (expr1
))
8360 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
8363 /* Use the scalar assignment as is. */
8364 gfc_add_block_to_block (&block
, &body
);
8368 gcc_assert (lse
.ss
== gfc_ss_terminator
8369 && rse
.ss
== gfc_ss_terminator
);
8373 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
8375 /* We need to copy the temporary to the actual lhs. */
8376 gfc_init_se (&lse
, NULL
);
8377 gfc_init_se (&rse
, NULL
);
8378 gfc_copy_loopinfo_to_se (&lse
, &loop
);
8379 gfc_copy_loopinfo_to_se (&rse
, &loop
);
8381 rse
.ss
= loop
.temp_ss
;
8384 gfc_conv_tmp_array_ref (&rse
);
8385 gfc_conv_expr (&lse
, expr1
);
8387 gcc_assert (lse
.ss
== gfc_ss_terminator
8388 && rse
.ss
== gfc_ss_terminator
);
8390 if (expr2
->ts
.type
== BT_CHARACTER
)
8391 rse
.string_length
= string_length
;
8393 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
8394 false, false, dealloc
);
8395 gfc_add_expr_to_block (&body
, tmp
);
8398 /* F2003: Allocate or reallocate lhs of allocatable array. */
8399 if (flag_realloc_lhs
8400 && gfc_is_reallocatable_lhs (expr1
)
8401 && !gfc_expr_attr (expr1
).codimension
8402 && !gfc_is_coindexed (expr1
)
8404 && !is_runtime_conformable (expr1
, expr2
))
8406 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
8407 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
8408 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
8409 if (tmp
!= NULL_TREE
)
8410 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
8413 /* Generate the copying loops. */
8414 gfc_trans_scalarizing_loops (&loop
, &body
);
8416 /* Wrap the whole thing up. */
8417 gfc_add_block_to_block (&block
, &loop
.pre
);
8418 gfc_add_block_to_block (&block
, &loop
.post
);
8420 gfc_cleanup_loop (&loop
);
8423 return gfc_finish_block (&block
);
8427 /* Check whether EXPR is a copyable array. */
8430 copyable_array_p (gfc_expr
* expr
)
8432 if (expr
->expr_type
!= EXPR_VARIABLE
)
8435 /* First check it's an array. */
8436 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
8439 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
8442 /* Next check that it's of a simple enough type. */
8443 switch (expr
->ts
.type
)
8455 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
8464 /* Translate an assignment. */
8467 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
8472 /* Special case a single function returning an array. */
8473 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
8475 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
8480 /* Special case assigning an array to zero. */
8481 if (copyable_array_p (expr1
)
8482 && is_zero_initializer_p (expr2
))
8484 tmp
= gfc_trans_zero_assign (expr1
);
8489 /* Special case copying one array to another. */
8490 if (copyable_array_p (expr1
)
8491 && copyable_array_p (expr2
)
8492 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
8493 && !gfc_check_dependency (expr1
, expr2
, 0))
8495 tmp
= gfc_trans_array_copy (expr1
, expr2
);
8500 /* Special case initializing an array from a constant array constructor. */
8501 if (copyable_array_p (expr1
)
8502 && expr2
->expr_type
== EXPR_ARRAY
8503 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
8505 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
8510 /* Fallback to the scalarizer to generate explicit loops. */
8511 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
8515 gfc_trans_init_assign (gfc_code
* code
)
8517 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
8521 gfc_trans_assign (gfc_code
* code
)
8523 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);