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 /* This is the seed for an eventual trans-class.c
47 The following parameters should not be used directly since they might
48 in future implementations. Use the corresponding APIs. */
49 #define CLASS_DATA_FIELD 0
50 #define CLASS_VPTR_FIELD 1
51 #define VTABLE_HASH_FIELD 0
52 #define VTABLE_SIZE_FIELD 1
53 #define VTABLE_EXTENDS_FIELD 2
54 #define VTABLE_DEF_INIT_FIELD 3
55 #define VTABLE_COPY_FIELD 4
59 gfc_class_data_get (tree decl
)
62 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
63 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
64 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
66 return fold_build3_loc (input_location
, COMPONENT_REF
,
67 TREE_TYPE (data
), decl
, data
,
73 gfc_class_vptr_get (tree decl
)
76 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
77 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
78 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
80 return fold_build3_loc (input_location
, COMPONENT_REF
,
81 TREE_TYPE (vptr
), decl
, vptr
,
87 gfc_vtable_field_get (tree decl
, int field
)
91 vptr
= gfc_class_vptr_get (decl
);
92 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
93 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
95 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
96 TREE_TYPE (size
), vptr
, size
,
98 /* Always return size as an array index type. */
99 if (field
== VTABLE_SIZE_FIELD
)
100 size
= fold_convert (gfc_array_index_type
, size
);
107 gfc_vtable_hash_get (tree decl
)
109 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
114 gfc_vtable_size_get (tree decl
)
116 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
121 gfc_vtable_extends_get (tree decl
)
123 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
128 gfc_vtable_def_init_get (tree decl
)
130 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
135 gfc_vtable_copy_get (tree decl
)
137 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
141 #undef CLASS_DATA_FIELD
142 #undef CLASS_VPTR_FIELD
143 #undef VTABLE_HASH_FIELD
144 #undef VTABLE_SIZE_FIELD
145 #undef VTABLE_EXTENDS_FIELD
146 #undef VTABLE_DEF_INIT_FIELD
147 #undef VTABLE_COPY_FIELD
150 /* Takes a derived type expression and returns the address of a temporary
151 class object of the 'declared' type. */
153 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
154 gfc_typespec class_ts
)
162 /* The derived type needs to be converted to a temporary
164 tmp
= gfc_typenode_for_spec (&class_ts
);
165 var
= gfc_create_var (tmp
, "class");
168 ctree
= gfc_class_vptr_get (var
);
170 /* Remember the vtab corresponds to the derived type
171 not to the class declared type. */
172 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
174 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
175 gfc_add_modify (&parmse
->pre
, ctree
,
176 fold_convert (TREE_TYPE (ctree
), tmp
));
178 /* Now set the data field. */
179 ctree
= gfc_class_data_get (var
);
181 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
183 /* For an array reference in an elemental procedure call we need
184 to retain the ss to provide the scalarized array reference. */
185 gfc_conv_expr_reference (parmse
, e
);
186 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
187 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
191 ss
= gfc_walk_expr (e
);
192 if (ss
== gfc_ss_terminator
)
195 gfc_conv_expr_reference (parmse
, e
);
196 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
197 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
202 gfc_conv_expr_descriptor (parmse
, e
, ss
);
203 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
207 /* Pass the address of the class object. */
208 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
212 /* Takes a scalarized class array expression and returns the
213 address of a temporary scalar class object of the 'declared'
215 OOP-TODO: This could be improved by adding code that branched on
216 the dynamic type being the same as the declared type. In this case
217 the original class expression can be passed directly. */
219 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
,
220 gfc_typespec class_ts
, bool elemental
)
228 bool full_array
= false;
231 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
233 if (ref
->type
== REF_COMPONENT
234 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
237 if (ref
->next
== NULL
)
241 if (ref
== NULL
|| class_ref
== ref
)
244 /* Test for FULL_ARRAY. */
245 gfc_is_class_array_ref (e
, &full_array
);
247 /* The derived type needs to be converted to a temporary
249 tmp
= gfc_typenode_for_spec (&class_ts
);
250 var
= gfc_create_var (tmp
, "class");
253 ctree
= gfc_class_data_get (var
);
254 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
256 /* Return the data component, except in the case of scalarized array
257 references, where nullification of the cannot occur and so there
259 if (!elemental
&& full_array
)
260 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
263 ctree
= gfc_class_vptr_get (var
);
265 /* The vptr is the second field of the actual argument.
266 First we have to find the corresponding class reference. */
269 if (class_ref
== NULL
270 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
271 tmp
= e
->symtree
->n
.sym
->backend_decl
;
274 /* Remove everything after the last class reference, convert the
275 expression and then recover its tailend once more. */
277 ref
= class_ref
->next
;
278 class_ref
->next
= NULL
;
279 gfc_init_se (&tmpse
, NULL
);
280 gfc_conv_expr (&tmpse
, e
);
281 class_ref
->next
= ref
;
285 gcc_assert (tmp
!= NULL_TREE
);
287 /* Dereference if needs be. */
288 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
289 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
291 vptr
= gfc_class_vptr_get (tmp
);
292 gfc_add_modify (&parmse
->pre
, ctree
,
293 fold_convert (TREE_TYPE (ctree
), vptr
));
295 /* Return the vptr component, except in the case of scalarized array
296 references, where the dynamic type cannot change. */
297 if (!elemental
&& full_array
)
298 gfc_add_modify (&parmse
->post
, vptr
,
299 fold_convert (TREE_TYPE (vptr
), ctree
));
301 /* Pass the address of the class object. */
302 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
305 /* End of prototype trans-class.c */
308 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
309 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
312 /* Copy the scalarization loop variables. */
315 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
318 dest
->loop
= src
->loop
;
322 /* Initialize a simple expression holder.
324 Care must be taken when multiple se are created with the same parent.
325 The child se must be kept in sync. The easiest way is to delay creation
326 of a child se until after after the previous se has been translated. */
329 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
331 memset (se
, 0, sizeof (gfc_se
));
332 gfc_init_block (&se
->pre
);
333 gfc_init_block (&se
->post
);
338 gfc_copy_se_loopvars (se
, parent
);
342 /* Advances to the next SS in the chain. Use this rather than setting
343 se->ss = se->ss->next because all the parents needs to be kept in sync.
347 gfc_advance_se_ss_chain (gfc_se
* se
)
352 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
355 /* Walk down the parent chain. */
358 /* Simple consistency check. */
359 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
360 || p
->parent
->ss
->nested_ss
== p
->ss
);
362 /* If we were in a nested loop, the next scalarized expression can be
363 on the parent ss' next pointer. Thus we should not take the next
364 pointer blindly, but rather go up one nest level as long as next
365 is the end of chain. */
367 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
377 /* Ensures the result of the expression as either a temporary variable
378 or a constant so that it can be used repeatedly. */
381 gfc_make_safe_expr (gfc_se
* se
)
385 if (CONSTANT_CLASS_P (se
->expr
))
388 /* We need a temporary for this result. */
389 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
390 gfc_add_modify (&se
->pre
, var
, se
->expr
);
395 /* Return an expression which determines if a dummy parameter is present.
396 Also used for arguments to procedures with multiple entry points. */
399 gfc_conv_expr_present (gfc_symbol
* sym
)
403 gcc_assert (sym
->attr
.dummy
);
405 decl
= gfc_get_symbol_decl (sym
);
406 if (TREE_CODE (decl
) != PARM_DECL
)
408 /* Array parameters use a temporary descriptor, we want the real
410 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
411 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
412 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
415 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
416 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
418 /* Fortran 2008 allows to pass null pointers and non-associated pointers
419 as actual argument to denote absent dummies. For array descriptors,
420 we thus also need to check the array descriptor. */
421 if (!sym
->attr
.pointer
&& !sym
->attr
.allocatable
422 && sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
423 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
426 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
427 tmp
= gfc_conv_array_data (tmp
);
428 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
429 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
430 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
431 boolean_type_node
, cond
, tmp
);
438 /* Converts a missing, dummy argument into a null or zero. */
441 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
446 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
450 /* Create a temporary and convert it to the correct type. */
451 tmp
= gfc_get_int_type (kind
);
452 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
455 /* Test for a NULL value. */
456 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
457 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
458 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
459 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
463 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
465 build_zero_cst (TREE_TYPE (se
->expr
)));
466 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
470 if (ts
.type
== BT_CHARACTER
)
472 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
473 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
474 present
, se
->string_length
, tmp
);
475 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
476 se
->string_length
= tmp
;
482 /* Get the character length of an expression, looking through gfc_refs
486 gfc_get_expr_charlen (gfc_expr
*e
)
491 gcc_assert (e
->expr_type
== EXPR_VARIABLE
492 && e
->ts
.type
== BT_CHARACTER
);
494 length
= NULL
; /* To silence compiler warning. */
496 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
499 gfc_init_se (&tmpse
, NULL
);
500 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
501 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
505 /* First candidate: if the variable is of type CHARACTER, the
506 expression's length could be the length of the character
508 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
509 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
511 /* Look through the reference chain for component references. */
512 for (r
= e
->ref
; r
; r
= r
->next
)
517 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
518 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
526 /* We should never got substring references here. These will be
527 broken down by the scalarizer. */
533 gcc_assert (length
!= NULL
);
538 /* Return for an expression the backend decl of the coarray. */
541 get_tree_for_caf_expr (gfc_expr
*expr
)
543 tree caf_decl
= NULL_TREE
;
546 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
547 if (expr
->symtree
->n
.sym
->attr
.codimension
)
548 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
550 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
551 if (ref
->type
== REF_COMPONENT
)
553 gfc_component
*comp
= ref
->u
.c
.component
;
554 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
555 caf_decl
= NULL_TREE
;
556 if (comp
->attr
.codimension
)
557 caf_decl
= comp
->backend_decl
;
560 gcc_assert (caf_decl
!= NULL_TREE
);
565 /* For each character array constructor subexpression without a ts.u.cl->length,
566 replace it by its first element (if there aren't any elements, the length
567 should already be set to zero). */
570 flatten_array_ctors_without_strlen (gfc_expr
* e
)
572 gfc_actual_arglist
* arg
;
578 switch (e
->expr_type
)
582 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
583 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
587 /* TODO: Implement as with EXPR_FUNCTION when needed. */
591 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
592 flatten_array_ctors_without_strlen (arg
->expr
);
597 /* We've found what we're looking for. */
598 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
603 gcc_assert (e
->value
.constructor
);
605 c
= gfc_constructor_first (e
->value
.constructor
);
609 flatten_array_ctors_without_strlen (new_expr
);
610 gfc_replace_expr (e
, new_expr
);
614 /* Otherwise, fall through to handle constructor elements. */
616 for (c
= gfc_constructor_first (e
->value
.constructor
);
617 c
; c
= gfc_constructor_next (c
))
618 flatten_array_ctors_without_strlen (c
->expr
);
628 /* Generate code to initialize a string length variable. Returns the
629 value. For array constructors, cl->length might be NULL and in this case,
630 the first element of the constructor is needed. expr is the original
631 expression so we can access it but can be NULL if this is not needed. */
634 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
638 gfc_init_se (&se
, NULL
);
642 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
645 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
646 "flatten" array constructors by taking their first element; all elements
647 should be the same length or a cl->length should be present. */
652 expr_flat
= gfc_copy_expr (expr
);
653 flatten_array_ctors_without_strlen (expr_flat
);
654 gfc_resolve_expr (expr_flat
);
656 gfc_conv_expr (&se
, expr_flat
);
657 gfc_add_block_to_block (pblock
, &se
.pre
);
658 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
660 gfc_free_expr (expr_flat
);
664 /* Convert cl->length. */
666 gcc_assert (cl
->length
);
668 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
669 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
670 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
671 gfc_add_block_to_block (pblock
, &se
.pre
);
673 if (cl
->backend_decl
)
674 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
676 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
681 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
682 const char *name
, locus
*where
)
691 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
692 type
= build_pointer_type (type
);
694 gfc_init_se (&start
, se
);
695 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
696 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
698 if (integer_onep (start
.expr
))
699 gfc_conv_string_parameter (se
);
704 /* Avoid multiple evaluation of substring start. */
705 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
706 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
708 /* Change the start of the string. */
709 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
712 tmp
= build_fold_indirect_ref_loc (input_location
,
714 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
715 se
->expr
= gfc_build_addr_expr (type
, tmp
);
718 /* Length = end + 1 - start. */
719 gfc_init_se (&end
, se
);
720 if (ref
->u
.ss
.end
== NULL
)
721 end
.expr
= se
->string_length
;
724 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
725 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
729 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
730 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
732 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
734 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
735 boolean_type_node
, start
.expr
,
738 /* Check lower bound. */
739 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
741 build_int_cst (gfc_charlen_type_node
, 1));
742 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
743 boolean_type_node
, nonempty
, fault
);
745 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
746 "is less than one", name
);
748 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
750 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
751 fold_convert (long_integer_type_node
,
755 /* Check upper bound. */
756 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
757 end
.expr
, se
->string_length
);
758 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
759 boolean_type_node
, nonempty
, fault
);
761 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
762 "exceeds string length (%%ld)", name
);
764 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
765 "exceeds string length (%%ld)");
766 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
767 fold_convert (long_integer_type_node
, end
.expr
),
768 fold_convert (long_integer_type_node
,
773 /* If the start and end expressions are equal, the length is one. */
775 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
776 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
779 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
780 end
.expr
, start
.expr
);
781 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
782 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
783 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
784 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
787 se
->string_length
= tmp
;
791 /* Convert a derived type component reference. */
794 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
801 c
= ref
->u
.c
.component
;
803 gcc_assert (c
->backend_decl
);
805 field
= c
->backend_decl
;
806 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
809 /* Components can correspond to fields of different containing
810 types, as components are created without context, whereas
811 a concrete use of a component has the type of decl as context.
812 So, if the type doesn't match, we search the corresponding
813 FIELD_DECL in the parent type. To not waste too much time
814 we cache this result in norestrict_decl. */
816 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
818 tree f2
= c
->norestrict_decl
;
819 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
820 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
821 if (TREE_CODE (f2
) == FIELD_DECL
822 && DECL_NAME (f2
) == DECL_NAME (field
))
825 c
->norestrict_decl
= f2
;
828 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
829 decl
, field
, NULL_TREE
);
833 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
835 tmp
= c
->ts
.u
.cl
->backend_decl
;
836 /* Components must always be constant length. */
837 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
838 se
->string_length
= tmp
;
841 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
842 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
843 && c
->ts
.type
!= BT_CHARACTER
)
844 || c
->attr
.proc_pointer
)
845 se
->expr
= build_fold_indirect_ref_loc (input_location
,
850 /* This function deals with component references to components of the
851 parent type for derived type extensons. */
853 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
861 c
= ref
->u
.c
.component
;
863 /* Return if the component is not in the parent type. */
864 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
865 if (strcmp (c
->name
, cmp
->name
) == 0)
868 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
869 parent
.type
= REF_COMPONENT
;
872 parent
.u
.c
.component
= dt
->components
;
874 if (dt
->backend_decl
== NULL
)
875 gfc_get_derived_type (dt
);
877 /* Build the reference and call self. */
878 gfc_conv_component_ref (se
, &parent
);
879 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
880 parent
.u
.c
.component
= c
;
881 conv_parent_component_references (se
, &parent
);
884 /* Return the contents of a variable. Also handles reference/pointer
885 variables (all Fortran pointer references are implicit). */
888 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
893 tree parent_decl
= NULL_TREE
;
896 bool alternate_entry
;
899 sym
= expr
->symtree
->n
.sym
;
903 gfc_ss_info
*ss_info
= ss
->info
;
905 /* Check that something hasn't gone horribly wrong. */
906 gcc_assert (ss
!= gfc_ss_terminator
);
907 gcc_assert (ss_info
->expr
== expr
);
909 /* A scalarized term. We already know the descriptor. */
910 se
->expr
= ss_info
->data
.array
.descriptor
;
911 se
->string_length
= ss_info
->string_length
;
912 for (ref
= ss_info
->data
.array
.ref
; ref
; ref
= ref
->next
)
913 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
918 tree se_expr
= NULL_TREE
;
920 se
->expr
= gfc_get_symbol_decl (sym
);
922 /* Deal with references to a parent results or entries by storing
923 the current_function_decl and moving to the parent_decl. */
924 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
925 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
926 && sym
->result
== sym
;
927 entry_master
= sym
->attr
.result
928 && sym
->ns
->proc_name
->attr
.entry_master
929 && !gfc_return_by_reference (sym
->ns
->proc_name
);
930 if (current_function_decl
)
931 parent_decl
= DECL_CONTEXT (current_function_decl
);
933 if ((se
->expr
== parent_decl
&& return_value
)
934 || (sym
->ns
&& sym
->ns
->proc_name
936 && sym
->ns
->proc_name
->backend_decl
== parent_decl
937 && (alternate_entry
|| entry_master
)))
942 /* Special case for assigning the return value of a function.
943 Self recursive functions must have an explicit return value. */
944 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
945 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
947 /* Similarly for alternate entry points. */
948 else if (alternate_entry
949 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
952 gfc_entry_list
*el
= NULL
;
954 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
957 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
962 else if (entry_master
963 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
965 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
970 /* Procedure actual arguments. */
971 else if (sym
->attr
.flavor
== FL_PROCEDURE
972 && se
->expr
!= current_function_decl
)
974 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
976 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
977 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
983 /* Dereference the expression, where needed. Since characters
984 are entirely different from other types, they are treated
986 if (sym
->ts
.type
== BT_CHARACTER
)
988 /* Dereference character pointer dummy arguments
990 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
992 || sym
->attr
.function
993 || sym
->attr
.result
))
994 se
->expr
= build_fold_indirect_ref_loc (input_location
,
998 else if (!sym
->attr
.value
)
1000 /* Dereference non-character scalar dummy arguments. */
1001 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1002 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1003 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1006 /* Dereference scalar hidden result. */
1007 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1008 && (sym
->attr
.function
|| sym
->attr
.result
)
1009 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1010 && !sym
->attr
.always_explicit
)
1011 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1014 /* Dereference non-character pointer variables.
1015 These must be dummies, results, or scalars. */
1016 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1017 || gfc_is_associate_pointer (sym
))
1019 || sym
->attr
.function
1021 || (!sym
->attr
.dimension
1022 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1023 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1030 /* For character variables, also get the length. */
1031 if (sym
->ts
.type
== BT_CHARACTER
)
1033 /* If the character length of an entry isn't set, get the length from
1034 the master function instead. */
1035 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1036 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1038 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1039 gcc_assert (se
->string_length
);
1047 /* Return the descriptor if that's what we want and this is an array
1048 section reference. */
1049 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1051 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1052 /* Return the descriptor for array pointers and allocations. */
1053 if (se
->want_pointer
1054 && ref
->next
== NULL
&& (se
->descriptor_only
))
1057 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
1058 /* Return a pointer to an element. */
1062 if (ref
->u
.c
.sym
->attr
.extension
)
1063 conv_parent_component_references (se
, ref
);
1065 gfc_conv_component_ref (se
, ref
);
1070 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1071 expr
->symtree
->name
, &expr
->where
);
1080 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1082 if (se
->want_pointer
)
1084 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
1085 gfc_conv_string_parameter (se
);
1087 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1092 /* Unary ops are easy... Or they would be if ! was a valid op. */
1095 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1100 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1101 /* Initialize the operand. */
1102 gfc_init_se (&operand
, se
);
1103 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1104 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1106 type
= gfc_typenode_for_spec (&expr
->ts
);
1108 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1109 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1110 All other unary operators have an equivalent GIMPLE unary operator. */
1111 if (code
== TRUTH_NOT_EXPR
)
1112 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1113 build_int_cst (type
, 0));
1115 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1119 /* Expand power operator to optimal multiplications when a value is raised
1120 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1121 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1122 Programming", 3rd Edition, 1998. */
1124 /* This code is mostly duplicated from expand_powi in the backend.
1125 We establish the "optimal power tree" lookup table with the defined size.
1126 The items in the table are the exponents used to calculate the index
1127 exponents. Any integer n less than the value can get an "addition chain",
1128 with the first node being one. */
1129 #define POWI_TABLE_SIZE 256
1131 /* The table is from builtins.c. */
1132 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1134 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1135 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1136 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1137 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1138 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1139 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1140 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1141 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1142 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1143 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1144 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1145 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1146 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1147 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1148 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1149 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1150 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1151 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1152 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1153 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1154 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1155 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1156 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1157 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1158 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1159 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1160 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1161 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1162 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1163 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1164 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1165 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1168 /* If n is larger than lookup table's max index, we use the "window
1170 #define POWI_WINDOW_SIZE 3
1172 /* Recursive function to expand the power operator. The temporary
1173 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1175 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
1182 if (n
< POWI_TABLE_SIZE
)
1187 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
1188 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
1192 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
1193 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
1194 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
1198 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
1202 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
1203 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1205 if (n
< POWI_TABLE_SIZE
)
1212 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1213 return 1. Else return 0 and a call to runtime library functions
1214 will have to be built. */
1216 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
1221 tree vartmp
[POWI_TABLE_SIZE
];
1223 unsigned HOST_WIDE_INT n
;
1226 /* If exponent is too large, we won't expand it anyway, so don't bother
1227 with large integer values. */
1228 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
1231 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
1232 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1233 of the asymmetric range of the integer type. */
1234 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
1236 type
= TREE_TYPE (lhs
);
1237 sgn
= tree_int_cst_sgn (rhs
);
1239 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
1240 || optimize_size
) && (m
> 2 || m
< -1))
1246 se
->expr
= gfc_build_const (type
, integer_one_node
);
1250 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1251 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
1253 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1254 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
1255 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1256 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
1259 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1262 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1263 boolean_type_node
, tmp
, cond
);
1264 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1265 tmp
, build_int_cst (type
, 1),
1266 build_int_cst (type
, 0));
1270 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1271 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
1272 build_int_cst (type
, -1),
1273 build_int_cst (type
, 0));
1274 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1275 cond
, build_int_cst (type
, 1), tmp
);
1279 memset (vartmp
, 0, sizeof (vartmp
));
1283 tmp
= gfc_build_const (type
, integer_one_node
);
1284 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
1288 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
1294 /* Power op (**). Constant integer exponent has special handling. */
1297 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
1299 tree gfc_int4_type_node
;
1302 int res_ikind_1
, res_ikind_2
;
1307 gfc_init_se (&lse
, se
);
1308 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
1309 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
1310 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1312 gfc_init_se (&rse
, se
);
1313 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
1314 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1316 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
1317 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
1318 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
1321 gfc_int4_type_node
= gfc_get_int_type (4);
1323 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1324 library routine. But in the end, we have to convert the result back
1325 if this case applies -- with res_ikind_K, we keep track whether operand K
1326 falls into this case. */
1330 kind
= expr
->value
.op
.op1
->ts
.kind
;
1331 switch (expr
->value
.op
.op2
->ts
.type
)
1334 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1339 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1340 res_ikind_2
= ikind
;
1362 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
1364 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1391 switch (expr
->value
.op
.op1
->ts
.type
)
1394 if (kind
== 3) /* Case 16 was not handled properly above. */
1396 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1400 /* Use builtins for real ** int4. */
1406 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
1410 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
1414 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
1418 /* Use the __builtin_powil() only if real(kind=16) is
1419 actually the C long double type. */
1420 if (!gfc_real16_is_float128
)
1421 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
1429 /* If we don't have a good builtin for this, go for the
1430 library function. */
1432 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1436 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1445 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
1449 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
1457 se
->expr
= build_call_expr_loc (input_location
,
1458 fndecl
, 2, lse
.expr
, rse
.expr
);
1460 /* Convert the result back if it is of wrong integer kind. */
1461 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
1463 /* We want the maximum of both operand kinds as result. */
1464 if (res_ikind_1
< res_ikind_2
)
1465 res_ikind_1
= res_ikind_2
;
1466 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
1471 /* Generate code to allocate a string temporary. */
1474 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1479 if (gfc_can_put_var_on_stack (len
))
1481 /* Create a temporary variable to hold the result. */
1482 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1483 gfc_charlen_type_node
, len
,
1484 build_int_cst (gfc_charlen_type_node
, 1));
1485 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1487 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1488 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1490 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1492 var
= gfc_create_var (tmp
, "str");
1493 var
= gfc_build_addr_expr (type
, var
);
1497 /* Allocate a temporary to hold the result. */
1498 var
= gfc_create_var (type
, "pstr");
1499 tmp
= gfc_call_malloc (&se
->pre
, type
,
1500 fold_build2_loc (input_location
, MULT_EXPR
,
1501 TREE_TYPE (len
), len
,
1502 fold_convert (TREE_TYPE (len
),
1503 TYPE_SIZE (type
))));
1504 gfc_add_modify (&se
->pre
, var
, tmp
);
1506 /* Free the temporary afterwards. */
1507 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1508 gfc_add_expr_to_block (&se
->post
, tmp
);
1515 /* Handle a string concatenation operation. A temporary will be allocated to
1519 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1522 tree len
, type
, var
, tmp
, fndecl
;
1524 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1525 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1526 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1528 gfc_init_se (&lse
, se
);
1529 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1530 gfc_conv_string_parameter (&lse
);
1531 gfc_init_se (&rse
, se
);
1532 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1533 gfc_conv_string_parameter (&rse
);
1535 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1536 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1538 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1539 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1540 if (len
== NULL_TREE
)
1542 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
1543 TREE_TYPE (lse
.string_length
),
1544 lse
.string_length
, rse
.string_length
);
1547 type
= build_pointer_type (type
);
1549 var
= gfc_conv_string_tmp (se
, type
, len
);
1551 /* Do the actual concatenation. */
1552 if (expr
->ts
.kind
== 1)
1553 fndecl
= gfor_fndecl_concat_string
;
1554 else if (expr
->ts
.kind
== 4)
1555 fndecl
= gfor_fndecl_concat_string_char4
;
1559 tmp
= build_call_expr_loc (input_location
,
1560 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1561 rse
.string_length
, rse
.expr
);
1562 gfc_add_expr_to_block (&se
->pre
, tmp
);
1564 /* Add the cleanup for the operands. */
1565 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1566 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1569 se
->string_length
= len
;
1572 /* Translates an op expression. Common (binary) cases are handled by this
1573 function, others are passed on. Recursion is used in either case.
1574 We use the fact that (op1.ts == op2.ts) (except for the power
1576 Operators need no special handling for scalarized expressions as long as
1577 they call gfc_conv_simple_val to get their operands.
1578 Character strings get special handling. */
1581 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1583 enum tree_code code
;
1592 switch (expr
->value
.op
.op
)
1594 case INTRINSIC_PARENTHESES
:
1595 if ((expr
->ts
.type
== BT_REAL
1596 || expr
->ts
.type
== BT_COMPLEX
)
1597 && gfc_option
.flag_protect_parens
)
1599 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1600 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1605 case INTRINSIC_UPLUS
:
1606 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1609 case INTRINSIC_UMINUS
:
1610 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1614 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1617 case INTRINSIC_PLUS
:
1621 case INTRINSIC_MINUS
:
1625 case INTRINSIC_TIMES
:
1629 case INTRINSIC_DIVIDE
:
1630 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1631 an integer, we must round towards zero, so we use a
1633 if (expr
->ts
.type
== BT_INTEGER
)
1634 code
= TRUNC_DIV_EXPR
;
1639 case INTRINSIC_POWER
:
1640 gfc_conv_power_op (se
, expr
);
1643 case INTRINSIC_CONCAT
:
1644 gfc_conv_concat_op (se
, expr
);
1648 code
= TRUTH_ANDIF_EXPR
;
1653 code
= TRUTH_ORIF_EXPR
;
1657 /* EQV and NEQV only work on logicals, but since we represent them
1658 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1660 case INTRINSIC_EQ_OS
:
1668 case INTRINSIC_NE_OS
:
1669 case INTRINSIC_NEQV
:
1676 case INTRINSIC_GT_OS
:
1683 case INTRINSIC_GE_OS
:
1690 case INTRINSIC_LT_OS
:
1697 case INTRINSIC_LE_OS
:
1703 case INTRINSIC_USER
:
1704 case INTRINSIC_ASSIGN
:
1705 /* These should be converted into function calls by the frontend. */
1709 fatal_error ("Unknown intrinsic op");
1713 /* The only exception to this is **, which is handled separately anyway. */
1714 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1716 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1720 gfc_init_se (&lse
, se
);
1721 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1722 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1725 gfc_init_se (&rse
, se
);
1726 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1727 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1731 gfc_conv_string_parameter (&lse
);
1732 gfc_conv_string_parameter (&rse
);
1734 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1735 rse
.string_length
, rse
.expr
,
1736 expr
->value
.op
.op1
->ts
.kind
,
1738 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1739 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1742 type
= gfc_typenode_for_spec (&expr
->ts
);
1746 /* The result of logical ops is always boolean_type_node. */
1747 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
1748 lse
.expr
, rse
.expr
);
1749 se
->expr
= convert (type
, tmp
);
1752 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
1754 /* Add the post blocks. */
1755 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1756 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1759 /* If a string's length is one, we convert it to a single character. */
1762 gfc_string_to_single_character (tree len
, tree str
, int kind
)
1765 if (!INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
1766 || !POINTER_TYPE_P (TREE_TYPE (str
)))
1769 if (TREE_INT_CST_LOW (len
) == 1)
1771 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1772 return build_fold_indirect_ref_loc (input_location
, str
);
1776 && TREE_CODE (str
) == ADDR_EXPR
1777 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1778 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1779 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1780 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1781 && TREE_INT_CST_LOW (len
) > 1
1782 && TREE_INT_CST_LOW (len
)
1783 == (unsigned HOST_WIDE_INT
)
1784 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1786 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
1787 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
1788 if (TREE_CODE (ret
) == INTEGER_CST
)
1790 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1791 int i
, length
= TREE_STRING_LENGTH (string_cst
);
1792 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1794 for (i
= 1; i
< length
; i
++)
1807 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1810 if (sym
->backend_decl
)
1812 /* This becomes the nominal_type in
1813 function.c:assign_parm_find_data_types. */
1814 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1815 /* This becomes the passed_type in
1816 function.c:assign_parm_find_data_types. C promotes char to
1817 integer for argument passing. */
1818 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1820 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1825 /* If we have a constant character expression, make it into an
1827 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1832 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1833 (int)(*expr
)->value
.character
.string
[0]);
1834 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1836 /* The expr needs to be compatible with a C int. If the
1837 conversion fails, then the 2 causes an ICE. */
1838 ts
.type
= BT_INTEGER
;
1839 ts
.kind
= gfc_c_int_kind
;
1840 gfc_convert_type (*expr
, &ts
, 2);
1843 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1845 if ((*expr
)->ref
== NULL
)
1847 se
->expr
= gfc_string_to_single_character
1848 (build_int_cst (integer_type_node
, 1),
1849 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1851 ((*expr
)->symtree
->n
.sym
)),
1856 gfc_conv_variable (se
, *expr
);
1857 se
->expr
= gfc_string_to_single_character
1858 (build_int_cst (integer_type_node
, 1),
1859 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1867 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
1868 if STR is a string literal, otherwise return -1. */
1871 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
1874 && TREE_CODE (str
) == ADDR_EXPR
1875 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
1876 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
1877 && array_ref_low_bound (TREE_OPERAND (str
, 0))
1878 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
1879 && TREE_INT_CST_LOW (len
) >= 1
1880 && TREE_INT_CST_LOW (len
)
1881 == (unsigned HOST_WIDE_INT
)
1882 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
1884 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
1885 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
1886 if (TREE_CODE (folded
) == INTEGER_CST
)
1888 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
1889 int length
= TREE_STRING_LENGTH (string_cst
);
1890 const char *ptr
= TREE_STRING_POINTER (string_cst
);
1892 for (; length
> 0; length
--)
1893 if (ptr
[length
- 1] != ' ')
1902 /* Compare two strings. If they are all single characters, the result is the
1903 subtraction of them. Otherwise, we build a library call. */
1906 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
1907 enum tree_code code
)
1913 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1914 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1916 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
1917 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
1919 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1921 /* Deal with single character specially. */
1922 sc1
= fold_convert (integer_type_node
, sc1
);
1923 sc2
= fold_convert (integer_type_node
, sc2
);
1924 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
1928 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
1930 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
1932 /* If one string is a string literal with LEN_TRIM longer
1933 than the length of the second string, the strings
1935 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
1936 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
1937 return integer_one_node
;
1938 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
1939 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
1940 return integer_one_node
;
1943 /* Build a call for the comparison. */
1945 fndecl
= gfor_fndecl_compare_string
;
1947 fndecl
= gfor_fndecl_compare_string_char4
;
1951 return build_call_expr_loc (input_location
, fndecl
, 4,
1952 len1
, str1
, len2
, str2
);
1956 /* Return the backend_decl for a procedure pointer component. */
1959 get_proc_ptr_comp (gfc_expr
*e
)
1965 gfc_init_se (&comp_se
, NULL
);
1966 e2
= gfc_copy_expr (e
);
1967 /* We have to restore the expr type later so that gfc_free_expr frees
1968 the exact same thing that was allocated.
1969 TODO: This is ugly. */
1970 old_type
= e2
->expr_type
;
1971 e2
->expr_type
= EXPR_VARIABLE
;
1972 gfc_conv_expr (&comp_se
, e2
);
1973 e2
->expr_type
= old_type
;
1975 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1980 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1984 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1985 tmp
= get_proc_ptr_comp (expr
);
1986 else if (sym
->attr
.dummy
)
1988 tmp
= gfc_get_symbol_decl (sym
);
1989 if (sym
->attr
.proc_pointer
)
1990 tmp
= build_fold_indirect_ref_loc (input_location
,
1992 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1993 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1997 if (!sym
->backend_decl
)
1998 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2000 tmp
= sym
->backend_decl
;
2002 if (sym
->attr
.cray_pointee
)
2004 /* TODO - make the cray pointee a pointer to a procedure,
2005 assign the pointer to it and use it for the call. This
2007 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2008 gfc_get_symbol_decl (sym
->cp_pointer
));
2009 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2012 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2014 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2015 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2022 /* Initialize MAPPING. */
2025 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2027 mapping
->syms
= NULL
;
2028 mapping
->charlens
= NULL
;
2032 /* Free all memory held by MAPPING (but not MAPPING itself). */
2035 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2037 gfc_interface_sym_mapping
*sym
;
2038 gfc_interface_sym_mapping
*nextsym
;
2040 gfc_charlen
*nextcl
;
2042 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2044 nextsym
= sym
->next
;
2045 sym
->new_sym
->n
.sym
->formal
= NULL
;
2046 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2047 gfc_free_expr (sym
->expr
);
2048 free (sym
->new_sym
);
2051 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2054 gfc_free_expr (cl
->length
);
2060 /* Return a copy of gfc_charlen CL. Add the returned structure to
2061 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2063 static gfc_charlen
*
2064 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
2067 gfc_charlen
*new_charlen
;
2069 new_charlen
= gfc_get_charlen ();
2070 new_charlen
->next
= mapping
->charlens
;
2071 new_charlen
->length
= gfc_copy_expr (cl
->length
);
2073 mapping
->charlens
= new_charlen
;
2078 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2079 array variable that can be used as the actual argument for dummy
2080 argument SYM. Add any initialization code to BLOCK. PACKED is as
2081 for gfc_get_nodesc_array_type and DATA points to the first element
2082 in the passed array. */
2085 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
2086 gfc_packed packed
, tree data
)
2091 type
= gfc_typenode_for_spec (&sym
->ts
);
2092 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
2093 !sym
->attr
.target
&& !sym
->attr
.pointer
2094 && !sym
->attr
.proc_pointer
);
2096 var
= gfc_create_var (type
, "ifm");
2097 gfc_add_modify (block
, var
, fold_convert (type
, data
));
2103 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2104 and offset of descriptorless array type TYPE given that it has the same
2105 size as DESC. Add any set-up code to BLOCK. */
2108 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
2115 offset
= gfc_index_zero_node
;
2116 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
2118 dim
= gfc_rank_cst
[n
];
2119 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
2120 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
2122 GFC_TYPE_ARRAY_LBOUND (type
, n
)
2123 = gfc_conv_descriptor_lbound_get (desc
, dim
);
2124 GFC_TYPE_ARRAY_UBOUND (type
, n
)
2125 = gfc_conv_descriptor_ubound_get (desc
, dim
);
2127 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
2129 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2130 gfc_array_index_type
,
2131 gfc_conv_descriptor_ubound_get (desc
, dim
),
2132 gfc_conv_descriptor_lbound_get (desc
, dim
));
2133 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2134 gfc_array_index_type
,
2135 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
2136 tmp
= gfc_evaluate_now (tmp
, block
);
2137 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
2139 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2140 GFC_TYPE_ARRAY_LBOUND (type
, n
),
2141 GFC_TYPE_ARRAY_STRIDE (type
, n
));
2142 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2143 gfc_array_index_type
, offset
, tmp
);
2145 offset
= gfc_evaluate_now (offset
, block
);
2146 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
2150 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2151 in SE. The caller may still use se->expr and se->string_length after
2152 calling this function. */
2155 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
2156 gfc_symbol
* sym
, gfc_se
* se
,
2159 gfc_interface_sym_mapping
*sm
;
2163 gfc_symbol
*new_sym
;
2165 gfc_symtree
*new_symtree
;
2167 /* Create a new symbol to represent the actual argument. */
2168 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
2169 new_sym
->ts
= sym
->ts
;
2170 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
2171 new_sym
->attr
.referenced
= 1;
2172 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
2173 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
2174 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
2175 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
2176 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
2177 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
2178 new_sym
->attr
.function
= sym
->attr
.function
;
2180 /* Ensure that the interface is available and that
2181 descriptors are passed for array actual arguments. */
2182 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2184 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
2185 new_sym
->attr
.always_explicit
2186 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
2189 /* Create a fake symtree for it. */
2191 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
2192 new_symtree
->n
.sym
= new_sym
;
2193 gcc_assert (new_symtree
== root
);
2195 /* Create a dummy->actual mapping. */
2196 sm
= XCNEW (gfc_interface_sym_mapping
);
2197 sm
->next
= mapping
->syms
;
2199 sm
->new_sym
= new_symtree
;
2200 sm
->expr
= gfc_copy_expr (expr
);
2203 /* Stabilize the argument's value. */
2204 if (!sym
->attr
.function
&& se
)
2205 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2207 if (sym
->ts
.type
== BT_CHARACTER
)
2209 /* Create a copy of the dummy argument's length. */
2210 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
2211 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
2213 /* If the length is specified as "*", record the length that
2214 the caller is passing. We should use the callee's length
2215 in all other cases. */
2216 if (!new_sym
->ts
.u
.cl
->length
&& se
)
2218 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
2219 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
2226 /* Use the passed value as-is if the argument is a function. */
2227 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2230 /* If the argument is either a string or a pointer to a string,
2231 convert it to a boundless character type. */
2232 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
2234 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
2235 tmp
= build_pointer_type (tmp
);
2236 if (sym
->attr
.pointer
)
2237 value
= build_fold_indirect_ref_loc (input_location
,
2241 value
= fold_convert (tmp
, value
);
2244 /* If the argument is a scalar, a pointer to an array or an allocatable,
2246 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2247 value
= build_fold_indirect_ref_loc (input_location
,
2250 /* For character(*), use the actual argument's descriptor. */
2251 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
2252 value
= build_fold_indirect_ref_loc (input_location
,
2255 /* If the argument is an array descriptor, use it to determine
2256 information about the actual argument's shape. */
2257 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
2258 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
2260 /* Get the actual argument's descriptor. */
2261 desc
= build_fold_indirect_ref_loc (input_location
,
2264 /* Create the replacement variable. */
2265 tmp
= gfc_conv_descriptor_data_get (desc
);
2266 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2269 /* Use DESC to work out the upper bounds, strides and offset. */
2270 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
2273 /* Otherwise we have a packed array. */
2274 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2275 PACKED_FULL
, se
->expr
);
2277 new_sym
->backend_decl
= value
;
2281 /* Called once all dummy argument mappings have been added to MAPPING,
2282 but before the mapping is used to evaluate expressions. Pre-evaluate
2283 the length of each argument, adding any initialization code to PRE and
2284 any finalization code to POST. */
2287 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
2288 stmtblock_t
* pre
, stmtblock_t
* post
)
2290 gfc_interface_sym_mapping
*sym
;
2294 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2295 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
2296 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
2298 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
2299 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2300 gfc_init_se (&se
, NULL
);
2301 gfc_conv_expr (&se
, expr
);
2302 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
2303 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
2304 gfc_add_block_to_block (pre
, &se
.pre
);
2305 gfc_add_block_to_block (post
, &se
.post
);
2307 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
2312 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2316 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
2317 gfc_constructor_base base
)
2320 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2322 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
2325 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
2326 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
2327 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2333 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2337 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2342 for (; ref
; ref
= ref
->next
)
2346 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2348 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2349 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2350 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2352 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2359 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2360 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2366 /* Convert intrinsic function calls into result expressions. */
2369 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2377 arg1
= expr
->value
.function
.actual
->expr
;
2378 if (expr
->value
.function
.actual
->next
)
2379 arg2
= expr
->value
.function
.actual
->next
->expr
;
2383 sym
= arg1
->symtree
->n
.sym
;
2385 if (sym
->attr
.dummy
)
2390 switch (expr
->value
.function
.isym
->id
)
2393 /* TODO figure out why this condition is necessary. */
2394 if (sym
->attr
.function
2395 && (arg1
->ts
.u
.cl
->length
== NULL
2396 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2397 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2400 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2404 if (!sym
->as
|| sym
->as
->rank
== 0)
2407 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2409 dup
= mpz_get_si (arg2
->value
.integer
);
2414 dup
= sym
->as
->rank
;
2418 for (; d
< dup
; d
++)
2422 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2424 gfc_free_expr (new_expr
);
2428 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
2429 gfc_get_int_expr (gfc_default_integer_kind
,
2431 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2433 new_expr
= gfc_multiply (new_expr
, tmp
);
2439 case GFC_ISYM_LBOUND
:
2440 case GFC_ISYM_UBOUND
:
2441 /* TODO These implementations of lbound and ubound do not limit if
2442 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2444 if (!sym
->as
|| sym
->as
->rank
== 0)
2447 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2448 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2450 /* TODO: If the need arises, this could produce an array of
2454 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2456 if (sym
->as
->lower
[d
])
2457 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2461 if (sym
->as
->upper
[d
])
2462 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2470 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2474 gfc_replace_expr (expr
, new_expr
);
2480 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2481 gfc_interface_mapping
* mapping
)
2483 gfc_formal_arglist
*f
;
2484 gfc_actual_arglist
*actual
;
2486 actual
= expr
->value
.function
.actual
;
2487 f
= map_expr
->symtree
->n
.sym
->formal
;
2489 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2494 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2497 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2502 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2504 for (d
= 0; d
< as
->rank
; d
++)
2506 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2507 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2510 expr
->value
.function
.esym
->as
= as
;
2513 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2515 expr
->value
.function
.esym
->ts
.u
.cl
->length
2516 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2518 gfc_apply_interface_mapping_to_expr (mapping
,
2519 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2524 /* EXPR is a copy of an expression that appeared in the interface
2525 associated with MAPPING. Walk it recursively looking for references to
2526 dummy arguments that MAPPING maps to actual arguments. Replace each such
2527 reference with a reference to the associated actual argument. */
2530 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2533 gfc_interface_sym_mapping
*sym
;
2534 gfc_actual_arglist
*actual
;
2539 /* Copying an expression does not copy its length, so do that here. */
2540 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2542 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2543 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2546 /* Apply the mapping to any references. */
2547 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2549 /* ...and to the expression's symbol, if it has one. */
2550 /* TODO Find out why the condition on expr->symtree had to be moved into
2551 the loop rather than being outside it, as originally. */
2552 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2553 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2555 if (sym
->new_sym
->n
.sym
->backend_decl
)
2556 expr
->symtree
= sym
->new_sym
;
2558 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2559 /* Replace base type for polymorphic arguments. */
2560 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
2561 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
2562 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
2565 /* ...and to subexpressions in expr->value. */
2566 switch (expr
->expr_type
)
2571 case EXPR_SUBSTRING
:
2575 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2576 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2580 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2581 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2583 if (expr
->value
.function
.esym
== NULL
2584 && expr
->value
.function
.isym
!= NULL
2585 && expr
->value
.function
.actual
->expr
->symtree
2586 && gfc_map_intrinsic_function (expr
, mapping
))
2589 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2590 if (sym
->old
== expr
->value
.function
.esym
)
2592 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2593 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2594 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2599 case EXPR_STRUCTURE
:
2600 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2613 /* Evaluate interface expression EXPR using MAPPING. Store the result
2617 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2618 gfc_se
* se
, gfc_expr
* expr
)
2620 expr
= gfc_copy_expr (expr
);
2621 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2622 gfc_conv_expr (se
, expr
);
2623 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2624 gfc_free_expr (expr
);
2628 /* Returns a reference to a temporary array into which a component of
2629 an actual argument derived type array is copied and then returned
2630 after the function call. */
2632 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2633 sym_intent intent
, bool formal_ptr
)
2641 gfc_array_info
*info
;
2651 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2653 gfc_init_se (&lse
, NULL
);
2654 gfc_init_se (&rse
, NULL
);
2656 /* Walk the argument expression. */
2657 rss
= gfc_walk_expr (expr
);
2659 gcc_assert (rss
!= gfc_ss_terminator
);
2661 /* Initialize the scalarizer. */
2662 gfc_init_loopinfo (&loop
);
2663 gfc_add_ss_to_loop (&loop
, rss
);
2665 /* Calculate the bounds of the scalarization. */
2666 gfc_conv_ss_startstride (&loop
);
2668 /* Build an ss for the temporary. */
2669 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2670 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2672 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2673 if (GFC_ARRAY_TYPE_P (base_type
)
2674 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2675 base_type
= gfc_get_element_type (base_type
);
2677 if (expr
->ts
.type
== BT_CLASS
)
2678 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
2680 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
2681 ? expr
->ts
.u
.cl
->backend_decl
2685 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
2687 /* Associate the SS with the loop. */
2688 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2690 /* Setup the scalarizing loops. */
2691 gfc_conv_loop_setup (&loop
, &expr
->where
);
2693 /* Pass the temporary descriptor back to the caller. */
2694 info
= &loop
.temp_ss
->info
->data
.array
;
2695 parmse
->expr
= info
->descriptor
;
2697 /* Setup the gfc_se structures. */
2698 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2699 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2702 lse
.ss
= loop
.temp_ss
;
2703 gfc_mark_ss_chain_used (rss
, 1);
2704 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2706 /* Start the scalarized loop body. */
2707 gfc_start_scalarized_body (&loop
, &body
);
2709 /* Translate the expression. */
2710 gfc_conv_expr (&rse
, expr
);
2712 gfc_conv_tmp_array_ref (&lse
);
2714 if (intent
!= INTENT_OUT
)
2716 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
2717 gfc_add_expr_to_block (&body
, tmp
);
2718 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2719 gfc_trans_scalarizing_loops (&loop
, &body
);
2723 /* Make sure that the temporary declaration survives by merging
2724 all the loop declarations into the current context. */
2725 for (n
= 0; n
< loop
.dimen
; n
++)
2727 gfc_merge_block_scope (&body
);
2728 body
= loop
.code
[loop
.order
[n
]];
2730 gfc_merge_block_scope (&body
);
2733 /* Add the post block after the second loop, so that any
2734 freeing of allocated memory is done at the right time. */
2735 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2737 /**********Copy the temporary back again.*********/
2739 gfc_init_se (&lse
, NULL
);
2740 gfc_init_se (&rse
, NULL
);
2742 /* Walk the argument expression. */
2743 lss
= gfc_walk_expr (expr
);
2744 rse
.ss
= loop
.temp_ss
;
2747 /* Initialize the scalarizer. */
2748 gfc_init_loopinfo (&loop2
);
2749 gfc_add_ss_to_loop (&loop2
, lss
);
2751 /* Calculate the bounds of the scalarization. */
2752 gfc_conv_ss_startstride (&loop2
);
2754 /* Setup the scalarizing loops. */
2755 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2757 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2758 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2760 gfc_mark_ss_chain_used (lss
, 1);
2761 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2763 /* Declare the variable to hold the temporary offset and start the
2764 scalarized loop body. */
2765 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2766 gfc_start_scalarized_body (&loop2
, &body
);
2768 /* Build the offsets for the temporary from the loop variables. The
2769 temporary array has lbounds of zero and strides of one in all
2770 dimensions, so this is very simple. The offset is only computed
2771 outside the innermost loop, so the overall transfer could be
2772 optimized further. */
2773 info
= &rse
.ss
->info
->data
.array
;
2774 dimen
= rse
.ss
->dimen
;
2776 tmp_index
= gfc_index_zero_node
;
2777 for (n
= dimen
- 1; n
> 0; n
--)
2780 tmp
= rse
.loop
->loopvar
[n
];
2781 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2782 tmp
, rse
.loop
->from
[n
]);
2783 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2786 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
2787 gfc_array_index_type
,
2788 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2789 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
2790 gfc_array_index_type
,
2791 tmp_str
, gfc_index_one_node
);
2793 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
2794 gfc_array_index_type
, tmp
, tmp_str
);
2797 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
2798 gfc_array_index_type
,
2799 tmp_index
, rse
.loop
->from
[0]);
2800 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2802 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
2803 gfc_array_index_type
,
2804 rse
.loop
->loopvar
[0], offset
);
2806 /* Now use the offset for the reference. */
2807 tmp
= build_fold_indirect_ref_loc (input_location
,
2809 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2811 if (expr
->ts
.type
== BT_CHARACTER
)
2812 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2814 gfc_conv_expr (&lse
, expr
);
2816 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2818 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
2819 gfc_add_expr_to_block (&body
, tmp
);
2821 /* Generate the copying loops. */
2822 gfc_trans_scalarizing_loops (&loop2
, &body
);
2824 /* Wrap the whole thing up by adding the second loop to the post-block
2825 and following it by the post-block of the first loop. In this way,
2826 if the temporary needs freeing, it is done after use! */
2827 if (intent
!= INTENT_IN
)
2829 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2830 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2833 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2835 gfc_cleanup_loop (&loop
);
2836 gfc_cleanup_loop (&loop2
);
2838 /* Pass the string length to the argument expression. */
2839 if (expr
->ts
.type
== BT_CHARACTER
)
2840 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2842 /* Determine the offset for pointer formal arguments and set the
2846 size
= gfc_index_one_node
;
2847 offset
= gfc_index_zero_node
;
2848 for (n
= 0; n
< dimen
; n
++)
2850 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2852 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2853 gfc_array_index_type
, tmp
,
2854 gfc_index_one_node
);
2855 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2859 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2862 gfc_index_one_node
);
2863 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2864 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2865 gfc_array_index_type
,
2867 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2868 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2869 gfc_array_index_type
,
2870 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2871 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2872 gfc_array_index_type
,
2873 tmp
, gfc_index_one_node
);
2874 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2875 gfc_array_index_type
, size
, tmp
);
2878 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2882 /* We want either the address for the data or the address of the descriptor,
2883 depending on the mode of passing array arguments. */
2885 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2887 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2893 /* Generate the code for argument list functions. */
2896 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2898 /* Pass by value for g77 %VAL(arg), pass the address
2899 indirectly for %LOC, else by reference. Thus %REF
2900 is a "do-nothing" and %LOC is the same as an F95
2902 if (strncmp (name
, "%VAL", 4) == 0)
2903 gfc_conv_expr (se
, expr
);
2904 else if (strncmp (name
, "%LOC", 4) == 0)
2906 gfc_conv_expr_reference (se
, expr
);
2907 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2909 else if (strncmp (name
, "%REF", 4) == 0)
2910 gfc_conv_expr_reference (se
, expr
);
2912 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2916 /* The following routine generates code for the intrinsic
2917 procedures from the ISO_C_BINDING module:
2919 * C_FUNLOC (function)
2920 * C_F_POINTER (subroutine)
2921 * C_F_PROCPOINTER (subroutine)
2922 * C_ASSOCIATED (function)
2923 One exception which is not handled here is C_F_POINTER with non-scalar
2924 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2927 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2928 gfc_actual_arglist
* arg
)
2933 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2935 if (arg
->expr
->rank
== 0)
2936 gfc_conv_expr_reference (se
, arg
->expr
);
2940 /* This is really the actual arg because no formal arglist is
2941 created for C_LOC. */
2942 fsym
= arg
->expr
->symtree
->n
.sym
;
2944 /* We should want it to do g77 calling convention. */
2946 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2947 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2948 f
= f
|| !sym
->attr
.always_explicit
;
2950 argss
= gfc_walk_expr (arg
->expr
);
2951 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2955 /* TODO -- the following two lines shouldn't be necessary, but if
2956 they're removed, a bug is exposed later in the code path.
2957 This workaround was thus introduced, but will have to be
2958 removed; please see PR 35150 for details about the issue. */
2959 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2960 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2964 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2966 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2967 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2968 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2969 gfc_conv_expr_reference (se
, arg
->expr
);
2973 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2974 && arg
->next
->expr
->rank
== 0)
2975 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2977 /* Convert c_f_pointer if fptr is a scalar
2978 and convert c_f_procpointer. */
2982 gfc_init_se (&cptrse
, NULL
);
2983 gfc_conv_expr (&cptrse
, arg
->expr
);
2984 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2985 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2987 gfc_init_se (&fptrse
, NULL
);
2988 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2989 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2990 fptrse
.want_pointer
= 1;
2992 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2993 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2994 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2996 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2997 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2998 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
3001 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3002 TREE_TYPE (fptrse
.expr
),
3004 fold_convert (TREE_TYPE (fptrse
.expr
),
3009 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3014 /* Build the addr_expr for the first argument. The argument is
3015 already an *address* so we don't need to set want_pointer in
3017 gfc_init_se (&arg1se
, NULL
);
3018 gfc_conv_expr (&arg1se
, arg
->expr
);
3019 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3020 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3022 /* See if we were given two arguments. */
3023 if (arg
->next
== NULL
)
3024 /* Only given one arg so generate a null and do a
3025 not-equal comparison against the first arg. */
3026 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3028 fold_convert (TREE_TYPE (arg1se
.expr
),
3029 null_pointer_node
));
3035 /* Given two arguments so build the arg2se from second arg. */
3036 gfc_init_se (&arg2se
, NULL
);
3037 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
3038 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3039 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3041 /* Generate test to compare that the two args are equal. */
3042 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3043 arg1se
.expr
, arg2se
.expr
);
3044 /* Generate test to ensure that the first arg is not null. */
3045 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
3047 arg1se
.expr
, null_pointer_node
);
3049 /* Finally, the generated test must check that both arg1 is not
3050 NULL and that it is equal to the second arg. */
3051 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3053 not_null_expr
, eq_expr
);
3059 /* Nothing was done. */
3064 /* Generate code for a procedure call. Note can return se->post != NULL.
3065 If se->direct_byref is set then se->expr contains the return parameter.
3066 Return nonzero, if the call has alternate specifiers.
3067 'expr' is only needed for procedure pointer components. */
3070 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3071 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3072 VEC(tree
,gc
) *append_args
)
3074 gfc_interface_mapping mapping
;
3075 VEC(tree
,gc
) *arglist
;
3076 VEC(tree
,gc
) *retargs
;
3081 gfc_array_info
*info
;
3087 VEC(tree
,gc
) *stringargs
;
3089 gfc_formal_arglist
*formal
;
3090 gfc_actual_arglist
*arg
;
3091 int has_alternate_specifier
= 0;
3092 bool need_interface_mapping
;
3099 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3100 gfc_component
*comp
= NULL
;
3110 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3111 && conv_isocbinding_procedure (se
, sym
, args
))
3114 gfc_is_proc_ptr_comp (expr
, &comp
);
3118 if (!sym
->attr
.elemental
)
3120 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3121 if (se
->ss
->info
->useflags
)
3123 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3124 && sym
->result
->attr
.dimension
)
3125 || (comp
&& comp
->attr
.dimension
));
3126 gcc_assert (se
->loop
!= NULL
);
3128 /* Access the previously obtained result. */
3129 gfc_conv_tmp_array_ref (se
);
3133 info
= &se
->ss
->info
->data
.array
;
3138 gfc_init_block (&post
);
3139 gfc_init_interface_mapping (&mapping
);
3142 formal
= sym
->formal
;
3143 need_interface_mapping
= sym
->attr
.dimension
||
3144 (sym
->ts
.type
== BT_CHARACTER
3145 && sym
->ts
.u
.cl
->length
3146 && sym
->ts
.u
.cl
->length
->expr_type
3151 formal
= comp
->formal
;
3152 need_interface_mapping
= comp
->attr
.dimension
||
3153 (comp
->ts
.type
== BT_CHARACTER
3154 && comp
->ts
.u
.cl
->length
3155 && comp
->ts
.u
.cl
->length
->expr_type
3159 /* Evaluate the arguments. */
3160 for (arg
= args
; arg
!= NULL
;
3161 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3164 fsym
= formal
? formal
->sym
: NULL
;
3165 parm_kind
= MISSING
;
3167 /* Class array expressions are sometimes coming completely unadorned
3168 with either arrayspec or _data component. Correct that here.
3169 OOP-TODO: Move this to the frontend. */
3170 if (e
&& e
->expr_type
== EXPR_VARIABLE
3172 && e
->ts
.type
== BT_CLASS
3173 && CLASS_DATA (e
)->attr
.dimension
)
3175 gfc_typespec temp_ts
= e
->ts
;
3176 gfc_add_class_array_ref (e
);
3182 if (se
->ignore_optional
)
3184 /* Some intrinsics have already been resolved to the correct
3188 else if (arg
->label
)
3190 has_alternate_specifier
= 1;
3195 /* Pass a NULL pointer for an absent arg. */
3196 gfc_init_se (&parmse
, NULL
);
3197 parmse
.expr
= null_pointer_node
;
3198 if (arg
->missing_arg_type
== BT_CHARACTER
)
3199 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3202 else if (arg
->expr
->expr_type
== EXPR_NULL
&& fsym
&& !fsym
->attr
.pointer
)
3204 /* Pass a NULL pointer to denote an absent arg. */
3205 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
);
3206 gfc_init_se (&parmse
, NULL
);
3207 parmse
.expr
= null_pointer_node
;
3208 if (arg
->missing_arg_type
== BT_CHARACTER
)
3209 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3211 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
3212 && e
->ts
.type
== BT_DERIVED
)
3214 /* The derived type needs to be converted to a temporary
3216 gfc_init_se (&parmse
, se
);
3217 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
3219 else if (se
->ss
&& se
->ss
->info
->useflags
)
3221 /* An elemental function inside a scalarized loop. */
3222 gfc_init_se (&parmse
, se
);
3223 parm_kind
= ELEMENTAL
;
3225 if (se
->ss
->dimen
> 0
3226 && se
->ss
->info
->data
.array
.ref
== NULL
)
3228 gfc_conv_tmp_array_ref (&parmse
);
3229 if (e
->ts
.type
== BT_CHARACTER
)
3230 gfc_conv_string_parameter (&parmse
);
3232 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3235 gfc_conv_expr_reference (&parmse
, e
);
3237 /* The scalarizer does not repackage the reference to a class
3238 array - instead it returns a pointer to the data element. */
3239 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
3240 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true);
3244 /* A scalar or transformational function. */
3245 gfc_init_se (&parmse
, NULL
);
3246 argss
= gfc_walk_expr (e
);
3248 if (argss
== gfc_ss_terminator
)
3250 if (e
->expr_type
== EXPR_VARIABLE
3251 && e
->symtree
->n
.sym
->attr
.cray_pointee
3252 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
3254 /* The Cray pointer needs to be converted to a pointer to
3255 a type given by the expression. */
3256 gfc_conv_expr (&parmse
, e
);
3257 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
3258 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
3259 parmse
.expr
= convert (type
, tmp
);
3261 else if (fsym
&& fsym
->attr
.value
)
3263 if (fsym
->ts
.type
== BT_CHARACTER
3264 && fsym
->ts
.is_c_interop
3265 && fsym
->ns
->proc_name
!= NULL
3266 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
3269 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
3270 if (parmse
.expr
== NULL
)
3271 gfc_conv_expr (&parmse
, e
);
3274 gfc_conv_expr (&parmse
, e
);
3276 else if (arg
->name
&& arg
->name
[0] == '%')
3277 /* Argument list functions %VAL, %LOC and %REF are signalled
3278 through arg->name. */
3279 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
3280 else if ((e
->expr_type
== EXPR_FUNCTION
)
3281 && ((e
->value
.function
.esym
3282 && e
->value
.function
.esym
->result
->attr
.pointer
)
3283 || (!e
->value
.function
.esym
3284 && e
->symtree
->n
.sym
->attr
.pointer
))
3285 && fsym
&& fsym
->attr
.target
)
3287 gfc_conv_expr (&parmse
, e
);
3288 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3290 else if (e
->expr_type
== EXPR_FUNCTION
3291 && e
->symtree
->n
.sym
->result
3292 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
3293 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3295 /* Functions returning procedure pointers. */
3296 gfc_conv_expr (&parmse
, e
);
3297 if (fsym
&& fsym
->attr
.proc_pointer
)
3298 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3302 gfc_conv_expr_reference (&parmse
, e
);
3304 /* A class array element needs converting back to be a
3305 class object, if the formal argument is a class object. */
3306 if (fsym
&& fsym
->ts
.type
== BT_CLASS
3307 && e
->ts
.type
== BT_CLASS
3308 && CLASS_DATA (e
)->attr
.dimension
)
3309 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false);
3311 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3312 allocated on entry, it must be deallocated. */
3313 if (fsym
&& fsym
->attr
.allocatable
3314 && fsym
->attr
.intent
== INTENT_OUT
)
3318 gfc_init_block (&block
);
3319 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
3321 gfc_add_expr_to_block (&block
, tmp
);
3322 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3323 void_type_node
, parmse
.expr
,
3325 gfc_add_expr_to_block (&block
, tmp
);
3327 if (fsym
->attr
.optional
3328 && e
->expr_type
== EXPR_VARIABLE
3329 && e
->symtree
->n
.sym
->attr
.optional
)
3331 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3333 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3334 gfc_finish_block (&block
),
3335 build_empty_stmt (input_location
));
3338 tmp
= gfc_finish_block (&block
);
3340 gfc_add_expr_to_block (&se
->pre
, tmp
);
3343 if (fsym
&& e
->expr_type
!= EXPR_NULL
3344 && ((fsym
->attr
.pointer
3345 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3346 || (fsym
->attr
.proc_pointer
3347 && !(e
->expr_type
== EXPR_VARIABLE
3348 && e
->symtree
->n
.sym
->attr
.dummy
))
3349 || (fsym
->attr
.proc_pointer
3350 && e
->expr_type
== EXPR_VARIABLE
3351 && gfc_is_proc_ptr_comp (e
, NULL
))
3352 || fsym
->attr
.allocatable
))
3354 /* Scalar pointer dummy args require an extra level of
3355 indirection. The null pointer already contains
3356 this level of indirection. */
3357 parm_kind
= SCALAR_POINTER
;
3358 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3362 else if (e
->ts
.type
== BT_CLASS
3363 && fsym
&& fsym
->ts
.type
== BT_CLASS
3364 && CLASS_DATA (fsym
)->attr
.dimension
)
3366 /* Pass a class array. */
3367 gfc_init_se (&parmse
, se
);
3368 gfc_conv_expr_descriptor (&parmse
, e
, argss
);
3369 /* The conversion does not repackage the reference to a class
3370 array - _data descriptor. */
3371 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false);
3375 /* If the procedure requires an explicit interface, the actual
3376 argument is passed according to the corresponding formal
3377 argument. If the corresponding formal argument is a POINTER,
3378 ALLOCATABLE or assumed shape, we do not use g77's calling
3379 convention, and pass the address of the array descriptor
3380 instead. Otherwise we use g77's calling convention. */
3383 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3384 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3386 f
= f
|| !comp
->attr
.always_explicit
;
3388 f
= f
|| !sym
->attr
.always_explicit
;
3390 /* If the argument is a function call that may not create
3391 a temporary for the result, we have to check that we
3392 can do it, i.e. that there is no alias between this
3393 argument and another one. */
3394 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
3400 intent
= fsym
->attr
.intent
;
3402 intent
= INTENT_UNKNOWN
;
3404 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
3406 parmse
.force_tmp
= 1;
3408 iarg
= e
->value
.function
.actual
->expr
;
3410 /* Temporary needed if aliasing due to host association. */
3411 if (sym
->attr
.contained
3413 && !sym
->attr
.implicit_pure
3414 && !sym
->attr
.use_assoc
3415 && iarg
->expr_type
== EXPR_VARIABLE
3416 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
3417 parmse
.force_tmp
= 1;
3419 /* Ditto within module. */
3420 if (sym
->attr
.use_assoc
3422 && !sym
->attr
.implicit_pure
3423 && iarg
->expr_type
== EXPR_VARIABLE
3424 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
3425 parmse
.force_tmp
= 1;
3428 if (e
->expr_type
== EXPR_VARIABLE
3429 && is_subref_array (e
))
3430 /* The actual argument is a component reference to an
3431 array of derived types. In this case, the argument
3432 is converted to a temporary, which is passed and then
3433 written back after the procedure call. */
3434 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3435 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3436 fsym
&& fsym
->attr
.pointer
);
3437 else if (gfc_is_class_array_ref (e
, NULL
)
3438 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
3439 /* The actual argument is a component reference to an
3440 array of derived types. In this case, the argument
3441 is converted to a temporary, which is passed and then
3442 written back after the procedure call.
3443 OOP-TODO: Insert code so that if the dynamic type is
3444 the same as the declared type, copy-in/copy-out does
3446 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3447 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3448 fsym
&& fsym
->attr
.pointer
);
3450 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
3453 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3454 allocated on entry, it must be deallocated. */
3455 if (fsym
&& fsym
->attr
.allocatable
3456 && fsym
->attr
.intent
== INTENT_OUT
)
3458 tmp
= build_fold_indirect_ref_loc (input_location
,
3460 tmp
= gfc_trans_dealloc_allocated (tmp
);
3461 if (fsym
->attr
.optional
3462 && e
->expr_type
== EXPR_VARIABLE
3463 && e
->symtree
->n
.sym
->attr
.optional
)
3464 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3466 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3467 tmp
, build_empty_stmt (input_location
));
3468 gfc_add_expr_to_block (&se
->pre
, tmp
);
3473 /* The case with fsym->attr.optional is that of a user subroutine
3474 with an interface indicating an optional argument. When we call
3475 an intrinsic subroutine, however, fsym is NULL, but we might still
3476 have an optional argument, so we proceed to the substitution
3478 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3480 /* If an optional argument is itself an optional dummy argument,
3481 check its presence and substitute a null if absent. This is
3482 only needed when passing an array to an elemental procedure
3483 as then array elements are accessed - or no NULL pointer is
3484 allowed and a "1" or "0" should be passed if not present.
3485 When passing a non-array-descriptor full array to a
3486 non-array-descriptor dummy, no check is needed. For
3487 array-descriptor actual to array-descriptor dummy, see
3488 PR 41911 for why a check has to be inserted.
3489 fsym == NULL is checked as intrinsics required the descriptor
3490 but do not always set fsym. */
3491 if (e
->expr_type
== EXPR_VARIABLE
3492 && e
->symtree
->n
.sym
->attr
.optional
3493 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3494 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3498 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
3499 || fsym
->as
->type
== AS_DEFERRED
))))))
3500 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3501 e
->representation
.length
);
3506 /* Obtain the character length of an assumed character length
3507 length procedure from the typespec. */
3508 if (fsym
->ts
.type
== BT_CHARACTER
3509 && parmse
.string_length
== NULL_TREE
3510 && e
->ts
.type
== BT_PROCEDURE
3511 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3512 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3513 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3515 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3516 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3520 if (fsym
&& need_interface_mapping
&& e
)
3521 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3523 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3524 gfc_add_block_to_block (&post
, &parmse
.post
);
3526 /* Allocated allocatable components of derived types must be
3527 deallocated for non-variable scalars. Non-variable arrays are
3528 dealt with in trans-array.c(gfc_conv_array_parameter). */
3529 if (e
&& e
->ts
.type
== BT_DERIVED
3530 && e
->ts
.u
.derived
->attr
.alloc_comp
3531 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3532 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3535 tmp
= build_fold_indirect_ref_loc (input_location
,
3537 parm_rank
= e
->rank
;
3545 case (SCALAR_POINTER
):
3546 tmp
= build_fold_indirect_ref_loc (input_location
,
3551 if (e
->expr_type
== EXPR_OP
3552 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3553 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3556 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3557 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3558 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3561 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3563 gfc_add_expr_to_block (&se
->post
, tmp
);
3566 /* Add argument checking of passing an unallocated/NULL actual to
3567 a nonallocatable/nonpointer dummy. */
3569 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3571 symbol_attribute attr
;
3575 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
3576 attr
= gfc_expr_attr (e
);
3578 goto end_pointer_check
;
3580 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3581 allocatable to an optional dummy, cf. 12.5.2.12. */
3582 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
3583 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3584 goto end_pointer_check
;
3588 /* If the actual argument is an optional pointer/allocatable and
3589 the formal argument takes an nonpointer optional value,
3590 it is invalid to pass a non-present argument on, even
3591 though there is no technical reason for this in gfortran.
3592 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3593 tree present
, null_ptr
, type
;
3595 if (attr
.allocatable
3596 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3597 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3598 "allocated or not present", e
->symtree
->n
.sym
->name
);
3599 else if (attr
.pointer
3600 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3601 asprintf (&msg
, "Pointer actual argument '%s' is not "
3602 "associated or not present",
3603 e
->symtree
->n
.sym
->name
);
3604 else if (attr
.proc_pointer
3605 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3606 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3607 "associated or not present",
3608 e
->symtree
->n
.sym
->name
);
3610 goto end_pointer_check
;
3612 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3613 type
= TREE_TYPE (present
);
3614 present
= fold_build2_loc (input_location
, EQ_EXPR
,
3615 boolean_type_node
, present
,
3617 null_pointer_node
));
3618 type
= TREE_TYPE (parmse
.expr
);
3619 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
3620 boolean_type_node
, parmse
.expr
,
3622 null_pointer_node
));
3623 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3624 boolean_type_node
, present
, null_ptr
);
3628 if (attr
.allocatable
3629 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3630 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3631 "allocated", e
->symtree
->n
.sym
->name
);
3632 else if (attr
.pointer
3633 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3634 asprintf (&msg
, "Pointer actual argument '%s' is not "
3635 "associated", e
->symtree
->n
.sym
->name
);
3636 else if (attr
.proc_pointer
3637 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3638 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3639 "associated", e
->symtree
->n
.sym
->name
);
3641 goto end_pointer_check
;
3645 /* If the argument is passed by value, we need to strip the
3647 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
3648 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3650 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3651 boolean_type_node
, tmp
,
3652 fold_convert (TREE_TYPE (tmp
),
3653 null_pointer_node
));
3656 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3662 /* Deferred length dummies pass the character length by reference
3663 so that the value can be returned. */
3664 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
3666 tmp
= parmse
.string_length
;
3667 if (TREE_CODE (tmp
) != VAR_DECL
)
3668 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
3669 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3672 /* Character strings are passed as two parameters, a length and a
3673 pointer - except for Bind(c) which only passes the pointer. */
3674 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3675 VEC_safe_push (tree
, gc
, stringargs
, parmse
.string_length
);
3677 /* For descriptorless coarrays and assumed-shape coarray dummies, we
3678 pass the token and the offset as additional arguments. */
3679 if (fsym
&& fsym
->attr
.codimension
3680 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
3681 && !fsym
->attr
.allocatable
3684 /* Token and offset. */
3685 VEC_safe_push (tree
, gc
, stringargs
, null_pointer_node
);
3686 VEC_safe_push (tree
, gc
, stringargs
,
3687 build_int_cst (gfc_array_index_type
, 0));
3688 gcc_assert (fsym
->attr
.optional
);
3690 else if (fsym
&& fsym
->attr
.codimension
3691 && !fsym
->attr
.allocatable
3692 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
3694 tree caf_decl
, caf_type
;
3697 caf_decl
= get_tree_for_caf_expr (e
);
3698 caf_type
= TREE_TYPE (caf_decl
);
3700 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
3701 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
3702 tmp
= gfc_conv_descriptor_token (caf_decl
);
3703 else if (DECL_LANG_SPECIFIC (caf_decl
)
3704 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
3705 tmp
= GFC_DECL_TOKEN (caf_decl
);
3708 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
3709 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
3710 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
3713 VEC_safe_push (tree
, gc
, stringargs
, tmp
);
3715 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
3716 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
3717 offset
= build_int_cst (gfc_array_index_type
, 0);
3718 else if (DECL_LANG_SPECIFIC (caf_decl
)
3719 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
3720 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
3721 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
3722 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
3724 offset
= build_int_cst (gfc_array_index_type
, 0);
3726 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
3727 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
3730 gcc_assert (POINTER_TYPE_P (caf_type
));
3734 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
)
3736 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
3737 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
3738 (TREE_TYPE (parmse
.expr
))));
3739 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
3740 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
3742 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
3743 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
3746 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
3750 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3751 gfc_array_index_type
,
3752 fold_convert (gfc_array_index_type
, tmp2
),
3753 fold_convert (gfc_array_index_type
, tmp
));
3754 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
3755 gfc_array_index_type
, offset
, tmp
);
3757 VEC_safe_push (tree
, gc
, stringargs
, offset
);
3760 VEC_safe_push (tree
, gc
, arglist
, parmse
.expr
);
3762 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3769 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3770 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3771 else if (ts
.type
== BT_CHARACTER
)
3773 if (ts
.u
.cl
->length
== NULL
)
3775 /* Assumed character length results are not allowed by 5.1.1.5 of the
3776 standard and are trapped in resolve.c; except in the case of SPREAD
3777 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3778 we take the character length of the first argument for the result.
3779 For dummies, we have to look through the formal argument list for
3780 this function and use the character length found there.*/
3781 if (ts
.deferred
&& (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
3782 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
3783 else if (!sym
->attr
.dummy
)
3784 cl
.backend_decl
= VEC_index (tree
, stringargs
, 0);
3787 formal
= sym
->ns
->proc_name
->formal
;
3788 for (; formal
; formal
= formal
->next
)
3789 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3790 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3797 /* Calculate the length of the returned string. */
3798 gfc_init_se (&parmse
, NULL
);
3799 if (need_interface_mapping
)
3800 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3802 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3803 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3804 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3806 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3807 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
3808 gfc_charlen_type_node
, tmp
,
3809 build_int_cst (gfc_charlen_type_node
, 0));
3810 cl
.backend_decl
= tmp
;
3813 /* Set up a charlen structure for it. */
3818 len
= cl
.backend_decl
;
3821 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3822 || (!comp
&& gfc_return_by_reference (sym
));
3825 if (se
->direct_byref
)
3827 /* Sometimes, too much indirection can be applied; e.g. for
3828 function_result = array_valued_recursive_function. */
3829 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3830 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3831 && GFC_DESCRIPTOR_TYPE_P
3832 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3833 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3836 /* If the lhs of an assignment x = f(..) is allocatable and
3837 f2003 is allowed, we must do the automatic reallocation.
3838 TODO - deal with intrinsics, without using a temporary. */
3839 if (gfc_option
.flag_realloc_lhs
3840 && se
->ss
&& se
->ss
->loop_chain
3841 && se
->ss
->loop_chain
->is_alloc_lhs
3842 && !expr
->value
.function
.isym
3843 && sym
->result
->as
!= NULL
)
3845 /* Evaluate the bounds of the result, if known. */
3846 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
3849 /* Perform the automatic reallocation. */
3850 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
3852 gfc_add_expr_to_block (&se
->pre
, tmp
);
3854 /* Pass the temporary as the first argument. */
3855 result
= info
->descriptor
;
3858 result
= build_fold_indirect_ref_loc (input_location
,
3860 VEC_safe_push (tree
, gc
, retargs
, se
->expr
);
3862 else if (comp
&& comp
->attr
.dimension
)
3864 gcc_assert (se
->loop
&& info
);
3866 /* Set the type of the array. */
3867 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3868 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
3870 /* Evaluate the bounds of the result, if known. */
3871 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3873 /* If the lhs of an assignment x = f(..) is allocatable and
3874 f2003 is allowed, we must not generate the function call
3875 here but should just send back the results of the mapping.
3876 This is signalled by the function ss being flagged. */
3877 if (gfc_option
.flag_realloc_lhs
3878 && se
->ss
&& se
->ss
->is_alloc_lhs
)
3880 gfc_free_interface_mapping (&mapping
);
3881 return has_alternate_specifier
;
3884 /* Create a temporary to store the result. In case the function
3885 returns a pointer, the temporary will be a shallow copy and
3886 mustn't be deallocated. */
3887 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3888 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
3889 tmp
, NULL_TREE
, false,
3890 !comp
->attr
.pointer
, callee_alloc
,
3891 &se
->ss
->info
->expr
->where
);
3893 /* Pass the temporary as the first argument. */
3894 result
= info
->descriptor
;
3895 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3896 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3898 else if (!comp
&& sym
->result
->attr
.dimension
)
3900 gcc_assert (se
->loop
&& info
);
3902 /* Set the type of the array. */
3903 tmp
= gfc_typenode_for_spec (&ts
);
3904 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
3906 /* Evaluate the bounds of the result, if known. */
3907 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3909 /* If the lhs of an assignment x = f(..) is allocatable and
3910 f2003 is allowed, we must not generate the function call
3911 here but should just send back the results of the mapping.
3912 This is signalled by the function ss being flagged. */
3913 if (gfc_option
.flag_realloc_lhs
3914 && se
->ss
&& se
->ss
->is_alloc_lhs
)
3916 gfc_free_interface_mapping (&mapping
);
3917 return has_alternate_specifier
;
3920 /* Create a temporary to store the result. In case the function
3921 returns a pointer, the temporary will be a shallow copy and
3922 mustn't be deallocated. */
3923 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3924 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
3925 tmp
, NULL_TREE
, false,
3926 !sym
->attr
.pointer
, callee_alloc
,
3927 &se
->ss
->info
->expr
->where
);
3929 /* Pass the temporary as the first argument. */
3930 result
= info
->descriptor
;
3931 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3932 VEC_safe_push (tree
, gc
, retargs
, tmp
);
3934 else if (ts
.type
== BT_CHARACTER
)
3936 /* Pass the string length. */
3937 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3938 type
= build_pointer_type (type
);
3940 /* Return an address to a char[0:len-1]* temporary for
3941 character pointers. */
3942 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3943 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3945 var
= gfc_create_var (type
, "pstr");
3947 if ((!comp
&& sym
->attr
.allocatable
)
3948 || (comp
&& comp
->attr
.allocatable
))
3949 gfc_add_modify (&se
->pre
, var
,
3950 fold_convert (TREE_TYPE (var
),
3951 null_pointer_node
));
3953 /* Provide an address expression for the function arguments. */
3954 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3957 var
= gfc_conv_string_tmp (se
, type
, len
);
3959 VEC_safe_push (tree
, gc
, retargs
, var
);
3963 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3965 type
= gfc_get_complex_type (ts
.kind
);
3966 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3967 VEC_safe_push (tree
, gc
, retargs
, var
);
3970 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
3971 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
3974 if (TREE_CODE (tmp
) != VAR_DECL
)
3975 tmp
= gfc_evaluate_now (len
, &se
->pre
);
3976 len
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3979 /* Add the string length to the argument list. */
3980 if (ts
.type
== BT_CHARACTER
)
3981 VEC_safe_push (tree
, gc
, retargs
, len
);
3983 gfc_free_interface_mapping (&mapping
);
3985 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
3986 arglen
= (VEC_length (tree
, arglist
)
3987 + VEC_length (tree
, stringargs
) + VEC_length (tree
, append_args
));
3988 VEC_reserve_exact (tree
, gc
, retargs
, arglen
);
3990 /* Add the return arguments. */
3991 VEC_splice (tree
, retargs
, arglist
);
3993 /* Add the hidden string length parameters to the arguments. */
3994 VEC_splice (tree
, retargs
, stringargs
);
3996 /* We may want to append extra arguments here. This is used e.g. for
3997 calls to libgfortran_matmul_??, which need extra information. */
3998 if (!VEC_empty (tree
, append_args
))
3999 VEC_splice (tree
, retargs
, append_args
);
4002 /* Generate the actual call. */
4003 conv_function_val (se
, sym
, expr
);
4005 /* If there are alternate return labels, function type should be
4006 integer. Can't modify the type in place though, since it can be shared
4007 with other functions. For dummy arguments, the typing is done to
4008 this result, even if it has to be repeated for each call. */
4009 if (has_alternate_specifier
4010 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
4012 if (!sym
->attr
.dummy
)
4014 TREE_TYPE (sym
->backend_decl
)
4015 = build_function_type (integer_type_node
,
4016 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
4017 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
4020 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
4023 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
4024 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
4026 /* If we have a pointer function, but we don't want a pointer, e.g.
4029 where f is pointer valued, we have to dereference the result. */
4030 if (!se
->want_pointer
&& !byref
4031 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4032 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
4033 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4035 /* f2c calling conventions require a scalar default real function to
4036 return a double precision result. Convert this back to default
4037 real. We only care about the cases that can happen in Fortran 77.
4039 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
4040 && sym
->ts
.kind
== gfc_default_real_kind
4041 && !sym
->attr
.always_explicit
)
4042 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
4044 /* A pure function may still have side-effects - it may modify its
4046 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4048 if (!sym
->attr
.pure
)
4049 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4054 /* Add the function call to the pre chain. There is no expression. */
4055 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
4056 se
->expr
= NULL_TREE
;
4058 if (!se
->direct_byref
)
4060 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
4062 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4064 /* Check the data pointer hasn't been modified. This would
4065 happen in a function returning a pointer. */
4066 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
4067 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
4070 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
4073 se
->expr
= info
->descriptor
;
4074 /* Bundle in the string length. */
4075 se
->string_length
= len
;
4077 else if (ts
.type
== BT_CHARACTER
)
4079 /* Dereference for character pointer results. */
4080 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4081 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
4082 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
4087 se
->string_length
= len
;
4088 else if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
4089 se
->string_length
= cl
.backend_decl
;
4093 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
4094 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
4099 /* Follow the function call with the argument post block. */
4102 gfc_add_block_to_block (&se
->pre
, &post
);
4104 /* Transformational functions of derived types with allocatable
4105 components must have the result allocatable components copied. */
4106 arg
= expr
->value
.function
.actual
;
4107 if (result
&& arg
&& expr
->rank
4108 && expr
->value
.function
.isym
4109 && expr
->value
.function
.isym
->transformational
4110 && arg
->expr
->ts
.type
== BT_DERIVED
4111 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
4114 /* Copy the allocatable components. We have to use a
4115 temporary here to prevent source allocatable components
4116 from being corrupted. */
4117 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
4118 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
4119 result
, tmp2
, expr
->rank
);
4120 gfc_add_expr_to_block (&se
->pre
, tmp
);
4121 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
4123 gfc_add_expr_to_block (&se
->pre
, tmp
);
4125 /* Finally free the temporary's data field. */
4126 tmp
= gfc_conv_descriptor_data_get (tmp2
);
4127 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
4128 gfc_add_expr_to_block (&se
->pre
, tmp
);
4132 gfc_add_block_to_block (&se
->post
, &post
);
4134 return has_alternate_specifier
;
4138 /* Fill a character string with spaces. */
4141 fill_with_spaces (tree start
, tree type
, tree size
)
4143 stmtblock_t block
, loop
;
4144 tree i
, el
, exit_label
, cond
, tmp
;
4146 /* For a simple char type, we can call memset(). */
4147 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
4148 return build_call_expr_loc (input_location
,
4149 builtin_decl_explicit (BUILT_IN_MEMSET
),
4151 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
4152 lang_hooks
.to_target_charset (' ')),
4155 /* Otherwise, we use a loop:
4156 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
4160 /* Initialize variables. */
4161 gfc_init_block (&block
);
4162 i
= gfc_create_var (sizetype
, "i");
4163 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
4164 el
= gfc_create_var (build_pointer_type (type
), "el");
4165 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
4166 exit_label
= gfc_build_label_decl (NULL_TREE
);
4167 TREE_USED (exit_label
) = 1;
4171 gfc_init_block (&loop
);
4173 /* Exit condition. */
4174 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
4175 build_zero_cst (sizetype
));
4176 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4177 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
4178 build_empty_stmt (input_location
));
4179 gfc_add_expr_to_block (&loop
, tmp
);
4182 gfc_add_modify (&loop
,
4183 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
4184 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
4186 /* Increment loop variables. */
4187 gfc_add_modify (&loop
, i
,
4188 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
4189 TYPE_SIZE_UNIT (type
)));
4190 gfc_add_modify (&loop
, el
,
4191 fold_build_pointer_plus_loc (input_location
,
4192 el
, TYPE_SIZE_UNIT (type
)));
4194 /* Making the loop... actually loop! */
4195 tmp
= gfc_finish_block (&loop
);
4196 tmp
= build1_v (LOOP_EXPR
, tmp
);
4197 gfc_add_expr_to_block (&block
, tmp
);
4199 /* The exit label. */
4200 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4201 gfc_add_expr_to_block (&block
, tmp
);
4204 return gfc_finish_block (&block
);
4208 /* Generate code to copy a string. */
4211 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
4212 int dkind
, tree slength
, tree src
, int skind
)
4214 tree tmp
, dlen
, slen
;
4223 stmtblock_t tempblock
;
4225 gcc_assert (dkind
== skind
);
4227 if (slength
!= NULL_TREE
)
4229 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
4230 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
4234 slen
= build_int_cst (size_type_node
, 1);
4238 if (dlength
!= NULL_TREE
)
4240 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
4241 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
4245 dlen
= build_int_cst (size_type_node
, 1);
4249 /* Assign directly if the types are compatible. */
4250 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
4251 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
4253 gfc_add_modify (block
, dsc
, ssc
);
4257 /* Do nothing if the destination length is zero. */
4258 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
4259 build_int_cst (size_type_node
, 0));
4261 /* The following code was previously in _gfortran_copy_string:
4263 // The two strings may overlap so we use memmove.
4265 copy_string (GFC_INTEGER_4 destlen, char * dest,
4266 GFC_INTEGER_4 srclen, const char * src)
4268 if (srclen >= destlen)
4270 // This will truncate if too long.
4271 memmove (dest, src, destlen);
4275 memmove (dest, src, srclen);
4277 memset (&dest[srclen], ' ', destlen - srclen);
4281 We're now doing it here for better optimization, but the logic
4284 /* For non-default character kinds, we have to multiply the string
4285 length by the base type size. */
4286 chartype
= gfc_get_char_type (dkind
);
4287 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4288 fold_convert (size_type_node
, slen
),
4289 fold_convert (size_type_node
,
4290 TYPE_SIZE_UNIT (chartype
)));
4291 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4292 fold_convert (size_type_node
, dlen
),
4293 fold_convert (size_type_node
,
4294 TYPE_SIZE_UNIT (chartype
)));
4296 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
4297 dest
= fold_convert (pvoid_type_node
, dest
);
4299 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4301 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
4302 src
= fold_convert (pvoid_type_node
, src
);
4304 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4306 /* Truncate string if source is too long. */
4307 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
4309 tmp2
= build_call_expr_loc (input_location
,
4310 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
4311 3, dest
, src
, dlen
);
4313 /* Else copy and pad with spaces. */
4314 tmp3
= build_call_expr_loc (input_location
,
4315 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
4316 3, dest
, src
, slen
);
4318 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
4319 tmp4
= fill_with_spaces (tmp4
, chartype
,
4320 fold_build2_loc (input_location
, MINUS_EXPR
,
4321 TREE_TYPE(dlen
), dlen
, slen
));
4323 gfc_init_block (&tempblock
);
4324 gfc_add_expr_to_block (&tempblock
, tmp3
);
4325 gfc_add_expr_to_block (&tempblock
, tmp4
);
4326 tmp3
= gfc_finish_block (&tempblock
);
4328 /* The whole copy_string function is there. */
4329 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
4331 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
4332 build_empty_stmt (input_location
));
4333 gfc_add_expr_to_block (block
, tmp
);
4337 /* Translate a statement function.
4338 The value of a statement function reference is obtained by evaluating the
4339 expression using the values of the actual arguments for the values of the
4340 corresponding dummy arguments. */
4343 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
4347 gfc_formal_arglist
*fargs
;
4348 gfc_actual_arglist
*args
;
4351 gfc_saved_var
*saved_vars
;
4357 sym
= expr
->symtree
->n
.sym
;
4358 args
= expr
->value
.function
.actual
;
4359 gfc_init_se (&lse
, NULL
);
4360 gfc_init_se (&rse
, NULL
);
4363 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
4365 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
4366 temp_vars
= XCNEWVEC (tree
, n
);
4368 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4370 /* Each dummy shall be specified, explicitly or implicitly, to be
4372 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
4375 if (fsym
->ts
.type
== BT_CHARACTER
)
4377 /* Copy string arguments. */
4380 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
4381 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4383 /* Create a temporary to hold the value. */
4384 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
4385 fsym
->ts
.u
.cl
->backend_decl
4386 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
4388 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
4389 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
4391 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4393 gfc_conv_expr (&rse
, args
->expr
);
4394 gfc_conv_string_parameter (&rse
);
4395 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
4396 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
4398 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
4399 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
4400 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
4401 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
4405 /* For everything else, just evaluate the expression. */
4407 /* Create a temporary to hold the value. */
4408 type
= gfc_typenode_for_spec (&fsym
->ts
);
4409 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
4411 gfc_conv_expr (&lse
, args
->expr
);
4413 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
4414 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
4415 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
4421 /* Use the temporary variables in place of the real ones. */
4422 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4423 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
4425 gfc_conv_expr (se
, sym
->value
);
4427 if (sym
->ts
.type
== BT_CHARACTER
)
4429 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4431 /* Force the expression to the correct length. */
4432 if (!INTEGER_CST_P (se
->string_length
)
4433 || tree_int_cst_lt (se
->string_length
,
4434 sym
->ts
.u
.cl
->backend_decl
))
4436 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
4437 tmp
= gfc_create_var (type
, sym
->name
);
4438 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
4439 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
4440 sym
->ts
.kind
, se
->string_length
, se
->expr
,
4444 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
4447 /* Restore the original variables. */
4448 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4449 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
4454 /* Translate a function expression. */
4457 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
4461 if (expr
->value
.function
.isym
)
4463 gfc_conv_intrinsic_function (se
, expr
);
4467 /* We distinguish statement functions from general functions to improve
4468 runtime performance. */
4469 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
4471 gfc_conv_statement_function (se
, expr
);
4475 /* expr.value.function.esym is the resolved (specific) function symbol for
4476 most functions. However this isn't set for dummy procedures. */
4477 sym
= expr
->value
.function
.esym
;
4479 sym
= expr
->symtree
->n
.sym
;
4481 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
, NULL
);
4485 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4488 is_zero_initializer_p (gfc_expr
* expr
)
4490 if (expr
->expr_type
!= EXPR_CONSTANT
)
4493 /* We ignore constants with prescribed memory representations for now. */
4494 if (expr
->representation
.string
)
4497 switch (expr
->ts
.type
)
4500 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4503 return mpfr_zero_p (expr
->value
.real
)
4504 && MPFR_SIGN (expr
->value
.real
) >= 0;
4507 return expr
->value
.logical
== 0;
4510 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
4511 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
4512 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
4513 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
4523 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
4528 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
4529 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
4531 gfc_conv_tmp_array_ref (se
);
4535 /* Build a static initializer. EXPR is the expression for the initial value.
4536 The other parameters describe the variable of the component being
4537 initialized. EXPR may be null. */
4540 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
4541 bool array
, bool pointer
, bool procptr
)
4545 if (!(expr
|| pointer
|| procptr
))
4548 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4549 (these are the only two iso_c_binding derived types that can be
4550 used as initialization expressions). If so, we need to modify
4551 the 'expr' to be that for a (void *). */
4552 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
4553 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
4555 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
4557 /* The derived symbol has already been converted to a (void *). Use
4559 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
4560 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
4562 gfc_init_se (&se
, NULL
);
4563 gfc_conv_constant (&se
, expr
);
4564 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4568 if (array
&& !procptr
)
4571 /* Arrays need special handling. */
4573 ctor
= gfc_build_null_descriptor (type
);
4574 /* Special case assigning an array to zero. */
4575 else if (is_zero_initializer_p (expr
))
4576 ctor
= build_constructor (type
, NULL
);
4578 ctor
= gfc_conv_array_initializer (type
, expr
);
4579 TREE_STATIC (ctor
) = 1;
4582 else if (pointer
|| procptr
)
4584 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
4585 return fold_convert (type
, null_pointer_node
);
4588 gfc_init_se (&se
, NULL
);
4589 se
.want_pointer
= 1;
4590 gfc_conv_expr (&se
, expr
);
4591 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4601 gfc_init_se (&se
, NULL
);
4602 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4603 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
4605 gfc_conv_structure (&se
, expr
, 1);
4606 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
4607 TREE_STATIC (se
.expr
) = 1;
4612 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
4613 TREE_STATIC (ctor
) = 1;
4618 gfc_init_se (&se
, NULL
);
4619 gfc_conv_constant (&se
, expr
);
4620 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4627 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4633 gfc_array_info
*lss_array
;
4640 gfc_start_block (&block
);
4642 /* Initialize the scalarizer. */
4643 gfc_init_loopinfo (&loop
);
4645 gfc_init_se (&lse
, NULL
);
4646 gfc_init_se (&rse
, NULL
);
4649 rss
= gfc_walk_expr (expr
);
4650 if (rss
== gfc_ss_terminator
)
4651 /* The rhs is scalar. Add a ss for the expression. */
4652 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
4654 /* Create a SS for the destination. */
4655 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
4657 lss_array
= &lss
->info
->data
.array
;
4658 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
4659 lss_array
->descriptor
= dest
;
4660 lss_array
->data
= gfc_conv_array_data (dest
);
4661 lss_array
->offset
= gfc_conv_array_offset (dest
);
4662 for (n
= 0; n
< cm
->as
->rank
; n
++)
4664 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
4665 lss_array
->stride
[n
] = gfc_index_one_node
;
4667 mpz_init (lss_array
->shape
[n
]);
4668 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
4669 cm
->as
->lower
[n
]->value
.integer
);
4670 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
4673 /* Associate the SS with the loop. */
4674 gfc_add_ss_to_loop (&loop
, lss
);
4675 gfc_add_ss_to_loop (&loop
, rss
);
4677 /* Calculate the bounds of the scalarization. */
4678 gfc_conv_ss_startstride (&loop
);
4680 /* Setup the scalarizing loops. */
4681 gfc_conv_loop_setup (&loop
, &expr
->where
);
4683 /* Setup the gfc_se structures. */
4684 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4685 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4688 gfc_mark_ss_chain_used (rss
, 1);
4690 gfc_mark_ss_chain_used (lss
, 1);
4692 /* Start the scalarized loop body. */
4693 gfc_start_scalarized_body (&loop
, &body
);
4695 gfc_conv_tmp_array_ref (&lse
);
4696 if (cm
->ts
.type
== BT_CHARACTER
)
4697 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4699 gfc_conv_expr (&rse
, expr
);
4701 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
4702 gfc_add_expr_to_block (&body
, tmp
);
4704 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4706 /* Generate the copying loops. */
4707 gfc_trans_scalarizing_loops (&loop
, &body
);
4709 /* Wrap the whole thing up. */
4710 gfc_add_block_to_block (&block
, &loop
.pre
);
4711 gfc_add_block_to_block (&block
, &loop
.post
);
4713 gcc_assert (lss_array
->shape
!= NULL
);
4714 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
4715 gfc_cleanup_loop (&loop
);
4717 return gfc_finish_block (&block
);
4722 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4733 gfc_expr
*arg
= NULL
;
4735 gfc_start_block (&block
);
4736 gfc_init_se (&se
, NULL
);
4738 /* Get the descriptor for the expressions. */
4739 rss
= gfc_walk_expr (expr
);
4740 se
.want_pointer
= 0;
4741 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4742 gfc_add_block_to_block (&block
, &se
.pre
);
4743 gfc_add_modify (&block
, dest
, se
.expr
);
4745 /* Deal with arrays of derived types with allocatable components. */
4746 if (cm
->ts
.type
== BT_DERIVED
4747 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4748 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4752 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4753 TREE_TYPE(cm
->backend_decl
),
4756 gfc_add_expr_to_block (&block
, tmp
);
4757 gfc_add_block_to_block (&block
, &se
.post
);
4759 if (expr
->expr_type
!= EXPR_VARIABLE
)
4760 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4763 /* We need to know if the argument of a conversion function is a
4764 variable, so that the correct lower bound can be used. */
4765 if (expr
->expr_type
== EXPR_FUNCTION
4766 && expr
->value
.function
.isym
4767 && expr
->value
.function
.isym
->conversion
4768 && expr
->value
.function
.actual
->expr
4769 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4770 arg
= expr
->value
.function
.actual
->expr
;
4772 /* Obtain the array spec of full array references. */
4774 as
= gfc_get_full_arrayspec_from_expr (arg
);
4776 as
= gfc_get_full_arrayspec_from_expr (expr
);
4778 /* Shift the lbound and ubound of temporaries to being unity,
4779 rather than zero, based. Always calculate the offset. */
4780 offset
= gfc_conv_descriptor_offset_get (dest
);
4781 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4782 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4784 for (n
= 0; n
< expr
->rank
; n
++)
4789 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4790 TODO It looks as if gfc_conv_expr_descriptor should return
4791 the correct bounds and that the following should not be
4792 necessary. This would simplify gfc_conv_intrinsic_bound
4794 if (as
&& as
->lower
[n
])
4797 gfc_init_se (&lbse
, NULL
);
4798 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4799 gfc_add_block_to_block (&block
, &lbse
.pre
);
4800 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4804 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4805 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4809 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4812 lbound
= gfc_index_one_node
;
4814 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4816 /* Shift the bounds and set the offset accordingly. */
4817 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4818 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4819 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4820 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4822 gfc_conv_descriptor_ubound_set (&block
, dest
,
4823 gfc_rank_cst
[n
], tmp
);
4824 gfc_conv_descriptor_lbound_set (&block
, dest
,
4825 gfc_rank_cst
[n
], lbound
);
4827 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4828 gfc_conv_descriptor_lbound_get (dest
,
4830 gfc_conv_descriptor_stride_get (dest
,
4832 gfc_add_modify (&block
, tmp2
, tmp
);
4833 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4835 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4840 /* If a conversion expression has a null data pointer
4841 argument, nullify the allocatable component. */
4845 if (arg
->symtree
->n
.sym
->attr
.allocatable
4846 || arg
->symtree
->n
.sym
->attr
.pointer
)
4848 non_null_expr
= gfc_finish_block (&block
);
4849 gfc_start_block (&block
);
4850 gfc_conv_descriptor_data_set (&block
, dest
,
4852 null_expr
= gfc_finish_block (&block
);
4853 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4854 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
4855 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
4856 return build3_v (COND_EXPR
, tmp
,
4857 null_expr
, non_null_expr
);
4861 return gfc_finish_block (&block
);
4865 /* Assign a single component of a derived type constructor. */
4868 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4876 gfc_start_block (&block
);
4878 if (cm
->attr
.pointer
)
4880 gfc_init_se (&se
, NULL
);
4881 /* Pointer component. */
4882 if (cm
->attr
.dimension
)
4884 /* Array pointer. */
4885 if (expr
->expr_type
== EXPR_NULL
)
4886 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4889 rss
= gfc_walk_expr (expr
);
4890 se
.direct_byref
= 1;
4892 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4893 gfc_add_block_to_block (&block
, &se
.pre
);
4894 gfc_add_block_to_block (&block
, &se
.post
);
4899 /* Scalar pointers. */
4900 se
.want_pointer
= 1;
4901 gfc_conv_expr (&se
, expr
);
4902 gfc_add_block_to_block (&block
, &se
.pre
);
4903 gfc_add_modify (&block
, dest
,
4904 fold_convert (TREE_TYPE (dest
), se
.expr
));
4905 gfc_add_block_to_block (&block
, &se
.post
);
4908 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4910 /* NULL initialization for CLASS components. */
4911 tmp
= gfc_trans_structure_assign (dest
,
4912 gfc_class_null_initializer (&cm
->ts
));
4913 gfc_add_expr_to_block (&block
, tmp
);
4915 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
4917 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4918 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4919 else if (cm
->attr
.allocatable
)
4921 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4922 gfc_add_expr_to_block (&block
, tmp
);
4926 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4927 gfc_add_expr_to_block (&block
, tmp
);
4930 else if (expr
->ts
.type
== BT_DERIVED
)
4932 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4934 gfc_init_se (&se
, NULL
);
4935 gfc_conv_expr (&se
, expr
);
4936 gfc_add_block_to_block (&block
, &se
.pre
);
4937 gfc_add_modify (&block
, dest
,
4938 fold_convert (TREE_TYPE (dest
), se
.expr
));
4939 gfc_add_block_to_block (&block
, &se
.post
);
4943 /* Nested constructors. */
4944 tmp
= gfc_trans_structure_assign (dest
, expr
);
4945 gfc_add_expr_to_block (&block
, tmp
);
4950 /* Scalar component. */
4951 gfc_init_se (&se
, NULL
);
4952 gfc_init_se (&lse
, NULL
);
4954 gfc_conv_expr (&se
, expr
);
4955 if (cm
->ts
.type
== BT_CHARACTER
)
4956 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4958 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
4959 gfc_add_expr_to_block (&block
, tmp
);
4961 return gfc_finish_block (&block
);
4964 /* Assign a derived type constructor to a variable. */
4967 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4975 gfc_start_block (&block
);
4976 cm
= expr
->ts
.u
.derived
->components
;
4978 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
4979 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
4980 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
4984 gcc_assert (cm
->backend_decl
== NULL
);
4985 gfc_init_se (&se
, NULL
);
4986 gfc_init_se (&lse
, NULL
);
4987 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
4989 gfc_add_modify (&block
, lse
.expr
,
4990 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
4992 return gfc_finish_block (&block
);
4995 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4996 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4998 /* Skip absent members in default initializers. */
5002 field
= cm
->backend_decl
;
5003 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
5004 dest
, field
, NULL_TREE
);
5005 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
5006 gfc_add_expr_to_block (&block
, tmp
);
5008 return gfc_finish_block (&block
);
5011 /* Build an expression for a constructor. If init is nonzero then
5012 this is part of a static variable initializer. */
5015 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
5022 VEC(constructor_elt
,gc
) *v
= NULL
;
5024 gcc_assert (se
->ss
== NULL
);
5025 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
5026 type
= gfc_typenode_for_spec (&expr
->ts
);
5030 /* Create a temporary variable and fill it in. */
5031 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
5032 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
5033 gfc_add_expr_to_block (&se
->pre
, tmp
);
5037 cm
= expr
->ts
.u
.derived
->components
;
5039 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5040 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5042 /* Skip absent members in default initializers and allocatable
5043 components. Although the latter have a default initializer
5044 of EXPR_NULL,... by default, the static nullify is not needed
5045 since this is done every time we come into scope. */
5046 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
5049 if (strcmp (cm
->name
, "_size") == 0)
5051 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
5052 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
5054 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
5055 && strcmp (cm
->name
, "_extends") == 0)
5059 vtabs
= cm
->initializer
->symtree
->n
.sym
;
5060 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
5061 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
5065 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
5066 TREE_TYPE (cm
->backend_decl
),
5067 cm
->attr
.dimension
, cm
->attr
.pointer
,
5068 cm
->attr
.proc_pointer
);
5070 /* Append it to the constructor list. */
5071 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
5074 se
->expr
= build_constructor (type
, v
);
5076 TREE_CONSTANT (se
->expr
) = 1;
5080 /* Translate a substring expression. */
5083 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
5089 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
5091 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
5092 expr
->value
.character
.length
,
5093 expr
->value
.character
.string
);
5095 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
5096 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
5099 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
5103 /* Entry point for expression translation. Evaluates a scalar quantity.
5104 EXPR is the expression to be translated, and SE is the state structure if
5105 called from within the scalarized. */
5108 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
5113 if (ss
&& ss
->info
->expr
== expr
5114 && (ss
->info
->type
== GFC_SS_SCALAR
5115 || ss
->info
->type
== GFC_SS_REFERENCE
))
5117 gfc_ss_info
*ss_info
;
5120 /* Substitute a scalar expression evaluated outside the scalarization
5122 se
->expr
= ss_info
->data
.scalar
.value
;
5123 if (ss_info
->type
== GFC_SS_REFERENCE
)
5124 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5125 se
->string_length
= ss_info
->string_length
;
5126 gfc_advance_se_ss_chain (se
);
5130 /* We need to convert the expressions for the iso_c_binding derived types.
5131 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
5132 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
5133 typespec for the C_PTR and C_FUNPTR symbols, which has already been
5134 updated to be an integer with a kind equal to the size of a (void *). */
5135 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
5136 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
5138 if (expr
->expr_type
== EXPR_VARIABLE
5139 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
5140 || expr
->symtree
->n
.sym
->intmod_sym_id
5141 == ISOCBINDING_NULL_FUNPTR
))
5143 /* Set expr_type to EXPR_NULL, which will result in
5144 null_pointer_node being used below. */
5145 expr
->expr_type
= EXPR_NULL
;
5149 /* Update the type/kind of the expression to be what the new
5150 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
5151 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
5152 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
5153 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
5157 /* TODO: make this work for general class array expressions. */
5158 if (expr
->ts
.type
== BT_CLASS
5159 && expr
->ref
&& expr
->ref
->type
== REF_ARRAY
)
5160 gfc_add_component_ref (expr
, "_data");
5162 switch (expr
->expr_type
)
5165 gfc_conv_expr_op (se
, expr
);
5169 gfc_conv_function_expr (se
, expr
);
5173 gfc_conv_constant (se
, expr
);
5177 gfc_conv_variable (se
, expr
);
5181 se
->expr
= null_pointer_node
;
5184 case EXPR_SUBSTRING
:
5185 gfc_conv_substring_expr (se
, expr
);
5188 case EXPR_STRUCTURE
:
5189 gfc_conv_structure (se
, expr
, 0);
5193 gfc_conv_array_constructor_expr (se
, expr
);
5202 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
5203 of an assignment. */
5205 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
5207 gfc_conv_expr (se
, expr
);
5208 /* All numeric lvalues should have empty post chains. If not we need to
5209 figure out a way of rewriting an lvalue so that it has no post chain. */
5210 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
5213 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
5214 numeric expressions. Used for scalar values where inserting cleanup code
5217 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
5221 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
5222 gfc_conv_expr (se
, expr
);
5225 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5226 gfc_add_modify (&se
->pre
, val
, se
->expr
);
5228 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5232 /* Helper to translate an expression and convert it to a particular type. */
5234 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
5236 gfc_conv_expr_val (se
, expr
);
5237 se
->expr
= convert (type
, se
->expr
);
5241 /* Converts an expression so that it can be passed by reference. Scalar
5245 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
5251 if (ss
&& ss
->info
->expr
== expr
5252 && ss
->info
->type
== GFC_SS_REFERENCE
)
5254 /* Returns a reference to the scalar evaluated outside the loop
5256 gfc_conv_expr (se
, expr
);
5260 if (expr
->ts
.type
== BT_CHARACTER
)
5262 gfc_conv_expr (se
, expr
);
5263 gfc_conv_string_parameter (se
);
5267 if (expr
->expr_type
== EXPR_VARIABLE
)
5269 se
->want_pointer
= 1;
5270 gfc_conv_expr (se
, expr
);
5273 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5274 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5275 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5281 if (expr
->expr_type
== EXPR_FUNCTION
5282 && ((expr
->value
.function
.esym
5283 && expr
->value
.function
.esym
->result
->attr
.pointer
5284 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
5285 || (!expr
->value
.function
.esym
5286 && expr
->symtree
->n
.sym
->attr
.pointer
5287 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
5289 se
->want_pointer
= 1;
5290 gfc_conv_expr (se
, expr
);
5291 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5292 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5298 gfc_conv_expr (se
, expr
);
5300 /* Create a temporary var to hold the value. */
5301 if (TREE_CONSTANT (se
->expr
))
5303 tree tmp
= se
->expr
;
5304 STRIP_TYPE_NOPS (tmp
);
5305 var
= build_decl (input_location
,
5306 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
5307 DECL_INITIAL (var
) = tmp
;
5308 TREE_STATIC (var
) = 1;
5313 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5314 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5316 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5318 /* Take the address of that value. */
5319 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5324 gfc_trans_pointer_assign (gfc_code
* code
)
5326 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
5330 /* Generate code for a pointer assignment. */
5333 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
5344 gfc_start_block (&block
);
5346 gfc_init_se (&lse
, NULL
);
5348 lss
= gfc_walk_expr (expr1
);
5349 rss
= gfc_walk_expr (expr2
);
5350 if (lss
== gfc_ss_terminator
)
5352 /* Scalar pointers. */
5353 lse
.want_pointer
= 1;
5354 gfc_conv_expr (&lse
, expr1
);
5355 gcc_assert (rss
== gfc_ss_terminator
);
5356 gfc_init_se (&rse
, NULL
);
5357 rse
.want_pointer
= 1;
5358 gfc_conv_expr (&rse
, expr2
);
5360 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
5361 && expr1
->symtree
->n
.sym
->attr
.dummy
)
5362 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
5365 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
5366 && expr2
->symtree
->n
.sym
->attr
.dummy
)
5367 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5370 gfc_add_block_to_block (&block
, &lse
.pre
);
5371 gfc_add_block_to_block (&block
, &rse
.pre
);
5373 /* Check character lengths if character expression. The test is only
5374 really added if -fbounds-check is enabled. Exclude deferred
5375 character length lefthand sides. */
5376 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
5377 && !(expr1
->ts
.deferred
5378 && (TREE_CODE (lse
.string_length
) == VAR_DECL
))
5379 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
5380 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
5382 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5383 gcc_assert (lse
.string_length
&& rse
.string_length
);
5384 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5385 lse
.string_length
, rse
.string_length
,
5389 /* The assignment to an deferred character length sets the string
5390 length to that of the rhs. */
5391 if (expr1
->ts
.deferred
&& (TREE_CODE (lse
.string_length
) == VAR_DECL
))
5393 if (expr2
->expr_type
!= EXPR_NULL
)
5394 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
5396 gfc_add_modify (&block
, lse
.string_length
,
5397 build_int_cst (gfc_charlen_type_node
, 0));
5400 gfc_add_modify (&block
, lse
.expr
,
5401 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
5403 gfc_add_block_to_block (&block
, &rse
.post
);
5404 gfc_add_block_to_block (&block
, &lse
.post
);
5411 tree strlen_rhs
= NULL_TREE
;
5413 /* Array pointer. Find the last reference on the LHS and if it is an
5414 array section ref, we're dealing with bounds remapping. In this case,
5415 set it to AR_FULL so that gfc_conv_expr_descriptor does
5416 not see it and process the bounds remapping afterwards explicitely. */
5417 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
5418 if (!remap
->next
&& remap
->type
== REF_ARRAY
5419 && remap
->u
.ar
.type
== AR_SECTION
)
5421 remap
->u
.ar
.type
= AR_FULL
;
5424 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
5426 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
5427 strlen_lhs
= lse
.string_length
;
5430 if (expr2
->expr_type
== EXPR_NULL
)
5432 /* Just set the data pointer to null. */
5433 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
5435 else if (rank_remap
)
5437 /* If we are rank-remapping, just get the RHS's descriptor and
5438 process this later on. */
5439 gfc_init_se (&rse
, NULL
);
5440 rse
.direct_byref
= 1;
5441 rse
.byref_noassign
= 1;
5442 gfc_conv_expr_descriptor (&rse
, expr2
, rss
);
5443 strlen_rhs
= rse
.string_length
;
5445 else if (expr2
->expr_type
== EXPR_VARIABLE
)
5447 /* Assign directly to the LHS's descriptor. */
5448 lse
.direct_byref
= 1;
5449 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
5450 strlen_rhs
= lse
.string_length
;
5452 /* If this is a subreference array pointer assignment, use the rhs
5453 descriptor element size for the lhs span. */
5454 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
5456 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
5457 gfc_init_se (&rse
, NULL
);
5458 rse
.descriptor_only
= 1;
5459 gfc_conv_expr (&rse
, expr2
);
5460 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
5461 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
5462 if (!INTEGER_CST_P (tmp
))
5463 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
5464 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
5469 /* Assign to a temporary descriptor and then copy that
5470 temporary to the pointer. */
5471 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
5474 lse
.direct_byref
= 1;
5475 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
5476 strlen_rhs
= lse
.string_length
;
5477 gfc_add_modify (&lse
.pre
, desc
, tmp
);
5480 gfc_add_block_to_block (&block
, &lse
.pre
);
5482 gfc_add_block_to_block (&block
, &rse
.pre
);
5484 /* If we do bounds remapping, update LHS descriptor accordingly. */
5488 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
5492 /* Do rank remapping. We already have the RHS's descriptor
5493 converted in rse and now have to build the correct LHS
5494 descriptor for it. */
5498 tree lbound
, ubound
;
5501 dtype
= gfc_conv_descriptor_dtype (desc
);
5502 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
5503 gfc_add_modify (&block
, dtype
, tmp
);
5505 /* Copy data pointer. */
5506 data
= gfc_conv_descriptor_data_get (rse
.expr
);
5507 gfc_conv_descriptor_data_set (&block
, desc
, data
);
5509 /* Copy offset but adjust it such that it would correspond
5510 to a lbound of zero. */
5511 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
5512 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
5514 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5516 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
5518 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5519 gfc_array_index_type
, stride
, lbound
);
5520 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
5521 gfc_array_index_type
, offs
, tmp
);
5523 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5525 /* Set the bounds as declared for the LHS and calculate strides as
5526 well as another offset update accordingly. */
5527 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5529 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
5534 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
5536 /* Convert declared bounds. */
5537 gfc_init_se (&lower_se
, NULL
);
5538 gfc_init_se (&upper_se
, NULL
);
5539 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
5540 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
5542 gfc_add_block_to_block (&block
, &lower_se
.pre
);
5543 gfc_add_block_to_block (&block
, &upper_se
.pre
);
5545 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
5546 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
5548 lbound
= gfc_evaluate_now (lbound
, &block
);
5549 ubound
= gfc_evaluate_now (ubound
, &block
);
5551 gfc_add_block_to_block (&block
, &lower_se
.post
);
5552 gfc_add_block_to_block (&block
, &upper_se
.post
);
5554 /* Set bounds in descriptor. */
5555 gfc_conv_descriptor_lbound_set (&block
, desc
,
5556 gfc_rank_cst
[dim
], lbound
);
5557 gfc_conv_descriptor_ubound_set (&block
, desc
,
5558 gfc_rank_cst
[dim
], ubound
);
5561 stride
= gfc_evaluate_now (stride
, &block
);
5562 gfc_conv_descriptor_stride_set (&block
, desc
,
5563 gfc_rank_cst
[dim
], stride
);
5565 /* Update offset. */
5566 offs
= gfc_conv_descriptor_offset_get (desc
);
5567 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5568 gfc_array_index_type
, lbound
, stride
);
5569 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
5570 gfc_array_index_type
, offs
, tmp
);
5571 offs
= gfc_evaluate_now (offs
, &block
);
5572 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5574 /* Update stride. */
5575 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5576 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5577 gfc_array_index_type
, stride
, tmp
);
5582 /* Bounds remapping. Just shift the lower bounds. */
5584 gcc_assert (expr1
->rank
== expr2
->rank
);
5586 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
5590 gcc_assert (remap
->u
.ar
.start
[dim
]);
5591 gcc_assert (!remap
->u
.ar
.end
[dim
]);
5592 gfc_init_se (&lbound_se
, NULL
);
5593 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
5595 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
5596 gfc_conv_shift_descriptor_lbound (&block
, desc
,
5597 dim
, lbound_se
.expr
);
5598 gfc_add_block_to_block (&block
, &lbound_se
.post
);
5603 /* Check string lengths if applicable. The check is only really added
5604 to the output code if -fbounds-check is enabled. */
5605 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
5607 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5608 gcc_assert (strlen_lhs
&& strlen_rhs
);
5609 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5610 strlen_lhs
, strlen_rhs
, &block
);
5613 /* If rank remapping was done, check with -fcheck=bounds that
5614 the target is at least as large as the pointer. */
5615 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
5621 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
5622 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
5624 lsize
= gfc_evaluate_now (lsize
, &block
);
5625 rsize
= gfc_evaluate_now (rsize
, &block
);
5626 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
5629 msg
= _("Target of rank remapping is too small (%ld < %ld)");
5630 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
5634 gfc_add_block_to_block (&block
, &lse
.post
);
5636 gfc_add_block_to_block (&block
, &rse
.post
);
5639 return gfc_finish_block (&block
);
5643 /* Makes sure se is suitable for passing as a function string parameter. */
5644 /* TODO: Need to check all callers of this function. It may be abused. */
5647 gfc_conv_string_parameter (gfc_se
* se
)
5651 if (TREE_CODE (se
->expr
) == STRING_CST
)
5653 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
5654 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5658 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
5660 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
5662 type
= TREE_TYPE (se
->expr
);
5663 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5667 type
= gfc_get_character_type_len (gfc_default_character_kind
,
5669 type
= build_pointer_type (type
);
5670 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
5674 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
5678 /* Generate code for assignment of scalar variables. Includes character
5679 strings and derived types with allocatable components.
5680 If you know that the LHS has no allocations, set dealloc to false. */
5683 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
5684 bool l_is_temp
, bool r_is_var
, bool dealloc
)
5690 gfc_init_block (&block
);
5692 if (ts
.type
== BT_CHARACTER
)
5697 if (lse
->string_length
!= NULL_TREE
)
5699 gfc_conv_string_parameter (lse
);
5700 gfc_add_block_to_block (&block
, &lse
->pre
);
5701 llen
= lse
->string_length
;
5704 if (rse
->string_length
!= NULL_TREE
)
5706 gcc_assert (rse
->string_length
!= NULL_TREE
);
5707 gfc_conv_string_parameter (rse
);
5708 gfc_add_block_to_block (&block
, &rse
->pre
);
5709 rlen
= rse
->string_length
;
5712 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
5713 rse
->expr
, ts
.kind
);
5715 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
5719 /* Are the rhs and the lhs the same? */
5722 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5723 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
5724 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
5725 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
5728 /* Deallocate the lhs allocated components as long as it is not
5729 the same as the rhs. This must be done following the assignment
5730 to prevent deallocating data that could be used in the rhs
5732 if (!l_is_temp
&& dealloc
)
5734 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
5735 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
5737 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5739 gfc_add_expr_to_block (&lse
->post
, tmp
);
5742 gfc_add_block_to_block (&block
, &rse
->pre
);
5743 gfc_add_block_to_block (&block
, &lse
->pre
);
5745 gfc_add_modify (&block
, lse
->expr
,
5746 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5748 /* Do a deep copy if the rhs is a variable, if it is not the
5752 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
5753 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5755 gfc_add_expr_to_block (&block
, tmp
);
5758 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
5760 gfc_add_block_to_block (&block
, &lse
->pre
);
5761 gfc_add_block_to_block (&block
, &rse
->pre
);
5762 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
5763 TREE_TYPE (lse
->expr
), rse
->expr
);
5764 gfc_add_modify (&block
, lse
->expr
, tmp
);
5768 gfc_add_block_to_block (&block
, &lse
->pre
);
5769 gfc_add_block_to_block (&block
, &rse
->pre
);
5771 gfc_add_modify (&block
, lse
->expr
,
5772 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5775 gfc_add_block_to_block (&block
, &lse
->post
);
5776 gfc_add_block_to_block (&block
, &rse
->post
);
5778 return gfc_finish_block (&block
);
5782 /* There are quite a lot of restrictions on the optimisation in using an
5783 array function assign without a temporary. */
5786 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
5789 bool seen_array_ref
;
5791 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
5793 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5794 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
5797 /* Elemental functions are scalarized so that they don't need a
5798 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5799 they would need special treatment in gfc_trans_arrayfunc_assign. */
5800 if (expr2
->value
.function
.esym
!= NULL
5801 && expr2
->value
.function
.esym
->attr
.elemental
)
5804 /* Need a temporary if rhs is not FULL or a contiguous section. */
5805 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
5808 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5809 if (gfc_ref_needs_temporary_p (expr1
->ref
))
5812 /* Functions returning pointers or allocatables need temporaries. */
5813 c
= expr2
->value
.function
.esym
5814 ? (expr2
->value
.function
.esym
->attr
.pointer
5815 || expr2
->value
.function
.esym
->attr
.allocatable
)
5816 : (expr2
->symtree
->n
.sym
->attr
.pointer
5817 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
5821 /* Character array functions need temporaries unless the
5822 character lengths are the same. */
5823 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
5825 if (expr1
->ts
.u
.cl
->length
== NULL
5826 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5829 if (expr2
->ts
.u
.cl
->length
== NULL
5830 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5833 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
5834 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
5838 /* Check that no LHS component references appear during an array
5839 reference. This is needed because we do not have the means to
5840 span any arbitrary stride with an array descriptor. This check
5841 is not needed for the rhs because the function result has to be
5843 seen_array_ref
= false;
5844 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
5846 if (ref
->type
== REF_ARRAY
)
5847 seen_array_ref
= true;
5848 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
5852 /* Check for a dependency. */
5853 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
5854 expr2
->value
.function
.esym
,
5855 expr2
->value
.function
.actual
,
5859 /* If we have reached here with an intrinsic function, we do not
5860 need a temporary except in the particular case that reallocation
5861 on assignment is active and the lhs is allocatable and a target. */
5862 if (expr2
->value
.function
.isym
)
5863 return (gfc_option
.flag_realloc_lhs
5864 && sym
->attr
.allocatable
5865 && sym
->attr
.target
);
5867 /* If the LHS is a dummy, we need a temporary if it is not
5869 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
5872 /* If the lhs has been host_associated, is in common, a pointer or is
5873 a target and the function is not using a RESULT variable, aliasing
5874 can occur and a temporary is needed. */
5875 if ((sym
->attr
.host_assoc
5876 || sym
->attr
.in_common
5877 || sym
->attr
.pointer
5878 || sym
->attr
.cray_pointee
5879 || sym
->attr
.target
)
5880 && expr2
->symtree
!= NULL
5881 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
5884 /* A PURE function can unconditionally be called without a temporary. */
5885 if (expr2
->value
.function
.esym
!= NULL
5886 && expr2
->value
.function
.esym
->attr
.pure
)
5889 /* Implicit_pure functions are those which could legally be declared
5891 if (expr2
->value
.function
.esym
!= NULL
5892 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
5895 if (!sym
->attr
.use_assoc
5896 && !sym
->attr
.in_common
5897 && !sym
->attr
.pointer
5898 && !sym
->attr
.target
5899 && !sym
->attr
.cray_pointee
5900 && expr2
->value
.function
.esym
)
5902 /* A temporary is not needed if the function is not contained and
5903 the variable is local or host associated and not a pointer or
5905 if (!expr2
->value
.function
.esym
->attr
.contained
)
5908 /* A temporary is not needed if the lhs has never been host
5909 associated and the procedure is contained. */
5910 else if (!sym
->attr
.host_assoc
)
5913 /* A temporary is not needed if the variable is local and not
5914 a pointer, a target or a result. */
5916 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
5920 /* Default to temporary use. */
5925 /* Provide the loop info so that the lhs descriptor can be built for
5926 reallocatable assignments from extrinsic function calls. */
5929 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
5932 /* Signal that the function call should not be made by
5933 gfc_conv_loop_setup. */
5934 se
->ss
->is_alloc_lhs
= 1;
5935 gfc_init_loopinfo (loop
);
5936 gfc_add_ss_to_loop (loop
, *ss
);
5937 gfc_add_ss_to_loop (loop
, se
->ss
);
5938 gfc_conv_ss_startstride (loop
);
5939 gfc_conv_loop_setup (loop
, where
);
5940 gfc_copy_loopinfo_to_se (se
, loop
);
5941 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
5942 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
5943 se
->ss
->is_alloc_lhs
= 0;
5947 /* For Assignment to a reallocatable lhs from intrinsic functions,
5948 replace the se.expr (ie. the result) with a temporary descriptor.
5949 Null the data field so that the library allocates space for the
5950 result. Free the data of the original descriptor after the function,
5951 in case it appears in an argument expression and transfer the
5952 result to the original descriptor. */
5955 fcncall_realloc_result (gfc_se
*se
, int rank
)
5963 /* Use the allocation done by the library. Substitute the lhs
5964 descriptor with a copy, whose data field is nulled.*/
5965 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5966 /* Unallocated, the descriptor does not have a dtype. */
5967 tmp
= gfc_conv_descriptor_dtype (desc
);
5968 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
5969 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
5970 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
5971 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
5973 /* Free the lhs after the function call and copy the result to
5974 the lhs descriptor. */
5975 tmp
= gfc_conv_descriptor_data_get (desc
);
5976 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
5977 gfc_add_expr_to_block (&se
->post
, tmp
);
5978 gfc_add_modify (&se
->post
, desc
, res_desc
);
5980 offset
= gfc_index_zero_node
;
5981 tmp
= gfc_index_one_node
;
5982 /* Now reset the bounds from zero based to unity based. */
5983 for (n
= 0 ; n
< rank
; n
++)
5985 /* Accumulate the offset. */
5986 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5987 gfc_array_index_type
,
5989 /* Now do the bounds. */
5990 gfc_conv_descriptor_offset_set (&se
->post
, desc
, tmp
);
5991 tmp
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
5992 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5993 gfc_array_index_type
,
5994 tmp
, gfc_index_one_node
);
5995 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
5997 gfc_index_one_node
);
5998 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
5999 gfc_rank_cst
[n
], tmp
);
6001 /* The extent for the next contribution to offset. */
6002 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6003 gfc_array_index_type
,
6004 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
6005 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
6006 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6007 gfc_array_index_type
,
6008 tmp
, gfc_index_one_node
);
6010 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
6015 /* Try to translate array(:) = func (...), where func is a transformational
6016 array function, without using a temporary. Returns NULL if this isn't the
6020 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
6024 gfc_component
*comp
= NULL
;
6027 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
6030 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
6032 gcc_assert (expr2
->value
.function
.isym
6033 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
6034 && comp
&& comp
->attr
.dimension
)
6035 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
6036 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
6038 ss
= gfc_walk_expr (expr1
);
6039 gcc_assert (ss
!= gfc_ss_terminator
);
6040 gfc_init_se (&se
, NULL
);
6041 gfc_start_block (&se
.pre
);
6042 se
.want_pointer
= 1;
6044 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
6046 if (expr1
->ts
.type
== BT_DERIVED
6047 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
6050 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
6052 gfc_add_expr_to_block (&se
.pre
, tmp
);
6055 se
.direct_byref
= 1;
6056 se
.ss
= gfc_walk_expr (expr2
);
6057 gcc_assert (se
.ss
!= gfc_ss_terminator
);
6059 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
6060 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
6061 Clearly, this cannot be done for an allocatable function result, since
6062 the shape of the result is unknown and, in any case, the function must
6063 correctly take care of the reallocation internally. For intrinsic
6064 calls, the array data is freed and the library takes care of allocation.
6065 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
6067 if (gfc_option
.flag_realloc_lhs
6068 && gfc_is_reallocatable_lhs (expr1
)
6069 && !gfc_expr_attr (expr1
).codimension
6070 && !gfc_is_coindexed (expr1
)
6071 && !(expr2
->value
.function
.esym
6072 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
6074 if (!expr2
->value
.function
.isym
)
6076 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
6077 ss
->is_alloc_lhs
= 1;
6080 fcncall_realloc_result (&se
, expr1
->rank
);
6083 gfc_conv_function_expr (&se
, expr2
);
6084 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6086 return gfc_finish_block (&se
.pre
);
6090 /* Try to efficiently translate array(:) = 0. Return NULL if this
6094 gfc_trans_zero_assign (gfc_expr
* expr
)
6096 tree dest
, len
, type
;
6100 sym
= expr
->symtree
->n
.sym
;
6101 dest
= gfc_get_symbol_decl (sym
);
6103 type
= TREE_TYPE (dest
);
6104 if (POINTER_TYPE_P (type
))
6105 type
= TREE_TYPE (type
);
6106 if (!GFC_ARRAY_TYPE_P (type
))
6109 /* Determine the length of the array. */
6110 len
= GFC_TYPE_ARRAY_SIZE (type
);
6111 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
6114 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6115 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
6116 fold_convert (gfc_array_index_type
, tmp
));
6118 /* If we are zeroing a local array avoid taking its address by emitting
6120 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
6121 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6122 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
6124 /* Convert arguments to the correct types. */
6125 dest
= fold_convert (pvoid_type_node
, dest
);
6126 len
= fold_convert (size_type_node
, len
);
6128 /* Construct call to __builtin_memset. */
6129 tmp
= build_call_expr_loc (input_location
,
6130 builtin_decl_explicit (BUILT_IN_MEMSET
),
6131 3, dest
, integer_zero_node
, len
);
6132 return fold_convert (void_type_node
, tmp
);
6136 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
6137 that constructs the call to __builtin_memcpy. */
6140 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
6144 /* Convert arguments to the correct types. */
6145 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
6146 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
6148 dst
= fold_convert (pvoid_type_node
, dst
);
6150 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
6151 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6153 src
= fold_convert (pvoid_type_node
, src
);
6155 len
= fold_convert (size_type_node
, len
);
6157 /* Construct call to __builtin_memcpy. */
6158 tmp
= build_call_expr_loc (input_location
,
6159 builtin_decl_explicit (BUILT_IN_MEMCPY
),
6161 return fold_convert (void_type_node
, tmp
);
6165 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
6166 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
6167 source/rhs, both are gfc_full_array_ref_p which have been checked for
6171 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
6173 tree dst
, dlen
, dtype
;
6174 tree src
, slen
, stype
;
6177 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
6178 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
6180 dtype
= TREE_TYPE (dst
);
6181 if (POINTER_TYPE_P (dtype
))
6182 dtype
= TREE_TYPE (dtype
);
6183 stype
= TREE_TYPE (src
);
6184 if (POINTER_TYPE_P (stype
))
6185 stype
= TREE_TYPE (stype
);
6187 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
6190 /* Determine the lengths of the arrays. */
6191 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
6192 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
6194 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
6195 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6196 dlen
, fold_convert (gfc_array_index_type
, tmp
));
6198 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
6199 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
6201 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
6202 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6203 slen
, fold_convert (gfc_array_index_type
, tmp
));
6205 /* Sanity check that they are the same. This should always be
6206 the case, as we should already have checked for conformance. */
6207 if (!tree_int_cst_equal (slen
, dlen
))
6210 return gfc_build_memcpy_call (dst
, src
, dlen
);
6214 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
6215 this can't be done. EXPR1 is the destination/lhs for which
6216 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
6219 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
6221 unsigned HOST_WIDE_INT nelem
;
6227 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
6231 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
6232 dtype
= TREE_TYPE (dst
);
6233 if (POINTER_TYPE_P (dtype
))
6234 dtype
= TREE_TYPE (dtype
);
6235 if (!GFC_ARRAY_TYPE_P (dtype
))
6238 /* Determine the lengths of the array. */
6239 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
6240 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
6243 /* Confirm that the constructor is the same size. */
6244 if (compare_tree_int (len
, nelem
) != 0)
6247 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
6248 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
6249 fold_convert (gfc_array_index_type
, tmp
));
6251 stype
= gfc_typenode_for_spec (&expr2
->ts
);
6252 src
= gfc_build_constant_array_constructor (expr2
, stype
);
6254 stype
= TREE_TYPE (src
);
6255 if (POINTER_TYPE_P (stype
))
6256 stype
= TREE_TYPE (stype
);
6258 return gfc_build_memcpy_call (dst
, src
, len
);
6262 /* Tells whether the expression is to be treated as a variable reference. */
6265 expr_is_variable (gfc_expr
*expr
)
6269 if (expr
->expr_type
== EXPR_VARIABLE
)
6272 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
6275 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6276 return expr_is_variable (arg
);
6283 /* Is the lhs OK for automatic reallocation? */
6286 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
6290 /* An allocatable variable with no reference. */
6291 if (expr
->symtree
->n
.sym
->attr
.allocatable
6295 /* All that can be left are allocatable components. */
6296 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
6297 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
6298 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
6301 /* Find an allocatable component ref last. */
6302 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6303 if (ref
->type
== REF_COMPONENT
6305 && ref
->u
.c
.component
->attr
.allocatable
)
6312 /* Allocate or reallocate scalar lhs, as necessary. */
6315 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
6329 if (!expr1
|| expr1
->rank
)
6332 if (!expr2
|| expr2
->rank
)
6335 /* Since this is a scalar lhs, we can afford to do this. That is,
6336 there is no risk of side effects being repeated. */
6337 gfc_init_se (&lse
, NULL
);
6338 lse
.want_pointer
= 1;
6339 gfc_conv_expr (&lse
, expr1
);
6341 jump_label1
= gfc_build_label_decl (NULL_TREE
);
6342 jump_label2
= gfc_build_label_decl (NULL_TREE
);
6344 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6345 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
6346 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6348 tmp
= build3_v (COND_EXPR
, cond
,
6349 build1_v (GOTO_EXPR
, jump_label1
),
6350 build_empty_stmt (input_location
));
6351 gfc_add_expr_to_block (block
, tmp
);
6353 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6355 /* Use the rhs string length and the lhs element size. */
6356 size
= string_length
;
6357 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
6358 tmp
= TYPE_SIZE_UNIT (tmp
);
6359 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6360 TREE_TYPE (tmp
), tmp
,
6361 fold_convert (TREE_TYPE (tmp
), size
));
6365 /* Otherwise use the length in bytes of the rhs. */
6366 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
6367 size_in_bytes
= size
;
6370 tmp
= build_call_expr_loc (input_location
,
6371 builtin_decl_explicit (BUILT_IN_MALLOC
),
6373 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
6374 gfc_add_modify (block
, lse
.expr
, tmp
);
6375 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6377 /* Deferred characters need checking for lhs and rhs string
6378 length. Other deferred parameter variables will have to
6380 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
6381 gfc_add_expr_to_block (block
, tmp
);
6383 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
6384 gfc_add_expr_to_block (block
, tmp
);
6386 /* For a deferred length character, reallocate if lengths of lhs and
6387 rhs are different. */
6388 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6390 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6391 expr1
->ts
.u
.cl
->backend_decl
, size
);
6392 /* Jump past the realloc if the lengths are the same. */
6393 tmp
= build3_v (COND_EXPR
, cond
,
6394 build1_v (GOTO_EXPR
, jump_label2
),
6395 build_empty_stmt (input_location
));
6396 gfc_add_expr_to_block (block
, tmp
);
6397 tmp
= build_call_expr_loc (input_location
,
6398 builtin_decl_explicit (BUILT_IN_REALLOC
),
6399 2, fold_convert (pvoid_type_node
, lse
.expr
),
6401 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
6402 gfc_add_modify (block
, lse
.expr
, tmp
);
6403 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
6404 gfc_add_expr_to_block (block
, tmp
);
6406 /* Update the lhs character length. */
6407 size
= string_length
;
6408 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
6413 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6414 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6415 init_flag indicates initialization expressions and dealloc that no
6416 deallocate prior assignment is needed (if in doubt, set true). */
6419 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
6425 gfc_ss
*lss_section
;
6432 bool scalar_to_array
;
6437 /* Assignment of the form lhs = rhs. */
6438 gfc_start_block (&block
);
6440 gfc_init_se (&lse
, NULL
);
6441 gfc_init_se (&rse
, NULL
);
6444 lss
= gfc_walk_expr (expr1
);
6445 if (gfc_is_reallocatable_lhs (expr1
)
6446 && !(expr2
->expr_type
== EXPR_FUNCTION
6447 && expr2
->value
.function
.isym
!= NULL
))
6448 lss
->is_alloc_lhs
= 1;
6450 if (lss
!= gfc_ss_terminator
)
6452 /* The assignment needs scalarization. */
6455 /* Find a non-scalar SS from the lhs. */
6456 while (lss_section
!= gfc_ss_terminator
6457 && lss_section
->info
->type
!= GFC_SS_SECTION
)
6458 lss_section
= lss_section
->next
;
6460 gcc_assert (lss_section
!= gfc_ss_terminator
);
6462 /* Initialize the scalarizer. */
6463 gfc_init_loopinfo (&loop
);
6466 rss
= gfc_walk_expr (expr2
);
6467 if (rss
== gfc_ss_terminator
)
6468 /* The rhs is scalar. Add a ss for the expression. */
6469 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
6471 /* Associate the SS with the loop. */
6472 gfc_add_ss_to_loop (&loop
, lss
);
6473 gfc_add_ss_to_loop (&loop
, rss
);
6475 /* Calculate the bounds of the scalarization. */
6476 gfc_conv_ss_startstride (&loop
);
6477 /* Enable loop reversal. */
6478 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
6479 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
6480 /* Resolve any data dependencies in the statement. */
6481 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
6482 /* Setup the scalarizing loops. */
6483 gfc_conv_loop_setup (&loop
, &expr2
->where
);
6485 /* Setup the gfc_se structures. */
6486 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6487 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6490 gfc_mark_ss_chain_used (rss
, 1);
6491 if (loop
.temp_ss
== NULL
)
6494 gfc_mark_ss_chain_used (lss
, 1);
6498 lse
.ss
= loop
.temp_ss
;
6499 gfc_mark_ss_chain_used (lss
, 3);
6500 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
6503 /* Allow the scalarizer to workshare array assignments. */
6504 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
6505 ompws_flags
|= OMPWS_SCALARIZER_WS
;
6507 /* Start the scalarized loop body. */
6508 gfc_start_scalarized_body (&loop
, &body
);
6511 gfc_init_block (&body
);
6513 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
6515 /* Translate the expression. */
6516 gfc_conv_expr (&rse
, expr2
);
6518 /* Stabilize a string length for temporaries. */
6519 if (expr2
->ts
.type
== BT_CHARACTER
)
6520 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
6522 string_length
= NULL_TREE
;
6526 gfc_conv_tmp_array_ref (&lse
);
6527 if (expr2
->ts
.type
== BT_CHARACTER
)
6528 lse
.string_length
= string_length
;
6531 gfc_conv_expr (&lse
, expr1
);
6533 /* Assignments of scalar derived types with allocatable components
6534 to arrays must be done with a deep copy and the rhs temporary
6535 must have its components deallocated afterwards. */
6536 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
6537 && expr2
->ts
.u
.derived
->attr
.alloc_comp
6538 && !expr_is_variable (expr2
)
6539 && !gfc_is_constant_expr (expr2
)
6540 && expr1
->rank
&& !expr2
->rank
);
6541 if (scalar_to_array
&& dealloc
)
6543 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
6544 gfc_add_expr_to_block (&loop
.post
, tmp
);
6547 /* For a deferred character length function, the function call must
6548 happen before the (re)allocation of the lhs, otherwise the character
6549 length of the result is not known. */
6550 def_clen_func
= (((expr2
->expr_type
== EXPR_FUNCTION
)
6551 || (expr2
->expr_type
== EXPR_COMPCALL
)
6552 || (expr2
->expr_type
== EXPR_PPC
))
6553 && expr2
->ts
.deferred
);
6554 if (gfc_option
.flag_realloc_lhs
6555 && expr2
->ts
.type
== BT_CHARACTER
6556 && (def_clen_func
|| expr2
->expr_type
== EXPR_OP
)
6557 && expr1
->ts
.deferred
)
6558 gfc_add_block_to_block (&block
, &rse
.pre
);
6560 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
6561 l_is_temp
|| init_flag
,
6562 expr_is_variable (expr2
) || scalar_to_array
6563 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
6564 gfc_add_expr_to_block (&body
, tmp
);
6566 if (lss
== gfc_ss_terminator
)
6568 /* F2003: Add the code for reallocation on assignment. */
6569 if (gfc_option
.flag_realloc_lhs
6570 && is_scalar_reallocatable_lhs (expr1
))
6571 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
6574 /* Use the scalar assignment as is. */
6575 gfc_add_block_to_block (&block
, &body
);
6579 gcc_assert (lse
.ss
== gfc_ss_terminator
6580 && rse
.ss
== gfc_ss_terminator
);
6584 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6586 /* We need to copy the temporary to the actual lhs. */
6587 gfc_init_se (&lse
, NULL
);
6588 gfc_init_se (&rse
, NULL
);
6589 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6590 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6592 rse
.ss
= loop
.temp_ss
;
6595 gfc_conv_tmp_array_ref (&rse
);
6596 gfc_conv_expr (&lse
, expr1
);
6598 gcc_assert (lse
.ss
== gfc_ss_terminator
6599 && rse
.ss
== gfc_ss_terminator
);
6601 if (expr2
->ts
.type
== BT_CHARACTER
)
6602 rse
.string_length
= string_length
;
6604 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
6605 false, false, dealloc
);
6606 gfc_add_expr_to_block (&body
, tmp
);
6609 /* F2003: Allocate or reallocate lhs of allocatable array. */
6610 if (gfc_option
.flag_realloc_lhs
6611 && gfc_is_reallocatable_lhs (expr1
)
6612 && !gfc_expr_attr (expr1
).codimension
6613 && !gfc_is_coindexed (expr1
))
6615 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
6616 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
6617 if (tmp
!= NULL_TREE
)
6618 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
6621 /* Generate the copying loops. */
6622 gfc_trans_scalarizing_loops (&loop
, &body
);
6624 /* Wrap the whole thing up. */
6625 gfc_add_block_to_block (&block
, &loop
.pre
);
6626 gfc_add_block_to_block (&block
, &loop
.post
);
6628 gfc_cleanup_loop (&loop
);
6631 return gfc_finish_block (&block
);
6635 /* Check whether EXPR is a copyable array. */
6638 copyable_array_p (gfc_expr
* expr
)
6640 if (expr
->expr_type
!= EXPR_VARIABLE
)
6643 /* First check it's an array. */
6644 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
6647 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
6650 /* Next check that it's of a simple enough type. */
6651 switch (expr
->ts
.type
)
6663 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
6672 /* Translate an assignment. */
6675 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
6680 /* Special case a single function returning an array. */
6681 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
6683 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
6688 /* Special case assigning an array to zero. */
6689 if (copyable_array_p (expr1
)
6690 && is_zero_initializer_p (expr2
))
6692 tmp
= gfc_trans_zero_assign (expr1
);
6697 /* Special case copying one array to another. */
6698 if (copyable_array_p (expr1
)
6699 && copyable_array_p (expr2
)
6700 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
6701 && !gfc_check_dependency (expr1
, expr2
, 0))
6703 tmp
= gfc_trans_array_copy (expr1
, expr2
);
6708 /* Special case initializing an array from a constant array constructor. */
6709 if (copyable_array_p (expr1
)
6710 && expr2
->expr_type
== EXPR_ARRAY
6711 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
6713 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
6718 /* Fallback to the scalarizer to generate explicit loops. */
6719 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
6723 gfc_trans_init_assign (gfc_code
* code
)
6725 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
6729 gfc_trans_assign (gfc_code
* code
)
6731 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
6736 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
6738 gfc_actual_arglist
*actual
;
6743 actual
= gfc_get_actual_arglist ();
6744 actual
->expr
= gfc_copy_expr (rhs
);
6745 actual
->next
= gfc_get_actual_arglist ();
6746 actual
->next
->expr
= gfc_copy_expr (lhs
);
6747 ppc
= gfc_copy_expr (obj
);
6748 gfc_add_vptr_component (ppc
);
6749 gfc_add_component_ref (ppc
, "_copy");
6750 ppc_code
= gfc_get_code ();
6751 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
6752 /* Although '_copy' is set to be elemental in class.c, it is
6753 not staying that way. Find out why, sometime.... */
6754 ppc_code
->resolved_sym
->attr
.elemental
= 1;
6755 ppc_code
->ext
.actual
= actual
;
6756 ppc_code
->expr1
= ppc
;
6757 ppc_code
->op
= EXEC_CALL
;
6758 /* Since '_copy' is elemental, the scalarizer will take care
6759 of arrays in gfc_trans_call. */
6760 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
6761 gfc_free_statements (ppc_code
);
6765 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6766 A MEMCPY is needed to copy the full data from the default initializer
6767 of the dynamic type. */
6770 gfc_trans_class_init_assign (gfc_code
*code
)
6774 gfc_se dst
,src
,memsz
;
6775 gfc_expr
*lhs
,*rhs
,*sz
;
6777 gfc_start_block (&block
);
6779 lhs
= gfc_copy_expr (code
->expr1
);
6780 gfc_add_data_component (lhs
);
6782 rhs
= gfc_copy_expr (code
->expr1
);
6783 gfc_add_vptr_component (rhs
);
6785 /* Make sure that the component backend_decls have been built, which
6786 will not have happened if the derived types concerned have not
6788 gfc_get_derived_type (rhs
->ts
.u
.derived
);
6789 gfc_add_def_init_component (rhs
);
6791 if (code
->expr1
->ts
.type
== BT_CLASS
6792 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
6793 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
6796 sz
= gfc_copy_expr (code
->expr1
);
6797 gfc_add_vptr_component (sz
);
6798 gfc_add_size_component (sz
);
6800 gfc_init_se (&dst
, NULL
);
6801 gfc_init_se (&src
, NULL
);
6802 gfc_init_se (&memsz
, NULL
);
6803 gfc_conv_expr (&dst
, lhs
);
6804 gfc_conv_expr (&src
, rhs
);
6805 gfc_conv_expr (&memsz
, sz
);
6806 gfc_add_block_to_block (&block
, &src
.pre
);
6807 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
6809 gfc_add_expr_to_block (&block
, tmp
);
6811 return gfc_finish_block (&block
);
6815 /* Translate an assignment to a CLASS object
6816 (pointer or ordinary assignment). */
6819 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
6826 gfc_start_block (&block
);
6828 if (expr2
->ts
.type
!= BT_CLASS
)
6830 /* Insert an additional assignment which sets the '_vptr' field. */
6831 gfc_symbol
*vtab
= NULL
;
6834 lhs
= gfc_copy_expr (expr1
);
6835 gfc_add_vptr_component (lhs
);
6837 if (expr2
->ts
.type
== BT_DERIVED
)
6838 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
6839 else if (expr2
->expr_type
== EXPR_NULL
)
6840 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
6843 rhs
= gfc_get_expr ();
6844 rhs
->expr_type
= EXPR_VARIABLE
;
6845 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
6849 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
6850 gfc_add_expr_to_block (&block
, tmp
);
6852 gfc_free_expr (lhs
);
6853 gfc_free_expr (rhs
);
6855 else if (CLASS_DATA (expr2
)->attr
.dimension
)
6857 /* Insert an additional assignment which sets the '_vptr' field. */
6858 lhs
= gfc_copy_expr (expr1
);
6859 gfc_add_vptr_component (lhs
);
6861 rhs
= gfc_copy_expr (expr2
);
6862 gfc_add_vptr_component (rhs
);
6864 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
6865 gfc_add_expr_to_block (&block
, tmp
);
6867 gfc_free_expr (lhs
);
6868 gfc_free_expr (rhs
);
6871 /* Do the actual CLASS assignment. */
6872 if (expr2
->ts
.type
== BT_CLASS
&& !CLASS_DATA (expr2
)->attr
.dimension
)
6875 gfc_add_data_component (expr1
);
6877 if (op
== EXEC_ASSIGN
)
6878 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
6879 else if (op
== EXEC_POINTER_ASSIGN
)
6880 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
6884 gfc_add_expr_to_block (&block
, tmp
);
6886 return gfc_finish_block (&block
);