1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
61 akind
, !(attr
.pointer
|| attr
.target
));
65 conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 type
= get_scalar_to_descriptor_type (scalar
, attr
);
70 desc
= gfc_create_var (type
, "desc");
71 DECL_ARTIFICIAL (desc
) = 1;
72 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
73 gfc_get_dtype (type
));
74 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
76 /* Copy pointer address back - but only if it could have changed and
77 if the actual argument is a pointer and not, e.g., NULL(). */
78 if ((attr
.pointer
|| attr
.allocatable
)
79 && attr
.intent
!= INTENT_IN
&& POINTER_TYPE_P (TREE_TYPE (scalar
)))
80 gfc_add_modify (&se
->post
, scalar
,
81 fold_convert (TREE_TYPE (scalar
),
82 gfc_conv_descriptor_data_get (desc
)));
87 /* This is the seed for an eventual trans-class.c
89 The following parameters should not be used directly since they might
90 in future implementations. Use the corresponding APIs. */
91 #define CLASS_DATA_FIELD 0
92 #define CLASS_VPTR_FIELD 1
93 #define VTABLE_HASH_FIELD 0
94 #define VTABLE_SIZE_FIELD 1
95 #define VTABLE_EXTENDS_FIELD 2
96 #define VTABLE_DEF_INIT_FIELD 3
97 #define VTABLE_COPY_FIELD 4
101 gfc_class_data_get (tree decl
)
104 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
105 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
106 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
108 return fold_build3_loc (input_location
, COMPONENT_REF
,
109 TREE_TYPE (data
), decl
, data
,
115 gfc_class_vptr_get (tree decl
)
118 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
119 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
120 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
122 return fold_build3_loc (input_location
, COMPONENT_REF
,
123 TREE_TYPE (vptr
), decl
, vptr
,
129 gfc_vtable_field_get (tree decl
, int field
)
133 vptr
= gfc_class_vptr_get (decl
);
134 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
135 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
137 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
138 TREE_TYPE (size
), vptr
, size
,
140 /* Always return size as an array index type. */
141 if (field
== VTABLE_SIZE_FIELD
)
142 size
= fold_convert (gfc_array_index_type
, size
);
149 gfc_vtable_hash_get (tree decl
)
151 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
156 gfc_vtable_size_get (tree decl
)
158 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
163 gfc_vtable_extends_get (tree decl
)
165 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
170 gfc_vtable_def_init_get (tree decl
)
172 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
177 gfc_vtable_copy_get (tree decl
)
179 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
183 #undef CLASS_DATA_FIELD
184 #undef CLASS_VPTR_FIELD
185 #undef VTABLE_HASH_FIELD
186 #undef VTABLE_SIZE_FIELD
187 #undef VTABLE_EXTENDS_FIELD
188 #undef VTABLE_DEF_INIT_FIELD
189 #undef VTABLE_COPY_FIELD
192 /* Obtain the vptr of the last class reference in an expression. */
195 gfc_get_vptr_from_expr (tree expr
)
198 while (tmp
&& !GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
199 tmp
= TREE_OPERAND (tmp
, 0);
200 tmp
= gfc_class_vptr_get (tmp
);
206 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
209 tree tmp
, tmp2
, type
;
211 gfc_conv_descriptor_data_set (block
, lhs_desc
,
212 gfc_conv_descriptor_data_get (rhs_desc
));
213 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
214 gfc_conv_descriptor_offset_get (rhs_desc
));
216 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
217 gfc_conv_descriptor_dtype (rhs_desc
));
219 /* Assign the dimension as range-ref. */
220 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
221 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
223 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
224 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
225 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
226 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
227 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
228 gfc_add_modify (block
, tmp
, tmp2
);
232 /* Takes a derived type expression and returns the address of a temporary
233 class object of the 'declared' type. If vptr is not NULL, this is
234 used for the temporary class object.
235 optional_alloc_ptr is false when the dummy is neither allocatable
236 nor a pointer; that's only relevant for the optional handling. */
238 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
239 gfc_typespec class_ts
, tree vptr
, bool optional
,
240 bool optional_alloc_ptr
)
243 tree cond_optional
= NULL_TREE
;
249 /* The derived type needs to be converted to a temporary
251 tmp
= gfc_typenode_for_spec (&class_ts
);
252 var
= gfc_create_var (tmp
, "class");
255 ctree
= gfc_class_vptr_get (var
);
257 if (vptr
!= NULL_TREE
)
259 /* Use the dynamic vptr. */
264 /* In this case the vtab corresponds to the derived type and the
265 vptr must point to it. */
266 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
268 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
270 gfc_add_modify (&parmse
->pre
, ctree
,
271 fold_convert (TREE_TYPE (ctree
), tmp
));
273 /* Now set the data field. */
274 ctree
= gfc_class_data_get (var
);
277 cond_optional
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
279 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
281 /* For an array reference in an elemental procedure call we need
282 to retain the ss to provide the scalarized array reference. */
283 gfc_conv_expr_reference (parmse
, e
);
284 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
286 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
288 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
289 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
294 ss
= gfc_walk_expr (e
);
295 if (ss
== gfc_ss_terminator
)
298 gfc_conv_expr_reference (parmse
, e
);
300 /* Scalar to an assumed-rank array. */
301 if (class_ts
.u
.derived
->components
->as
)
304 type
= get_scalar_to_descriptor_type (parmse
->expr
,
306 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
307 gfc_get_dtype (type
));
309 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
310 TREE_TYPE (parmse
->expr
),
311 cond_optional
, parmse
->expr
,
312 fold_convert (TREE_TYPE (parmse
->expr
),
314 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
318 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
320 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
322 fold_convert (TREE_TYPE (tmp
),
324 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
330 gfc_init_block (&block
);
333 gfc_conv_expr_descriptor (parmse
, e
);
335 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
336 class_array_data_assign (&block
, ctree
, parmse
->expr
, true);
339 if (gfc_expr_attr (e
).codimension
)
340 parmse
->expr
= fold_build1_loc (input_location
,
344 gfc_add_modify (&block
, ctree
, parmse
->expr
);
349 tmp
= gfc_finish_block (&block
);
351 gfc_init_block (&block
);
352 gfc_conv_descriptor_data_set (&block
, ctree
, null_pointer_node
);
354 tmp
= build3_v (COND_EXPR
, cond_optional
, tmp
,
355 gfc_finish_block (&block
));
356 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
359 gfc_add_block_to_block (&parmse
->pre
, &block
);
363 /* Pass the address of the class object. */
364 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
366 if (optional
&& optional_alloc_ptr
)
367 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
368 TREE_TYPE (parmse
->expr
),
369 cond_optional
, parmse
->expr
,
370 fold_convert (TREE_TYPE (parmse
->expr
),
375 /* Create a new class container, which is required as scalar coarrays
376 have an array descriptor while normal scalars haven't. Optionally,
377 NULL pointer checks are added if the argument is OPTIONAL. */
380 class_scalar_coarray_to_class (gfc_se
*parmse
, gfc_expr
*e
,
381 gfc_typespec class_ts
, bool optional
)
383 tree var
, ctree
, tmp
;
388 gfc_init_block (&block
);
391 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
393 if (ref
->type
== REF_COMPONENT
394 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
398 if (class_ref
== NULL
399 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
400 tmp
= e
->symtree
->n
.sym
->backend_decl
;
403 /* Remove everything after the last class reference, convert the
404 expression and then recover its tailend once more. */
406 ref
= class_ref
->next
;
407 class_ref
->next
= NULL
;
408 gfc_init_se (&tmpse
, NULL
);
409 gfc_conv_expr (&tmpse
, e
);
410 class_ref
->next
= ref
;
414 var
= gfc_typenode_for_spec (&class_ts
);
415 var
= gfc_create_var (var
, "class");
417 ctree
= gfc_class_vptr_get (var
);
418 gfc_add_modify (&block
, ctree
,
419 fold_convert (TREE_TYPE (ctree
), gfc_class_vptr_get (tmp
)));
421 ctree
= gfc_class_data_get (var
);
422 tmp
= gfc_conv_descriptor_data_get (gfc_class_data_get (tmp
));
423 gfc_add_modify (&block
, ctree
, fold_convert (TREE_TYPE (ctree
), tmp
));
425 /* Pass the address of the class object. */
426 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
430 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
433 tmp
= gfc_finish_block (&block
);
435 gfc_init_block (&block
);
436 tmp2
= gfc_class_data_get (var
);
437 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
439 tmp2
= gfc_finish_block (&block
);
441 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
443 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
446 gfc_add_block_to_block (&parmse
->pre
, &block
);
450 /* Takes a scalarized class array expression and returns the
451 address of a temporary scalar class object of the 'declared'
453 OOP-TODO: This could be improved by adding code that branched on
454 the dynamic type being the same as the declared type. In this case
455 the original class expression can be passed directly.
456 optional_alloc_ptr is false when the dummy is neither allocatable
457 nor a pointer; that's relevant for the optional handling.
458 Set copyback to true if class container's _data and _vtab pointers
459 might get modified. */
462 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
, gfc_typespec class_ts
,
463 bool elemental
, bool copyback
, bool optional
,
464 bool optional_alloc_ptr
)
470 tree cond
= NULL_TREE
;
474 bool full_array
= false;
476 gfc_init_block (&block
);
479 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
481 if (ref
->type
== REF_COMPONENT
482 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
485 if (ref
->next
== NULL
)
489 if ((ref
== NULL
|| class_ref
== ref
)
490 && (!class_ts
.u
.derived
->components
->as
491 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
494 /* Test for FULL_ARRAY. */
495 if (e
->rank
== 0 && gfc_expr_attr (e
).codimension
496 && gfc_expr_attr (e
).dimension
)
499 gfc_is_class_array_ref (e
, &full_array
);
501 /* The derived type needs to be converted to a temporary
503 tmp
= gfc_typenode_for_spec (&class_ts
);
504 var
= gfc_create_var (tmp
, "class");
507 ctree
= gfc_class_data_get (var
);
508 if (class_ts
.u
.derived
->components
->as
509 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
513 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
515 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (ctree
),
516 gfc_get_dtype (type
));
518 tmp
= gfc_class_data_get (parmse
->expr
);
519 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
520 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
522 gfc_conv_descriptor_data_set (&block
, ctree
, tmp
);
525 class_array_data_assign (&block
, ctree
, parmse
->expr
, false);
529 if (CLASS_DATA (e
)->attr
.codimension
)
530 parmse
->expr
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
531 TREE_TYPE (ctree
), parmse
->expr
);
532 gfc_add_modify (&block
, ctree
, parmse
->expr
);
535 /* Return the data component, except in the case of scalarized array
536 references, where nullification of the cannot occur and so there
538 if (!elemental
&& full_array
&& copyback
)
540 if (class_ts
.u
.derived
->components
->as
541 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
544 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
545 gfc_conv_descriptor_data_get (ctree
));
547 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
550 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
554 ctree
= gfc_class_vptr_get (var
);
556 /* The vptr is the second field of the actual argument.
557 First we have to find the corresponding class reference. */
560 if (class_ref
== NULL
561 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
562 tmp
= e
->symtree
->n
.sym
->backend_decl
;
565 /* Remove everything after the last class reference, convert the
566 expression and then recover its tailend once more. */
568 ref
= class_ref
->next
;
569 class_ref
->next
= NULL
;
570 gfc_init_se (&tmpse
, NULL
);
571 gfc_conv_expr (&tmpse
, e
);
572 class_ref
->next
= ref
;
576 gcc_assert (tmp
!= NULL_TREE
);
578 /* Dereference if needs be. */
579 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
580 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
582 vptr
= gfc_class_vptr_get (tmp
);
583 gfc_add_modify (&block
, ctree
,
584 fold_convert (TREE_TYPE (ctree
), vptr
));
586 /* Return the vptr component, except in the case of scalarized array
587 references, where the dynamic type cannot change. */
588 if (!elemental
&& full_array
&& copyback
)
589 gfc_add_modify (&parmse
->post
, vptr
,
590 fold_convert (TREE_TYPE (vptr
), ctree
));
592 gcc_assert (!optional
|| (optional
&& !copyback
));
597 cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
598 tmp
= gfc_finish_block (&block
);
600 if (optional_alloc_ptr
)
601 tmp2
= build_empty_stmt (input_location
);
604 gfc_init_block (&block
);
606 tmp2
= gfc_conv_descriptor_data_get (gfc_class_data_get (var
));
607 gfc_add_modify (&block
, tmp2
, fold_convert (TREE_TYPE (tmp2
),
609 tmp2
= gfc_finish_block (&block
);
612 tmp
= build3_loc (input_location
, COND_EXPR
, void_type_node
,
614 gfc_add_expr_to_block (&parmse
->pre
, tmp
);
617 gfc_add_block_to_block (&parmse
->pre
, &block
);
619 /* Pass the address of the class object. */
620 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
622 if (optional
&& optional_alloc_ptr
)
623 parmse
->expr
= build3_loc (input_location
, COND_EXPR
,
624 TREE_TYPE (parmse
->expr
),
626 fold_convert (TREE_TYPE (parmse
->expr
),
631 /* Given a class array declaration and an index, returns the address
632 of the referenced element. */
635 gfc_get_class_array_ref (tree index
, tree class_decl
)
637 tree data
= gfc_class_data_get (class_decl
);
638 tree size
= gfc_vtable_size_get (class_decl
);
639 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
640 gfc_array_index_type
,
643 data
= gfc_conv_descriptor_data_get (data
);
644 ptr
= fold_convert (pvoid_type_node
, data
);
645 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
646 return fold_convert (TREE_TYPE (data
), ptr
);
650 /* Copies one class expression to another, assuming that if either
651 'to' or 'from' are arrays they are packed. Should 'from' be
652 NULL_TREE, the initialization expression for 'to' is used, assuming
653 that the _vptr is set. */
656 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
664 vec
<tree
, va_gc
> *args
;
667 stmtblock_t loopbody
;
673 if (from
!= NULL_TREE
)
674 fcn
= gfc_vtable_copy_get (from
);
676 fcn
= gfc_vtable_copy_get (to
);
678 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
680 if (from
!= NULL_TREE
)
681 from_data
= gfc_class_data_get (from
);
683 from_data
= gfc_vtable_def_init_get (to
);
685 to_data
= gfc_class_data_get (to
);
687 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
689 gfc_init_block (&body
);
690 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
691 gfc_array_index_type
, nelems
,
693 nelems
= gfc_evaluate_now (tmp
, &body
);
694 index
= gfc_create_var (gfc_array_index_type
, "S");
696 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
698 from_ref
= gfc_get_class_array_ref (index
, from
);
699 vec_safe_push (args
, from_ref
);
702 vec_safe_push (args
, from_data
);
704 to_ref
= gfc_get_class_array_ref (index
, to
);
705 vec_safe_push (args
, to_ref
);
707 tmp
= build_call_vec (fcn_type
, fcn
, args
);
709 /* Build the body of the loop. */
710 gfc_init_block (&loopbody
);
711 gfc_add_expr_to_block (&loopbody
, tmp
);
713 /* Build the loop and return. */
714 gfc_init_loopinfo (&loop
);
716 loop
.from
[0] = gfc_index_zero_node
;
717 loop
.loopvar
[0] = index
;
719 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
720 gfc_add_block_to_block (&body
, &loop
.pre
);
721 tmp
= gfc_finish_block (&body
);
722 gfc_cleanup_loop (&loop
);
726 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
727 vec_safe_push (args
, from_data
);
728 vec_safe_push (args
, to_data
);
729 tmp
= build_call_vec (fcn_type
, fcn
, args
);
736 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
738 gfc_actual_arglist
*actual
;
743 actual
= gfc_get_actual_arglist ();
744 actual
->expr
= gfc_copy_expr (rhs
);
745 actual
->next
= gfc_get_actual_arglist ();
746 actual
->next
->expr
= gfc_copy_expr (lhs
);
747 ppc
= gfc_copy_expr (obj
);
748 gfc_add_vptr_component (ppc
);
749 gfc_add_component_ref (ppc
, "_copy");
750 ppc_code
= gfc_get_code ();
751 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
752 /* Although '_copy' is set to be elemental in class.c, it is
753 not staying that way. Find out why, sometime.... */
754 ppc_code
->resolved_sym
->attr
.elemental
= 1;
755 ppc_code
->ext
.actual
= actual
;
756 ppc_code
->expr1
= ppc
;
757 ppc_code
->op
= EXEC_CALL
;
758 /* Since '_copy' is elemental, the scalarizer will take care
759 of arrays in gfc_trans_call. */
760 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
761 gfc_free_statements (ppc_code
);
765 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
766 A MEMCPY is needed to copy the full data from the default initializer
767 of the dynamic type. */
770 gfc_trans_class_init_assign (gfc_code
*code
)
774 gfc_se dst
,src
,memsz
;
775 gfc_expr
*lhs
, *rhs
, *sz
;
777 gfc_start_block (&block
);
779 lhs
= gfc_copy_expr (code
->expr1
);
780 gfc_add_data_component (lhs
);
782 rhs
= gfc_copy_expr (code
->expr1
);
783 gfc_add_vptr_component (rhs
);
785 /* Make sure that the component backend_decls have been built, which
786 will not have happened if the derived types concerned have not
788 gfc_get_derived_type (rhs
->ts
.u
.derived
);
789 gfc_add_def_init_component (rhs
);
791 if (code
->expr1
->ts
.type
== BT_CLASS
792 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
793 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
796 sz
= gfc_copy_expr (code
->expr1
);
797 gfc_add_vptr_component (sz
);
798 gfc_add_size_component (sz
);
800 gfc_init_se (&dst
, NULL
);
801 gfc_init_se (&src
, NULL
);
802 gfc_init_se (&memsz
, NULL
);
803 gfc_conv_expr (&dst
, lhs
);
804 gfc_conv_expr (&src
, rhs
);
805 gfc_conv_expr (&memsz
, sz
);
806 gfc_add_block_to_block (&block
, &src
.pre
);
807 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
810 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
811 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
813 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
814 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
816 build_empty_stmt (input_location
));
819 gfc_add_expr_to_block (&block
, tmp
);
821 return gfc_finish_block (&block
);
825 /* Translate an assignment to a CLASS object
826 (pointer or ordinary assignment). */
829 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
837 gfc_start_block (&block
);
840 while (ref
&& ref
->next
)
843 /* Class valued proc_pointer assignments do not need any further
845 if (ref
&& ref
->type
== REF_COMPONENT
846 && ref
->u
.c
.component
->attr
.proc_pointer
847 && expr2
->expr_type
== EXPR_VARIABLE
848 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
849 && op
== EXEC_POINTER_ASSIGN
)
852 if (expr2
->ts
.type
!= BT_CLASS
)
854 /* Insert an additional assignment which sets the '_vptr' field. */
855 gfc_symbol
*vtab
= NULL
;
858 lhs
= gfc_copy_expr (expr1
);
859 gfc_add_vptr_component (lhs
);
861 if (expr2
->ts
.type
== BT_DERIVED
)
862 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
863 else if (expr2
->expr_type
== EXPR_NULL
)
864 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
867 rhs
= gfc_get_expr ();
868 rhs
->expr_type
= EXPR_VARIABLE
;
869 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
873 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
874 gfc_add_expr_to_block (&block
, tmp
);
879 else if (CLASS_DATA (expr2
)->attr
.dimension
)
881 /* Insert an additional assignment which sets the '_vptr' field. */
882 lhs
= gfc_copy_expr (expr1
);
883 gfc_add_vptr_component (lhs
);
885 rhs
= gfc_copy_expr (expr2
);
886 gfc_add_vptr_component (rhs
);
888 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
889 gfc_add_expr_to_block (&block
, tmp
);
895 /* Do the actual CLASS assignment. */
896 if (expr2
->ts
.type
== BT_CLASS
897 && !CLASS_DATA (expr2
)->attr
.dimension
)
900 gfc_add_data_component (expr1
);
904 if (op
== EXEC_ASSIGN
)
905 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
906 else if (op
== EXEC_POINTER_ASSIGN
)
907 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
911 gfc_add_expr_to_block (&block
, tmp
);
913 return gfc_finish_block (&block
);
917 /* End of prototype trans-class.c */
921 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
923 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
924 && gfc_option
.warn_realloc_lhs
)
925 gfc_warning ("Code for reallocating the allocatable array at %L will "
927 else if (gfc_option
.warn_realloc_lhs_all
)
928 gfc_warning ("Code for reallocating the allocatable variable at %L "
929 "will be added", where
);
933 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
934 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
937 /* Copy the scalarization loop variables. */
940 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
943 dest
->loop
= src
->loop
;
947 /* Initialize a simple expression holder.
949 Care must be taken when multiple se are created with the same parent.
950 The child se must be kept in sync. The easiest way is to delay creation
951 of a child se until after after the previous se has been translated. */
954 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
956 memset (se
, 0, sizeof (gfc_se
));
957 gfc_init_block (&se
->pre
);
958 gfc_init_block (&se
->post
);
963 gfc_copy_se_loopvars (se
, parent
);
967 /* Advances to the next SS in the chain. Use this rather than setting
968 se->ss = se->ss->next because all the parents needs to be kept in sync.
972 gfc_advance_se_ss_chain (gfc_se
* se
)
977 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
980 /* Walk down the parent chain. */
983 /* Simple consistency check. */
984 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
985 || p
->parent
->ss
->nested_ss
== p
->ss
);
987 /* If we were in a nested loop, the next scalarized expression can be
988 on the parent ss' next pointer. Thus we should not take the next
989 pointer blindly, but rather go up one nest level as long as next
990 is the end of chain. */
992 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
1002 /* Ensures the result of the expression as either a temporary variable
1003 or a constant so that it can be used repeatedly. */
1006 gfc_make_safe_expr (gfc_se
* se
)
1010 if (CONSTANT_CLASS_P (se
->expr
))
1013 /* We need a temporary for this result. */
1014 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1015 gfc_add_modify (&se
->pre
, var
, se
->expr
);
1020 /* Return an expression which determines if a dummy parameter is present.
1021 Also used for arguments to procedures with multiple entry points. */
1024 gfc_conv_expr_present (gfc_symbol
* sym
)
1028 gcc_assert (sym
->attr
.dummy
);
1030 decl
= gfc_get_symbol_decl (sym
);
1031 if (TREE_CODE (decl
) != PARM_DECL
)
1033 /* Array parameters use a temporary descriptor, we want the real
1035 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
1036 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
1037 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
1040 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
1041 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
1043 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1044 as actual argument to denote absent dummies. For array descriptors,
1045 we thus also need to check the array descriptor. For BT_CLASS, it
1046 can also occur for scalars and F2003 due to type->class wrapping and
1047 class->class wrapping. Note futher that BT_CLASS always uses an
1048 array descriptor for arrays, also for explicit-shape/assumed-size. */
1050 if (!sym
->attr
.allocatable
1051 && ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.pointer
)
1052 || (sym
->ts
.type
== BT_CLASS
1053 && !CLASS_DATA (sym
)->attr
.allocatable
1054 && !CLASS_DATA (sym
)->attr
.class_pointer
))
1055 && ((gfc_option
.allow_std
& GFC_STD_F2008
) != 0
1056 || sym
->ts
.type
== BT_CLASS
))
1060 if ((sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
1061 || sym
->as
->type
== AS_ASSUMED_RANK
1062 || sym
->attr
.codimension
))
1063 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
))
1065 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
1066 if (sym
->ts
.type
== BT_CLASS
)
1067 tmp
= gfc_class_data_get (tmp
);
1068 tmp
= gfc_conv_array_data (tmp
);
1070 else if (sym
->ts
.type
== BT_CLASS
)
1071 tmp
= gfc_class_data_get (decl
);
1075 if (tmp
!= NULL_TREE
)
1077 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
1078 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
1079 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1080 boolean_type_node
, cond
, tmp
);
1088 /* Converts a missing, dummy argument into a null or zero. */
1091 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
1096 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
1100 /* Create a temporary and convert it to the correct type. */
1101 tmp
= gfc_get_int_type (kind
);
1102 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
1105 /* Test for a NULL value. */
1106 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
1107 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
1108 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1109 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1113 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
1115 build_zero_cst (TREE_TYPE (se
->expr
)));
1116 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1120 if (ts
.type
== BT_CHARACTER
)
1122 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1123 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
1124 present
, se
->string_length
, tmp
);
1125 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1126 se
->string_length
= tmp
;
1132 /* Get the character length of an expression, looking through gfc_refs
1136 gfc_get_expr_charlen (gfc_expr
*e
)
1141 gcc_assert (e
->expr_type
== EXPR_VARIABLE
1142 && e
->ts
.type
== BT_CHARACTER
);
1144 length
= NULL
; /* To silence compiler warning. */
1146 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
1149 gfc_init_se (&tmpse
, NULL
);
1150 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
1151 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
1155 /* First candidate: if the variable is of type CHARACTER, the
1156 expression's length could be the length of the character
1158 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1159 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1161 /* Look through the reference chain for component references. */
1162 for (r
= e
->ref
; r
; r
= r
->next
)
1167 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
1168 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
1176 /* We should never got substring references here. These will be
1177 broken down by the scalarizer. */
1183 gcc_assert (length
!= NULL
);
1188 /* Return for an expression the backend decl of the coarray. */
1191 get_tree_for_caf_expr (gfc_expr
*expr
)
1193 tree caf_decl
= NULL_TREE
;
1196 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
1197 if (expr
->symtree
->n
.sym
->attr
.codimension
)
1198 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
1200 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1201 if (ref
->type
== REF_COMPONENT
)
1203 gfc_component
*comp
= ref
->u
.c
.component
;
1204 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
1205 caf_decl
= NULL_TREE
;
1206 if (comp
->attr
.codimension
)
1207 caf_decl
= comp
->backend_decl
;
1210 gcc_assert (caf_decl
!= NULL_TREE
);
1215 /* For each character array constructor subexpression without a ts.u.cl->length,
1216 replace it by its first element (if there aren't any elements, the length
1217 should already be set to zero). */
1220 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1222 gfc_actual_arglist
* arg
;
1228 switch (e
->expr_type
)
1232 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1233 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1237 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1241 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1242 flatten_array_ctors_without_strlen (arg
->expr
);
1247 /* We've found what we're looking for. */
1248 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1253 gcc_assert (e
->value
.constructor
);
1255 c
= gfc_constructor_first (e
->value
.constructor
);
1259 flatten_array_ctors_without_strlen (new_expr
);
1260 gfc_replace_expr (e
, new_expr
);
1264 /* Otherwise, fall through to handle constructor elements. */
1265 case EXPR_STRUCTURE
:
1266 for (c
= gfc_constructor_first (e
->value
.constructor
);
1267 c
; c
= gfc_constructor_next (c
))
1268 flatten_array_ctors_without_strlen (c
->expr
);
1278 /* Generate code to initialize a string length variable. Returns the
1279 value. For array constructors, cl->length might be NULL and in this case,
1280 the first element of the constructor is needed. expr is the original
1281 expression so we can access it but can be NULL if this is not needed. */
1284 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1288 gfc_init_se (&se
, NULL
);
1292 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1295 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1296 "flatten" array constructors by taking their first element; all elements
1297 should be the same length or a cl->length should be present. */
1300 gfc_expr
* expr_flat
;
1302 expr_flat
= gfc_copy_expr (expr
);
1303 flatten_array_ctors_without_strlen (expr_flat
);
1304 gfc_resolve_expr (expr_flat
);
1306 gfc_conv_expr (&se
, expr_flat
);
1307 gfc_add_block_to_block (pblock
, &se
.pre
);
1308 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1310 gfc_free_expr (expr_flat
);
1314 /* Convert cl->length. */
1316 gcc_assert (cl
->length
);
1318 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1319 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1320 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1321 gfc_add_block_to_block (pblock
, &se
.pre
);
1323 if (cl
->backend_decl
)
1324 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1326 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1331 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1332 const char *name
, locus
*where
)
1341 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1342 type
= build_pointer_type (type
);
1344 gfc_init_se (&start
, se
);
1345 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1346 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1348 if (integer_onep (start
.expr
))
1349 gfc_conv_string_parameter (se
);
1354 /* Avoid multiple evaluation of substring start. */
1355 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1356 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1358 /* Change the start of the string. */
1359 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1362 tmp
= build_fold_indirect_ref_loc (input_location
,
1364 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1365 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1368 /* Length = end + 1 - start. */
1369 gfc_init_se (&end
, se
);
1370 if (ref
->u
.ss
.end
== NULL
)
1371 end
.expr
= se
->string_length
;
1374 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1375 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1379 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1380 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1382 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1384 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1385 boolean_type_node
, start
.expr
,
1388 /* Check lower bound. */
1389 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1391 build_int_cst (gfc_charlen_type_node
, 1));
1392 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1393 boolean_type_node
, nonempty
, fault
);
1395 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1396 "is less than one", name
);
1398 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1399 "is less than one");
1400 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1401 fold_convert (long_integer_type_node
,
1405 /* Check upper bound. */
1406 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1407 end
.expr
, se
->string_length
);
1408 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1409 boolean_type_node
, nonempty
, fault
);
1411 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1412 "exceeds string length (%%ld)", name
);
1414 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1415 "exceeds string length (%%ld)");
1416 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1417 fold_convert (long_integer_type_node
, end
.expr
),
1418 fold_convert (long_integer_type_node
,
1419 se
->string_length
));
1423 /* If the start and end expressions are equal, the length is one. */
1425 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
1426 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
1429 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1430 end
.expr
, start
.expr
);
1431 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1432 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1433 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1434 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1437 se
->string_length
= tmp
;
1441 /* Convert a derived type component reference. */
1444 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1451 c
= ref
->u
.c
.component
;
1453 gcc_assert (c
->backend_decl
);
1455 field
= c
->backend_decl
;
1456 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1459 /* Components can correspond to fields of different containing
1460 types, as components are created without context, whereas
1461 a concrete use of a component has the type of decl as context.
1462 So, if the type doesn't match, we search the corresponding
1463 FIELD_DECL in the parent type. To not waste too much time
1464 we cache this result in norestrict_decl. */
1466 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1468 tree f2
= c
->norestrict_decl
;
1469 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1470 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1471 if (TREE_CODE (f2
) == FIELD_DECL
1472 && DECL_NAME (f2
) == DECL_NAME (field
))
1475 c
->norestrict_decl
= f2
;
1478 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1479 decl
, field
, NULL_TREE
);
1483 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1485 tmp
= c
->ts
.u
.cl
->backend_decl
;
1486 /* Components must always be constant length. */
1487 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1488 se
->string_length
= tmp
;
1491 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1492 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1493 && c
->ts
.type
!= BT_CHARACTER
)
1494 || c
->attr
.proc_pointer
)
1495 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1500 /* This function deals with component references to components of the
1501 parent type for derived type extensions. */
1503 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1511 c
= ref
->u
.c
.component
;
1513 /* Return if the component is not in the parent type. */
1514 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1515 if (strcmp (c
->name
, cmp
->name
) == 0)
1518 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1519 parent
.type
= REF_COMPONENT
;
1521 parent
.u
.c
.sym
= dt
;
1522 parent
.u
.c
.component
= dt
->components
;
1524 if (dt
->backend_decl
== NULL
)
1525 gfc_get_derived_type (dt
);
1527 /* Build the reference and call self. */
1528 gfc_conv_component_ref (se
, &parent
);
1529 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1530 parent
.u
.c
.component
= c
;
1531 conv_parent_component_references (se
, &parent
);
1534 /* Return the contents of a variable. Also handles reference/pointer
1535 variables (all Fortran pointer references are implicit). */
1538 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1543 tree parent_decl
= NULL_TREE
;
1546 bool alternate_entry
;
1549 sym
= expr
->symtree
->n
.sym
;
1553 gfc_ss_info
*ss_info
= ss
->info
;
1555 /* Check that something hasn't gone horribly wrong. */
1556 gcc_assert (ss
!= gfc_ss_terminator
);
1557 gcc_assert (ss_info
->expr
== expr
);
1559 /* A scalarized term. We already know the descriptor. */
1560 se
->expr
= ss_info
->data
.array
.descriptor
;
1561 se
->string_length
= ss_info
->string_length
;
1562 for (ref
= ss_info
->data
.array
.ref
; ref
; ref
= ref
->next
)
1563 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1568 tree se_expr
= NULL_TREE
;
1570 se
->expr
= gfc_get_symbol_decl (sym
);
1572 /* Deal with references to a parent results or entries by storing
1573 the current_function_decl and moving to the parent_decl. */
1574 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1575 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1576 && sym
->result
== sym
;
1577 entry_master
= sym
->attr
.result
1578 && sym
->ns
->proc_name
->attr
.entry_master
1579 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1580 if (current_function_decl
)
1581 parent_decl
= DECL_CONTEXT (current_function_decl
);
1583 if ((se
->expr
== parent_decl
&& return_value
)
1584 || (sym
->ns
&& sym
->ns
->proc_name
1586 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1587 && (alternate_entry
|| entry_master
)))
1592 /* Special case for assigning the return value of a function.
1593 Self recursive functions must have an explicit return value. */
1594 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1595 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1597 /* Similarly for alternate entry points. */
1598 else if (alternate_entry
1599 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1602 gfc_entry_list
*el
= NULL
;
1604 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1607 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1612 else if (entry_master
1613 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1615 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1620 /* Procedure actual arguments. */
1621 else if (sym
->attr
.flavor
== FL_PROCEDURE
1622 && se
->expr
!= current_function_decl
)
1624 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1626 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1627 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1633 /* Dereference the expression, where needed. Since characters
1634 are entirely different from other types, they are treated
1636 if (sym
->ts
.type
== BT_CHARACTER
)
1638 /* Dereference character pointer dummy arguments
1640 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1642 || sym
->attr
.function
1643 || sym
->attr
.result
))
1644 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1648 else if (!sym
->attr
.value
)
1650 /* Dereference non-character scalar dummy arguments. */
1651 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1652 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1653 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1656 /* Dereference scalar hidden result. */
1657 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1658 && (sym
->attr
.function
|| sym
->attr
.result
)
1659 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1660 && !sym
->attr
.always_explicit
)
1661 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1664 /* Dereference non-character pointer variables.
1665 These must be dummies, results, or scalars. */
1666 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1667 || gfc_is_associate_pointer (sym
)
1668 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1670 || sym
->attr
.function
1672 || (!sym
->attr
.dimension
1673 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1674 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1681 /* For character variables, also get the length. */
1682 if (sym
->ts
.type
== BT_CHARACTER
)
1684 /* If the character length of an entry isn't set, get the length from
1685 the master function instead. */
1686 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1687 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1689 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1690 gcc_assert (se
->string_length
);
1698 /* Return the descriptor if that's what we want and this is an array
1699 section reference. */
1700 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1702 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1703 /* Return the descriptor for array pointers and allocations. */
1704 if (se
->want_pointer
1705 && ref
->next
== NULL
&& (se
->descriptor_only
))
1708 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
1709 /* Return a pointer to an element. */
1713 if (ref
->u
.c
.sym
->attr
.extension
)
1714 conv_parent_component_references (se
, ref
);
1716 gfc_conv_component_ref (se
, ref
);
1721 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1722 expr
->symtree
->name
, &expr
->where
);
1731 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1733 if (se
->want_pointer
)
1735 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1736 gfc_conv_string_parameter (se
);
1738 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1743 /* Unary ops are easy... Or they would be if ! was a valid op. */
1746 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1751 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1752 /* Initialize the operand. */
1753 gfc_init_se (&operand
, se
);
1754 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1755 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1757 type
= gfc_typenode_for_spec (&expr
->ts
);
1759 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1760 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1761 All other unary operators have an equivalent GIMPLE unary operator. */
1762 if (code
== TRUTH_NOT_EXPR
)
1763 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1764 build_int_cst (type
, 0));
1766 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1770 /* Expand power operator to optimal multiplications when a value is raised
1771 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1772 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1773 Programming", 3rd Edition, 1998. */
1775 /* This code is mostly duplicated from expand_powi in the backend.
1776 We establish the "optimal power tree" lookup table with the defined size.
1777 The items in the table are the exponents used to calculate the index
1778 exponents. Any integer n less than the value can get an "addition chain",
1779 with the first node being one. */
1780 #define POWI_TABLE_SIZE 256
1782 /* The table is from builtins.c. */
1783 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1785 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1786 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1787 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1788 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1789 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1790 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1791 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1792 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1793 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1794 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1795 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1796 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1797 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1798 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1799 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1800 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1801 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1802 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1803 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1804 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1805 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1806 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1807 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1808 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1809 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1810 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1811 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1812 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1813 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1814 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1815 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1816 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1819 /* If n is larger than lookup table's max index, we use the "window
1821 #define POWI_WINDOW_SIZE 3
1823 /* Recursive function to expand the power operator. The temporary
1824 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1826 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
1833 if (n
< POWI_TABLE_SIZE
)
1838 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
1839 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
1843 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
1844 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
1845 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
1849 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
1853 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
1854 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1856 if (n
< POWI_TABLE_SIZE
)
1863 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1864 return 1. Else return 0 and a call to runtime library functions
1865 will have to be built. */
1867 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
1872 tree vartmp
[POWI_TABLE_SIZE
];
1874 unsigned HOST_WIDE_INT n
;
1877 /* If exponent is too large, we won't expand it anyway, so don't bother
1878 with large integer values. */
1879 if (!TREE_INT_CST (rhs
).fits_shwi ())
1882 m
= TREE_INT_CST (rhs
).to_shwi ();
1883 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1884 of the asymmetric range of the integer type. */
1885 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
1887 type
= TREE_TYPE (lhs
);
1888 sgn
= tree_int_cst_sgn (rhs
);
1890 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
1891 || optimize_size
) && (m
> 2 || m
< -1))
1897 se
->expr
= gfc_build_const (type
, integer_one_node
);
1901 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1902 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
1904 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1905 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
1906 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1907 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
1910 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1913 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1914 boolean_type_node
, tmp
, cond
);
1915 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1916 tmp
, build_int_cst (type
, 1),
1917 build_int_cst (type
, 0));
1921 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1922 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
1923 build_int_cst (type
, -1),
1924 build_int_cst (type
, 0));
1925 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1926 cond
, build_int_cst (type
, 1), tmp
);
1930 memset (vartmp
, 0, sizeof (vartmp
));
1934 tmp
= gfc_build_const (type
, integer_one_node
);
1935 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
1939 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
1945 /* Power op (**). Constant integer exponent has special handling. */
1948 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
1950 tree gfc_int4_type_node
;
1953 int res_ikind_1
, res_ikind_2
;
1958 gfc_init_se (&lse
, se
);
1959 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
1960 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
1961 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1963 gfc_init_se (&rse
, se
);
1964 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
1965 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1967 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
1968 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
1969 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
1972 gfc_int4_type_node
= gfc_get_int_type (4);
1974 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1975 library routine. But in the end, we have to convert the result back
1976 if this case applies -- with res_ikind_K, we keep track whether operand K
1977 falls into this case. */
1981 kind
= expr
->value
.op
.op1
->ts
.kind
;
1982 switch (expr
->value
.op
.op2
->ts
.type
)
1985 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1990 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1991 res_ikind_2
= ikind
;
2013 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
2015 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
2042 switch (expr
->value
.op
.op1
->ts
.type
)
2045 if (kind
== 3) /* Case 16 was not handled properly above. */
2047 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
2051 /* Use builtins for real ** int4. */
2057 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
2061 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
2065 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2069 /* Use the __builtin_powil() only if real(kind=16) is
2070 actually the C long double type. */
2071 if (!gfc_real16_is_float128
)
2072 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
2080 /* If we don't have a good builtin for this, go for the
2081 library function. */
2083 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
2087 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
2096 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
2100 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
2108 se
->expr
= build_call_expr_loc (input_location
,
2109 fndecl
, 2, lse
.expr
, rse
.expr
);
2111 /* Convert the result back if it is of wrong integer kind. */
2112 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
2114 /* We want the maximum of both operand kinds as result. */
2115 if (res_ikind_1
< res_ikind_2
)
2116 res_ikind_1
= res_ikind_2
;
2117 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
2122 /* Generate code to allocate a string temporary. */
2125 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
2130 if (gfc_can_put_var_on_stack (len
))
2132 /* Create a temporary variable to hold the result. */
2133 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2134 gfc_charlen_type_node
, len
,
2135 build_int_cst (gfc_charlen_type_node
, 1));
2136 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2138 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
2139 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
2141 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
2143 var
= gfc_create_var (tmp
, "str");
2144 var
= gfc_build_addr_expr (type
, var
);
2148 /* Allocate a temporary to hold the result. */
2149 var
= gfc_create_var (type
, "pstr");
2150 tmp
= gfc_call_malloc (&se
->pre
, type
,
2151 fold_build2_loc (input_location
, MULT_EXPR
,
2152 TREE_TYPE (len
), len
,
2153 fold_convert (TREE_TYPE (len
),
2154 TYPE_SIZE (type
))));
2155 gfc_add_modify (&se
->pre
, var
, tmp
);
2157 /* Free the temporary afterwards. */
2158 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
2159 gfc_add_expr_to_block (&se
->post
, tmp
);
2166 /* Handle a string concatenation operation. A temporary will be allocated to
2170 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
2173 tree len
, type
, var
, tmp
, fndecl
;
2175 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
2176 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
2177 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
2179 gfc_init_se (&lse
, se
);
2180 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2181 gfc_conv_string_parameter (&lse
);
2182 gfc_init_se (&rse
, se
);
2183 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2184 gfc_conv_string_parameter (&rse
);
2186 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2187 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2189 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
2190 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2191 if (len
== NULL_TREE
)
2193 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
2194 TREE_TYPE (lse
.string_length
),
2195 lse
.string_length
, rse
.string_length
);
2198 type
= build_pointer_type (type
);
2200 var
= gfc_conv_string_tmp (se
, type
, len
);
2202 /* Do the actual concatenation. */
2203 if (expr
->ts
.kind
== 1)
2204 fndecl
= gfor_fndecl_concat_string
;
2205 else if (expr
->ts
.kind
== 4)
2206 fndecl
= gfor_fndecl_concat_string_char4
;
2210 tmp
= build_call_expr_loc (input_location
,
2211 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2212 rse
.string_length
, rse
.expr
);
2213 gfc_add_expr_to_block (&se
->pre
, tmp
);
2215 /* Add the cleanup for the operands. */
2216 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2217 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2220 se
->string_length
= len
;
2223 /* Translates an op expression. Common (binary) cases are handled by this
2224 function, others are passed on. Recursion is used in either case.
2225 We use the fact that (op1.ts == op2.ts) (except for the power
2227 Operators need no special handling for scalarized expressions as long as
2228 they call gfc_conv_simple_val to get their operands.
2229 Character strings get special handling. */
2232 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2234 enum tree_code code
;
2243 switch (expr
->value
.op
.op
)
2245 case INTRINSIC_PARENTHESES
:
2246 if ((expr
->ts
.type
== BT_REAL
2247 || expr
->ts
.type
== BT_COMPLEX
)
2248 && gfc_option
.flag_protect_parens
)
2250 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2251 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2256 case INTRINSIC_UPLUS
:
2257 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2260 case INTRINSIC_UMINUS
:
2261 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2265 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2268 case INTRINSIC_PLUS
:
2272 case INTRINSIC_MINUS
:
2276 case INTRINSIC_TIMES
:
2280 case INTRINSIC_DIVIDE
:
2281 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2282 an integer, we must round towards zero, so we use a
2284 if (expr
->ts
.type
== BT_INTEGER
)
2285 code
= TRUNC_DIV_EXPR
;
2290 case INTRINSIC_POWER
:
2291 gfc_conv_power_op (se
, expr
);
2294 case INTRINSIC_CONCAT
:
2295 gfc_conv_concat_op (se
, expr
);
2299 code
= TRUTH_ANDIF_EXPR
;
2304 code
= TRUTH_ORIF_EXPR
;
2308 /* EQV and NEQV only work on logicals, but since we represent them
2309 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2311 case INTRINSIC_EQ_OS
:
2319 case INTRINSIC_NE_OS
:
2320 case INTRINSIC_NEQV
:
2327 case INTRINSIC_GT_OS
:
2334 case INTRINSIC_GE_OS
:
2341 case INTRINSIC_LT_OS
:
2348 case INTRINSIC_LE_OS
:
2354 case INTRINSIC_USER
:
2355 case INTRINSIC_ASSIGN
:
2356 /* These should be converted into function calls by the frontend. */
2360 fatal_error ("Unknown intrinsic op");
2364 /* The only exception to this is **, which is handled separately anyway. */
2365 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2367 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2371 gfc_init_se (&lse
, se
);
2372 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2373 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2376 gfc_init_se (&rse
, se
);
2377 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2378 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2382 gfc_conv_string_parameter (&lse
);
2383 gfc_conv_string_parameter (&rse
);
2385 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2386 rse
.string_length
, rse
.expr
,
2387 expr
->value
.op
.op1
->ts
.kind
,
2389 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2390 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2393 type
= gfc_typenode_for_spec (&expr
->ts
);
2397 /* The result of logical ops is always boolean_type_node. */
2398 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2399 lse
.expr
, rse
.expr
);
2400 se
->expr
= convert (type
, tmp
);
2403 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2405 /* Add the post blocks. */
2406 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2407 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2410 /* If a string's length is one, we convert it to a single character. */
2413 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2417 || !INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2418 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2421 if (TREE_INT_CST_LOW (len
) == 1)
2423 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2424 return build_fold_indirect_ref_loc (input_location
, str
);
2428 && TREE_CODE (str
) == ADDR_EXPR
2429 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2430 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2431 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2432 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2433 && TREE_INT_CST_LOW (len
) > 1
2434 && TREE_INT_CST_LOW (len
)
2435 == (unsigned HOST_WIDE_INT
)
2436 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2438 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2439 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2440 if (TREE_CODE (ret
) == INTEGER_CST
)
2442 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2443 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2444 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2446 for (i
= 1; i
< length
; i
++)
2459 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2462 if (sym
->backend_decl
)
2464 /* This becomes the nominal_type in
2465 function.c:assign_parm_find_data_types. */
2466 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2467 /* This becomes the passed_type in
2468 function.c:assign_parm_find_data_types. C promotes char to
2469 integer for argument passing. */
2470 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2472 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2477 /* If we have a constant character expression, make it into an
2479 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2484 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2485 (int)(*expr
)->value
.character
.string
[0]);
2486 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2488 /* The expr needs to be compatible with a C int. If the
2489 conversion fails, then the 2 causes an ICE. */
2490 ts
.type
= BT_INTEGER
;
2491 ts
.kind
= gfc_c_int_kind
;
2492 gfc_convert_type (*expr
, &ts
, 2);
2495 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2497 if ((*expr
)->ref
== NULL
)
2499 se
->expr
= gfc_string_to_single_character
2500 (build_int_cst (integer_type_node
, 1),
2501 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2503 ((*expr
)->symtree
->n
.sym
)),
2508 gfc_conv_variable (se
, *expr
);
2509 se
->expr
= gfc_string_to_single_character
2510 (build_int_cst (integer_type_node
, 1),
2511 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2519 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2520 if STR is a string literal, otherwise return -1. */
2523 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2526 && TREE_CODE (str
) == ADDR_EXPR
2527 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2528 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2529 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2530 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2531 && TREE_INT_CST_LOW (len
) >= 1
2532 && TREE_INT_CST_LOW (len
)
2533 == (unsigned HOST_WIDE_INT
)
2534 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2536 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2537 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2538 if (TREE_CODE (folded
) == INTEGER_CST
)
2540 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2541 int length
= TREE_STRING_LENGTH (string_cst
);
2542 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2544 for (; length
> 0; length
--)
2545 if (ptr
[length
- 1] != ' ')
2554 /* Compare two strings. If they are all single characters, the result is the
2555 subtraction of them. Otherwise, we build a library call. */
2558 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2559 enum tree_code code
)
2565 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2566 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2568 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2569 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2571 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2573 /* Deal with single character specially. */
2574 sc1
= fold_convert (integer_type_node
, sc1
);
2575 sc2
= fold_convert (integer_type_node
, sc2
);
2576 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2580 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2582 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2584 /* If one string is a string literal with LEN_TRIM longer
2585 than the length of the second string, the strings
2587 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2588 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2589 return integer_one_node
;
2590 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2591 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2592 return integer_one_node
;
2595 /* Build a call for the comparison. */
2597 fndecl
= gfor_fndecl_compare_string
;
2599 fndecl
= gfor_fndecl_compare_string_char4
;
2603 return build_call_expr_loc (input_location
, fndecl
, 4,
2604 len1
, str1
, len2
, str2
);
2608 /* Return the backend_decl for a procedure pointer component. */
2611 get_proc_ptr_comp (gfc_expr
*e
)
2617 gfc_init_se (&comp_se
, NULL
);
2618 e2
= gfc_copy_expr (e
);
2619 /* We have to restore the expr type later so that gfc_free_expr frees
2620 the exact same thing that was allocated.
2621 TODO: This is ugly. */
2622 old_type
= e2
->expr_type
;
2623 e2
->expr_type
= EXPR_VARIABLE
;
2624 gfc_conv_expr (&comp_se
, e2
);
2625 e2
->expr_type
= old_type
;
2627 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2631 /* Convert a typebound function reference from a class object. */
2633 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2638 if (TREE_CODE (base_object
) != VAR_DECL
)
2640 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2641 gfc_add_modify (&se
->pre
, var
, base_object
);
2643 se
->expr
= gfc_class_vptr_get (base_object
);
2644 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2646 while (ref
&& ref
->next
)
2648 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2649 if (ref
->u
.c
.sym
->attr
.extension
)
2650 conv_parent_component_references (se
, ref
);
2651 gfc_conv_component_ref (se
, ref
);
2652 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2657 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2661 if (gfc_is_proc_ptr_comp (expr
))
2662 tmp
= get_proc_ptr_comp (expr
);
2663 else if (sym
->attr
.dummy
)
2665 tmp
= gfc_get_symbol_decl (sym
);
2666 if (sym
->attr
.proc_pointer
)
2667 tmp
= build_fold_indirect_ref_loc (input_location
,
2669 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2670 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2674 if (!sym
->backend_decl
)
2675 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2677 TREE_USED (sym
->backend_decl
) = 1;
2679 tmp
= sym
->backend_decl
;
2681 if (sym
->attr
.cray_pointee
)
2683 /* TODO - make the cray pointee a pointer to a procedure,
2684 assign the pointer to it and use it for the call. This
2686 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2687 gfc_get_symbol_decl (sym
->cp_pointer
));
2688 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2691 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2693 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2694 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2701 /* Initialize MAPPING. */
2704 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2706 mapping
->syms
= NULL
;
2707 mapping
->charlens
= NULL
;
2711 /* Free all memory held by MAPPING (but not MAPPING itself). */
2714 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2716 gfc_interface_sym_mapping
*sym
;
2717 gfc_interface_sym_mapping
*nextsym
;
2719 gfc_charlen
*nextcl
;
2721 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2723 nextsym
= sym
->next
;
2724 sym
->new_sym
->n
.sym
->formal
= NULL
;
2725 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2726 gfc_free_expr (sym
->expr
);
2727 free (sym
->new_sym
);
2730 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2733 gfc_free_expr (cl
->length
);
2739 /* Return a copy of gfc_charlen CL. Add the returned structure to
2740 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2742 static gfc_charlen
*
2743 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
2746 gfc_charlen
*new_charlen
;
2748 new_charlen
= gfc_get_charlen ();
2749 new_charlen
->next
= mapping
->charlens
;
2750 new_charlen
->length
= gfc_copy_expr (cl
->length
);
2752 mapping
->charlens
= new_charlen
;
2757 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2758 array variable that can be used as the actual argument for dummy
2759 argument SYM. Add any initialization code to BLOCK. PACKED is as
2760 for gfc_get_nodesc_array_type and DATA points to the first element
2761 in the passed array. */
2764 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
2765 gfc_packed packed
, tree data
)
2770 type
= gfc_typenode_for_spec (&sym
->ts
);
2771 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
2772 !sym
->attr
.target
&& !sym
->attr
.pointer
2773 && !sym
->attr
.proc_pointer
);
2775 var
= gfc_create_var (type
, "ifm");
2776 gfc_add_modify (block
, var
, fold_convert (type
, data
));
2782 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2783 and offset of descriptorless array type TYPE given that it has the same
2784 size as DESC. Add any set-up code to BLOCK. */
2787 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
2794 offset
= gfc_index_zero_node
;
2795 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
2797 dim
= gfc_rank_cst
[n
];
2798 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
2799 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
2801 GFC_TYPE_ARRAY_LBOUND (type
, n
)
2802 = gfc_conv_descriptor_lbound_get (desc
, dim
);
2803 GFC_TYPE_ARRAY_UBOUND (type
, n
)
2804 = gfc_conv_descriptor_ubound_get (desc
, dim
);
2806 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
2808 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2809 gfc_array_index_type
,
2810 gfc_conv_descriptor_ubound_get (desc
, dim
),
2811 gfc_conv_descriptor_lbound_get (desc
, dim
));
2812 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2813 gfc_array_index_type
,
2814 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
2815 tmp
= gfc_evaluate_now (tmp
, block
);
2816 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
2818 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2819 GFC_TYPE_ARRAY_LBOUND (type
, n
),
2820 GFC_TYPE_ARRAY_STRIDE (type
, n
));
2821 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2822 gfc_array_index_type
, offset
, tmp
);
2824 offset
= gfc_evaluate_now (offset
, block
);
2825 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
2829 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2830 in SE. The caller may still use se->expr and se->string_length after
2831 calling this function. */
2834 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
2835 gfc_symbol
* sym
, gfc_se
* se
,
2838 gfc_interface_sym_mapping
*sm
;
2842 gfc_symbol
*new_sym
;
2844 gfc_symtree
*new_symtree
;
2846 /* Create a new symbol to represent the actual argument. */
2847 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
2848 new_sym
->ts
= sym
->ts
;
2849 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
2850 new_sym
->attr
.referenced
= 1;
2851 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
2852 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
2853 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
2854 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
2855 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
2856 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
2857 new_sym
->attr
.function
= sym
->attr
.function
;
2859 /* Ensure that the interface is available and that
2860 descriptors are passed for array actual arguments. */
2861 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2863 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
2864 new_sym
->attr
.always_explicit
2865 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
2868 /* Create a fake symtree for it. */
2870 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
2871 new_symtree
->n
.sym
= new_sym
;
2872 gcc_assert (new_symtree
== root
);
2874 /* Create a dummy->actual mapping. */
2875 sm
= XCNEW (gfc_interface_sym_mapping
);
2876 sm
->next
= mapping
->syms
;
2878 sm
->new_sym
= new_symtree
;
2879 sm
->expr
= gfc_copy_expr (expr
);
2882 /* Stabilize the argument's value. */
2883 if (!sym
->attr
.function
&& se
)
2884 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2886 if (sym
->ts
.type
== BT_CHARACTER
)
2888 /* Create a copy of the dummy argument's length. */
2889 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
2890 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
2892 /* If the length is specified as "*", record the length that
2893 the caller is passing. We should use the callee's length
2894 in all other cases. */
2895 if (!new_sym
->ts
.u
.cl
->length
&& se
)
2897 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
2898 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
2905 /* Use the passed value as-is if the argument is a function. */
2906 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2909 /* If the argument is either a string or a pointer to a string,
2910 convert it to a boundless character type. */
2911 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
2913 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
2914 tmp
= build_pointer_type (tmp
);
2915 if (sym
->attr
.pointer
)
2916 value
= build_fold_indirect_ref_loc (input_location
,
2920 value
= fold_convert (tmp
, value
);
2923 /* If the argument is a scalar, a pointer to an array or an allocatable,
2925 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2926 value
= build_fold_indirect_ref_loc (input_location
,
2929 /* For character(*), use the actual argument's descriptor. */
2930 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
2931 value
= build_fold_indirect_ref_loc (input_location
,
2934 /* If the argument is an array descriptor, use it to determine
2935 information about the actual argument's shape. */
2936 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
2937 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
2939 /* Get the actual argument's descriptor. */
2940 desc
= build_fold_indirect_ref_loc (input_location
,
2943 /* Create the replacement variable. */
2944 tmp
= gfc_conv_descriptor_data_get (desc
);
2945 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2948 /* Use DESC to work out the upper bounds, strides and offset. */
2949 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
2952 /* Otherwise we have a packed array. */
2953 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2954 PACKED_FULL
, se
->expr
);
2956 new_sym
->backend_decl
= value
;
2960 /* Called once all dummy argument mappings have been added to MAPPING,
2961 but before the mapping is used to evaluate expressions. Pre-evaluate
2962 the length of each argument, adding any initialization code to PRE and
2963 any finalization code to POST. */
2966 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
2967 stmtblock_t
* pre
, stmtblock_t
* post
)
2969 gfc_interface_sym_mapping
*sym
;
2973 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2974 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
2975 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
2977 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
2978 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2979 gfc_init_se (&se
, NULL
);
2980 gfc_conv_expr (&se
, expr
);
2981 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
2982 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
2983 gfc_add_block_to_block (pre
, &se
.pre
);
2984 gfc_add_block_to_block (post
, &se
.post
);
2986 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
2991 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2995 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
2996 gfc_constructor_base base
)
2999 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
3001 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
3004 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
3005 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
3006 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
3012 /* Like gfc_apply_interface_mapping_to_expr, but applied to
3016 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
3021 for (; ref
; ref
= ref
->next
)
3025 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
3027 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
3028 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
3029 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
3037 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
3038 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
3044 /* Convert intrinsic function calls into result expressions. */
3047 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
3055 arg1
= expr
->value
.function
.actual
->expr
;
3056 if (expr
->value
.function
.actual
->next
)
3057 arg2
= expr
->value
.function
.actual
->next
->expr
;
3061 sym
= arg1
->symtree
->n
.sym
;
3063 if (sym
->attr
.dummy
)
3068 switch (expr
->value
.function
.isym
->id
)
3071 /* TODO figure out why this condition is necessary. */
3072 if (sym
->attr
.function
3073 && (arg1
->ts
.u
.cl
->length
== NULL
3074 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3075 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
3078 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
3082 if (!sym
->as
|| sym
->as
->rank
== 0)
3085 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3087 dup
= mpz_get_si (arg2
->value
.integer
);
3092 dup
= sym
->as
->rank
;
3096 for (; d
< dup
; d
++)
3100 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
3102 gfc_free_expr (new_expr
);
3106 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
3107 gfc_get_int_expr (gfc_default_integer_kind
,
3109 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
3111 new_expr
= gfc_multiply (new_expr
, tmp
);
3117 case GFC_ISYM_LBOUND
:
3118 case GFC_ISYM_UBOUND
:
3119 /* TODO These implementations of lbound and ubound do not limit if
3120 the size < 0, according to F95's 13.14.53 and 13.14.113. */
3122 if (!sym
->as
|| sym
->as
->rank
== 0)
3125 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
3126 d
= mpz_get_si (arg2
->value
.integer
) - 1;
3128 /* TODO: If the need arises, this could produce an array of
3132 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
3134 if (sym
->as
->lower
[d
])
3135 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
3139 if (sym
->as
->upper
[d
])
3140 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
3148 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
3152 gfc_replace_expr (expr
, new_expr
);
3158 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
3159 gfc_interface_mapping
* mapping
)
3161 gfc_formal_arglist
*f
;
3162 gfc_actual_arglist
*actual
;
3164 actual
= expr
->value
.function
.actual
;
3165 f
= map_expr
->symtree
->n
.sym
->formal
;
3167 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
3172 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
3175 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
3180 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
3182 for (d
= 0; d
< as
->rank
; d
++)
3184 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
3185 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
3188 expr
->value
.function
.esym
->as
= as
;
3191 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
3193 expr
->value
.function
.esym
->ts
.u
.cl
->length
3194 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
3196 gfc_apply_interface_mapping_to_expr (mapping
,
3197 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
3202 /* EXPR is a copy of an expression that appeared in the interface
3203 associated with MAPPING. Walk it recursively looking for references to
3204 dummy arguments that MAPPING maps to actual arguments. Replace each such
3205 reference with a reference to the associated actual argument. */
3208 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3211 gfc_interface_sym_mapping
*sym
;
3212 gfc_actual_arglist
*actual
;
3217 /* Copying an expression does not copy its length, so do that here. */
3218 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3220 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3221 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3224 /* Apply the mapping to any references. */
3225 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3227 /* ...and to the expression's symbol, if it has one. */
3228 /* TODO Find out why the condition on expr->symtree had to be moved into
3229 the loop rather than being outside it, as originally. */
3230 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3231 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3233 if (sym
->new_sym
->n
.sym
->backend_decl
)
3234 expr
->symtree
= sym
->new_sym
;
3236 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3237 /* Replace base type for polymorphic arguments. */
3238 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3239 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3240 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3243 /* ...and to subexpressions in expr->value. */
3244 switch (expr
->expr_type
)
3249 case EXPR_SUBSTRING
:
3253 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3254 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3258 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3259 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3261 if (expr
->value
.function
.esym
== NULL
3262 && expr
->value
.function
.isym
!= NULL
3263 && expr
->value
.function
.actual
->expr
->symtree
3264 && gfc_map_intrinsic_function (expr
, mapping
))
3267 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3268 if (sym
->old
== expr
->value
.function
.esym
)
3270 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3271 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3272 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3277 case EXPR_STRUCTURE
:
3278 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3291 /* Evaluate interface expression EXPR using MAPPING. Store the result
3295 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3296 gfc_se
* se
, gfc_expr
* expr
)
3298 expr
= gfc_copy_expr (expr
);
3299 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3300 gfc_conv_expr (se
, expr
);
3301 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3302 gfc_free_expr (expr
);
3306 /* Returns a reference to a temporary array into which a component of
3307 an actual argument derived type array is copied and then returned
3308 after the function call. */
3310 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3311 sym_intent intent
, bool formal_ptr
)
3319 gfc_array_info
*info
;
3329 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3331 gfc_init_se (&lse
, NULL
);
3332 gfc_init_se (&rse
, NULL
);
3334 /* Walk the argument expression. */
3335 rss
= gfc_walk_expr (expr
);
3337 gcc_assert (rss
!= gfc_ss_terminator
);
3339 /* Initialize the scalarizer. */
3340 gfc_init_loopinfo (&loop
);
3341 gfc_add_ss_to_loop (&loop
, rss
);
3343 /* Calculate the bounds of the scalarization. */
3344 gfc_conv_ss_startstride (&loop
);
3346 /* Build an ss for the temporary. */
3347 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3348 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3350 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3351 if (GFC_ARRAY_TYPE_P (base_type
)
3352 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3353 base_type
= gfc_get_element_type (base_type
);
3355 if (expr
->ts
.type
== BT_CLASS
)
3356 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3358 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3359 ? expr
->ts
.u
.cl
->backend_decl
3363 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3365 /* Associate the SS with the loop. */
3366 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3368 /* Setup the scalarizing loops. */
3369 gfc_conv_loop_setup (&loop
, &expr
->where
);
3371 /* Pass the temporary descriptor back to the caller. */
3372 info
= &loop
.temp_ss
->info
->data
.array
;
3373 parmse
->expr
= info
->descriptor
;
3375 /* Setup the gfc_se structures. */
3376 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3377 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3380 lse
.ss
= loop
.temp_ss
;
3381 gfc_mark_ss_chain_used (rss
, 1);
3382 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3384 /* Start the scalarized loop body. */
3385 gfc_start_scalarized_body (&loop
, &body
);
3387 /* Translate the expression. */
3388 gfc_conv_expr (&rse
, expr
);
3390 gfc_conv_tmp_array_ref (&lse
);
3392 if (intent
!= INTENT_OUT
)
3394 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3395 gfc_add_expr_to_block (&body
, tmp
);
3396 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3397 gfc_trans_scalarizing_loops (&loop
, &body
);
3401 /* Make sure that the temporary declaration survives by merging
3402 all the loop declarations into the current context. */
3403 for (n
= 0; n
< loop
.dimen
; n
++)
3405 gfc_merge_block_scope (&body
);
3406 body
= loop
.code
[loop
.order
[n
]];
3408 gfc_merge_block_scope (&body
);
3411 /* Add the post block after the second loop, so that any
3412 freeing of allocated memory is done at the right time. */
3413 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3415 /**********Copy the temporary back again.*********/
3417 gfc_init_se (&lse
, NULL
);
3418 gfc_init_se (&rse
, NULL
);
3420 /* Walk the argument expression. */
3421 lss
= gfc_walk_expr (expr
);
3422 rse
.ss
= loop
.temp_ss
;
3425 /* Initialize the scalarizer. */
3426 gfc_init_loopinfo (&loop2
);
3427 gfc_add_ss_to_loop (&loop2
, lss
);
3429 /* Calculate the bounds of the scalarization. */
3430 gfc_conv_ss_startstride (&loop2
);
3432 /* Setup the scalarizing loops. */
3433 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3435 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3436 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3438 gfc_mark_ss_chain_used (lss
, 1);
3439 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3441 /* Declare the variable to hold the temporary offset and start the
3442 scalarized loop body. */
3443 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3444 gfc_start_scalarized_body (&loop2
, &body
);
3446 /* Build the offsets for the temporary from the loop variables. The
3447 temporary array has lbounds of zero and strides of one in all
3448 dimensions, so this is very simple. The offset is only computed
3449 outside the innermost loop, so the overall transfer could be
3450 optimized further. */
3451 info
= &rse
.ss
->info
->data
.array
;
3452 dimen
= rse
.ss
->dimen
;
3454 tmp_index
= gfc_index_zero_node
;
3455 for (n
= dimen
- 1; n
> 0; n
--)
3458 tmp
= rse
.loop
->loopvar
[n
];
3459 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3460 tmp
, rse
.loop
->from
[n
]);
3461 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3464 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3465 gfc_array_index_type
,
3466 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3467 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3468 gfc_array_index_type
,
3469 tmp_str
, gfc_index_one_node
);
3471 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3472 gfc_array_index_type
, tmp
, tmp_str
);
3475 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3476 gfc_array_index_type
,
3477 tmp_index
, rse
.loop
->from
[0]);
3478 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3480 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3481 gfc_array_index_type
,
3482 rse
.loop
->loopvar
[0], offset
);
3484 /* Now use the offset for the reference. */
3485 tmp
= build_fold_indirect_ref_loc (input_location
,
3487 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3489 if (expr
->ts
.type
== BT_CHARACTER
)
3490 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3492 gfc_conv_expr (&lse
, expr
);
3494 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3496 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3497 gfc_add_expr_to_block (&body
, tmp
);
3499 /* Generate the copying loops. */
3500 gfc_trans_scalarizing_loops (&loop2
, &body
);
3502 /* Wrap the whole thing up by adding the second loop to the post-block
3503 and following it by the post-block of the first loop. In this way,
3504 if the temporary needs freeing, it is done after use! */
3505 if (intent
!= INTENT_IN
)
3507 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3508 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3511 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3513 gfc_cleanup_loop (&loop
);
3514 gfc_cleanup_loop (&loop2
);
3516 /* Pass the string length to the argument expression. */
3517 if (expr
->ts
.type
== BT_CHARACTER
)
3518 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3520 /* Determine the offset for pointer formal arguments and set the
3524 size
= gfc_index_one_node
;
3525 offset
= gfc_index_zero_node
;
3526 for (n
= 0; n
< dimen
; n
++)
3528 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3530 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3531 gfc_array_index_type
, tmp
,
3532 gfc_index_one_node
);
3533 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3537 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3540 gfc_index_one_node
);
3541 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3542 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3543 gfc_array_index_type
,
3545 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3546 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3547 gfc_array_index_type
,
3548 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3549 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3550 gfc_array_index_type
,
3551 tmp
, gfc_index_one_node
);
3552 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3553 gfc_array_index_type
, size
, tmp
);
3556 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3560 /* We want either the address for the data or the address of the descriptor,
3561 depending on the mode of passing array arguments. */
3563 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3565 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3571 /* Generate the code for argument list functions. */
3574 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3576 /* Pass by value for g77 %VAL(arg), pass the address
3577 indirectly for %LOC, else by reference. Thus %REF
3578 is a "do-nothing" and %LOC is the same as an F95
3580 if (strncmp (name
, "%VAL", 4) == 0)
3581 gfc_conv_expr (se
, expr
);
3582 else if (strncmp (name
, "%LOC", 4) == 0)
3584 gfc_conv_expr_reference (se
, expr
);
3585 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3587 else if (strncmp (name
, "%REF", 4) == 0)
3588 gfc_conv_expr_reference (se
, expr
);
3590 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3594 /* The following routine generates code for the intrinsic
3595 procedures from the ISO_C_BINDING module:
3597 * C_FUNLOC (function)
3598 * C_F_POINTER (subroutine)
3599 * C_F_PROCPOINTER (subroutine)
3600 * C_ASSOCIATED (function)
3601 One exception which is not handled here is C_F_POINTER with non-scalar
3602 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3605 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
3606 gfc_actual_arglist
* arg
)
3610 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
3612 if (arg
->expr
->rank
== 0)
3613 gfc_conv_expr_reference (se
, arg
->expr
);
3617 /* This is really the actual arg because no formal arglist is
3618 created for C_LOC. */
3619 fsym
= arg
->expr
->symtree
->n
.sym
;
3621 /* We should want it to do g77 calling convention. */
3623 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3624 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3625 f
= f
|| !sym
->attr
.always_explicit
;
3627 gfc_conv_array_parameter (se
, arg
->expr
, f
, NULL
, NULL
, NULL
);
3630 /* TODO -- the following two lines shouldn't be necessary, but if
3631 they're removed, a bug is exposed later in the code path.
3632 This workaround was thus introduced, but will have to be
3633 removed; please see PR 35150 for details about the issue. */
3634 se
->expr
= convert (pvoid_type_node
, se
->expr
);
3635 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3639 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3641 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
3642 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
3643 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
3644 gfc_conv_expr_reference (se
, arg
->expr
);
3648 else if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
3649 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3651 /* Convert c_f_pointer and c_f_procpointer. */
3656 tree desc
, dim
, tmp
, stride
, offset
;
3657 stmtblock_t body
, block
;
3660 gfc_init_se (&cptrse
, NULL
);
3661 gfc_conv_expr (&cptrse
, arg
->expr
);
3662 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
3663 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
3665 gfc_init_se (&fptrse
, NULL
);
3666 if (arg
->next
->expr
->rank
== 0)
3668 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
3669 || gfc_is_proc_ptr_comp (arg
->next
->expr
))
3670 fptrse
.want_pointer
= 1;
3672 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
3673 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
3674 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
3675 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3676 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
3677 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
3679 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3680 TREE_TYPE (fptrse
.expr
),
3682 fold_convert (TREE_TYPE (fptrse
.expr
),
3687 gfc_start_block (&block
);
3689 /* Get the descriptor of the Fortran pointer. */
3690 fptrse
.descriptor_only
= 1;
3691 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
3692 gfc_add_block_to_block (&block
, &fptrse
.pre
);
3695 /* Set data value, dtype, and offset. */
3696 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
3697 gfc_conv_descriptor_data_set (&block
, desc
,
3698 fold_convert (tmp
, cptrse
.expr
));
3699 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
3700 gfc_get_dtype (TREE_TYPE (desc
)));
3702 /* Start scalarization of the bounds, using the shape argument. */
3704 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
3705 gcc_assert (shape_ss
!= gfc_ss_terminator
);
3706 gfc_init_se (&shapese
, NULL
);
3708 gfc_init_loopinfo (&loop
);
3709 gfc_add_ss_to_loop (&loop
, shape_ss
);
3710 gfc_conv_ss_startstride (&loop
);
3711 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
3712 gfc_mark_ss_chain_used (shape_ss
, 1);
3714 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
3715 shapese
.ss
= shape_ss
;
3717 stride
= gfc_create_var (gfc_array_index_type
, "stride");
3718 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3719 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
3720 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
3723 gfc_start_scalarized_body (&loop
, &body
);
3725 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3726 loop
.loopvar
[0], loop
.from
[0]);
3728 /* Set bounds and stride. */
3729 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
3730 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
3732 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
3733 gfc_add_block_to_block (&body
, &shapese
.pre
);
3734 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
3735 gfc_add_block_to_block (&body
, &shapese
.post
);
3737 /* Calculate offset. */
3738 gfc_add_modify (&body
, offset
,
3739 fold_build2_loc (input_location
, PLUS_EXPR
,
3740 gfc_array_index_type
, offset
, stride
));
3741 /* Update stride. */
3742 gfc_add_modify (&body
, stride
,
3743 fold_build2_loc (input_location
, MULT_EXPR
,
3744 gfc_array_index_type
, stride
,
3745 fold_convert (gfc_array_index_type
,
3747 /* Finish scalarization loop. */
3748 gfc_trans_scalarizing_loops (&loop
, &body
);
3749 gfc_add_block_to_block (&block
, &loop
.pre
);
3750 gfc_add_block_to_block (&block
, &loop
.post
);
3751 gfc_add_block_to_block (&block
, &fptrse
.post
);
3752 gfc_cleanup_loop (&loop
);
3754 gfc_add_modify (&block
, offset
,
3755 fold_build1_loc (input_location
, NEGATE_EXPR
,
3756 gfc_array_index_type
, offset
));
3757 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
3759 se
->expr
= gfc_finish_block (&block
);
3762 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3767 /* Build the addr_expr for the first argument. The argument is
3768 already an *address* so we don't need to set want_pointer in
3770 gfc_init_se (&arg1se
, NULL
);
3771 gfc_conv_expr (&arg1se
, arg
->expr
);
3772 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3773 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3775 /* See if we were given two arguments. */
3776 if (arg
->next
== NULL
)
3777 /* Only given one arg so generate a null and do a
3778 not-equal comparison against the first arg. */
3779 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3781 fold_convert (TREE_TYPE (arg1se
.expr
),
3782 null_pointer_node
));
3788 /* Given two arguments so build the arg2se from second arg. */
3789 gfc_init_se (&arg2se
, NULL
);
3790 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
3791 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3792 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3794 /* Generate test to compare that the two args are equal. */
3795 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3796 arg1se
.expr
, arg2se
.expr
);
3797 /* Generate test to ensure that the first arg is not null. */
3798 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
3800 arg1se
.expr
, null_pointer_node
);
3802 /* Finally, the generated test must check that both arg1 is not
3803 NULL and that it is equal to the second arg. */
3804 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3806 not_null_expr
, eq_expr
);
3812 /* Nothing was done. */
3817 /* Generate code for a procedure call. Note can return se->post != NULL.
3818 If se->direct_byref is set then se->expr contains the return parameter.
3819 Return nonzero, if the call has alternate specifiers.
3820 'expr' is only needed for procedure pointer components. */
3823 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3824 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3825 vec
<tree
, va_gc
> *append_args
)
3827 gfc_interface_mapping mapping
;
3828 vec
<tree
, va_gc
> *arglist
;
3829 vec
<tree
, va_gc
> *retargs
;
3833 gfc_array_info
*info
;
3840 vec
<tree
, va_gc
> *stringargs
;
3842 gfc_formal_arglist
*formal
;
3843 gfc_actual_arglist
*arg
;
3844 int has_alternate_specifier
= 0;
3845 bool need_interface_mapping
;
3852 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3853 gfc_component
*comp
= NULL
;
3863 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3864 && conv_isocbinding_procedure (se
, sym
, args
))
3867 comp
= gfc_get_proc_ptr_comp (expr
);
3871 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3873 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3874 if (se
->ss
->info
->useflags
)
3876 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3877 && sym
->result
->attr
.dimension
)
3878 || (comp
&& comp
->attr
.dimension
));
3879 gcc_assert (se
->loop
!= NULL
);
3881 /* Access the previously obtained result. */
3882 gfc_conv_tmp_array_ref (se
);
3886 info
= &se
->ss
->info
->data
.array
;
3891 gfc_init_block (&post
);
3892 gfc_init_interface_mapping (&mapping
);
3895 formal
= sym
->formal
;
3896 need_interface_mapping
= sym
->attr
.dimension
||
3897 (sym
->ts
.type
== BT_CHARACTER
3898 && sym
->ts
.u
.cl
->length
3899 && sym
->ts
.u
.cl
->length
->expr_type
3904 formal
= comp
->formal
;
3905 need_interface_mapping
= comp
->attr
.dimension
||
3906 (comp
->ts
.type
== BT_CHARACTER
3907 && comp
->ts
.u
.cl
->length
3908 && comp
->ts
.u
.cl
->length
->expr_type
3912 base_object
= NULL_TREE
;
3914 /* Evaluate the arguments. */
3915 for (arg
= args
; arg
!= NULL
;
3916 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3919 fsym
= formal
? formal
->sym
: NULL
;
3920 parm_kind
= MISSING
;
3922 /* Class array expressions are sometimes coming completely unadorned
3923 with either arrayspec or _data component. Correct that here.
3924 OOP-TODO: Move this to the frontend. */
3925 if (e
&& e
->expr_type
== EXPR_VARIABLE
3927 && e
->ts
.type
== BT_CLASS
3928 && (CLASS_DATA (e
)->attr
.codimension
3929 || CLASS_DATA (e
)->attr
.dimension
))
3931 gfc_typespec temp_ts
= e
->ts
;
3932 gfc_add_class_array_ref (e
);
3938 if (se
->ignore_optional
)
3940 /* Some intrinsics have already been resolved to the correct
3944 else if (arg
->label
)
3946 has_alternate_specifier
= 1;
3951 /* Pass a NULL pointer for an absent arg. */
3952 gfc_init_se (&parmse
, NULL
);
3953 parmse
.expr
= null_pointer_node
;
3954 if (arg
->missing_arg_type
== BT_CHARACTER
)
3955 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3958 else if (arg
->expr
->expr_type
== EXPR_NULL
3959 && fsym
&& !fsym
->attr
.pointer
3960 && (fsym
->ts
.type
!= BT_CLASS
3961 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
3963 /* Pass a NULL pointer to denote an absent arg. */
3964 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
3965 && (fsym
->ts
.type
!= BT_CLASS
3966 || !CLASS_DATA (fsym
)->attr
.allocatable
));
3967 gfc_init_se (&parmse
, NULL
);
3968 parmse
.expr
= null_pointer_node
;
3969 if (arg
->missing_arg_type
== BT_CHARACTER
)
3970 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3972 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
3973 && e
->ts
.type
== BT_DERIVED
)
3975 /* The derived type needs to be converted to a temporary
3977 gfc_init_se (&parmse
, se
);
3978 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
,
3980 && e
->expr_type
== EXPR_VARIABLE
3981 && e
->symtree
->n
.sym
->attr
.optional
,
3982 CLASS_DATA (fsym
)->attr
.class_pointer
3983 || CLASS_DATA (fsym
)->attr
.allocatable
);
3985 else if (se
->ss
&& se
->ss
->info
->useflags
)
3991 /* An elemental function inside a scalarized loop. */
3992 gfc_init_se (&parmse
, se
);
3993 parm_kind
= ELEMENTAL
;
3995 if (ss
->dimen
> 0 && e
->expr_type
== EXPR_VARIABLE
3996 && ss
->info
->data
.array
.ref
== NULL
)
3998 gfc_conv_tmp_array_ref (&parmse
);
3999 if (e
->ts
.type
== BT_CHARACTER
)
4000 gfc_conv_string_parameter (&parmse
);
4002 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4005 gfc_conv_expr_reference (&parmse
, e
);
4007 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
4008 && gfc_is_class_container_ref (e
))
4010 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4012 if (fsym
->attr
.optional
&& e
->expr_type
== EXPR_VARIABLE
4013 && e
->symtree
->n
.sym
->attr
.optional
)
4015 tree cond
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4016 parmse
.expr
= build3_loc (input_location
, COND_EXPR
,
4017 TREE_TYPE (parmse
.expr
),
4019 fold_convert (TREE_TYPE (parmse
.expr
),
4020 null_pointer_node
));
4024 /* If we are passing an absent array as optional dummy to an
4025 elemental procedure, make sure that we pass NULL when the data
4026 pointer is NULL. We need this extra conditional because of
4027 scalarization which passes arrays elements to the procedure,
4028 ignoring the fact that the array can be absent/unallocated/... */
4029 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
4031 tree descriptor_data
;
4033 descriptor_data
= ss
->info
->data
.array
.data
;
4034 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
4036 fold_convert (TREE_TYPE (descriptor_data
),
4037 null_pointer_node
));
4039 = fold_build3_loc (input_location
, COND_EXPR
,
4040 TREE_TYPE (parmse
.expr
),
4042 fold_convert (TREE_TYPE (parmse
.expr
),
4047 /* The scalarizer does not repackage the reference to a class
4048 array - instead it returns a pointer to the data element. */
4049 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
4050 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true,
4051 fsym
->attr
.intent
!= INTENT_IN
4052 && (CLASS_DATA (fsym
)->attr
.class_pointer
4053 || CLASS_DATA (fsym
)->attr
.allocatable
),
4055 && e
->expr_type
== EXPR_VARIABLE
4056 && e
->symtree
->n
.sym
->attr
.optional
,
4057 CLASS_DATA (fsym
)->attr
.class_pointer
4058 || CLASS_DATA (fsym
)->attr
.allocatable
);
4065 gfc_init_se (&parmse
, NULL
);
4067 /* Check whether the expression is a scalar or not; we cannot use
4068 e->rank as it can be nonzero for functions arguments. */
4069 argss
= gfc_walk_expr (e
);
4070 scalar
= argss
== gfc_ss_terminator
;
4072 gfc_free_ss_chain (argss
);
4074 /* Special handling for passing scalar polymorphic coarrays;
4075 otherwise one passes "class->_data.data" instead of "&class". */
4076 if (e
->rank
== 0 && e
->ts
.type
== BT_CLASS
4077 && fsym
&& fsym
->ts
.type
== BT_CLASS
4078 && CLASS_DATA (fsym
)->attr
.codimension
4079 && !CLASS_DATA (fsym
)->attr
.dimension
)
4081 gfc_add_class_array_ref (e
);
4082 parmse
.want_coarray
= 1;
4086 /* A scalar or transformational function. */
4089 if (e
->expr_type
== EXPR_VARIABLE
4090 && e
->symtree
->n
.sym
->attr
.cray_pointee
4091 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
4093 /* The Cray pointer needs to be converted to a pointer to
4094 a type given by the expression. */
4095 gfc_conv_expr (&parmse
, e
);
4096 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
4097 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
4098 parmse
.expr
= convert (type
, tmp
);
4100 else if (fsym
&& fsym
->attr
.value
)
4102 if (fsym
->ts
.type
== BT_CHARACTER
4103 && fsym
->ts
.is_c_interop
4104 && fsym
->ns
->proc_name
!= NULL
4105 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
4108 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
4109 if (parmse
.expr
== NULL
)
4110 gfc_conv_expr (&parmse
, e
);
4113 gfc_conv_expr (&parmse
, e
);
4115 else if (arg
->name
&& arg
->name
[0] == '%')
4116 /* Argument list functions %VAL, %LOC and %REF are signalled
4117 through arg->name. */
4118 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
4119 else if ((e
->expr_type
== EXPR_FUNCTION
)
4120 && ((e
->value
.function
.esym
4121 && e
->value
.function
.esym
->result
->attr
.pointer
)
4122 || (!e
->value
.function
.esym
4123 && e
->symtree
->n
.sym
->attr
.pointer
))
4124 && fsym
&& fsym
->attr
.target
)
4126 gfc_conv_expr (&parmse
, e
);
4127 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4129 else if (e
->expr_type
== EXPR_FUNCTION
4130 && e
->symtree
->n
.sym
->result
4131 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
4132 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
4134 /* Functions returning procedure pointers. */
4135 gfc_conv_expr (&parmse
, e
);
4136 if (fsym
&& fsym
->attr
.proc_pointer
)
4137 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4141 if (e
->ts
.type
== BT_CLASS
&& fsym
4142 && fsym
->ts
.type
== BT_CLASS
4143 && (!CLASS_DATA (fsym
)->as
4144 || CLASS_DATA (fsym
)->as
->type
!= AS_ASSUMED_RANK
)
4145 && CLASS_DATA (e
)->attr
.codimension
)
4147 gcc_assert (!CLASS_DATA (fsym
)->attr
.codimension
);
4148 gcc_assert (!CLASS_DATA (fsym
)->as
);
4149 gfc_add_class_array_ref (e
);
4150 parmse
.want_coarray
= 1;
4151 gfc_conv_expr_reference (&parmse
, e
);
4152 class_scalar_coarray_to_class (&parmse
, e
, fsym
->ts
,
4154 && e
->expr_type
== EXPR_VARIABLE
);
4157 gfc_conv_expr_reference (&parmse
, e
);
4159 /* Catch base objects that are not variables. */
4160 if (e
->ts
.type
== BT_CLASS
4161 && e
->expr_type
!= EXPR_VARIABLE
4162 && expr
&& e
== expr
->base_expr
)
4163 base_object
= build_fold_indirect_ref_loc (input_location
,
4166 /* A class array element needs converting back to be a
4167 class object, if the formal argument is a class object. */
4168 if (fsym
&& fsym
->ts
.type
== BT_CLASS
4169 && e
->ts
.type
== BT_CLASS
4170 && ((CLASS_DATA (fsym
)->as
4171 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
4172 || CLASS_DATA (e
)->attr
.dimension
))
4173 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4174 fsym
->attr
.intent
!= INTENT_IN
4175 && (CLASS_DATA (fsym
)->attr
.class_pointer
4176 || CLASS_DATA (fsym
)->attr
.allocatable
),
4178 && e
->expr_type
== EXPR_VARIABLE
4179 && e
->symtree
->n
.sym
->attr
.optional
,
4180 CLASS_DATA (fsym
)->attr
.class_pointer
4181 || CLASS_DATA (fsym
)->attr
.allocatable
);
4183 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4184 allocated on entry, it must be deallocated. */
4185 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
4186 && (fsym
->attr
.allocatable
4187 || (fsym
->ts
.type
== BT_CLASS
4188 && CLASS_DATA (fsym
)->attr
.allocatable
)))
4193 gfc_init_block (&block
);
4195 if (e
->ts
.type
== BT_CLASS
)
4196 ptr
= gfc_class_data_get (ptr
);
4198 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
4199 NULL_TREE
, NULL_TREE
,
4200 NULL_TREE
, true, NULL
,
4202 gfc_add_expr_to_block (&block
, tmp
);
4203 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4204 void_type_node
, ptr
,
4206 gfc_add_expr_to_block (&block
, tmp
);
4208 if (fsym
->ts
.type
== BT_CLASS
)
4211 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
4212 tmp
= gfc_get_symbol_decl (vtab
);
4213 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4214 ptr
= gfc_class_vptr_get (parmse
.expr
);
4215 gfc_add_modify (&block
, ptr
,
4216 fold_convert (TREE_TYPE (ptr
), tmp
));
4217 gfc_add_expr_to_block (&block
, tmp
);
4220 if (fsym
->attr
.optional
4221 && e
->expr_type
== EXPR_VARIABLE
4222 && e
->symtree
->n
.sym
->attr
.optional
)
4224 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4226 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4227 gfc_finish_block (&block
),
4228 build_empty_stmt (input_location
));
4231 tmp
= gfc_finish_block (&block
);
4233 gfc_add_expr_to_block (&se
->pre
, tmp
);
4236 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
4237 || fsym
->ts
.type
== BT_ASSUMED
)
4238 && e
->ts
.type
== BT_CLASS
4239 && !CLASS_DATA (e
)->attr
.dimension
4240 && !CLASS_DATA (e
)->attr
.codimension
)
4241 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
4243 /* Wrap scalar variable in a descriptor. We need to convert
4244 the address of a pointer back to the pointer itself before,
4245 we can assign it to the data field. */
4247 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
4248 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
4251 if (TREE_CODE (tmp
) == ADDR_EXPR
4252 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
4253 tmp
= TREE_OPERAND (tmp
, 0);
4254 parmse
.expr
= conv_scalar_to_descriptor (&parmse
, tmp
,
4256 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
4259 else if (fsym
&& e
->expr_type
!= EXPR_NULL
4260 && ((fsym
->attr
.pointer
4261 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
4262 || (fsym
->attr
.proc_pointer
4263 && !(e
->expr_type
== EXPR_VARIABLE
4264 && e
->symtree
->n
.sym
->attr
.dummy
))
4265 || (fsym
->attr
.proc_pointer
4266 && e
->expr_type
== EXPR_VARIABLE
4267 && gfc_is_proc_ptr_comp (e
))
4268 || (fsym
->attr
.allocatable
4269 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
4271 /* Scalar pointer dummy args require an extra level of
4272 indirection. The null pointer already contains
4273 this level of indirection. */
4274 parm_kind
= SCALAR_POINTER
;
4275 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4279 else if (e
->ts
.type
== BT_CLASS
4280 && fsym
&& fsym
->ts
.type
== BT_CLASS
4281 && (CLASS_DATA (fsym
)->attr
.dimension
4282 || CLASS_DATA (fsym
)->attr
.codimension
))
4284 /* Pass a class array. */
4285 gfc_conv_expr_descriptor (&parmse
, e
);
4286 /* The conversion does not repackage the reference to a class
4287 array - _data descriptor. */
4288 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false,
4289 fsym
->attr
.intent
!= INTENT_IN
4290 && (CLASS_DATA (fsym
)->attr
.class_pointer
4291 || CLASS_DATA (fsym
)->attr
.allocatable
),
4293 && e
->expr_type
== EXPR_VARIABLE
4294 && e
->symtree
->n
.sym
->attr
.optional
,
4295 CLASS_DATA (fsym
)->attr
.class_pointer
4296 || CLASS_DATA (fsym
)->attr
.allocatable
);
4300 /* If the procedure requires an explicit interface, the actual
4301 argument is passed according to the corresponding formal
4302 argument. If the corresponding formal argument is a POINTER,
4303 ALLOCATABLE or assumed shape, we do not use g77's calling
4304 convention, and pass the address of the array descriptor
4305 instead. Otherwise we use g77's calling convention. */
4308 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4309 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4310 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4312 f
= f
|| !comp
->attr
.always_explicit
;
4314 f
= f
|| !sym
->attr
.always_explicit
;
4316 /* If the argument is a function call that may not create
4317 a temporary for the result, we have to check that we
4318 can do it, i.e. that there is no alias between this
4319 argument and another one. */
4320 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4326 intent
= fsym
->attr
.intent
;
4328 intent
= INTENT_UNKNOWN
;
4330 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4332 parmse
.force_tmp
= 1;
4334 iarg
= e
->value
.function
.actual
->expr
;
4336 /* Temporary needed if aliasing due to host association. */
4337 if (sym
->attr
.contained
4339 && !sym
->attr
.implicit_pure
4340 && !sym
->attr
.use_assoc
4341 && iarg
->expr_type
== EXPR_VARIABLE
4342 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4343 parmse
.force_tmp
= 1;
4345 /* Ditto within module. */
4346 if (sym
->attr
.use_assoc
4348 && !sym
->attr
.implicit_pure
4349 && iarg
->expr_type
== EXPR_VARIABLE
4350 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4351 parmse
.force_tmp
= 1;
4354 if (e
->expr_type
== EXPR_VARIABLE
4355 && is_subref_array (e
))
4356 /* The actual argument is a component reference to an
4357 array of derived types. In this case, the argument
4358 is converted to a temporary, which is passed and then
4359 written back after the procedure call. */
4360 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4361 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4362 fsym
&& fsym
->attr
.pointer
);
4363 else if (gfc_is_class_array_ref (e
, NULL
)
4364 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4365 /* The actual argument is a component reference to an
4366 array of derived types. In this case, the argument
4367 is converted to a temporary, which is passed and then
4368 written back after the procedure call.
4369 OOP-TODO: Insert code so that if the dynamic type is
4370 the same as the declared type, copy-in/copy-out does
4372 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4373 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4374 fsym
&& fsym
->attr
.pointer
);
4376 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4378 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4379 allocated on entry, it must be deallocated. */
4380 if (fsym
&& fsym
->attr
.allocatable
4381 && fsym
->attr
.intent
== INTENT_OUT
)
4383 tmp
= build_fold_indirect_ref_loc (input_location
,
4385 tmp
= gfc_trans_dealloc_allocated (tmp
, false);
4386 if (fsym
->attr
.optional
4387 && e
->expr_type
== EXPR_VARIABLE
4388 && e
->symtree
->n
.sym
->attr
.optional
)
4389 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4391 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4392 tmp
, build_empty_stmt (input_location
));
4393 gfc_add_expr_to_block (&se
->pre
, tmp
);
4398 /* The case with fsym->attr.optional is that of a user subroutine
4399 with an interface indicating an optional argument. When we call
4400 an intrinsic subroutine, however, fsym is NULL, but we might still
4401 have an optional argument, so we proceed to the substitution
4403 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4405 /* If an optional argument is itself an optional dummy argument,
4406 check its presence and substitute a null if absent. This is
4407 only needed when passing an array to an elemental procedure
4408 as then array elements are accessed - or no NULL pointer is
4409 allowed and a "1" or "0" should be passed if not present.
4410 When passing a non-array-descriptor full array to a
4411 non-array-descriptor dummy, no check is needed. For
4412 array-descriptor actual to array-descriptor dummy, see
4413 PR 41911 for why a check has to be inserted.
4414 fsym == NULL is checked as intrinsics required the descriptor
4415 but do not always set fsym. */
4416 if (e
->expr_type
== EXPR_VARIABLE
4417 && e
->symtree
->n
.sym
->attr
.optional
4418 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4419 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4423 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4424 || fsym
->as
->type
== AS_ASSUMED_RANK
4425 || fsym
->as
->type
== AS_DEFERRED
))))))
4426 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4427 e
->representation
.length
);
4432 /* Obtain the character length of an assumed character length
4433 length procedure from the typespec. */
4434 if (fsym
->ts
.type
== BT_CHARACTER
4435 && parmse
.string_length
== NULL_TREE
4436 && e
->ts
.type
== BT_PROCEDURE
4437 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4438 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4439 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4441 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4442 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4446 if (fsym
&& need_interface_mapping
&& e
)
4447 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4449 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4450 gfc_add_block_to_block (&post
, &parmse
.post
);
4452 /* Allocated allocatable components of derived types must be
4453 deallocated for non-variable scalars. Non-variable arrays are
4454 dealt with in trans-array.c(gfc_conv_array_parameter). */
4455 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4456 && e
->ts
.u
.derived
->attr
.alloc_comp
4457 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4458 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4461 tmp
= build_fold_indirect_ref_loc (input_location
,
4463 parm_rank
= e
->rank
;
4471 case (SCALAR_POINTER
):
4472 tmp
= build_fold_indirect_ref_loc (input_location
,
4477 if (e
->expr_type
== EXPR_OP
4478 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4479 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4482 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4483 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4484 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4487 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4489 /* The derived type is passed to gfc_deallocate_alloc_comp.
4490 Therefore, class actuals can handled correctly but derived
4491 types passed to class formals need the _data component. */
4492 tmp
= gfc_class_data_get (tmp
);
4493 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4494 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4497 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4499 gfc_add_expr_to_block (&se
->post
, tmp
);
4502 /* Add argument checking of passing an unallocated/NULL actual to
4503 a nonallocatable/nonpointer dummy. */
4505 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4507 symbol_attribute attr
;
4511 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4512 attr
= gfc_expr_attr (e
);
4514 goto end_pointer_check
;
4516 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4517 allocatable to an optional dummy, cf. 12.5.2.12. */
4518 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4519 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4520 goto end_pointer_check
;
4524 /* If the actual argument is an optional pointer/allocatable and
4525 the formal argument takes an nonpointer optional value,
4526 it is invalid to pass a non-present argument on, even
4527 though there is no technical reason for this in gfortran.
4528 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4529 tree present
, null_ptr
, type
;
4531 if (attr
.allocatable
4532 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4533 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4534 "allocated or not present", e
->symtree
->n
.sym
->name
);
4535 else if (attr
.pointer
4536 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4537 asprintf (&msg
, "Pointer actual argument '%s' is not "
4538 "associated or not present",
4539 e
->symtree
->n
.sym
->name
);
4540 else if (attr
.proc_pointer
4541 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4542 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4543 "associated or not present",
4544 e
->symtree
->n
.sym
->name
);
4546 goto end_pointer_check
;
4548 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4549 type
= TREE_TYPE (present
);
4550 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4551 boolean_type_node
, present
,
4553 null_pointer_node
));
4554 type
= TREE_TYPE (parmse
.expr
);
4555 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4556 boolean_type_node
, parmse
.expr
,
4558 null_pointer_node
));
4559 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4560 boolean_type_node
, present
, null_ptr
);
4564 if (attr
.allocatable
4565 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4566 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4567 "allocated", e
->symtree
->n
.sym
->name
);
4568 else if (attr
.pointer
4569 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4570 asprintf (&msg
, "Pointer actual argument '%s' is not "
4571 "associated", e
->symtree
->n
.sym
->name
);
4572 else if (attr
.proc_pointer
4573 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4574 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4575 "associated", e
->symtree
->n
.sym
->name
);
4577 goto end_pointer_check
;
4581 /* If the argument is passed by value, we need to strip the
4583 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4584 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4586 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4587 boolean_type_node
, tmp
,
4588 fold_convert (TREE_TYPE (tmp
),
4589 null_pointer_node
));
4592 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4598 /* Deferred length dummies pass the character length by reference
4599 so that the value can be returned. */
4600 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4602 tmp
= parmse
.string_length
;
4603 if (TREE_CODE (tmp
) != VAR_DECL
)
4604 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4605 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4608 /* Character strings are passed as two parameters, a length and a
4609 pointer - except for Bind(c) which only passes the pointer. */
4610 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
4611 vec_safe_push (stringargs
, parmse
.string_length
);
4613 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4614 pass the token and the offset as additional arguments. */
4615 if (fsym
&& fsym
->attr
.codimension
4616 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4617 && !fsym
->attr
.allocatable
4620 /* Token and offset. */
4621 vec_safe_push (stringargs
, null_pointer_node
);
4622 vec_safe_push (stringargs
, build_int_cst (gfc_array_index_type
, 0));
4623 gcc_assert (fsym
->attr
.optional
);
4625 else if (fsym
&& fsym
->attr
.codimension
4626 && !fsym
->attr
.allocatable
4627 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4629 tree caf_decl
, caf_type
;
4632 caf_decl
= get_tree_for_caf_expr (e
);
4633 caf_type
= TREE_TYPE (caf_decl
);
4635 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4636 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4637 tmp
= gfc_conv_descriptor_token (caf_decl
);
4638 else if (DECL_LANG_SPECIFIC (caf_decl
)
4639 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4640 tmp
= GFC_DECL_TOKEN (caf_decl
);
4643 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4644 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4645 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4648 vec_safe_push (stringargs
, tmp
);
4650 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4651 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4652 offset
= build_int_cst (gfc_array_index_type
, 0);
4653 else if (DECL_LANG_SPECIFIC (caf_decl
)
4654 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4655 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4656 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4657 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4659 offset
= build_int_cst (gfc_array_index_type
, 0);
4661 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4662 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4665 gcc_assert (POINTER_TYPE_P (caf_type
));
4669 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4670 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4671 && !fsym
->attr
.allocatable
))
4673 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4674 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4675 (TREE_TYPE (parmse
.expr
))));
4676 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4677 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4679 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4680 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4683 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4687 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4688 gfc_array_index_type
,
4689 fold_convert (gfc_array_index_type
, tmp2
),
4690 fold_convert (gfc_array_index_type
, tmp
));
4691 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4692 gfc_array_index_type
, offset
, tmp
);
4694 vec_safe_push (stringargs
, offset
);
4697 vec_safe_push (arglist
, parmse
.expr
);
4699 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4706 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4707 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4708 else if (ts
.type
== BT_CHARACTER
)
4710 if (ts
.u
.cl
->length
== NULL
)
4712 /* Assumed character length results are not allowed by 5.1.1.5 of the
4713 standard and are trapped in resolve.c; except in the case of SPREAD
4714 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4715 we take the character length of the first argument for the result.
4716 For dummies, we have to look through the formal argument list for
4717 this function and use the character length found there.*/
4719 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4720 else if (!sym
->attr
.dummy
)
4721 cl
.backend_decl
= (*stringargs
)[0];
4724 formal
= sym
->ns
->proc_name
->formal
;
4725 for (; formal
; formal
= formal
->next
)
4726 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4727 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4729 len
= cl
.backend_decl
;
4735 /* Calculate the length of the returned string. */
4736 gfc_init_se (&parmse
, NULL
);
4737 if (need_interface_mapping
)
4738 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4740 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4741 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4742 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4744 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4745 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4746 gfc_charlen_type_node
, tmp
,
4747 build_int_cst (gfc_charlen_type_node
, 0));
4748 cl
.backend_decl
= tmp
;
4751 /* Set up a charlen structure for it. */
4756 len
= cl
.backend_decl
;
4759 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4760 || (!comp
&& gfc_return_by_reference (sym
));
4763 if (se
->direct_byref
)
4765 /* Sometimes, too much indirection can be applied; e.g. for
4766 function_result = array_valued_recursive_function. */
4767 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4768 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4769 && GFC_DESCRIPTOR_TYPE_P
4770 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4771 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4774 /* If the lhs of an assignment x = f(..) is allocatable and
4775 f2003 is allowed, we must do the automatic reallocation.
4776 TODO - deal with intrinsics, without using a temporary. */
4777 if (gfc_option
.flag_realloc_lhs
4778 && se
->ss
&& se
->ss
->loop_chain
4779 && se
->ss
->loop_chain
->is_alloc_lhs
4780 && !expr
->value
.function
.isym
4781 && sym
->result
->as
!= NULL
)
4783 /* Evaluate the bounds of the result, if known. */
4784 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4787 /* Perform the automatic reallocation. */
4788 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4790 gfc_add_expr_to_block (&se
->pre
, tmp
);
4792 /* Pass the temporary as the first argument. */
4793 result
= info
->descriptor
;
4796 result
= build_fold_indirect_ref_loc (input_location
,
4798 vec_safe_push (retargs
, se
->expr
);
4800 else if (comp
&& comp
->attr
.dimension
)
4802 gcc_assert (se
->loop
&& info
);
4804 /* Set the type of the array. */
4805 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4806 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4808 /* Evaluate the bounds of the result, if known. */
4809 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4811 /* If the lhs of an assignment x = f(..) is allocatable and
4812 f2003 is allowed, we must not generate the function call
4813 here but should just send back the results of the mapping.
4814 This is signalled by the function ss being flagged. */
4815 if (gfc_option
.flag_realloc_lhs
4816 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4818 gfc_free_interface_mapping (&mapping
);
4819 return has_alternate_specifier
;
4822 /* Create a temporary to store the result. In case the function
4823 returns a pointer, the temporary will be a shallow copy and
4824 mustn't be deallocated. */
4825 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4826 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4827 tmp
, NULL_TREE
, false,
4828 !comp
->attr
.pointer
, callee_alloc
,
4829 &se
->ss
->info
->expr
->where
);
4831 /* Pass the temporary as the first argument. */
4832 result
= info
->descriptor
;
4833 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4834 vec_safe_push (retargs
, tmp
);
4836 else if (!comp
&& sym
->result
->attr
.dimension
)
4838 gcc_assert (se
->loop
&& info
);
4840 /* Set the type of the array. */
4841 tmp
= gfc_typenode_for_spec (&ts
);
4842 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4844 /* Evaluate the bounds of the result, if known. */
4845 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
4847 /* If the lhs of an assignment x = f(..) is allocatable and
4848 f2003 is allowed, we must not generate the function call
4849 here but should just send back the results of the mapping.
4850 This is signalled by the function ss being flagged. */
4851 if (gfc_option
.flag_realloc_lhs
4852 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4854 gfc_free_interface_mapping (&mapping
);
4855 return has_alternate_specifier
;
4858 /* Create a temporary to store the result. In case the function
4859 returns a pointer, the temporary will be a shallow copy and
4860 mustn't be deallocated. */
4861 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
4862 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4863 tmp
, NULL_TREE
, false,
4864 !sym
->attr
.pointer
, callee_alloc
,
4865 &se
->ss
->info
->expr
->where
);
4867 /* Pass the temporary as the first argument. */
4868 result
= info
->descriptor
;
4869 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4870 vec_safe_push (retargs
, tmp
);
4872 else if (ts
.type
== BT_CHARACTER
)
4874 /* Pass the string length. */
4875 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
4876 type
= build_pointer_type (type
);
4878 /* Return an address to a char[0:len-1]* temporary for
4879 character pointers. */
4880 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4881 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
4883 var
= gfc_create_var (type
, "pstr");
4885 if ((!comp
&& sym
->attr
.allocatable
)
4886 || (comp
&& comp
->attr
.allocatable
))
4888 gfc_add_modify (&se
->pre
, var
,
4889 fold_convert (TREE_TYPE (var
),
4890 null_pointer_node
));
4891 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
4892 gfc_add_expr_to_block (&se
->post
, tmp
);
4895 /* Provide an address expression for the function arguments. */
4896 var
= gfc_build_addr_expr (NULL_TREE
, var
);
4899 var
= gfc_conv_string_tmp (se
, type
, len
);
4901 vec_safe_push (retargs
, var
);
4905 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
4907 type
= gfc_get_complex_type (ts
.kind
);
4908 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
4909 vec_safe_push (retargs
, var
);
4912 /* Add the string length to the argument list. */
4913 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
4916 if (TREE_CODE (tmp
) != VAR_DECL
)
4917 tmp
= gfc_evaluate_now (len
, &se
->pre
);
4918 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4919 vec_safe_push (retargs
, tmp
);
4921 else if (ts
.type
== BT_CHARACTER
)
4922 vec_safe_push (retargs
, len
);
4924 gfc_free_interface_mapping (&mapping
);
4926 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
4927 arglen
= (vec_safe_length (arglist
) + vec_safe_length (stringargs
)
4928 + vec_safe_length (append_args
));
4929 vec_safe_reserve (retargs
, arglen
);
4931 /* Add the return arguments. */
4932 retargs
->splice (arglist
);
4934 /* Add the hidden string length parameters to the arguments. */
4935 retargs
->splice (stringargs
);
4937 /* We may want to append extra arguments here. This is used e.g. for
4938 calls to libgfortran_matmul_??, which need extra information. */
4939 if (!vec_safe_is_empty (append_args
))
4940 retargs
->splice (append_args
);
4943 /* Generate the actual call. */
4944 if (base_object
== NULL_TREE
)
4945 conv_function_val (se
, sym
, expr
);
4947 conv_base_obj_fcn_val (se
, base_object
, expr
);
4949 /* If there are alternate return labels, function type should be
4950 integer. Can't modify the type in place though, since it can be shared
4951 with other functions. For dummy arguments, the typing is done to
4952 this result, even if it has to be repeated for each call. */
4953 if (has_alternate_specifier
4954 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
4956 if (!sym
->attr
.dummy
)
4958 TREE_TYPE (sym
->backend_decl
)
4959 = build_function_type (integer_type_node
,
4960 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
4961 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
4964 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
4967 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
4968 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
4970 /* If we have a pointer function, but we don't want a pointer, e.g.
4973 where f is pointer valued, we have to dereference the result. */
4974 if (!se
->want_pointer
&& !byref
4975 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4976 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
4977 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4979 /* f2c calling conventions require a scalar default real function to
4980 return a double precision result. Convert this back to default
4981 real. We only care about the cases that can happen in Fortran 77.
4983 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
4984 && sym
->ts
.kind
== gfc_default_real_kind
4985 && !sym
->attr
.always_explicit
)
4986 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
4988 /* A pure function may still have side-effects - it may modify its
4990 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4992 if (!sym
->attr
.pure
)
4993 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4998 /* Add the function call to the pre chain. There is no expression. */
4999 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
5000 se
->expr
= NULL_TREE
;
5002 if (!se
->direct_byref
)
5004 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
5006 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
5008 /* Check the data pointer hasn't been modified. This would
5009 happen in a function returning a pointer. */
5010 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
5011 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
5014 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
5017 se
->expr
= info
->descriptor
;
5018 /* Bundle in the string length. */
5019 se
->string_length
= len
;
5021 else if (ts
.type
== BT_CHARACTER
)
5023 /* Dereference for character pointer results. */
5024 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
5025 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
5026 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5030 se
->string_length
= len
;
5034 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
5035 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
5040 /* Follow the function call with the argument post block. */
5043 gfc_add_block_to_block (&se
->pre
, &post
);
5045 /* Transformational functions of derived types with allocatable
5046 components must have the result allocatable components copied. */
5047 arg
= expr
->value
.function
.actual
;
5048 if (result
&& arg
&& expr
->rank
5049 && expr
->value
.function
.isym
5050 && expr
->value
.function
.isym
->transformational
5051 && arg
->expr
->ts
.type
== BT_DERIVED
5052 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
5055 /* Copy the allocatable components. We have to use a
5056 temporary here to prevent source allocatable components
5057 from being corrupted. */
5058 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
5059 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
5060 result
, tmp2
, expr
->rank
);
5061 gfc_add_expr_to_block (&se
->pre
, tmp
);
5062 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
5064 gfc_add_expr_to_block (&se
->pre
, tmp
);
5066 /* Finally free the temporary's data field. */
5067 tmp
= gfc_conv_descriptor_data_get (tmp2
);
5068 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
5069 NULL_TREE
, NULL_TREE
, true,
5071 gfc_add_expr_to_block (&se
->pre
, tmp
);
5075 gfc_add_block_to_block (&se
->post
, &post
);
5077 return has_alternate_specifier
;
5081 /* Fill a character string with spaces. */
5084 fill_with_spaces (tree start
, tree type
, tree size
)
5086 stmtblock_t block
, loop
;
5087 tree i
, el
, exit_label
, cond
, tmp
;
5089 /* For a simple char type, we can call memset(). */
5090 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
5091 return build_call_expr_loc (input_location
,
5092 builtin_decl_explicit (BUILT_IN_MEMSET
),
5094 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
5095 lang_hooks
.to_target_charset (' ')),
5098 /* Otherwise, we use a loop:
5099 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
5103 /* Initialize variables. */
5104 gfc_init_block (&block
);
5105 i
= gfc_create_var (sizetype
, "i");
5106 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
5107 el
= gfc_create_var (build_pointer_type (type
), "el");
5108 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
5109 exit_label
= gfc_build_label_decl (NULL_TREE
);
5110 TREE_USED (exit_label
) = 1;
5114 gfc_init_block (&loop
);
5116 /* Exit condition. */
5117 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
5118 build_zero_cst (sizetype
));
5119 tmp
= build1_v (GOTO_EXPR
, exit_label
);
5120 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5121 build_empty_stmt (input_location
));
5122 gfc_add_expr_to_block (&loop
, tmp
);
5125 gfc_add_modify (&loop
,
5126 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
5127 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
5129 /* Increment loop variables. */
5130 gfc_add_modify (&loop
, i
,
5131 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
5132 TYPE_SIZE_UNIT (type
)));
5133 gfc_add_modify (&loop
, el
,
5134 fold_build_pointer_plus_loc (input_location
,
5135 el
, TYPE_SIZE_UNIT (type
)));
5137 /* Making the loop... actually loop! */
5138 tmp
= gfc_finish_block (&loop
);
5139 tmp
= build1_v (LOOP_EXPR
, tmp
);
5140 gfc_add_expr_to_block (&block
, tmp
);
5142 /* The exit label. */
5143 tmp
= build1_v (LABEL_EXPR
, exit_label
);
5144 gfc_add_expr_to_block (&block
, tmp
);
5147 return gfc_finish_block (&block
);
5151 /* Generate code to copy a string. */
5154 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
5155 int dkind
, tree slength
, tree src
, int skind
)
5157 tree tmp
, dlen
, slen
;
5166 stmtblock_t tempblock
;
5168 gcc_assert (dkind
== skind
);
5170 if (slength
!= NULL_TREE
)
5172 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
5173 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
5177 slen
= build_int_cst (size_type_node
, 1);
5181 if (dlength
!= NULL_TREE
)
5183 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
5184 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
5188 dlen
= build_int_cst (size_type_node
, 1);
5192 /* Assign directly if the types are compatible. */
5193 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
5194 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
5196 gfc_add_modify (block
, dsc
, ssc
);
5200 /* Do nothing if the destination length is zero. */
5201 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
5202 build_int_cst (size_type_node
, 0));
5204 /* The following code was previously in _gfortran_copy_string:
5206 // The two strings may overlap so we use memmove.
5208 copy_string (GFC_INTEGER_4 destlen, char * dest,
5209 GFC_INTEGER_4 srclen, const char * src)
5211 if (srclen >= destlen)
5213 // This will truncate if too long.
5214 memmove (dest, src, destlen);
5218 memmove (dest, src, srclen);
5220 memset (&dest[srclen], ' ', destlen - srclen);
5224 We're now doing it here for better optimization, but the logic
5227 /* For non-default character kinds, we have to multiply the string
5228 length by the base type size. */
5229 chartype
= gfc_get_char_type (dkind
);
5230 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5231 fold_convert (size_type_node
, slen
),
5232 fold_convert (size_type_node
,
5233 TYPE_SIZE_UNIT (chartype
)));
5234 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5235 fold_convert (size_type_node
, dlen
),
5236 fold_convert (size_type_node
,
5237 TYPE_SIZE_UNIT (chartype
)));
5239 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
5240 dest
= fold_convert (pvoid_type_node
, dest
);
5242 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
5244 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
5245 src
= fold_convert (pvoid_type_node
, src
);
5247 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5249 /* Truncate string if source is too long. */
5250 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
5252 tmp2
= build_call_expr_loc (input_location
,
5253 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5254 3, dest
, src
, dlen
);
5256 /* Else copy and pad with spaces. */
5257 tmp3
= build_call_expr_loc (input_location
,
5258 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
5259 3, dest
, src
, slen
);
5261 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
5262 tmp4
= fill_with_spaces (tmp4
, chartype
,
5263 fold_build2_loc (input_location
, MINUS_EXPR
,
5264 TREE_TYPE(dlen
), dlen
, slen
));
5266 gfc_init_block (&tempblock
);
5267 gfc_add_expr_to_block (&tempblock
, tmp3
);
5268 gfc_add_expr_to_block (&tempblock
, tmp4
);
5269 tmp3
= gfc_finish_block (&tempblock
);
5271 /* The whole copy_string function is there. */
5272 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
5274 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
5275 build_empty_stmt (input_location
));
5276 gfc_add_expr_to_block (block
, tmp
);
5280 /* Translate a statement function.
5281 The value of a statement function reference is obtained by evaluating the
5282 expression using the values of the actual arguments for the values of the
5283 corresponding dummy arguments. */
5286 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5290 gfc_formal_arglist
*fargs
;
5291 gfc_actual_arglist
*args
;
5294 gfc_saved_var
*saved_vars
;
5300 sym
= expr
->symtree
->n
.sym
;
5301 args
= expr
->value
.function
.actual
;
5302 gfc_init_se (&lse
, NULL
);
5303 gfc_init_se (&rse
, NULL
);
5306 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
5308 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5309 temp_vars
= XCNEWVEC (tree
, n
);
5311 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
5313 /* Each dummy shall be specified, explicitly or implicitly, to be
5315 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5318 if (fsym
->ts
.type
== BT_CHARACTER
)
5320 /* Copy string arguments. */
5323 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5324 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5326 /* Create a temporary to hold the value. */
5327 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5328 fsym
->ts
.u
.cl
->backend_decl
5329 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5331 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5332 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5334 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5336 gfc_conv_expr (&rse
, args
->expr
);
5337 gfc_conv_string_parameter (&rse
);
5338 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5339 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5341 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5342 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5343 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5344 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5348 /* For everything else, just evaluate the expression. */
5350 /* Create a temporary to hold the value. */
5351 type
= gfc_typenode_for_spec (&fsym
->ts
);
5352 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5354 gfc_conv_expr (&lse
, args
->expr
);
5356 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5357 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5358 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5364 /* Use the temporary variables in place of the real ones. */
5365 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
5366 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5368 gfc_conv_expr (se
, sym
->value
);
5370 if (sym
->ts
.type
== BT_CHARACTER
)
5372 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5374 /* Force the expression to the correct length. */
5375 if (!INTEGER_CST_P (se
->string_length
)
5376 || tree_int_cst_lt (se
->string_length
,
5377 sym
->ts
.u
.cl
->backend_decl
))
5379 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5380 tmp
= gfc_create_var (type
, sym
->name
);
5381 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5382 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5383 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5387 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5390 /* Restore the original variables. */
5391 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
5392 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5398 /* Translate a function expression. */
5401 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5405 if (expr
->value
.function
.isym
)
5407 gfc_conv_intrinsic_function (se
, expr
);
5411 /* We distinguish statement functions from general functions to improve
5412 runtime performance. */
5413 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
5415 gfc_conv_statement_function (se
, expr
);
5419 /* expr.value.function.esym is the resolved (specific) function symbol for
5420 most functions. However this isn't set for dummy procedures. */
5421 sym
= expr
->value
.function
.esym
;
5423 sym
= expr
->symtree
->n
.sym
;
5425 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
5430 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5433 is_zero_initializer_p (gfc_expr
* expr
)
5435 if (expr
->expr_type
!= EXPR_CONSTANT
)
5438 /* We ignore constants with prescribed memory representations for now. */
5439 if (expr
->representation
.string
)
5442 switch (expr
->ts
.type
)
5445 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5448 return mpfr_zero_p (expr
->value
.real
)
5449 && MPFR_SIGN (expr
->value
.real
) >= 0;
5452 return expr
->value
.logical
== 0;
5455 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5456 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5457 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5458 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5468 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5473 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5474 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5476 gfc_conv_tmp_array_ref (se
);
5480 /* Build a static initializer. EXPR is the expression for the initial value.
5481 The other parameters describe the variable of the component being
5482 initialized. EXPR may be null. */
5485 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5486 bool array
, bool pointer
, bool procptr
)
5490 if (!(expr
|| pointer
|| procptr
))
5493 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5494 (these are the only two iso_c_binding derived types that can be
5495 used as initialization expressions). If so, we need to modify
5496 the 'expr' to be that for a (void *). */
5497 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5498 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5500 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5502 /* The derived symbol has already been converted to a (void *). Use
5504 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5505 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5507 gfc_init_se (&se
, NULL
);
5508 gfc_conv_constant (&se
, expr
);
5509 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5513 if (array
&& !procptr
)
5516 /* Arrays need special handling. */
5518 ctor
= gfc_build_null_descriptor (type
);
5519 /* Special case assigning an array to zero. */
5520 else if (is_zero_initializer_p (expr
))
5521 ctor
= build_constructor (type
, NULL
);
5523 ctor
= gfc_conv_array_initializer (type
, expr
);
5524 TREE_STATIC (ctor
) = 1;
5527 else if (pointer
|| procptr
)
5529 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5530 return fold_convert (type
, null_pointer_node
);
5533 gfc_init_se (&se
, NULL
);
5534 se
.want_pointer
= 1;
5535 gfc_conv_expr (&se
, expr
);
5536 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5546 gfc_init_se (&se
, NULL
);
5547 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5548 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
5550 gfc_conv_structure (&se
, expr
, 1);
5551 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5552 TREE_STATIC (se
.expr
) = 1;
5557 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5558 TREE_STATIC (ctor
) = 1;
5563 gfc_init_se (&se
, NULL
);
5564 gfc_conv_constant (&se
, expr
);
5565 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5572 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5578 gfc_array_info
*lss_array
;
5585 gfc_start_block (&block
);
5587 /* Initialize the scalarizer. */
5588 gfc_init_loopinfo (&loop
);
5590 gfc_init_se (&lse
, NULL
);
5591 gfc_init_se (&rse
, NULL
);
5594 rss
= gfc_walk_expr (expr
);
5595 if (rss
== gfc_ss_terminator
)
5596 /* The rhs is scalar. Add a ss for the expression. */
5597 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5599 /* Create a SS for the destination. */
5600 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5602 lss_array
= &lss
->info
->data
.array
;
5603 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5604 lss_array
->descriptor
= dest
;
5605 lss_array
->data
= gfc_conv_array_data (dest
);
5606 lss_array
->offset
= gfc_conv_array_offset (dest
);
5607 for (n
= 0; n
< cm
->as
->rank
; n
++)
5609 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5610 lss_array
->stride
[n
] = gfc_index_one_node
;
5612 mpz_init (lss_array
->shape
[n
]);
5613 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5614 cm
->as
->lower
[n
]->value
.integer
);
5615 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5618 /* Associate the SS with the loop. */
5619 gfc_add_ss_to_loop (&loop
, lss
);
5620 gfc_add_ss_to_loop (&loop
, rss
);
5622 /* Calculate the bounds of the scalarization. */
5623 gfc_conv_ss_startstride (&loop
);
5625 /* Setup the scalarizing loops. */
5626 gfc_conv_loop_setup (&loop
, &expr
->where
);
5628 /* Setup the gfc_se structures. */
5629 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5630 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5633 gfc_mark_ss_chain_used (rss
, 1);
5635 gfc_mark_ss_chain_used (lss
, 1);
5637 /* Start the scalarized loop body. */
5638 gfc_start_scalarized_body (&loop
, &body
);
5640 gfc_conv_tmp_array_ref (&lse
);
5641 if (cm
->ts
.type
== BT_CHARACTER
)
5642 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5644 gfc_conv_expr (&rse
, expr
);
5646 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5647 gfc_add_expr_to_block (&body
, tmp
);
5649 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5651 /* Generate the copying loops. */
5652 gfc_trans_scalarizing_loops (&loop
, &body
);
5654 /* Wrap the whole thing up. */
5655 gfc_add_block_to_block (&block
, &loop
.pre
);
5656 gfc_add_block_to_block (&block
, &loop
.post
);
5658 gcc_assert (lss_array
->shape
!= NULL
);
5659 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5660 gfc_cleanup_loop (&loop
);
5662 return gfc_finish_block (&block
);
5667 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5677 gfc_expr
*arg
= NULL
;
5679 gfc_start_block (&block
);
5680 gfc_init_se (&se
, NULL
);
5682 /* Get the descriptor for the expressions. */
5683 se
.want_pointer
= 0;
5684 gfc_conv_expr_descriptor (&se
, expr
);
5685 gfc_add_block_to_block (&block
, &se
.pre
);
5686 gfc_add_modify (&block
, dest
, se
.expr
);
5688 /* Deal with arrays of derived types with allocatable components. */
5689 if (cm
->ts
.type
== BT_DERIVED
5690 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5691 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5695 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5696 TREE_TYPE(cm
->backend_decl
),
5699 gfc_add_expr_to_block (&block
, tmp
);
5700 gfc_add_block_to_block (&block
, &se
.post
);
5702 if (expr
->expr_type
!= EXPR_VARIABLE
)
5703 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5706 /* We need to know if the argument of a conversion function is a
5707 variable, so that the correct lower bound can be used. */
5708 if (expr
->expr_type
== EXPR_FUNCTION
5709 && expr
->value
.function
.isym
5710 && expr
->value
.function
.isym
->conversion
5711 && expr
->value
.function
.actual
->expr
5712 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5713 arg
= expr
->value
.function
.actual
->expr
;
5715 /* Obtain the array spec of full array references. */
5717 as
= gfc_get_full_arrayspec_from_expr (arg
);
5719 as
= gfc_get_full_arrayspec_from_expr (expr
);
5721 /* Shift the lbound and ubound of temporaries to being unity,
5722 rather than zero, based. Always calculate the offset. */
5723 offset
= gfc_conv_descriptor_offset_get (dest
);
5724 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5725 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5727 for (n
= 0; n
< expr
->rank
; n
++)
5732 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5733 TODO It looks as if gfc_conv_expr_descriptor should return
5734 the correct bounds and that the following should not be
5735 necessary. This would simplify gfc_conv_intrinsic_bound
5737 if (as
&& as
->lower
[n
])
5740 gfc_init_se (&lbse
, NULL
);
5741 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5742 gfc_add_block_to_block (&block
, &lbse
.pre
);
5743 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5747 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5748 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5752 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5755 lbound
= gfc_index_one_node
;
5757 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5759 /* Shift the bounds and set the offset accordingly. */
5760 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5761 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5762 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5763 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5765 gfc_conv_descriptor_ubound_set (&block
, dest
,
5766 gfc_rank_cst
[n
], tmp
);
5767 gfc_conv_descriptor_lbound_set (&block
, dest
,
5768 gfc_rank_cst
[n
], lbound
);
5770 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5771 gfc_conv_descriptor_lbound_get (dest
,
5773 gfc_conv_descriptor_stride_get (dest
,
5775 gfc_add_modify (&block
, tmp2
, tmp
);
5776 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5778 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5783 /* If a conversion expression has a null data pointer
5784 argument, nullify the allocatable component. */
5788 if (arg
->symtree
->n
.sym
->attr
.allocatable
5789 || arg
->symtree
->n
.sym
->attr
.pointer
)
5791 non_null_expr
= gfc_finish_block (&block
);
5792 gfc_start_block (&block
);
5793 gfc_conv_descriptor_data_set (&block
, dest
,
5795 null_expr
= gfc_finish_block (&block
);
5796 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5797 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5798 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5799 return build3_v (COND_EXPR
, tmp
,
5800 null_expr
, non_null_expr
);
5804 return gfc_finish_block (&block
);
5808 /* Assign a single component of a derived type constructor. */
5811 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5818 gfc_start_block (&block
);
5820 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5822 gfc_init_se (&se
, NULL
);
5823 /* Pointer component. */
5824 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5826 /* Array pointer. */
5827 if (expr
->expr_type
== EXPR_NULL
)
5828 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5831 se
.direct_byref
= 1;
5833 gfc_conv_expr_descriptor (&se
, expr
);
5834 gfc_add_block_to_block (&block
, &se
.pre
);
5835 gfc_add_block_to_block (&block
, &se
.post
);
5840 /* Scalar pointers. */
5841 se
.want_pointer
= 1;
5842 gfc_conv_expr (&se
, expr
);
5843 gfc_add_block_to_block (&block
, &se
.pre
);
5845 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
5846 && expr
->symtree
->n
.sym
->attr
.dummy
)
5847 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5849 gfc_add_modify (&block
, dest
,
5850 fold_convert (TREE_TYPE (dest
), se
.expr
));
5851 gfc_add_block_to_block (&block
, &se
.post
);
5854 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5856 /* NULL initialization for CLASS components. */
5857 tmp
= gfc_trans_structure_assign (dest
,
5858 gfc_class_null_initializer (&cm
->ts
));
5859 gfc_add_expr_to_block (&block
, tmp
);
5861 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5863 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
5864 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5865 else if (cm
->attr
.allocatable
)
5867 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
5868 gfc_add_expr_to_block (&block
, tmp
);
5872 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
5873 gfc_add_expr_to_block (&block
, tmp
);
5876 else if (expr
->ts
.type
== BT_DERIVED
)
5878 if (expr
->expr_type
!= EXPR_STRUCTURE
)
5880 gfc_init_se (&se
, NULL
);
5881 gfc_conv_expr (&se
, expr
);
5882 gfc_add_block_to_block (&block
, &se
.pre
);
5883 gfc_add_modify (&block
, dest
,
5884 fold_convert (TREE_TYPE (dest
), se
.expr
));
5885 gfc_add_block_to_block (&block
, &se
.post
);
5889 /* Nested constructors. */
5890 tmp
= gfc_trans_structure_assign (dest
, expr
);
5891 gfc_add_expr_to_block (&block
, tmp
);
5896 /* Scalar component. */
5897 gfc_init_se (&se
, NULL
);
5898 gfc_init_se (&lse
, NULL
);
5900 gfc_conv_expr (&se
, expr
);
5901 if (cm
->ts
.type
== BT_CHARACTER
)
5902 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5904 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
5905 gfc_add_expr_to_block (&block
, tmp
);
5907 return gfc_finish_block (&block
);
5910 /* Assign a derived type constructor to a variable. */
5913 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
5921 gfc_start_block (&block
);
5922 cm
= expr
->ts
.u
.derived
->components
;
5924 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
5925 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
5926 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
5930 gcc_assert (cm
->backend_decl
== NULL
);
5931 gfc_init_se (&se
, NULL
);
5932 gfc_init_se (&lse
, NULL
);
5933 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
5935 gfc_add_modify (&block
, lse
.expr
,
5936 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
5938 return gfc_finish_block (&block
);
5941 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5942 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5944 /* Skip absent members in default initializers. */
5948 field
= cm
->backend_decl
;
5949 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
5950 dest
, field
, NULL_TREE
);
5951 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
5952 gfc_add_expr_to_block (&block
, tmp
);
5954 return gfc_finish_block (&block
);
5957 /* Build an expression for a constructor. If init is nonzero then
5958 this is part of a static variable initializer. */
5961 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
5968 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5970 gcc_assert (se
->ss
== NULL
);
5971 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
5972 type
= gfc_typenode_for_spec (&expr
->ts
);
5976 /* Create a temporary variable and fill it in. */
5977 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
5978 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
5979 gfc_add_expr_to_block (&se
->pre
, tmp
);
5983 cm
= expr
->ts
.u
.derived
->components
;
5985 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5986 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5988 /* Skip absent members in default initializers and allocatable
5989 components. Although the latter have a default initializer
5990 of EXPR_NULL,... by default, the static nullify is not needed
5991 since this is done every time we come into scope. */
5992 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
5995 if (strcmp (cm
->name
, "_size") == 0)
5997 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
5998 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6000 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
6001 && strcmp (cm
->name
, "_extends") == 0)
6005 vtabs
= cm
->initializer
->symtree
->n
.sym
;
6006 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
6007 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
6011 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
6012 TREE_TYPE (cm
->backend_decl
),
6013 cm
->attr
.dimension
, cm
->attr
.pointer
,
6014 cm
->attr
.proc_pointer
);
6016 /* Append it to the constructor list. */
6017 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
6020 se
->expr
= build_constructor (type
, v
);
6022 TREE_CONSTANT (se
->expr
) = 1;
6026 /* Translate a substring expression. */
6029 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
6035 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
6037 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
6038 expr
->value
.character
.length
,
6039 expr
->value
.character
.string
);
6041 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
6042 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
6045 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
6049 /* Entry point for expression translation. Evaluates a scalar quantity.
6050 EXPR is the expression to be translated, and SE is the state structure if
6051 called from within the scalarized. */
6054 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
6059 if (ss
&& ss
->info
->expr
== expr
6060 && (ss
->info
->type
== GFC_SS_SCALAR
6061 || ss
->info
->type
== GFC_SS_REFERENCE
))
6063 gfc_ss_info
*ss_info
;
6066 /* Substitute a scalar expression evaluated outside the scalarization
6068 se
->expr
= ss_info
->data
.scalar
.value
;
6069 /* If the reference can be NULL, the value field contains the reference,
6070 not the value the reference points to (see gfc_add_loop_ss_code). */
6071 if (ss_info
->can_be_null_ref
)
6072 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6074 se
->string_length
= ss_info
->string_length
;
6075 gfc_advance_se_ss_chain (se
);
6079 /* We need to convert the expressions for the iso_c_binding derived types.
6080 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
6081 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
6082 typespec for the C_PTR and C_FUNPTR symbols, which has already been
6083 updated to be an integer with a kind equal to the size of a (void *). */
6084 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
6085 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
6087 if (expr
->expr_type
== EXPR_VARIABLE
6088 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
6089 || expr
->symtree
->n
.sym
->intmod_sym_id
6090 == ISOCBINDING_NULL_FUNPTR
))
6092 /* Set expr_type to EXPR_NULL, which will result in
6093 null_pointer_node being used below. */
6094 expr
->expr_type
= EXPR_NULL
;
6098 /* Update the type/kind of the expression to be what the new
6099 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
6100 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
6101 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
6102 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
6106 gfc_fix_class_refs (expr
);
6108 switch (expr
->expr_type
)
6111 gfc_conv_expr_op (se
, expr
);
6115 gfc_conv_function_expr (se
, expr
);
6119 gfc_conv_constant (se
, expr
);
6123 gfc_conv_variable (se
, expr
);
6127 se
->expr
= null_pointer_node
;
6130 case EXPR_SUBSTRING
:
6131 gfc_conv_substring_expr (se
, expr
);
6134 case EXPR_STRUCTURE
:
6135 gfc_conv_structure (se
, expr
, 0);
6139 gfc_conv_array_constructor_expr (se
, expr
);
6148 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
6149 of an assignment. */
6151 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
6153 gfc_conv_expr (se
, expr
);
6154 /* All numeric lvalues should have empty post chains. If not we need to
6155 figure out a way of rewriting an lvalue so that it has no post chain. */
6156 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
6159 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
6160 numeric expressions. Used for scalar values where inserting cleanup code
6163 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
6167 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
6168 gfc_conv_expr (se
, expr
);
6171 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6172 gfc_add_modify (&se
->pre
, val
, se
->expr
);
6174 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6178 /* Helper to translate an expression and convert it to a particular type. */
6180 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
6182 gfc_conv_expr_val (se
, expr
);
6183 se
->expr
= convert (type
, se
->expr
);
6187 /* Converts an expression so that it can be passed by reference. Scalar
6191 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
6197 if (ss
&& ss
->info
->expr
== expr
6198 && ss
->info
->type
== GFC_SS_REFERENCE
)
6200 /* Returns a reference to the scalar evaluated outside the loop
6202 gfc_conv_expr (se
, expr
);
6203 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
6207 if (expr
->ts
.type
== BT_CHARACTER
)
6209 gfc_conv_expr (se
, expr
);
6210 gfc_conv_string_parameter (se
);
6214 if (expr
->expr_type
== EXPR_VARIABLE
)
6216 se
->want_pointer
= 1;
6217 gfc_conv_expr (se
, expr
);
6220 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6221 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6222 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6228 if (expr
->expr_type
== EXPR_FUNCTION
6229 && ((expr
->value
.function
.esym
6230 && expr
->value
.function
.esym
->result
->attr
.pointer
6231 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
6232 || (!expr
->value
.function
.esym
&& !expr
->ref
6233 && expr
->symtree
->n
.sym
->attr
.pointer
6234 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
6236 se
->want_pointer
= 1;
6237 gfc_conv_expr (se
, expr
);
6238 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6239 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6244 gfc_conv_expr (se
, expr
);
6246 /* Create a temporary var to hold the value. */
6247 if (TREE_CONSTANT (se
->expr
))
6249 tree tmp
= se
->expr
;
6250 STRIP_TYPE_NOPS (tmp
);
6251 var
= build_decl (input_location
,
6252 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
6253 DECL_INITIAL (var
) = tmp
;
6254 TREE_STATIC (var
) = 1;
6259 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
6260 gfc_add_modify (&se
->pre
, var
, se
->expr
);
6262 gfc_add_block_to_block (&se
->pre
, &se
->post
);
6264 /* Take the address of that value. */
6265 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
6270 gfc_trans_pointer_assign (gfc_code
* code
)
6272 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
6276 /* Generate code for a pointer assignment. */
6279 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6290 gfc_start_block (&block
);
6292 gfc_init_se (&lse
, NULL
);
6294 /* Check whether the expression is a scalar or not; we cannot use
6295 expr1->rank as it can be nonzero for proc pointers. */
6296 ss
= gfc_walk_expr (expr1
);
6297 scalar
= ss
== gfc_ss_terminator
;
6299 gfc_free_ss_chain (ss
);
6303 /* Scalar pointers. */
6304 lse
.want_pointer
= 1;
6305 gfc_conv_expr (&lse
, expr1
);
6306 gfc_init_se (&rse
, NULL
);
6307 rse
.want_pointer
= 1;
6308 gfc_conv_expr (&rse
, expr2
);
6310 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6311 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6312 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6315 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6316 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6317 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6320 gfc_add_block_to_block (&block
, &lse
.pre
);
6321 gfc_add_block_to_block (&block
, &rse
.pre
);
6323 /* Check character lengths if character expression. The test is only
6324 really added if -fbounds-check is enabled. Exclude deferred
6325 character length lefthand sides. */
6326 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6327 && !expr1
->ts
.deferred
6328 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6329 && !gfc_is_proc_ptr_comp (expr1
))
6331 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6332 gcc_assert (lse
.string_length
&& rse
.string_length
);
6333 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6334 lse
.string_length
, rse
.string_length
,
6338 /* The assignment to an deferred character length sets the string
6339 length to that of the rhs. */
6340 if (expr1
->ts
.deferred
)
6342 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6343 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6344 else if (lse
.string_length
!= NULL
)
6345 gfc_add_modify (&block
, lse
.string_length
,
6346 build_int_cst (gfc_charlen_type_node
, 0));
6349 gfc_add_modify (&block
, lse
.expr
,
6350 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6352 gfc_add_block_to_block (&block
, &rse
.post
);
6353 gfc_add_block_to_block (&block
, &lse
.post
);
6360 tree strlen_rhs
= NULL_TREE
;
6362 /* Array pointer. Find the last reference on the LHS and if it is an
6363 array section ref, we're dealing with bounds remapping. In this case,
6364 set it to AR_FULL so that gfc_conv_expr_descriptor does
6365 not see it and process the bounds remapping afterwards explicitly. */
6366 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6367 if (!remap
->next
&& remap
->type
== REF_ARRAY
6368 && remap
->u
.ar
.type
== AR_SECTION
)
6370 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6373 lse
.descriptor_only
= 1;
6374 gfc_conv_expr_descriptor (&lse
, expr1
);
6375 strlen_lhs
= lse
.string_length
;
6378 if (expr2
->expr_type
== EXPR_NULL
)
6380 /* Just set the data pointer to null. */
6381 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6383 else if (rank_remap
)
6385 /* If we are rank-remapping, just get the RHS's descriptor and
6386 process this later on. */
6387 gfc_init_se (&rse
, NULL
);
6388 rse
.direct_byref
= 1;
6389 rse
.byref_noassign
= 1;
6390 gfc_conv_expr_descriptor (&rse
, expr2
);
6391 strlen_rhs
= rse
.string_length
;
6393 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6395 /* Assign directly to the LHS's descriptor. */
6396 lse
.direct_byref
= 1;
6397 gfc_conv_expr_descriptor (&lse
, expr2
);
6398 strlen_rhs
= lse
.string_length
;
6400 /* If this is a subreference array pointer assignment, use the rhs
6401 descriptor element size for the lhs span. */
6402 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6404 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6405 gfc_init_se (&rse
, NULL
);
6406 rse
.descriptor_only
= 1;
6407 gfc_conv_expr (&rse
, expr2
);
6408 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6409 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6410 if (!INTEGER_CST_P (tmp
))
6411 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6412 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6417 /* Assign to a temporary descriptor and then copy that
6418 temporary to the pointer. */
6419 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6422 lse
.direct_byref
= 1;
6423 gfc_conv_expr_descriptor (&lse
, expr2
);
6424 strlen_rhs
= lse
.string_length
;
6425 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6428 gfc_add_block_to_block (&block
, &lse
.pre
);
6430 gfc_add_block_to_block (&block
, &rse
.pre
);
6432 /* If we do bounds remapping, update LHS descriptor accordingly. */
6436 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6440 /* Do rank remapping. We already have the RHS's descriptor
6441 converted in rse and now have to build the correct LHS
6442 descriptor for it. */
6446 tree lbound
, ubound
;
6449 dtype
= gfc_conv_descriptor_dtype (desc
);
6450 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6451 gfc_add_modify (&block
, dtype
, tmp
);
6453 /* Copy data pointer. */
6454 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6455 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6457 /* Copy offset but adjust it such that it would correspond
6458 to a lbound of zero. */
6459 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6460 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6462 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6464 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6466 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6467 gfc_array_index_type
, stride
, lbound
);
6468 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6469 gfc_array_index_type
, offs
, tmp
);
6471 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6473 /* Set the bounds as declared for the LHS and calculate strides as
6474 well as another offset update accordingly. */
6475 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6477 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6482 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6484 /* Convert declared bounds. */
6485 gfc_init_se (&lower_se
, NULL
);
6486 gfc_init_se (&upper_se
, NULL
);
6487 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6488 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6490 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6491 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6493 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6494 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6496 lbound
= gfc_evaluate_now (lbound
, &block
);
6497 ubound
= gfc_evaluate_now (ubound
, &block
);
6499 gfc_add_block_to_block (&block
, &lower_se
.post
);
6500 gfc_add_block_to_block (&block
, &upper_se
.post
);
6502 /* Set bounds in descriptor. */
6503 gfc_conv_descriptor_lbound_set (&block
, desc
,
6504 gfc_rank_cst
[dim
], lbound
);
6505 gfc_conv_descriptor_ubound_set (&block
, desc
,
6506 gfc_rank_cst
[dim
], ubound
);
6509 stride
= gfc_evaluate_now (stride
, &block
);
6510 gfc_conv_descriptor_stride_set (&block
, desc
,
6511 gfc_rank_cst
[dim
], stride
);
6513 /* Update offset. */
6514 offs
= gfc_conv_descriptor_offset_get (desc
);
6515 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6516 gfc_array_index_type
, lbound
, stride
);
6517 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6518 gfc_array_index_type
, offs
, tmp
);
6519 offs
= gfc_evaluate_now (offs
, &block
);
6520 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6522 /* Update stride. */
6523 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6524 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6525 gfc_array_index_type
, stride
, tmp
);
6530 /* Bounds remapping. Just shift the lower bounds. */
6532 gcc_assert (expr1
->rank
== expr2
->rank
);
6534 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6538 gcc_assert (remap
->u
.ar
.start
[dim
]);
6539 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6540 gfc_init_se (&lbound_se
, NULL
);
6541 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6543 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6544 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6545 dim
, lbound_se
.expr
);
6546 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6551 /* Check string lengths if applicable. The check is only really added
6552 to the output code if -fbounds-check is enabled. */
6553 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6555 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6556 gcc_assert (strlen_lhs
&& strlen_rhs
);
6557 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6558 strlen_lhs
, strlen_rhs
, &block
);
6561 /* If rank remapping was done, check with -fcheck=bounds that
6562 the target is at least as large as the pointer. */
6563 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6569 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6570 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6572 lsize
= gfc_evaluate_now (lsize
, &block
);
6573 rsize
= gfc_evaluate_now (rsize
, &block
);
6574 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6577 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6578 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6582 gfc_add_block_to_block (&block
, &lse
.post
);
6584 gfc_add_block_to_block (&block
, &rse
.post
);
6587 return gfc_finish_block (&block
);
6591 /* Makes sure se is suitable for passing as a function string parameter. */
6592 /* TODO: Need to check all callers of this function. It may be abused. */
6595 gfc_conv_string_parameter (gfc_se
* se
)
6599 if (TREE_CODE (se
->expr
) == STRING_CST
)
6601 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6602 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6606 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6608 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6610 type
= TREE_TYPE (se
->expr
);
6611 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6615 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6617 type
= build_pointer_type (type
);
6618 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6622 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6626 /* Generate code for assignment of scalar variables. Includes character
6627 strings and derived types with allocatable components.
6628 If you know that the LHS has no allocations, set dealloc to false.
6630 DEEP_COPY has no effect if the typespec TS is not a derived type with
6631 allocatable components. Otherwise, if it is set, an explicit copy of each
6632 allocatable component is made. This is necessary as a simple copy of the
6633 whole object would copy array descriptors as is, so that the lhs's
6634 allocatable components would point to the rhs's after the assignment.
6635 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6636 necessary if the rhs is a non-pointer function, as the allocatable components
6637 are not accessible by other means than the function's result after the
6638 function has returned. It is even more subtle when temporaries are involved,
6639 as the two following examples show:
6640 1. When we evaluate an array constructor, a temporary is created. Thus
6641 there is theoretically no alias possible. However, no deep copy is
6642 made for this temporary, so that if the constructor is made of one or
6643 more variable with allocatable components, those components still point
6644 to the variable's: DEEP_COPY should be set for the assignment from the
6645 temporary to the lhs in that case.
6646 2. When assigning a scalar to an array, we evaluate the scalar value out
6647 of the loop, store it into a temporary variable, and assign from that.
6648 In that case, deep copying when assigning to the temporary would be a
6649 waste of resources; however deep copies should happen when assigning from
6650 the temporary to each array element: again DEEP_COPY should be set for
6651 the assignment from the temporary to the lhs. */
6654 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6655 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6661 gfc_init_block (&block
);
6663 if (ts
.type
== BT_CHARACTER
)
6668 if (lse
->string_length
!= NULL_TREE
)
6670 gfc_conv_string_parameter (lse
);
6671 gfc_add_block_to_block (&block
, &lse
->pre
);
6672 llen
= lse
->string_length
;
6675 if (rse
->string_length
!= NULL_TREE
)
6677 gcc_assert (rse
->string_length
!= NULL_TREE
);
6678 gfc_conv_string_parameter (rse
);
6679 gfc_add_block_to_block (&block
, &rse
->pre
);
6680 rlen
= rse
->string_length
;
6683 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6684 rse
->expr
, ts
.kind
);
6686 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6690 /* Are the rhs and the lhs the same? */
6693 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6694 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6695 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6696 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6699 /* Deallocate the lhs allocated components as long as it is not
6700 the same as the rhs. This must be done following the assignment
6701 to prevent deallocating data that could be used in the rhs
6703 if (!l_is_temp
&& dealloc
)
6705 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
6706 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
6708 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6710 gfc_add_expr_to_block (&lse
->post
, tmp
);
6713 gfc_add_block_to_block (&block
, &rse
->pre
);
6714 gfc_add_block_to_block (&block
, &lse
->pre
);
6716 gfc_add_modify (&block
, lse
->expr
,
6717 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6719 /* Do a deep copy if the rhs is a variable, if it is not the
6723 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
6724 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6726 gfc_add_expr_to_block (&block
, tmp
);
6729 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
6731 gfc_add_block_to_block (&block
, &lse
->pre
);
6732 gfc_add_block_to_block (&block
, &rse
->pre
);
6733 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
6734 TREE_TYPE (lse
->expr
), rse
->expr
);
6735 gfc_add_modify (&block
, lse
->expr
, tmp
);
6739 gfc_add_block_to_block (&block
, &lse
->pre
);
6740 gfc_add_block_to_block (&block
, &rse
->pre
);
6742 gfc_add_modify (&block
, lse
->expr
,
6743 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6746 gfc_add_block_to_block (&block
, &lse
->post
);
6747 gfc_add_block_to_block (&block
, &rse
->post
);
6749 return gfc_finish_block (&block
);
6753 /* There are quite a lot of restrictions on the optimisation in using an
6754 array function assign without a temporary. */
6757 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
6760 bool seen_array_ref
;
6762 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
6764 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6765 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
6768 /* Elemental functions are scalarized so that they don't need a
6769 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6770 they would need special treatment in gfc_trans_arrayfunc_assign. */
6771 if (expr2
->value
.function
.esym
!= NULL
6772 && expr2
->value
.function
.esym
->attr
.elemental
)
6775 /* Need a temporary if rhs is not FULL or a contiguous section. */
6776 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
6779 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6780 if (gfc_ref_needs_temporary_p (expr1
->ref
))
6783 /* Functions returning pointers or allocatables need temporaries. */
6784 c
= expr2
->value
.function
.esym
6785 ? (expr2
->value
.function
.esym
->attr
.pointer
6786 || expr2
->value
.function
.esym
->attr
.allocatable
)
6787 : (expr2
->symtree
->n
.sym
->attr
.pointer
6788 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
6792 /* Character array functions need temporaries unless the
6793 character lengths are the same. */
6794 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
6796 if (expr1
->ts
.u
.cl
->length
== NULL
6797 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6800 if (expr2
->ts
.u
.cl
->length
== NULL
6801 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6804 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
6805 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
6809 /* Check that no LHS component references appear during an array
6810 reference. This is needed because we do not have the means to
6811 span any arbitrary stride with an array descriptor. This check
6812 is not needed for the rhs because the function result has to be
6814 seen_array_ref
= false;
6815 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
6817 if (ref
->type
== REF_ARRAY
)
6818 seen_array_ref
= true;
6819 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
6823 /* Check for a dependency. */
6824 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
6825 expr2
->value
.function
.esym
,
6826 expr2
->value
.function
.actual
,
6830 /* If we have reached here with an intrinsic function, we do not
6831 need a temporary except in the particular case that reallocation
6832 on assignment is active and the lhs is allocatable and a target. */
6833 if (expr2
->value
.function
.isym
)
6834 return (gfc_option
.flag_realloc_lhs
6835 && sym
->attr
.allocatable
6836 && sym
->attr
.target
);
6838 /* If the LHS is a dummy, we need a temporary if it is not
6840 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
6843 /* If the lhs has been host_associated, is in common, a pointer or is
6844 a target and the function is not using a RESULT variable, aliasing
6845 can occur and a temporary is needed. */
6846 if ((sym
->attr
.host_assoc
6847 || sym
->attr
.in_common
6848 || sym
->attr
.pointer
6849 || sym
->attr
.cray_pointee
6850 || sym
->attr
.target
)
6851 && expr2
->symtree
!= NULL
6852 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
6855 /* A PURE function can unconditionally be called without a temporary. */
6856 if (expr2
->value
.function
.esym
!= NULL
6857 && expr2
->value
.function
.esym
->attr
.pure
)
6860 /* Implicit_pure functions are those which could legally be declared
6862 if (expr2
->value
.function
.esym
!= NULL
6863 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
6866 if (!sym
->attr
.use_assoc
6867 && !sym
->attr
.in_common
6868 && !sym
->attr
.pointer
6869 && !sym
->attr
.target
6870 && !sym
->attr
.cray_pointee
6871 && expr2
->value
.function
.esym
)
6873 /* A temporary is not needed if the function is not contained and
6874 the variable is local or host associated and not a pointer or
6876 if (!expr2
->value
.function
.esym
->attr
.contained
)
6879 /* A temporary is not needed if the lhs has never been host
6880 associated and the procedure is contained. */
6881 else if (!sym
->attr
.host_assoc
)
6884 /* A temporary is not needed if the variable is local and not
6885 a pointer, a target or a result. */
6887 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
6891 /* Default to temporary use. */
6896 /* Provide the loop info so that the lhs descriptor can be built for
6897 reallocatable assignments from extrinsic function calls. */
6900 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
6903 /* Signal that the function call should not be made by
6904 gfc_conv_loop_setup. */
6905 se
->ss
->is_alloc_lhs
= 1;
6906 gfc_init_loopinfo (loop
);
6907 gfc_add_ss_to_loop (loop
, *ss
);
6908 gfc_add_ss_to_loop (loop
, se
->ss
);
6909 gfc_conv_ss_startstride (loop
);
6910 gfc_conv_loop_setup (loop
, where
);
6911 gfc_copy_loopinfo_to_se (se
, loop
);
6912 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
6913 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
6914 se
->ss
->is_alloc_lhs
= 0;
6918 /* For assignment to a reallocatable lhs from intrinsic functions,
6919 replace the se.expr (ie. the result) with a temporary descriptor.
6920 Null the data field so that the library allocates space for the
6921 result. Free the data of the original descriptor after the function,
6922 in case it appears in an argument expression and transfer the
6923 result to the original descriptor. */
6926 fcncall_realloc_result (gfc_se
*se
, int rank
)
6935 /* Use the allocation done by the library. Substitute the lhs
6936 descriptor with a copy, whose data field is nulled.*/
6937 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6938 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
6939 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
6941 /* Unallocated, the descriptor does not have a dtype. */
6942 tmp
= gfc_conv_descriptor_dtype (desc
);
6943 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
6945 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
6946 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
6947 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
6949 /* Free the lhs after the function call and copy the result data to
6950 the lhs descriptor. */
6951 tmp
= gfc_conv_descriptor_data_get (desc
);
6952 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6953 boolean_type_node
, tmp
,
6954 build_int_cst (TREE_TYPE (tmp
), 0));
6955 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
6956 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
6957 gfc_add_expr_to_block (&se
->post
, tmp
);
6959 tmp
= gfc_conv_descriptor_data_get (res_desc
);
6960 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
6962 /* Check that the shapes are the same between lhs and expression. */
6963 for (n
= 0 ; n
< rank
; n
++)
6966 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6967 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
6968 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6969 gfc_array_index_type
, tmp
, tmp1
);
6970 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
6971 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6972 gfc_array_index_type
, tmp
, tmp1
);
6973 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
6974 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6975 gfc_array_index_type
, tmp
, tmp1
);
6976 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6977 boolean_type_node
, tmp
,
6978 gfc_index_zero_node
);
6979 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
6980 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6981 boolean_type_node
, tmp
,
6985 /* 'zero_cond' being true is equal to lhs not being allocated or the
6986 shapes being different. */
6987 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
6989 /* Now reset the bounds returned from the function call to bounds based
6990 on the lhs lbounds, except where the lhs is not allocated or the shapes
6991 of 'variable and 'expr' are different. Set the offset accordingly. */
6992 offset
= gfc_index_zero_node
;
6993 for (n
= 0 ; n
< rank
; n
++)
6997 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6998 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
6999 gfc_array_index_type
, zero_cond
,
7000 gfc_index_one_node
, lbound
);
7001 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
7003 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
7004 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
7005 gfc_array_index_type
, tmp
, lbound
);
7006 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
7007 gfc_rank_cst
[n
], lbound
);
7008 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
7009 gfc_rank_cst
[n
], tmp
);
7011 /* Set stride and accumulate the offset. */
7012 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
7013 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
7014 gfc_rank_cst
[n
], tmp
);
7015 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7016 gfc_array_index_type
, lbound
, tmp
);
7017 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
7018 gfc_array_index_type
, offset
, tmp
);
7019 offset
= gfc_evaluate_now (offset
, &se
->post
);
7022 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
7027 /* Try to translate array(:) = func (...), where func is a transformational
7028 array function, without using a temporary. Returns NULL if this isn't the
7032 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
7036 gfc_component
*comp
= NULL
;
7039 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
7042 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
7044 comp
= gfc_get_proc_ptr_comp (expr2
);
7045 gcc_assert (expr2
->value
.function
.isym
7046 || (comp
&& comp
->attr
.dimension
)
7047 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
7048 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
7050 gfc_init_se (&se
, NULL
);
7051 gfc_start_block (&se
.pre
);
7052 se
.want_pointer
= 1;
7054 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
7056 if (expr1
->ts
.type
== BT_DERIVED
7057 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7060 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
7062 gfc_add_expr_to_block (&se
.pre
, tmp
);
7065 se
.direct_byref
= 1;
7066 se
.ss
= gfc_walk_expr (expr2
);
7067 gcc_assert (se
.ss
!= gfc_ss_terminator
);
7069 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
7070 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
7071 Clearly, this cannot be done for an allocatable function result, since
7072 the shape of the result is unknown and, in any case, the function must
7073 correctly take care of the reallocation internally. For intrinsic
7074 calls, the array data is freed and the library takes care of allocation.
7075 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
7077 if (gfc_option
.flag_realloc_lhs
7078 && gfc_is_reallocatable_lhs (expr1
)
7079 && !gfc_expr_attr (expr1
).codimension
7080 && !gfc_is_coindexed (expr1
)
7081 && !(expr2
->value
.function
.esym
7082 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
7084 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7086 if (!expr2
->value
.function
.isym
)
7088 ss
= gfc_walk_expr (expr1
);
7089 gcc_assert (ss
!= gfc_ss_terminator
);
7091 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
7092 ss
->is_alloc_lhs
= 1;
7095 fcncall_realloc_result (&se
, expr1
->rank
);
7098 gfc_conv_function_expr (&se
, expr2
);
7099 gfc_add_block_to_block (&se
.pre
, &se
.post
);
7102 gfc_cleanup_loop (&loop
);
7104 gfc_free_ss_chain (se
.ss
);
7106 return gfc_finish_block (&se
.pre
);
7110 /* Try to efficiently translate array(:) = 0. Return NULL if this
7114 gfc_trans_zero_assign (gfc_expr
* expr
)
7116 tree dest
, len
, type
;
7120 sym
= expr
->symtree
->n
.sym
;
7121 dest
= gfc_get_symbol_decl (sym
);
7123 type
= TREE_TYPE (dest
);
7124 if (POINTER_TYPE_P (type
))
7125 type
= TREE_TYPE (type
);
7126 if (!GFC_ARRAY_TYPE_P (type
))
7129 /* Determine the length of the array. */
7130 len
= GFC_TYPE_ARRAY_SIZE (type
);
7131 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7134 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
7135 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7136 fold_convert (gfc_array_index_type
, tmp
));
7138 /* If we are zeroing a local array avoid taking its address by emitting
7140 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
7141 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7142 dest
, build_constructor (TREE_TYPE (dest
),
7145 /* Convert arguments to the correct types. */
7146 dest
= fold_convert (pvoid_type_node
, dest
);
7147 len
= fold_convert (size_type_node
, len
);
7149 /* Construct call to __builtin_memset. */
7150 tmp
= build_call_expr_loc (input_location
,
7151 builtin_decl_explicit (BUILT_IN_MEMSET
),
7152 3, dest
, integer_zero_node
, len
);
7153 return fold_convert (void_type_node
, tmp
);
7157 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
7158 that constructs the call to __builtin_memcpy. */
7161 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
7165 /* Convert arguments to the correct types. */
7166 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
7167 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
7169 dst
= fold_convert (pvoid_type_node
, dst
);
7171 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
7172 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
7174 src
= fold_convert (pvoid_type_node
, src
);
7176 len
= fold_convert (size_type_node
, len
);
7178 /* Construct call to __builtin_memcpy. */
7179 tmp
= build_call_expr_loc (input_location
,
7180 builtin_decl_explicit (BUILT_IN_MEMCPY
),
7182 return fold_convert (void_type_node
, tmp
);
7186 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
7187 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
7188 source/rhs, both are gfc_full_array_ref_p which have been checked for
7192 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7194 tree dst
, dlen
, dtype
;
7195 tree src
, slen
, stype
;
7198 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7199 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
7201 dtype
= TREE_TYPE (dst
);
7202 if (POINTER_TYPE_P (dtype
))
7203 dtype
= TREE_TYPE (dtype
);
7204 stype
= TREE_TYPE (src
);
7205 if (POINTER_TYPE_P (stype
))
7206 stype
= TREE_TYPE (stype
);
7208 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
7211 /* Determine the lengths of the arrays. */
7212 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
7213 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
7215 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7216 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7217 dlen
, fold_convert (gfc_array_index_type
, tmp
));
7219 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
7220 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
7222 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
7223 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7224 slen
, fold_convert (gfc_array_index_type
, tmp
));
7226 /* Sanity check that they are the same. This should always be
7227 the case, as we should already have checked for conformance. */
7228 if (!tree_int_cst_equal (slen
, dlen
))
7231 return gfc_build_memcpy_call (dst
, src
, dlen
);
7235 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
7236 this can't be done. EXPR1 is the destination/lhs for which
7237 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
7240 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
7242 unsigned HOST_WIDE_INT nelem
;
7248 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
7252 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
7253 dtype
= TREE_TYPE (dst
);
7254 if (POINTER_TYPE_P (dtype
))
7255 dtype
= TREE_TYPE (dtype
);
7256 if (!GFC_ARRAY_TYPE_P (dtype
))
7259 /* Determine the lengths of the array. */
7260 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
7261 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
7264 /* Confirm that the constructor is the same size. */
7265 if (compare_tree_int (len
, nelem
) != 0)
7268 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
7269 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
7270 fold_convert (gfc_array_index_type
, tmp
));
7272 stype
= gfc_typenode_for_spec (&expr2
->ts
);
7273 src
= gfc_build_constant_array_constructor (expr2
, stype
);
7275 stype
= TREE_TYPE (src
);
7276 if (POINTER_TYPE_P (stype
))
7277 stype
= TREE_TYPE (stype
);
7279 return gfc_build_memcpy_call (dst
, src
, len
);
7283 /* Tells whether the expression is to be treated as a variable reference. */
7286 expr_is_variable (gfc_expr
*expr
)
7289 gfc_component
*comp
;
7290 gfc_symbol
*func_ifc
;
7292 if (expr
->expr_type
== EXPR_VARIABLE
)
7295 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7298 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7299 return expr_is_variable (arg
);
7302 /* A data-pointer-returning function should be considered as a variable
7304 if (expr
->expr_type
== EXPR_FUNCTION
7305 && expr
->ref
== NULL
)
7307 if (expr
->value
.function
.isym
!= NULL
)
7310 if (expr
->value
.function
.esym
!= NULL
)
7312 func_ifc
= expr
->value
.function
.esym
;
7317 gcc_assert (expr
->symtree
);
7318 func_ifc
= expr
->symtree
->n
.sym
;
7325 comp
= gfc_get_proc_ptr_comp (expr
);
7326 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7329 func_ifc
= comp
->ts
.interface
;
7333 if (expr
->expr_type
== EXPR_COMPCALL
)
7335 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7336 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7343 gcc_assert (func_ifc
->attr
.function
7344 && func_ifc
->result
!= NULL
);
7345 return func_ifc
->result
->attr
.pointer
;
7349 /* Is the lhs OK for automatic reallocation? */
7352 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7356 /* An allocatable variable with no reference. */
7357 if (expr
->symtree
->n
.sym
->attr
.allocatable
7361 /* All that can be left are allocatable components. */
7362 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7363 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7364 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7367 /* Find an allocatable component ref last. */
7368 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7369 if (ref
->type
== REF_COMPONENT
7371 && ref
->u
.c
.component
->attr
.allocatable
)
7378 /* Allocate or reallocate scalar lhs, as necessary. */
7381 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7395 if (!expr1
|| expr1
->rank
)
7398 if (!expr2
|| expr2
->rank
)
7401 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7403 /* Since this is a scalar lhs, we can afford to do this. That is,
7404 there is no risk of side effects being repeated. */
7405 gfc_init_se (&lse
, NULL
);
7406 lse
.want_pointer
= 1;
7407 gfc_conv_expr (&lse
, expr1
);
7409 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7410 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7412 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7413 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7414 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7416 tmp
= build3_v (COND_EXPR
, cond
,
7417 build1_v (GOTO_EXPR
, jump_label1
),
7418 build_empty_stmt (input_location
));
7419 gfc_add_expr_to_block (block
, tmp
);
7421 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7423 /* Use the rhs string length and the lhs element size. */
7424 size
= string_length
;
7425 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7426 tmp
= TYPE_SIZE_UNIT (tmp
);
7427 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7428 TREE_TYPE (tmp
), tmp
,
7429 fold_convert (TREE_TYPE (tmp
), size
));
7433 /* Otherwise use the length in bytes of the rhs. */
7434 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7435 size_in_bytes
= size
;
7438 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7440 tmp
= build_call_expr_loc (input_location
,
7441 builtin_decl_explicit (BUILT_IN_CALLOC
),
7442 2, build_one_cst (size_type_node
),
7444 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7445 gfc_add_modify (block
, lse
.expr
, tmp
);
7449 tmp
= build_call_expr_loc (input_location
,
7450 builtin_decl_explicit (BUILT_IN_MALLOC
),
7452 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7453 gfc_add_modify (block
, lse
.expr
, tmp
);
7456 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7458 /* Deferred characters need checking for lhs and rhs string
7459 length. Other deferred parameter variables will have to
7461 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7462 gfc_add_expr_to_block (block
, tmp
);
7464 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7465 gfc_add_expr_to_block (block
, tmp
);
7467 /* For a deferred length character, reallocate if lengths of lhs and
7468 rhs are different. */
7469 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7471 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7472 expr1
->ts
.u
.cl
->backend_decl
, size
);
7473 /* Jump past the realloc if the lengths are the same. */
7474 tmp
= build3_v (COND_EXPR
, cond
,
7475 build1_v (GOTO_EXPR
, jump_label2
),
7476 build_empty_stmt (input_location
));
7477 gfc_add_expr_to_block (block
, tmp
);
7478 tmp
= build_call_expr_loc (input_location
,
7479 builtin_decl_explicit (BUILT_IN_REALLOC
),
7480 2, fold_convert (pvoid_type_node
, lse
.expr
),
7482 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7483 gfc_add_modify (block
, lse
.expr
, tmp
);
7484 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7485 gfc_add_expr_to_block (block
, tmp
);
7487 /* Update the lhs character length. */
7488 size
= string_length
;
7489 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7494 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7495 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7496 init_flag indicates initialization expressions and dealloc that no
7497 deallocate prior assignment is needed (if in doubt, set true). */
7500 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7506 gfc_ss
*lss_section
;
7513 bool scalar_to_array
;
7517 /* Assignment of the form lhs = rhs. */
7518 gfc_start_block (&block
);
7520 gfc_init_se (&lse
, NULL
);
7521 gfc_init_se (&rse
, NULL
);
7524 lss
= gfc_walk_expr (expr1
);
7525 if (gfc_is_reallocatable_lhs (expr1
)
7526 && !(expr2
->expr_type
== EXPR_FUNCTION
7527 && expr2
->value
.function
.isym
!= NULL
))
7528 lss
->is_alloc_lhs
= 1;
7530 if (lss
!= gfc_ss_terminator
)
7532 /* The assignment needs scalarization. */
7535 /* Find a non-scalar SS from the lhs. */
7536 while (lss_section
!= gfc_ss_terminator
7537 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7538 lss_section
= lss_section
->next
;
7540 gcc_assert (lss_section
!= gfc_ss_terminator
);
7542 /* Initialize the scalarizer. */
7543 gfc_init_loopinfo (&loop
);
7546 rss
= gfc_walk_expr (expr2
);
7547 if (rss
== gfc_ss_terminator
)
7548 /* The rhs is scalar. Add a ss for the expression. */
7549 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7551 /* Associate the SS with the loop. */
7552 gfc_add_ss_to_loop (&loop
, lss
);
7553 gfc_add_ss_to_loop (&loop
, rss
);
7555 /* Calculate the bounds of the scalarization. */
7556 gfc_conv_ss_startstride (&loop
);
7557 /* Enable loop reversal. */
7558 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7559 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7560 /* Resolve any data dependencies in the statement. */
7561 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7562 /* Setup the scalarizing loops. */
7563 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7565 /* Setup the gfc_se structures. */
7566 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7567 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7570 gfc_mark_ss_chain_used (rss
, 1);
7571 if (loop
.temp_ss
== NULL
)
7574 gfc_mark_ss_chain_used (lss
, 1);
7578 lse
.ss
= loop
.temp_ss
;
7579 gfc_mark_ss_chain_used (lss
, 3);
7580 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
7583 /* Allow the scalarizer to workshare array assignments. */
7584 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
7585 ompws_flags
|= OMPWS_SCALARIZER_WS
;
7587 /* Start the scalarized loop body. */
7588 gfc_start_scalarized_body (&loop
, &body
);
7591 gfc_init_block (&body
);
7593 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
7595 /* Translate the expression. */
7596 gfc_conv_expr (&rse
, expr2
);
7598 /* Stabilize a string length for temporaries. */
7599 if (expr2
->ts
.type
== BT_CHARACTER
)
7600 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
7602 string_length
= NULL_TREE
;
7606 gfc_conv_tmp_array_ref (&lse
);
7607 if (expr2
->ts
.type
== BT_CHARACTER
)
7608 lse
.string_length
= string_length
;
7611 gfc_conv_expr (&lse
, expr1
);
7613 /* Assignments of scalar derived types with allocatable components
7614 to arrays must be done with a deep copy and the rhs temporary
7615 must have its components deallocated afterwards. */
7616 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
7617 && expr2
->ts
.u
.derived
->attr
.alloc_comp
7618 && !expr_is_variable (expr2
)
7619 && !gfc_is_constant_expr (expr2
)
7620 && expr1
->rank
&& !expr2
->rank
);
7621 if (scalar_to_array
&& dealloc
)
7623 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
7624 gfc_add_expr_to_block (&loop
.post
, tmp
);
7627 /* When assigning a character function result to a deferred-length variable,
7628 the function call must happen before the (re)allocation of the lhs -
7629 otherwise the character length of the result is not known.
7630 NOTE: This relies on having the exact dependence of the length type
7631 parameter available to the caller; gfortran saves it in the .mod files. */
7632 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
7633 && expr1
->ts
.deferred
)
7634 gfc_add_block_to_block (&block
, &rse
.pre
);
7636 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7637 l_is_temp
|| init_flag
,
7638 expr_is_variable (expr2
) || scalar_to_array
7639 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
7640 gfc_add_expr_to_block (&body
, tmp
);
7642 if (lss
== gfc_ss_terminator
)
7644 /* F2003: Add the code for reallocation on assignment. */
7645 if (gfc_option
.flag_realloc_lhs
7646 && is_scalar_reallocatable_lhs (expr1
))
7647 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
7650 /* Use the scalar assignment as is. */
7651 gfc_add_block_to_block (&block
, &body
);
7655 gcc_assert (lse
.ss
== gfc_ss_terminator
7656 && rse
.ss
== gfc_ss_terminator
);
7660 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
7662 /* We need to copy the temporary to the actual lhs. */
7663 gfc_init_se (&lse
, NULL
);
7664 gfc_init_se (&rse
, NULL
);
7665 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7666 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7668 rse
.ss
= loop
.temp_ss
;
7671 gfc_conv_tmp_array_ref (&rse
);
7672 gfc_conv_expr (&lse
, expr1
);
7674 gcc_assert (lse
.ss
== gfc_ss_terminator
7675 && rse
.ss
== gfc_ss_terminator
);
7677 if (expr2
->ts
.type
== BT_CHARACTER
)
7678 rse
.string_length
= string_length
;
7680 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7681 false, false, dealloc
);
7682 gfc_add_expr_to_block (&body
, tmp
);
7685 /* F2003: Allocate or reallocate lhs of allocatable array. */
7686 if (gfc_option
.flag_realloc_lhs
7687 && gfc_is_reallocatable_lhs (expr1
)
7688 && !gfc_expr_attr (expr1
).codimension
7689 && !gfc_is_coindexed (expr1
)
7692 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7693 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
7694 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
7695 if (tmp
!= NULL_TREE
)
7696 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
7699 /* Generate the copying loops. */
7700 gfc_trans_scalarizing_loops (&loop
, &body
);
7702 /* Wrap the whole thing up. */
7703 gfc_add_block_to_block (&block
, &loop
.pre
);
7704 gfc_add_block_to_block (&block
, &loop
.post
);
7706 gfc_cleanup_loop (&loop
);
7709 return gfc_finish_block (&block
);
7713 /* Check whether EXPR is a copyable array. */
7716 copyable_array_p (gfc_expr
* expr
)
7718 if (expr
->expr_type
!= EXPR_VARIABLE
)
7721 /* First check it's an array. */
7722 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
7725 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
7728 /* Next check that it's of a simple enough type. */
7729 switch (expr
->ts
.type
)
7741 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
7750 /* Translate an assignment. */
7753 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7758 /* Special case a single function returning an array. */
7759 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
7761 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
7766 /* Special case assigning an array to zero. */
7767 if (copyable_array_p (expr1
)
7768 && is_zero_initializer_p (expr2
))
7770 tmp
= gfc_trans_zero_assign (expr1
);
7775 /* Special case copying one array to another. */
7776 if (copyable_array_p (expr1
)
7777 && copyable_array_p (expr2
)
7778 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
7779 && !gfc_check_dependency (expr1
, expr2
, 0))
7781 tmp
= gfc_trans_array_copy (expr1
, expr2
);
7786 /* Special case initializing an array from a constant array constructor. */
7787 if (copyable_array_p (expr1
)
7788 && expr2
->expr_type
== EXPR_ARRAY
7789 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
7791 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
7796 /* Fallback to the scalarizer to generate explicit loops. */
7797 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
7801 gfc_trans_init_assign (gfc_code
* code
)
7803 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
7807 gfc_trans_assign (gfc_code
* code
)
7809 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);