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
);
306 /* Given a class array declaration and an index, returns the address
307 of the referenced element. */
310 gfc_get_class_array_ref (tree index
, tree class_decl
)
312 tree data
= gfc_class_data_get (class_decl
);
313 tree size
= gfc_vtable_size_get (class_decl
);
314 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
315 gfc_array_index_type
,
318 data
= gfc_conv_descriptor_data_get (data
);
319 ptr
= fold_convert (pvoid_type_node
, data
);
320 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
321 return fold_convert (TREE_TYPE (data
), ptr
);
325 /* Copies one class expression to another, assuming that if either
326 'to' or 'from' are arrays they are packed. Should 'from' be
327 NULL_TREE, the inialization expression for 'to' is used, assuming
328 that the _vptr is set. */
331 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
342 stmtblock_t loopbody
;
348 if (from
!= NULL_TREE
)
349 fcn
= gfc_vtable_copy_get (from
);
351 fcn
= gfc_vtable_copy_get (to
);
353 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
355 if (from
!= NULL_TREE
)
356 from_data
= gfc_class_data_get (from
);
358 from_data
= gfc_vtable_def_init_get (to
);
360 to_data
= gfc_class_data_get (to
);
362 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
364 gfc_init_block (&body
);
365 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
366 gfc_array_index_type
, nelems
,
368 nelems
= gfc_evaluate_now (tmp
, &body
);
369 index
= gfc_create_var (gfc_array_index_type
, "S");
371 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
373 from_ref
= gfc_get_class_array_ref (index
, from
);
374 VEC_safe_push (tree
, gc
, args
, from_ref
);
377 VEC_safe_push (tree
, gc
, args
, from_data
);
379 to_ref
= gfc_get_class_array_ref (index
, to
);
380 VEC_safe_push (tree
, gc
, args
, to_ref
);
382 tmp
= build_call_vec (fcn_type
, fcn
, args
);
384 /* Build the body of the loop. */
385 gfc_init_block (&loopbody
);
386 gfc_add_expr_to_block (&loopbody
, tmp
);
388 /* Build the loop and return. */
389 gfc_init_loopinfo (&loop
);
391 loop
.from
[0] = gfc_index_zero_node
;
392 loop
.loopvar
[0] = index
;
394 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
395 gfc_add_block_to_block (&body
, &loop
.pre
);
396 tmp
= gfc_finish_block (&body
);
400 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
401 VEC_safe_push (tree
, gc
, args
, from_data
);
402 VEC_safe_push (tree
, gc
, args
, to_data
);
403 tmp
= build_call_vec (fcn_type
, fcn
, args
);
410 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
412 gfc_actual_arglist
*actual
;
417 actual
= gfc_get_actual_arglist ();
418 actual
->expr
= gfc_copy_expr (rhs
);
419 actual
->next
= gfc_get_actual_arglist ();
420 actual
->next
->expr
= gfc_copy_expr (lhs
);
421 ppc
= gfc_copy_expr (obj
);
422 gfc_add_vptr_component (ppc
);
423 gfc_add_component_ref (ppc
, "_copy");
424 ppc_code
= gfc_get_code ();
425 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
426 /* Although '_copy' is set to be elemental in class.c, it is
427 not staying that way. Find out why, sometime.... */
428 ppc_code
->resolved_sym
->attr
.elemental
= 1;
429 ppc_code
->ext
.actual
= actual
;
430 ppc_code
->expr1
= ppc
;
431 ppc_code
->op
= EXEC_CALL
;
432 /* Since '_copy' is elemental, the scalarizer will take care
433 of arrays in gfc_trans_call. */
434 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
435 gfc_free_statements (ppc_code
);
439 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
440 A MEMCPY is needed to copy the full data from the default initializer
441 of the dynamic type. */
444 gfc_trans_class_init_assign (gfc_code
*code
)
448 gfc_se dst
,src
,memsz
;
449 gfc_expr
*lhs
, *rhs
, *sz
;
451 gfc_start_block (&block
);
453 lhs
= gfc_copy_expr (code
->expr1
);
454 gfc_add_data_component (lhs
);
456 rhs
= gfc_copy_expr (code
->expr1
);
457 gfc_add_vptr_component (rhs
);
459 /* Make sure that the component backend_decls have been built, which
460 will not have happened if the derived types concerned have not
462 gfc_get_derived_type (rhs
->ts
.u
.derived
);
463 gfc_add_def_init_component (rhs
);
465 if (code
->expr1
->ts
.type
== BT_CLASS
466 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
467 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
470 sz
= gfc_copy_expr (code
->expr1
);
471 gfc_add_vptr_component (sz
);
472 gfc_add_size_component (sz
);
474 gfc_init_se (&dst
, NULL
);
475 gfc_init_se (&src
, NULL
);
476 gfc_init_se (&memsz
, NULL
);
477 gfc_conv_expr (&dst
, lhs
);
478 gfc_conv_expr (&src
, rhs
);
479 gfc_conv_expr (&memsz
, sz
);
480 gfc_add_block_to_block (&block
, &src
.pre
);
481 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
483 gfc_add_expr_to_block (&block
, tmp
);
485 return gfc_finish_block (&block
);
489 /* Translate an assignment to a CLASS object
490 (pointer or ordinary assignment). */
493 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
501 gfc_start_block (&block
);
504 while (ref
&& ref
->next
)
507 /* Class valued proc_pointer assignments do not need any further
509 if (ref
&& ref
->type
== REF_COMPONENT
510 && ref
->u
.c
.component
->attr
.proc_pointer
511 && expr2
->expr_type
== EXPR_VARIABLE
512 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
513 && op
== EXEC_POINTER_ASSIGN
)
516 if (expr2
->ts
.type
!= BT_CLASS
)
518 /* Insert an additional assignment which sets the '_vptr' field. */
519 gfc_symbol
*vtab
= NULL
;
522 lhs
= gfc_copy_expr (expr1
);
523 gfc_add_vptr_component (lhs
);
525 if (expr2
->ts
.type
== BT_DERIVED
)
526 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
527 else if (expr2
->expr_type
== EXPR_NULL
)
528 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
531 rhs
= gfc_get_expr ();
532 rhs
->expr_type
= EXPR_VARIABLE
;
533 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
537 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
538 gfc_add_expr_to_block (&block
, tmp
);
543 else if (CLASS_DATA (expr2
)->attr
.dimension
)
545 /* Insert an additional assignment which sets the '_vptr' field. */
546 lhs
= gfc_copy_expr (expr1
);
547 gfc_add_vptr_component (lhs
);
549 rhs
= gfc_copy_expr (expr2
);
550 gfc_add_vptr_component (rhs
);
552 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
553 gfc_add_expr_to_block (&block
, tmp
);
559 /* Do the actual CLASS assignment. */
560 if (expr2
->ts
.type
== BT_CLASS
561 && !CLASS_DATA (expr2
)->attr
.dimension
)
564 gfc_add_data_component (expr1
);
568 if (op
== EXEC_ASSIGN
)
569 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
570 else if (op
== EXEC_POINTER_ASSIGN
)
571 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
575 gfc_add_expr_to_block (&block
, tmp
);
577 return gfc_finish_block (&block
);
581 /* End of prototype trans-class.c */
584 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
585 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
588 /* Copy the scalarization loop variables. */
591 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
594 dest
->loop
= src
->loop
;
598 /* Initialize a simple expression holder.
600 Care must be taken when multiple se are created with the same parent.
601 The child se must be kept in sync. The easiest way is to delay creation
602 of a child se until after after the previous se has been translated. */
605 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
607 memset (se
, 0, sizeof (gfc_se
));
608 gfc_init_block (&se
->pre
);
609 gfc_init_block (&se
->post
);
614 gfc_copy_se_loopvars (se
, parent
);
618 /* Advances to the next SS in the chain. Use this rather than setting
619 se->ss = se->ss->next because all the parents needs to be kept in sync.
623 gfc_advance_se_ss_chain (gfc_se
* se
)
628 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
631 /* Walk down the parent chain. */
634 /* Simple consistency check. */
635 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
636 || p
->parent
->ss
->nested_ss
== p
->ss
);
638 /* If we were in a nested loop, the next scalarized expression can be
639 on the parent ss' next pointer. Thus we should not take the next
640 pointer blindly, but rather go up one nest level as long as next
641 is the end of chain. */
643 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
653 /* Ensures the result of the expression as either a temporary variable
654 or a constant so that it can be used repeatedly. */
657 gfc_make_safe_expr (gfc_se
* se
)
661 if (CONSTANT_CLASS_P (se
->expr
))
664 /* We need a temporary for this result. */
665 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
666 gfc_add_modify (&se
->pre
, var
, se
->expr
);
671 /* Return an expression which determines if a dummy parameter is present.
672 Also used for arguments to procedures with multiple entry points. */
675 gfc_conv_expr_present (gfc_symbol
* sym
)
679 gcc_assert (sym
->attr
.dummy
);
681 decl
= gfc_get_symbol_decl (sym
);
682 if (TREE_CODE (decl
) != PARM_DECL
)
684 /* Array parameters use a temporary descriptor, we want the real
686 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
687 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
688 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
691 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
692 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
694 /* Fortran 2008 allows to pass null pointers and non-associated pointers
695 as actual argument to denote absent dummies. For array descriptors,
696 we thus also need to check the array descriptor. */
697 if (!sym
->attr
.pointer
&& !sym
->attr
.allocatable
698 && sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
699 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
702 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
703 tmp
= gfc_conv_array_data (tmp
);
704 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
705 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
706 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
707 boolean_type_node
, cond
, tmp
);
714 /* Converts a missing, dummy argument into a null or zero. */
717 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
722 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
726 /* Create a temporary and convert it to the correct type. */
727 tmp
= gfc_get_int_type (kind
);
728 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
731 /* Test for a NULL value. */
732 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
733 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
734 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
735 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
739 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
741 build_zero_cst (TREE_TYPE (se
->expr
)));
742 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
746 if (ts
.type
== BT_CHARACTER
)
748 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
749 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
750 present
, se
->string_length
, tmp
);
751 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
752 se
->string_length
= tmp
;
758 /* Get the character length of an expression, looking through gfc_refs
762 gfc_get_expr_charlen (gfc_expr
*e
)
767 gcc_assert (e
->expr_type
== EXPR_VARIABLE
768 && e
->ts
.type
== BT_CHARACTER
);
770 length
= NULL
; /* To silence compiler warning. */
772 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
775 gfc_init_se (&tmpse
, NULL
);
776 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
777 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
781 /* First candidate: if the variable is of type CHARACTER, the
782 expression's length could be the length of the character
784 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
785 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
787 /* Look through the reference chain for component references. */
788 for (r
= e
->ref
; r
; r
= r
->next
)
793 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
794 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
802 /* We should never got substring references here. These will be
803 broken down by the scalarizer. */
809 gcc_assert (length
!= NULL
);
814 /* Return for an expression the backend decl of the coarray. */
817 get_tree_for_caf_expr (gfc_expr
*expr
)
819 tree caf_decl
= NULL_TREE
;
822 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
823 if (expr
->symtree
->n
.sym
->attr
.codimension
)
824 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
826 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
827 if (ref
->type
== REF_COMPONENT
)
829 gfc_component
*comp
= ref
->u
.c
.component
;
830 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
831 caf_decl
= NULL_TREE
;
832 if (comp
->attr
.codimension
)
833 caf_decl
= comp
->backend_decl
;
836 gcc_assert (caf_decl
!= NULL_TREE
);
841 /* For each character array constructor subexpression without a ts.u.cl->length,
842 replace it by its first element (if there aren't any elements, the length
843 should already be set to zero). */
846 flatten_array_ctors_without_strlen (gfc_expr
* e
)
848 gfc_actual_arglist
* arg
;
854 switch (e
->expr_type
)
858 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
859 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
863 /* TODO: Implement as with EXPR_FUNCTION when needed. */
867 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
868 flatten_array_ctors_without_strlen (arg
->expr
);
873 /* We've found what we're looking for. */
874 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
879 gcc_assert (e
->value
.constructor
);
881 c
= gfc_constructor_first (e
->value
.constructor
);
885 flatten_array_ctors_without_strlen (new_expr
);
886 gfc_replace_expr (e
, new_expr
);
890 /* Otherwise, fall through to handle constructor elements. */
892 for (c
= gfc_constructor_first (e
->value
.constructor
);
893 c
; c
= gfc_constructor_next (c
))
894 flatten_array_ctors_without_strlen (c
->expr
);
904 /* Generate code to initialize a string length variable. Returns the
905 value. For array constructors, cl->length might be NULL and in this case,
906 the first element of the constructor is needed. expr is the original
907 expression so we can access it but can be NULL if this is not needed. */
910 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
914 gfc_init_se (&se
, NULL
);
918 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
921 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
922 "flatten" array constructors by taking their first element; all elements
923 should be the same length or a cl->length should be present. */
928 expr_flat
= gfc_copy_expr (expr
);
929 flatten_array_ctors_without_strlen (expr_flat
);
930 gfc_resolve_expr (expr_flat
);
932 gfc_conv_expr (&se
, expr_flat
);
933 gfc_add_block_to_block (pblock
, &se
.pre
);
934 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
936 gfc_free_expr (expr_flat
);
940 /* Convert cl->length. */
942 gcc_assert (cl
->length
);
944 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
945 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
946 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
947 gfc_add_block_to_block (pblock
, &se
.pre
);
949 if (cl
->backend_decl
)
950 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
952 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
957 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
958 const char *name
, locus
*where
)
967 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
968 type
= build_pointer_type (type
);
970 gfc_init_se (&start
, se
);
971 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
972 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
974 if (integer_onep (start
.expr
))
975 gfc_conv_string_parameter (se
);
980 /* Avoid multiple evaluation of substring start. */
981 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
982 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
984 /* Change the start of the string. */
985 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
988 tmp
= build_fold_indirect_ref_loc (input_location
,
990 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
991 se
->expr
= gfc_build_addr_expr (type
, tmp
);
994 /* Length = end + 1 - start. */
995 gfc_init_se (&end
, se
);
996 if (ref
->u
.ss
.end
== NULL
)
997 end
.expr
= se
->string_length
;
1000 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1001 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1005 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1006 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1008 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1010 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1011 boolean_type_node
, start
.expr
,
1014 /* Check lower bound. */
1015 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1017 build_int_cst (gfc_charlen_type_node
, 1));
1018 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1019 boolean_type_node
, nonempty
, fault
);
1021 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1022 "is less than one", name
);
1024 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1025 "is less than one");
1026 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1027 fold_convert (long_integer_type_node
,
1031 /* Check upper bound. */
1032 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1033 end
.expr
, se
->string_length
);
1034 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1035 boolean_type_node
, nonempty
, fault
);
1037 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1038 "exceeds string length (%%ld)", name
);
1040 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1041 "exceeds string length (%%ld)");
1042 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1043 fold_convert (long_integer_type_node
, end
.expr
),
1044 fold_convert (long_integer_type_node
,
1045 se
->string_length
));
1049 /* If the start and end expressions are equal, the length is one. */
1051 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
1052 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
1055 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1056 end
.expr
, start
.expr
);
1057 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1058 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1059 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1060 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1063 se
->string_length
= tmp
;
1067 /* Convert a derived type component reference. */
1070 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1077 c
= ref
->u
.c
.component
;
1079 gcc_assert (c
->backend_decl
);
1081 field
= c
->backend_decl
;
1082 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1085 /* Components can correspond to fields of different containing
1086 types, as components are created without context, whereas
1087 a concrete use of a component has the type of decl as context.
1088 So, if the type doesn't match, we search the corresponding
1089 FIELD_DECL in the parent type. To not waste too much time
1090 we cache this result in norestrict_decl. */
1092 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1094 tree f2
= c
->norestrict_decl
;
1095 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1096 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1097 if (TREE_CODE (f2
) == FIELD_DECL
1098 && DECL_NAME (f2
) == DECL_NAME (field
))
1101 c
->norestrict_decl
= f2
;
1104 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1105 decl
, field
, NULL_TREE
);
1109 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1111 tmp
= c
->ts
.u
.cl
->backend_decl
;
1112 /* Components must always be constant length. */
1113 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1114 se
->string_length
= tmp
;
1117 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1118 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1119 && c
->ts
.type
!= BT_CHARACTER
)
1120 || c
->attr
.proc_pointer
)
1121 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1126 /* This function deals with component references to components of the
1127 parent type for derived type extensons. */
1129 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1137 c
= ref
->u
.c
.component
;
1139 /* Return if the component is not in the parent type. */
1140 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1141 if (strcmp (c
->name
, cmp
->name
) == 0)
1144 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1145 parent
.type
= REF_COMPONENT
;
1147 parent
.u
.c
.sym
= dt
;
1148 parent
.u
.c
.component
= dt
->components
;
1150 if (dt
->backend_decl
== NULL
)
1151 gfc_get_derived_type (dt
);
1153 /* Build the reference and call self. */
1154 gfc_conv_component_ref (se
, &parent
);
1155 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1156 parent
.u
.c
.component
= c
;
1157 conv_parent_component_references (se
, &parent
);
1160 /* Return the contents of a variable. Also handles reference/pointer
1161 variables (all Fortran pointer references are implicit). */
1164 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1169 tree parent_decl
= NULL_TREE
;
1172 bool alternate_entry
;
1175 sym
= expr
->symtree
->n
.sym
;
1179 gfc_ss_info
*ss_info
= ss
->info
;
1181 /* Check that something hasn't gone horribly wrong. */
1182 gcc_assert (ss
!= gfc_ss_terminator
);
1183 gcc_assert (ss_info
->expr
== expr
);
1185 /* A scalarized term. We already know the descriptor. */
1186 se
->expr
= ss_info
->data
.array
.descriptor
;
1187 se
->string_length
= ss_info
->string_length
;
1188 for (ref
= ss_info
->data
.array
.ref
; ref
; ref
= ref
->next
)
1189 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1194 tree se_expr
= NULL_TREE
;
1196 se
->expr
= gfc_get_symbol_decl (sym
);
1198 /* Deal with references to a parent results or entries by storing
1199 the current_function_decl and moving to the parent_decl. */
1200 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1201 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1202 && sym
->result
== sym
;
1203 entry_master
= sym
->attr
.result
1204 && sym
->ns
->proc_name
->attr
.entry_master
1205 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1206 if (current_function_decl
)
1207 parent_decl
= DECL_CONTEXT (current_function_decl
);
1209 if ((se
->expr
== parent_decl
&& return_value
)
1210 || (sym
->ns
&& sym
->ns
->proc_name
1212 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1213 && (alternate_entry
|| entry_master
)))
1218 /* Special case for assigning the return value of a function.
1219 Self recursive functions must have an explicit return value. */
1220 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1221 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1223 /* Similarly for alternate entry points. */
1224 else if (alternate_entry
1225 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1228 gfc_entry_list
*el
= NULL
;
1230 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1233 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1238 else if (entry_master
1239 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1241 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1246 /* Procedure actual arguments. */
1247 else if (sym
->attr
.flavor
== FL_PROCEDURE
1248 && se
->expr
!= current_function_decl
)
1250 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1252 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1253 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1259 /* Dereference the expression, where needed. Since characters
1260 are entirely different from other types, they are treated
1262 if (sym
->ts
.type
== BT_CHARACTER
)
1264 /* Dereference character pointer dummy arguments
1266 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1268 || sym
->attr
.function
1269 || sym
->attr
.result
))
1270 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1274 else if (!sym
->attr
.value
)
1276 /* Dereference non-character scalar dummy arguments. */
1277 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1278 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1279 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1282 /* Dereference scalar hidden result. */
1283 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1284 && (sym
->attr
.function
|| sym
->attr
.result
)
1285 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1286 && !sym
->attr
.always_explicit
)
1287 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1290 /* Dereference non-character pointer variables.
1291 These must be dummies, results, or scalars. */
1292 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1293 || gfc_is_associate_pointer (sym
))
1295 || sym
->attr
.function
1297 || (!sym
->attr
.dimension
1298 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1299 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1306 /* For character variables, also get the length. */
1307 if (sym
->ts
.type
== BT_CHARACTER
)
1309 /* If the character length of an entry isn't set, get the length from
1310 the master function instead. */
1311 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1312 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1314 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1315 gcc_assert (se
->string_length
);
1323 /* Return the descriptor if that's what we want and this is an array
1324 section reference. */
1325 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1327 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1328 /* Return the descriptor for array pointers and allocations. */
1329 if (se
->want_pointer
1330 && ref
->next
== NULL
&& (se
->descriptor_only
))
1333 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
1334 /* Return a pointer to an element. */
1338 if (ref
->u
.c
.sym
->attr
.extension
)
1339 conv_parent_component_references (se
, ref
);
1341 gfc_conv_component_ref (se
, ref
);
1346 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1347 expr
->symtree
->name
, &expr
->where
);
1356 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1358 if (se
->want_pointer
)
1360 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
1361 gfc_conv_string_parameter (se
);
1363 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1368 /* Unary ops are easy... Or they would be if ! was a valid op. */
1371 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1376 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1377 /* Initialize the operand. */
1378 gfc_init_se (&operand
, se
);
1379 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1380 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1382 type
= gfc_typenode_for_spec (&expr
->ts
);
1384 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1385 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1386 All other unary operators have an equivalent GIMPLE unary operator. */
1387 if (code
== TRUTH_NOT_EXPR
)
1388 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1389 build_int_cst (type
, 0));
1391 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1395 /* Expand power operator to optimal multiplications when a value is raised
1396 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1397 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1398 Programming", 3rd Edition, 1998. */
1400 /* This code is mostly duplicated from expand_powi in the backend.
1401 We establish the "optimal power tree" lookup table with the defined size.
1402 The items in the table are the exponents used to calculate the index
1403 exponents. Any integer n less than the value can get an "addition chain",
1404 with the first node being one. */
1405 #define POWI_TABLE_SIZE 256
1407 /* The table is from builtins.c. */
1408 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1410 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1411 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1412 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1413 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1414 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1415 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1416 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1417 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1418 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1419 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1420 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1421 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1422 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1423 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1424 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1425 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1426 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1427 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1428 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1429 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1430 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1431 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1432 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1433 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1434 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1435 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1436 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1437 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1438 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1439 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1440 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1441 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1444 /* If n is larger than lookup table's max index, we use the "window
1446 #define POWI_WINDOW_SIZE 3
1448 /* Recursive function to expand the power operator. The temporary
1449 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1451 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
1458 if (n
< POWI_TABLE_SIZE
)
1463 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
1464 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
1468 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
1469 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
1470 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
1474 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
1478 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
1479 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1481 if (n
< POWI_TABLE_SIZE
)
1488 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1489 return 1. Else return 0 and a call to runtime library functions
1490 will have to be built. */
1492 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
1497 tree vartmp
[POWI_TABLE_SIZE
];
1499 unsigned HOST_WIDE_INT n
;
1502 /* If exponent is too large, we won't expand it anyway, so don't bother
1503 with large integer values. */
1504 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
1507 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
1508 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1509 of the asymmetric range of the integer type. */
1510 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
1512 type
= TREE_TYPE (lhs
);
1513 sgn
= tree_int_cst_sgn (rhs
);
1515 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
1516 || optimize_size
) && (m
> 2 || m
< -1))
1522 se
->expr
= gfc_build_const (type
, integer_one_node
);
1526 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1527 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
1529 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1530 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
1531 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1532 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
1535 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1538 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1539 boolean_type_node
, tmp
, cond
);
1540 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1541 tmp
, build_int_cst (type
, 1),
1542 build_int_cst (type
, 0));
1546 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1547 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
1548 build_int_cst (type
, -1),
1549 build_int_cst (type
, 0));
1550 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1551 cond
, build_int_cst (type
, 1), tmp
);
1555 memset (vartmp
, 0, sizeof (vartmp
));
1559 tmp
= gfc_build_const (type
, integer_one_node
);
1560 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
1564 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
1570 /* Power op (**). Constant integer exponent has special handling. */
1573 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
1575 tree gfc_int4_type_node
;
1578 int res_ikind_1
, res_ikind_2
;
1583 gfc_init_se (&lse
, se
);
1584 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
1585 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
1586 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1588 gfc_init_se (&rse
, se
);
1589 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
1590 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1592 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
1593 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
1594 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
1597 gfc_int4_type_node
= gfc_get_int_type (4);
1599 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1600 library routine. But in the end, we have to convert the result back
1601 if this case applies -- with res_ikind_K, we keep track whether operand K
1602 falls into this case. */
1606 kind
= expr
->value
.op
.op1
->ts
.kind
;
1607 switch (expr
->value
.op
.op2
->ts
.type
)
1610 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1615 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1616 res_ikind_2
= ikind
;
1638 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
1640 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1667 switch (expr
->value
.op
.op1
->ts
.type
)
1670 if (kind
== 3) /* Case 16 was not handled properly above. */
1672 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1676 /* Use builtins for real ** int4. */
1682 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
1686 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
1690 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
1694 /* Use the __builtin_powil() only if real(kind=16) is
1695 actually the C long double type. */
1696 if (!gfc_real16_is_float128
)
1697 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
1705 /* If we don't have a good builtin for this, go for the
1706 library function. */
1708 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1712 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1721 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
1725 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
1733 se
->expr
= build_call_expr_loc (input_location
,
1734 fndecl
, 2, lse
.expr
, rse
.expr
);
1736 /* Convert the result back if it is of wrong integer kind. */
1737 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
1739 /* We want the maximum of both operand kinds as result. */
1740 if (res_ikind_1
< res_ikind_2
)
1741 res_ikind_1
= res_ikind_2
;
1742 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
1747 /* Generate code to allocate a string temporary. */
1750 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1755 if (gfc_can_put_var_on_stack (len
))
1757 /* Create a temporary variable to hold the result. */
1758 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1759 gfc_charlen_type_node
, len
,
1760 build_int_cst (gfc_charlen_type_node
, 1));
1761 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1763 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1764 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1766 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1768 var
= gfc_create_var (tmp
, "str");
1769 var
= gfc_build_addr_expr (type
, var
);
1773 /* Allocate a temporary to hold the result. */
1774 var
= gfc_create_var (type
, "pstr");
1775 tmp
= gfc_call_malloc (&se
->pre
, type
,
1776 fold_build2_loc (input_location
, MULT_EXPR
,
1777 TREE_TYPE (len
), len
,
1778 fold_convert (TREE_TYPE (len
),
1779 TYPE_SIZE (type
))));
1780 gfc_add_modify (&se
->pre
, var
, tmp
);
1782 /* Free the temporary afterwards. */
1783 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1784 gfc_add_expr_to_block (&se
->post
, tmp
);
1791 /* Handle a string concatenation operation. A temporary will be allocated to
1795 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1798 tree len
, type
, var
, tmp
, fndecl
;
1800 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1801 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1802 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1804 gfc_init_se (&lse
, se
);
1805 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1806 gfc_conv_string_parameter (&lse
);
1807 gfc_init_se (&rse
, se
);
1808 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1809 gfc_conv_string_parameter (&rse
);
1811 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1812 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1814 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1815 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1816 if (len
== NULL_TREE
)
1818 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
1819 TREE_TYPE (lse
.string_length
),
1820 lse
.string_length
, rse
.string_length
);
1823 type
= build_pointer_type (type
);
1825 var
= gfc_conv_string_tmp (se
, type
, len
);
1827 /* Do the actual concatenation. */
1828 if (expr
->ts
.kind
== 1)
1829 fndecl
= gfor_fndecl_concat_string
;
1830 else if (expr
->ts
.kind
== 4)
1831 fndecl
= gfor_fndecl_concat_string_char4
;
1835 tmp
= build_call_expr_loc (input_location
,
1836 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1837 rse
.string_length
, rse
.expr
);
1838 gfc_add_expr_to_block (&se
->pre
, tmp
);
1840 /* Add the cleanup for the operands. */
1841 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1842 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1845 se
->string_length
= len
;
1848 /* Translates an op expression. Common (binary) cases are handled by this
1849 function, others are passed on. Recursion is used in either case.
1850 We use the fact that (op1.ts == op2.ts) (except for the power
1852 Operators need no special handling for scalarized expressions as long as
1853 they call gfc_conv_simple_val to get their operands.
1854 Character strings get special handling. */
1857 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1859 enum tree_code code
;
1868 switch (expr
->value
.op
.op
)
1870 case INTRINSIC_PARENTHESES
:
1871 if ((expr
->ts
.type
== BT_REAL
1872 || expr
->ts
.type
== BT_COMPLEX
)
1873 && gfc_option
.flag_protect_parens
)
1875 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1876 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1881 case INTRINSIC_UPLUS
:
1882 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1885 case INTRINSIC_UMINUS
:
1886 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1890 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1893 case INTRINSIC_PLUS
:
1897 case INTRINSIC_MINUS
:
1901 case INTRINSIC_TIMES
:
1905 case INTRINSIC_DIVIDE
:
1906 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1907 an integer, we must round towards zero, so we use a
1909 if (expr
->ts
.type
== BT_INTEGER
)
1910 code
= TRUNC_DIV_EXPR
;
1915 case INTRINSIC_POWER
:
1916 gfc_conv_power_op (se
, expr
);
1919 case INTRINSIC_CONCAT
:
1920 gfc_conv_concat_op (se
, expr
);
1924 code
= TRUTH_ANDIF_EXPR
;
1929 code
= TRUTH_ORIF_EXPR
;
1933 /* EQV and NEQV only work on logicals, but since we represent them
1934 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1936 case INTRINSIC_EQ_OS
:
1944 case INTRINSIC_NE_OS
:
1945 case INTRINSIC_NEQV
:
1952 case INTRINSIC_GT_OS
:
1959 case INTRINSIC_GE_OS
:
1966 case INTRINSIC_LT_OS
:
1973 case INTRINSIC_LE_OS
:
1979 case INTRINSIC_USER
:
1980 case INTRINSIC_ASSIGN
:
1981 /* These should be converted into function calls by the frontend. */
1985 fatal_error ("Unknown intrinsic op");
1989 /* The only exception to this is **, which is handled separately anyway. */
1990 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1992 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1996 gfc_init_se (&lse
, se
);
1997 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1998 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2001 gfc_init_se (&rse
, se
);
2002 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2003 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2007 gfc_conv_string_parameter (&lse
);
2008 gfc_conv_string_parameter (&rse
);
2010 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2011 rse
.string_length
, rse
.expr
,
2012 expr
->value
.op
.op1
->ts
.kind
,
2014 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2015 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2018 type
= gfc_typenode_for_spec (&expr
->ts
);
2022 /* The result of logical ops is always boolean_type_node. */
2023 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2024 lse
.expr
, rse
.expr
);
2025 se
->expr
= convert (type
, tmp
);
2028 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2030 /* Add the post blocks. */
2031 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2032 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2035 /* If a string's length is one, we convert it to a single character. */
2038 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2041 if (!INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2042 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2045 if (TREE_INT_CST_LOW (len
) == 1)
2047 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2048 return build_fold_indirect_ref_loc (input_location
, str
);
2052 && TREE_CODE (str
) == ADDR_EXPR
2053 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2054 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2055 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2056 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2057 && TREE_INT_CST_LOW (len
) > 1
2058 && TREE_INT_CST_LOW (len
)
2059 == (unsigned HOST_WIDE_INT
)
2060 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2062 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2063 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2064 if (TREE_CODE (ret
) == INTEGER_CST
)
2066 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2067 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2068 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2070 for (i
= 1; i
< length
; i
++)
2083 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2086 if (sym
->backend_decl
)
2088 /* This becomes the nominal_type in
2089 function.c:assign_parm_find_data_types. */
2090 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2091 /* This becomes the passed_type in
2092 function.c:assign_parm_find_data_types. C promotes char to
2093 integer for argument passing. */
2094 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2096 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2101 /* If we have a constant character expression, make it into an
2103 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2108 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2109 (int)(*expr
)->value
.character
.string
[0]);
2110 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2112 /* The expr needs to be compatible with a C int. If the
2113 conversion fails, then the 2 causes an ICE. */
2114 ts
.type
= BT_INTEGER
;
2115 ts
.kind
= gfc_c_int_kind
;
2116 gfc_convert_type (*expr
, &ts
, 2);
2119 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2121 if ((*expr
)->ref
== NULL
)
2123 se
->expr
= gfc_string_to_single_character
2124 (build_int_cst (integer_type_node
, 1),
2125 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2127 ((*expr
)->symtree
->n
.sym
)),
2132 gfc_conv_variable (se
, *expr
);
2133 se
->expr
= gfc_string_to_single_character
2134 (build_int_cst (integer_type_node
, 1),
2135 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2143 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2144 if STR is a string literal, otherwise return -1. */
2147 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2150 && TREE_CODE (str
) == ADDR_EXPR
2151 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2152 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2153 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2154 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2155 && TREE_INT_CST_LOW (len
) >= 1
2156 && TREE_INT_CST_LOW (len
)
2157 == (unsigned HOST_WIDE_INT
)
2158 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2160 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2161 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2162 if (TREE_CODE (folded
) == INTEGER_CST
)
2164 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2165 int length
= TREE_STRING_LENGTH (string_cst
);
2166 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2168 for (; length
> 0; length
--)
2169 if (ptr
[length
- 1] != ' ')
2178 /* Compare two strings. If they are all single characters, the result is the
2179 subtraction of them. Otherwise, we build a library call. */
2182 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2183 enum tree_code code
)
2189 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2190 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2192 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2193 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2195 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2197 /* Deal with single character specially. */
2198 sc1
= fold_convert (integer_type_node
, sc1
);
2199 sc2
= fold_convert (integer_type_node
, sc2
);
2200 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2204 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2206 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2208 /* If one string is a string literal with LEN_TRIM longer
2209 than the length of the second string, the strings
2211 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2212 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2213 return integer_one_node
;
2214 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2215 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2216 return integer_one_node
;
2219 /* Build a call for the comparison. */
2221 fndecl
= gfor_fndecl_compare_string
;
2223 fndecl
= gfor_fndecl_compare_string_char4
;
2227 return build_call_expr_loc (input_location
, fndecl
, 4,
2228 len1
, str1
, len2
, str2
);
2232 /* Return the backend_decl for a procedure pointer component. */
2235 get_proc_ptr_comp (gfc_expr
*e
)
2241 gfc_init_se (&comp_se
, NULL
);
2242 e2
= gfc_copy_expr (e
);
2243 /* We have to restore the expr type later so that gfc_free_expr frees
2244 the exact same thing that was allocated.
2245 TODO: This is ugly. */
2246 old_type
= e2
->expr_type
;
2247 e2
->expr_type
= EXPR_VARIABLE
;
2248 gfc_conv_expr (&comp_se
, e2
);
2249 e2
->expr_type
= old_type
;
2251 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2255 /* Convert a typebound function reference from a class object. */
2257 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2262 if (TREE_CODE (base_object
) != VAR_DECL
)
2264 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2265 gfc_add_modify (&se
->pre
, var
, base_object
);
2267 se
->expr
= gfc_class_vptr_get (base_object
);
2268 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2270 while (ref
&& ref
->next
)
2272 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2273 if (ref
->u
.c
.sym
->attr
.extension
)
2274 conv_parent_component_references (se
, ref
);
2275 gfc_conv_component_ref (se
, ref
);
2276 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2281 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2285 if (gfc_is_proc_ptr_comp (expr
, NULL
))
2286 tmp
= get_proc_ptr_comp (expr
);
2287 else if (sym
->attr
.dummy
)
2289 tmp
= gfc_get_symbol_decl (sym
);
2290 if (sym
->attr
.proc_pointer
)
2291 tmp
= build_fold_indirect_ref_loc (input_location
,
2293 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2294 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2298 if (!sym
->backend_decl
)
2299 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2301 tmp
= sym
->backend_decl
;
2303 if (sym
->attr
.cray_pointee
)
2305 /* TODO - make the cray pointee a pointer to a procedure,
2306 assign the pointer to it and use it for the call. This
2308 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2309 gfc_get_symbol_decl (sym
->cp_pointer
));
2310 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2313 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2315 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2316 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2323 /* Initialize MAPPING. */
2326 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2328 mapping
->syms
= NULL
;
2329 mapping
->charlens
= NULL
;
2333 /* Free all memory held by MAPPING (but not MAPPING itself). */
2336 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2338 gfc_interface_sym_mapping
*sym
;
2339 gfc_interface_sym_mapping
*nextsym
;
2341 gfc_charlen
*nextcl
;
2343 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2345 nextsym
= sym
->next
;
2346 sym
->new_sym
->n
.sym
->formal
= NULL
;
2347 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2348 gfc_free_expr (sym
->expr
);
2349 free (sym
->new_sym
);
2352 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2355 gfc_free_expr (cl
->length
);
2361 /* Return a copy of gfc_charlen CL. Add the returned structure to
2362 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2364 static gfc_charlen
*
2365 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
2368 gfc_charlen
*new_charlen
;
2370 new_charlen
= gfc_get_charlen ();
2371 new_charlen
->next
= mapping
->charlens
;
2372 new_charlen
->length
= gfc_copy_expr (cl
->length
);
2374 mapping
->charlens
= new_charlen
;
2379 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2380 array variable that can be used as the actual argument for dummy
2381 argument SYM. Add any initialization code to BLOCK. PACKED is as
2382 for gfc_get_nodesc_array_type and DATA points to the first element
2383 in the passed array. */
2386 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
2387 gfc_packed packed
, tree data
)
2392 type
= gfc_typenode_for_spec (&sym
->ts
);
2393 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
2394 !sym
->attr
.target
&& !sym
->attr
.pointer
2395 && !sym
->attr
.proc_pointer
);
2397 var
= gfc_create_var (type
, "ifm");
2398 gfc_add_modify (block
, var
, fold_convert (type
, data
));
2404 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2405 and offset of descriptorless array type TYPE given that it has the same
2406 size as DESC. Add any set-up code to BLOCK. */
2409 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
2416 offset
= gfc_index_zero_node
;
2417 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
2419 dim
= gfc_rank_cst
[n
];
2420 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
2421 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
2423 GFC_TYPE_ARRAY_LBOUND (type
, n
)
2424 = gfc_conv_descriptor_lbound_get (desc
, dim
);
2425 GFC_TYPE_ARRAY_UBOUND (type
, n
)
2426 = gfc_conv_descriptor_ubound_get (desc
, dim
);
2428 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
2430 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2431 gfc_array_index_type
,
2432 gfc_conv_descriptor_ubound_get (desc
, dim
),
2433 gfc_conv_descriptor_lbound_get (desc
, dim
));
2434 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2435 gfc_array_index_type
,
2436 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
2437 tmp
= gfc_evaluate_now (tmp
, block
);
2438 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
2440 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2441 GFC_TYPE_ARRAY_LBOUND (type
, n
),
2442 GFC_TYPE_ARRAY_STRIDE (type
, n
));
2443 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2444 gfc_array_index_type
, offset
, tmp
);
2446 offset
= gfc_evaluate_now (offset
, block
);
2447 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
2451 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2452 in SE. The caller may still use se->expr and se->string_length after
2453 calling this function. */
2456 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
2457 gfc_symbol
* sym
, gfc_se
* se
,
2460 gfc_interface_sym_mapping
*sm
;
2464 gfc_symbol
*new_sym
;
2466 gfc_symtree
*new_symtree
;
2468 /* Create a new symbol to represent the actual argument. */
2469 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
2470 new_sym
->ts
= sym
->ts
;
2471 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
2472 new_sym
->attr
.referenced
= 1;
2473 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
2474 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
2475 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
2476 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
2477 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
2478 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
2479 new_sym
->attr
.function
= sym
->attr
.function
;
2481 /* Ensure that the interface is available and that
2482 descriptors are passed for array actual arguments. */
2483 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2485 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
2486 new_sym
->attr
.always_explicit
2487 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
2490 /* Create a fake symtree for it. */
2492 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
2493 new_symtree
->n
.sym
= new_sym
;
2494 gcc_assert (new_symtree
== root
);
2496 /* Create a dummy->actual mapping. */
2497 sm
= XCNEW (gfc_interface_sym_mapping
);
2498 sm
->next
= mapping
->syms
;
2500 sm
->new_sym
= new_symtree
;
2501 sm
->expr
= gfc_copy_expr (expr
);
2504 /* Stabilize the argument's value. */
2505 if (!sym
->attr
.function
&& se
)
2506 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2508 if (sym
->ts
.type
== BT_CHARACTER
)
2510 /* Create a copy of the dummy argument's length. */
2511 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
2512 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
2514 /* If the length is specified as "*", record the length that
2515 the caller is passing. We should use the callee's length
2516 in all other cases. */
2517 if (!new_sym
->ts
.u
.cl
->length
&& se
)
2519 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
2520 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
2527 /* Use the passed value as-is if the argument is a function. */
2528 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2531 /* If the argument is either a string or a pointer to a string,
2532 convert it to a boundless character type. */
2533 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
2535 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
2536 tmp
= build_pointer_type (tmp
);
2537 if (sym
->attr
.pointer
)
2538 value
= build_fold_indirect_ref_loc (input_location
,
2542 value
= fold_convert (tmp
, value
);
2545 /* If the argument is a scalar, a pointer to an array or an allocatable,
2547 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2548 value
= build_fold_indirect_ref_loc (input_location
,
2551 /* For character(*), use the actual argument's descriptor. */
2552 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
2553 value
= build_fold_indirect_ref_loc (input_location
,
2556 /* If the argument is an array descriptor, use it to determine
2557 information about the actual argument's shape. */
2558 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
2559 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
2561 /* Get the actual argument's descriptor. */
2562 desc
= build_fold_indirect_ref_loc (input_location
,
2565 /* Create the replacement variable. */
2566 tmp
= gfc_conv_descriptor_data_get (desc
);
2567 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2570 /* Use DESC to work out the upper bounds, strides and offset. */
2571 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
2574 /* Otherwise we have a packed array. */
2575 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2576 PACKED_FULL
, se
->expr
);
2578 new_sym
->backend_decl
= value
;
2582 /* Called once all dummy argument mappings have been added to MAPPING,
2583 but before the mapping is used to evaluate expressions. Pre-evaluate
2584 the length of each argument, adding any initialization code to PRE and
2585 any finalization code to POST. */
2588 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
2589 stmtblock_t
* pre
, stmtblock_t
* post
)
2591 gfc_interface_sym_mapping
*sym
;
2595 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2596 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
2597 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
2599 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
2600 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2601 gfc_init_se (&se
, NULL
);
2602 gfc_conv_expr (&se
, expr
);
2603 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
2604 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
2605 gfc_add_block_to_block (pre
, &se
.pre
);
2606 gfc_add_block_to_block (post
, &se
.post
);
2608 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
2613 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2617 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
2618 gfc_constructor_base base
)
2621 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2623 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
2626 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
2627 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
2628 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2634 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2638 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2643 for (; ref
; ref
= ref
->next
)
2647 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2649 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2650 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2651 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2653 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2660 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2661 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2667 /* Convert intrinsic function calls into result expressions. */
2670 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2678 arg1
= expr
->value
.function
.actual
->expr
;
2679 if (expr
->value
.function
.actual
->next
)
2680 arg2
= expr
->value
.function
.actual
->next
->expr
;
2684 sym
= arg1
->symtree
->n
.sym
;
2686 if (sym
->attr
.dummy
)
2691 switch (expr
->value
.function
.isym
->id
)
2694 /* TODO figure out why this condition is necessary. */
2695 if (sym
->attr
.function
2696 && (arg1
->ts
.u
.cl
->length
== NULL
2697 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2698 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2701 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2705 if (!sym
->as
|| sym
->as
->rank
== 0)
2708 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2710 dup
= mpz_get_si (arg2
->value
.integer
);
2715 dup
= sym
->as
->rank
;
2719 for (; d
< dup
; d
++)
2723 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2725 gfc_free_expr (new_expr
);
2729 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
2730 gfc_get_int_expr (gfc_default_integer_kind
,
2732 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2734 new_expr
= gfc_multiply (new_expr
, tmp
);
2740 case GFC_ISYM_LBOUND
:
2741 case GFC_ISYM_UBOUND
:
2742 /* TODO These implementations of lbound and ubound do not limit if
2743 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2745 if (!sym
->as
|| sym
->as
->rank
== 0)
2748 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2749 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2751 /* TODO: If the need arises, this could produce an array of
2755 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2757 if (sym
->as
->lower
[d
])
2758 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2762 if (sym
->as
->upper
[d
])
2763 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2771 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2775 gfc_replace_expr (expr
, new_expr
);
2781 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2782 gfc_interface_mapping
* mapping
)
2784 gfc_formal_arglist
*f
;
2785 gfc_actual_arglist
*actual
;
2787 actual
= expr
->value
.function
.actual
;
2788 f
= map_expr
->symtree
->n
.sym
->formal
;
2790 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2795 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2798 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2803 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2805 for (d
= 0; d
< as
->rank
; d
++)
2807 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2808 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2811 expr
->value
.function
.esym
->as
= as
;
2814 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2816 expr
->value
.function
.esym
->ts
.u
.cl
->length
2817 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2819 gfc_apply_interface_mapping_to_expr (mapping
,
2820 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2825 /* EXPR is a copy of an expression that appeared in the interface
2826 associated with MAPPING. Walk it recursively looking for references to
2827 dummy arguments that MAPPING maps to actual arguments. Replace each such
2828 reference with a reference to the associated actual argument. */
2831 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2834 gfc_interface_sym_mapping
*sym
;
2835 gfc_actual_arglist
*actual
;
2840 /* Copying an expression does not copy its length, so do that here. */
2841 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2843 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2844 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2847 /* Apply the mapping to any references. */
2848 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2850 /* ...and to the expression's symbol, if it has one. */
2851 /* TODO Find out why the condition on expr->symtree had to be moved into
2852 the loop rather than being outside it, as originally. */
2853 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2854 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2856 if (sym
->new_sym
->n
.sym
->backend_decl
)
2857 expr
->symtree
= sym
->new_sym
;
2859 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2860 /* Replace base type for polymorphic arguments. */
2861 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
2862 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
2863 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
2866 /* ...and to subexpressions in expr->value. */
2867 switch (expr
->expr_type
)
2872 case EXPR_SUBSTRING
:
2876 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2877 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2881 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2882 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2884 if (expr
->value
.function
.esym
== NULL
2885 && expr
->value
.function
.isym
!= NULL
2886 && expr
->value
.function
.actual
->expr
->symtree
2887 && gfc_map_intrinsic_function (expr
, mapping
))
2890 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2891 if (sym
->old
== expr
->value
.function
.esym
)
2893 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2894 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2895 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2900 case EXPR_STRUCTURE
:
2901 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2914 /* Evaluate interface expression EXPR using MAPPING. Store the result
2918 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2919 gfc_se
* se
, gfc_expr
* expr
)
2921 expr
= gfc_copy_expr (expr
);
2922 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2923 gfc_conv_expr (se
, expr
);
2924 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2925 gfc_free_expr (expr
);
2929 /* Returns a reference to a temporary array into which a component of
2930 an actual argument derived type array is copied and then returned
2931 after the function call. */
2933 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2934 sym_intent intent
, bool formal_ptr
)
2942 gfc_array_info
*info
;
2952 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2954 gfc_init_se (&lse
, NULL
);
2955 gfc_init_se (&rse
, NULL
);
2957 /* Walk the argument expression. */
2958 rss
= gfc_walk_expr (expr
);
2960 gcc_assert (rss
!= gfc_ss_terminator
);
2962 /* Initialize the scalarizer. */
2963 gfc_init_loopinfo (&loop
);
2964 gfc_add_ss_to_loop (&loop
, rss
);
2966 /* Calculate the bounds of the scalarization. */
2967 gfc_conv_ss_startstride (&loop
);
2969 /* Build an ss for the temporary. */
2970 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2971 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2973 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2974 if (GFC_ARRAY_TYPE_P (base_type
)
2975 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2976 base_type
= gfc_get_element_type (base_type
);
2978 if (expr
->ts
.type
== BT_CLASS
)
2979 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
2981 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
2982 ? expr
->ts
.u
.cl
->backend_decl
2986 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
2988 /* Associate the SS with the loop. */
2989 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2991 /* Setup the scalarizing loops. */
2992 gfc_conv_loop_setup (&loop
, &expr
->where
);
2994 /* Pass the temporary descriptor back to the caller. */
2995 info
= &loop
.temp_ss
->info
->data
.array
;
2996 parmse
->expr
= info
->descriptor
;
2998 /* Setup the gfc_se structures. */
2999 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3000 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3003 lse
.ss
= loop
.temp_ss
;
3004 gfc_mark_ss_chain_used (rss
, 1);
3005 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3007 /* Start the scalarized loop body. */
3008 gfc_start_scalarized_body (&loop
, &body
);
3010 /* Translate the expression. */
3011 gfc_conv_expr (&rse
, expr
);
3013 gfc_conv_tmp_array_ref (&lse
);
3015 if (intent
!= INTENT_OUT
)
3017 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3018 gfc_add_expr_to_block (&body
, tmp
);
3019 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3020 gfc_trans_scalarizing_loops (&loop
, &body
);
3024 /* Make sure that the temporary declaration survives by merging
3025 all the loop declarations into the current context. */
3026 for (n
= 0; n
< loop
.dimen
; n
++)
3028 gfc_merge_block_scope (&body
);
3029 body
= loop
.code
[loop
.order
[n
]];
3031 gfc_merge_block_scope (&body
);
3034 /* Add the post block after the second loop, so that any
3035 freeing of allocated memory is done at the right time. */
3036 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3038 /**********Copy the temporary back again.*********/
3040 gfc_init_se (&lse
, NULL
);
3041 gfc_init_se (&rse
, NULL
);
3043 /* Walk the argument expression. */
3044 lss
= gfc_walk_expr (expr
);
3045 rse
.ss
= loop
.temp_ss
;
3048 /* Initialize the scalarizer. */
3049 gfc_init_loopinfo (&loop2
);
3050 gfc_add_ss_to_loop (&loop2
, lss
);
3052 /* Calculate the bounds of the scalarization. */
3053 gfc_conv_ss_startstride (&loop2
);
3055 /* Setup the scalarizing loops. */
3056 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3058 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3059 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3061 gfc_mark_ss_chain_used (lss
, 1);
3062 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3064 /* Declare the variable to hold the temporary offset and start the
3065 scalarized loop body. */
3066 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3067 gfc_start_scalarized_body (&loop2
, &body
);
3069 /* Build the offsets for the temporary from the loop variables. The
3070 temporary array has lbounds of zero and strides of one in all
3071 dimensions, so this is very simple. The offset is only computed
3072 outside the innermost loop, so the overall transfer could be
3073 optimized further. */
3074 info
= &rse
.ss
->info
->data
.array
;
3075 dimen
= rse
.ss
->dimen
;
3077 tmp_index
= gfc_index_zero_node
;
3078 for (n
= dimen
- 1; n
> 0; n
--)
3081 tmp
= rse
.loop
->loopvar
[n
];
3082 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3083 tmp
, rse
.loop
->from
[n
]);
3084 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3087 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3088 gfc_array_index_type
,
3089 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3090 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3091 gfc_array_index_type
,
3092 tmp_str
, gfc_index_one_node
);
3094 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3095 gfc_array_index_type
, tmp
, tmp_str
);
3098 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3099 gfc_array_index_type
,
3100 tmp_index
, rse
.loop
->from
[0]);
3101 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3103 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3104 gfc_array_index_type
,
3105 rse
.loop
->loopvar
[0], offset
);
3107 /* Now use the offset for the reference. */
3108 tmp
= build_fold_indirect_ref_loc (input_location
,
3110 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3112 if (expr
->ts
.type
== BT_CHARACTER
)
3113 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3115 gfc_conv_expr (&lse
, expr
);
3117 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3119 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3120 gfc_add_expr_to_block (&body
, tmp
);
3122 /* Generate the copying loops. */
3123 gfc_trans_scalarizing_loops (&loop2
, &body
);
3125 /* Wrap the whole thing up by adding the second loop to the post-block
3126 and following it by the post-block of the first loop. In this way,
3127 if the temporary needs freeing, it is done after use! */
3128 if (intent
!= INTENT_IN
)
3130 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3131 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3134 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3136 gfc_cleanup_loop (&loop
);
3137 gfc_cleanup_loop (&loop2
);
3139 /* Pass the string length to the argument expression. */
3140 if (expr
->ts
.type
== BT_CHARACTER
)
3141 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3143 /* Determine the offset for pointer formal arguments and set the
3147 size
= gfc_index_one_node
;
3148 offset
= gfc_index_zero_node
;
3149 for (n
= 0; n
< dimen
; n
++)
3151 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3153 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3154 gfc_array_index_type
, tmp
,
3155 gfc_index_one_node
);
3156 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3160 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3163 gfc_index_one_node
);
3164 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3165 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3166 gfc_array_index_type
,
3168 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3170 gfc_array_index_type
,
3171 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3172 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3173 gfc_array_index_type
,
3174 tmp
, gfc_index_one_node
);
3175 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3176 gfc_array_index_type
, size
, tmp
);
3179 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3183 /* We want either the address for the data or the address of the descriptor,
3184 depending on the mode of passing array arguments. */
3186 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3188 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3194 /* Generate the code for argument list functions. */
3197 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3199 /* Pass by value for g77 %VAL(arg), pass the address
3200 indirectly for %LOC, else by reference. Thus %REF
3201 is a "do-nothing" and %LOC is the same as an F95
3203 if (strncmp (name
, "%VAL", 4) == 0)
3204 gfc_conv_expr (se
, expr
);
3205 else if (strncmp (name
, "%LOC", 4) == 0)
3207 gfc_conv_expr_reference (se
, expr
);
3208 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3210 else if (strncmp (name
, "%REF", 4) == 0)
3211 gfc_conv_expr_reference (se
, expr
);
3213 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3217 /* The following routine generates code for the intrinsic
3218 procedures from the ISO_C_BINDING module:
3220 * C_FUNLOC (function)
3221 * C_F_POINTER (subroutine)
3222 * C_F_PROCPOINTER (subroutine)
3223 * C_ASSOCIATED (function)
3224 One exception which is not handled here is C_F_POINTER with non-scalar
3225 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3228 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
3229 gfc_actual_arglist
* arg
)
3234 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
3236 if (arg
->expr
->rank
== 0)
3237 gfc_conv_expr_reference (se
, arg
->expr
);
3241 /* This is really the actual arg because no formal arglist is
3242 created for C_LOC. */
3243 fsym
= arg
->expr
->symtree
->n
.sym
;
3245 /* We should want it to do g77 calling convention. */
3247 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3248 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3249 f
= f
|| !sym
->attr
.always_explicit
;
3251 argss
= gfc_walk_expr (arg
->expr
);
3252 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
3256 /* TODO -- the following two lines shouldn't be necessary, but if
3257 they're removed, a bug is exposed later in the code path.
3258 This workaround was thus introduced, but will have to be
3259 removed; please see PR 35150 for details about the issue. */
3260 se
->expr
= convert (pvoid_type_node
, se
->expr
);
3261 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3265 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3267 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
3268 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
3269 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
3270 gfc_conv_expr_reference (se
, arg
->expr
);
3274 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
3275 && arg
->next
->expr
->rank
== 0)
3276 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3278 /* Convert c_f_pointer if fptr is a scalar
3279 and convert c_f_procpointer. */
3283 gfc_init_se (&cptrse
, NULL
);
3284 gfc_conv_expr (&cptrse
, arg
->expr
);
3285 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
3286 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
3288 gfc_init_se (&fptrse
, NULL
);
3289 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
3290 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
3291 fptrse
.want_pointer
= 1;
3293 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
3294 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
3295 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
3297 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3298 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
3299 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
3302 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3303 TREE_TYPE (fptrse
.expr
),
3305 fold_convert (TREE_TYPE (fptrse
.expr
),
3310 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3315 /* Build the addr_expr for the first argument. The argument is
3316 already an *address* so we don't need to set want_pointer in
3318 gfc_init_se (&arg1se
, NULL
);
3319 gfc_conv_expr (&arg1se
, arg
->expr
);
3320 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3321 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3323 /* See if we were given two arguments. */
3324 if (arg
->next
== NULL
)
3325 /* Only given one arg so generate a null and do a
3326 not-equal comparison against the first arg. */
3327 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3329 fold_convert (TREE_TYPE (arg1se
.expr
),
3330 null_pointer_node
));
3336 /* Given two arguments so build the arg2se from second arg. */
3337 gfc_init_se (&arg2se
, NULL
);
3338 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
3339 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3340 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3342 /* Generate test to compare that the two args are equal. */
3343 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3344 arg1se
.expr
, arg2se
.expr
);
3345 /* Generate test to ensure that the first arg is not null. */
3346 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
3348 arg1se
.expr
, null_pointer_node
);
3350 /* Finally, the generated test must check that both arg1 is not
3351 NULL and that it is equal to the second arg. */
3352 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3354 not_null_expr
, eq_expr
);
3360 /* Nothing was done. */
3365 /* Generate code for a procedure call. Note can return se->post != NULL.
3366 If se->direct_byref is set then se->expr contains the return parameter.
3367 Return nonzero, if the call has alternate specifiers.
3368 'expr' is only needed for procedure pointer components. */
3371 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3372 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3373 VEC(tree
,gc
) *append_args
)
3375 gfc_interface_mapping mapping
;
3376 VEC(tree
,gc
) *arglist
;
3377 VEC(tree
,gc
) *retargs
;
3382 gfc_array_info
*info
;
3389 VEC(tree
,gc
) *stringargs
;
3391 gfc_formal_arglist
*formal
;
3392 gfc_actual_arglist
*arg
;
3393 int has_alternate_specifier
= 0;
3394 bool need_interface_mapping
;
3401 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3402 gfc_component
*comp
= NULL
;
3412 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3413 && conv_isocbinding_procedure (se
, sym
, args
))
3416 gfc_is_proc_ptr_comp (expr
, &comp
);
3420 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3422 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3423 if (se
->ss
->info
->useflags
)
3425 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3426 && sym
->result
->attr
.dimension
)
3427 || (comp
&& comp
->attr
.dimension
));
3428 gcc_assert (se
->loop
!= NULL
);
3430 /* Access the previously obtained result. */
3431 gfc_conv_tmp_array_ref (se
);
3435 info
= &se
->ss
->info
->data
.array
;
3440 gfc_init_block (&post
);
3441 gfc_init_interface_mapping (&mapping
);
3444 formal
= sym
->formal
;
3445 need_interface_mapping
= sym
->attr
.dimension
||
3446 (sym
->ts
.type
== BT_CHARACTER
3447 && sym
->ts
.u
.cl
->length
3448 && sym
->ts
.u
.cl
->length
->expr_type
3453 formal
= comp
->formal
;
3454 need_interface_mapping
= comp
->attr
.dimension
||
3455 (comp
->ts
.type
== BT_CHARACTER
3456 && comp
->ts
.u
.cl
->length
3457 && comp
->ts
.u
.cl
->length
->expr_type
3461 base_object
= NULL_TREE
;
3463 /* Evaluate the arguments. */
3464 for (arg
= args
; arg
!= NULL
;
3465 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3468 fsym
= formal
? formal
->sym
: NULL
;
3469 parm_kind
= MISSING
;
3471 /* Class array expressions are sometimes coming completely unadorned
3472 with either arrayspec or _data component. Correct that here.
3473 OOP-TODO: Move this to the frontend. */
3474 if (e
&& e
->expr_type
== EXPR_VARIABLE
3476 && e
->ts
.type
== BT_CLASS
3477 && CLASS_DATA (e
)->attr
.dimension
)
3479 gfc_typespec temp_ts
= e
->ts
;
3480 gfc_add_class_array_ref (e
);
3486 if (se
->ignore_optional
)
3488 /* Some intrinsics have already been resolved to the correct
3492 else if (arg
->label
)
3494 has_alternate_specifier
= 1;
3499 /* Pass a NULL pointer for an absent arg. */
3500 gfc_init_se (&parmse
, NULL
);
3501 parmse
.expr
= null_pointer_node
;
3502 if (arg
->missing_arg_type
== BT_CHARACTER
)
3503 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3506 else if (arg
->expr
->expr_type
== EXPR_NULL
&& fsym
&& !fsym
->attr
.pointer
)
3508 /* Pass a NULL pointer to denote an absent arg. */
3509 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
);
3510 gfc_init_se (&parmse
, NULL
);
3511 parmse
.expr
= null_pointer_node
;
3512 if (arg
->missing_arg_type
== BT_CHARACTER
)
3513 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3515 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
3516 && e
->ts
.type
== BT_DERIVED
)
3518 /* The derived type needs to be converted to a temporary
3520 gfc_init_se (&parmse
, se
);
3521 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
3523 else if (se
->ss
&& se
->ss
->info
->useflags
)
3525 /* An elemental function inside a scalarized loop. */
3526 gfc_init_se (&parmse
, se
);
3527 parm_kind
= ELEMENTAL
;
3529 if (se
->ss
->dimen
> 0 && e
->expr_type
== EXPR_VARIABLE
3530 && se
->ss
->info
->data
.array
.ref
== NULL
)
3532 gfc_conv_tmp_array_ref (&parmse
);
3533 if (e
->ts
.type
== BT_CHARACTER
)
3534 gfc_conv_string_parameter (&parmse
);
3536 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3539 gfc_conv_expr_reference (&parmse
, e
);
3541 /* The scalarizer does not repackage the reference to a class
3542 array - instead it returns a pointer to the data element. */
3543 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
3544 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true);
3548 /* A scalar or transformational function. */
3549 gfc_init_se (&parmse
, NULL
);
3550 argss
= gfc_walk_expr (e
);
3552 if (argss
== gfc_ss_terminator
)
3554 if (e
->expr_type
== EXPR_VARIABLE
3555 && e
->symtree
->n
.sym
->attr
.cray_pointee
3556 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
3558 /* The Cray pointer needs to be converted to a pointer to
3559 a type given by the expression. */
3560 gfc_conv_expr (&parmse
, e
);
3561 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
3562 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
3563 parmse
.expr
= convert (type
, tmp
);
3565 else if (fsym
&& fsym
->attr
.value
)
3567 if (fsym
->ts
.type
== BT_CHARACTER
3568 && fsym
->ts
.is_c_interop
3569 && fsym
->ns
->proc_name
!= NULL
3570 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
3573 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
3574 if (parmse
.expr
== NULL
)
3575 gfc_conv_expr (&parmse
, e
);
3578 gfc_conv_expr (&parmse
, e
);
3580 else if (arg
->name
&& arg
->name
[0] == '%')
3581 /* Argument list functions %VAL, %LOC and %REF are signalled
3582 through arg->name. */
3583 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
3584 else if ((e
->expr_type
== EXPR_FUNCTION
)
3585 && ((e
->value
.function
.esym
3586 && e
->value
.function
.esym
->result
->attr
.pointer
)
3587 || (!e
->value
.function
.esym
3588 && e
->symtree
->n
.sym
->attr
.pointer
))
3589 && fsym
&& fsym
->attr
.target
)
3591 gfc_conv_expr (&parmse
, e
);
3592 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3594 else if (e
->expr_type
== EXPR_FUNCTION
3595 && e
->symtree
->n
.sym
->result
3596 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
3597 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3599 /* Functions returning procedure pointers. */
3600 gfc_conv_expr (&parmse
, e
);
3601 if (fsym
&& fsym
->attr
.proc_pointer
)
3602 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3606 gfc_conv_expr_reference (&parmse
, e
);
3608 /* Catch base objects that are not variables. */
3609 if (e
->ts
.type
== BT_CLASS
3610 && e
->expr_type
!= EXPR_VARIABLE
3611 && expr
&& e
== expr
->base_expr
)
3612 base_object
= build_fold_indirect_ref_loc (input_location
,
3615 /* A class array element needs converting back to be a
3616 class object, if the formal argument is a class object. */
3617 if (fsym
&& fsym
->ts
.type
== BT_CLASS
3618 && e
->ts
.type
== BT_CLASS
3619 && CLASS_DATA (e
)->attr
.dimension
)
3620 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false);
3622 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
3623 || fsym
->ts
.type
== BT_ASSUMED
)
3624 && e
->ts
.type
== BT_CLASS
3625 && !CLASS_DATA (e
)->attr
.dimension
3626 && !CLASS_DATA (e
)->attr
.codimension
)
3627 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
3629 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3630 allocated on entry, it must be deallocated. */
3631 if (fsym
&& fsym
->attr
.allocatable
3632 && fsym
->attr
.intent
== INTENT_OUT
)
3636 gfc_init_block (&block
);
3637 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
3638 NULL_TREE
, NULL_TREE
,
3639 NULL_TREE
, true, NULL
,
3641 gfc_add_expr_to_block (&block
, tmp
);
3642 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3643 void_type_node
, parmse
.expr
,
3645 gfc_add_expr_to_block (&block
, tmp
);
3647 if (fsym
->attr
.optional
3648 && e
->expr_type
== EXPR_VARIABLE
3649 && e
->symtree
->n
.sym
->attr
.optional
)
3651 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3653 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3654 gfc_finish_block (&block
),
3655 build_empty_stmt (input_location
));
3658 tmp
= gfc_finish_block (&block
);
3660 gfc_add_expr_to_block (&se
->pre
, tmp
);
3663 if (fsym
&& e
->expr_type
!= EXPR_NULL
3664 && ((fsym
->attr
.pointer
3665 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3666 || (fsym
->attr
.proc_pointer
3667 && !(e
->expr_type
== EXPR_VARIABLE
3668 && e
->symtree
->n
.sym
->attr
.dummy
))
3669 || (fsym
->attr
.proc_pointer
3670 && e
->expr_type
== EXPR_VARIABLE
3671 && gfc_is_proc_ptr_comp (e
, NULL
))
3672 || (fsym
->attr
.allocatable
3673 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
3675 /* Scalar pointer dummy args require an extra level of
3676 indirection. The null pointer already contains
3677 this level of indirection. */
3678 parm_kind
= SCALAR_POINTER
;
3679 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3683 else if (e
->ts
.type
== BT_CLASS
3684 && fsym
&& fsym
->ts
.type
== BT_CLASS
3685 && CLASS_DATA (fsym
)->attr
.dimension
)
3687 /* Pass a class array. */
3688 gfc_init_se (&parmse
, se
);
3689 gfc_conv_expr_descriptor (&parmse
, e
, argss
);
3690 /* The conversion does not repackage the reference to a class
3691 array - _data descriptor. */
3692 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false);
3696 /* If the procedure requires an explicit interface, the actual
3697 argument is passed according to the corresponding formal
3698 argument. If the corresponding formal argument is a POINTER,
3699 ALLOCATABLE or assumed shape, we do not use g77's calling
3700 convention, and pass the address of the array descriptor
3701 instead. Otherwise we use g77's calling convention. */
3704 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3705 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3707 f
= f
|| !comp
->attr
.always_explicit
;
3709 f
= f
|| !sym
->attr
.always_explicit
;
3711 /* If the argument is a function call that may not create
3712 a temporary for the result, we have to check that we
3713 can do it, i.e. that there is no alias between this
3714 argument and another one. */
3715 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
3721 intent
= fsym
->attr
.intent
;
3723 intent
= INTENT_UNKNOWN
;
3725 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
3727 parmse
.force_tmp
= 1;
3729 iarg
= e
->value
.function
.actual
->expr
;
3731 /* Temporary needed if aliasing due to host association. */
3732 if (sym
->attr
.contained
3734 && !sym
->attr
.implicit_pure
3735 && !sym
->attr
.use_assoc
3736 && iarg
->expr_type
== EXPR_VARIABLE
3737 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
3738 parmse
.force_tmp
= 1;
3740 /* Ditto within module. */
3741 if (sym
->attr
.use_assoc
3743 && !sym
->attr
.implicit_pure
3744 && iarg
->expr_type
== EXPR_VARIABLE
3745 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
3746 parmse
.force_tmp
= 1;
3749 if (e
->expr_type
== EXPR_VARIABLE
3750 && is_subref_array (e
))
3751 /* The actual argument is a component reference to an
3752 array of derived types. In this case, the argument
3753 is converted to a temporary, which is passed and then
3754 written back after the procedure call. */
3755 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3756 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3757 fsym
&& fsym
->attr
.pointer
);
3758 else if (gfc_is_class_array_ref (e
, NULL
)
3759 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
3760 /* The actual argument is a component reference to an
3761 array of derived types. In this case, the argument
3762 is converted to a temporary, which is passed and then
3763 written back after the procedure call.
3764 OOP-TODO: Insert code so that if the dynamic type is
3765 the same as the declared type, copy-in/copy-out does
3767 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3768 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3769 fsym
&& fsym
->attr
.pointer
);
3771 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
3774 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3775 allocated on entry, it must be deallocated. */
3776 if (fsym
&& fsym
->attr
.allocatable
3777 && fsym
->attr
.intent
== INTENT_OUT
)
3779 tmp
= build_fold_indirect_ref_loc (input_location
,
3781 tmp
= gfc_trans_dealloc_allocated (tmp
, false);
3782 if (fsym
->attr
.optional
3783 && e
->expr_type
== EXPR_VARIABLE
3784 && e
->symtree
->n
.sym
->attr
.optional
)
3785 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3787 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3788 tmp
, build_empty_stmt (input_location
));
3789 gfc_add_expr_to_block (&se
->pre
, tmp
);
3794 /* The case with fsym->attr.optional is that of a user subroutine
3795 with an interface indicating an optional argument. When we call
3796 an intrinsic subroutine, however, fsym is NULL, but we might still
3797 have an optional argument, so we proceed to the substitution
3799 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3801 /* If an optional argument is itself an optional dummy argument,
3802 check its presence and substitute a null if absent. This is
3803 only needed when passing an array to an elemental procedure
3804 as then array elements are accessed - or no NULL pointer is
3805 allowed and a "1" or "0" should be passed if not present.
3806 When passing a non-array-descriptor full array to a
3807 non-array-descriptor dummy, no check is needed. For
3808 array-descriptor actual to array-descriptor dummy, see
3809 PR 41911 for why a check has to be inserted.
3810 fsym == NULL is checked as intrinsics required the descriptor
3811 but do not always set fsym. */
3812 if (e
->expr_type
== EXPR_VARIABLE
3813 && e
->symtree
->n
.sym
->attr
.optional
3814 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3815 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3819 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
3820 || fsym
->as
->type
== AS_DEFERRED
))))))
3821 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3822 e
->representation
.length
);
3827 /* Obtain the character length of an assumed character length
3828 length procedure from the typespec. */
3829 if (fsym
->ts
.type
== BT_CHARACTER
3830 && parmse
.string_length
== NULL_TREE
3831 && e
->ts
.type
== BT_PROCEDURE
3832 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3833 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3834 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3836 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3837 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3841 if (fsym
&& need_interface_mapping
&& e
)
3842 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3844 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3845 gfc_add_block_to_block (&post
, &parmse
.post
);
3847 /* Allocated allocatable components of derived types must be
3848 deallocated for non-variable scalars. Non-variable arrays are
3849 dealt with in trans-array.c(gfc_conv_array_parameter). */
3850 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
3851 && e
->ts
.u
.derived
->attr
.alloc_comp
3852 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3853 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3856 tmp
= build_fold_indirect_ref_loc (input_location
,
3858 parm_rank
= e
->rank
;
3866 case (SCALAR_POINTER
):
3867 tmp
= build_fold_indirect_ref_loc (input_location
,
3872 if (e
->expr_type
== EXPR_OP
3873 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3874 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3877 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3878 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3879 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3882 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
3884 /* The derived type is passed to gfc_deallocate_alloc_comp.
3885 Therefore, class actuals can handled correctly but derived
3886 types passed to class formals need the _data component. */
3887 tmp
= gfc_class_data_get (tmp
);
3888 if (!CLASS_DATA (fsym
)->attr
.dimension
)
3889 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3892 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3894 gfc_add_expr_to_block (&se
->post
, tmp
);
3897 /* Add argument checking of passing an unallocated/NULL actual to
3898 a nonallocatable/nonpointer dummy. */
3900 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3902 symbol_attribute attr
;
3906 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
3907 attr
= gfc_expr_attr (e
);
3909 goto end_pointer_check
;
3911 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
3912 allocatable to an optional dummy, cf. 12.5.2.12. */
3913 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
3914 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3915 goto end_pointer_check
;
3919 /* If the actual argument is an optional pointer/allocatable and
3920 the formal argument takes an nonpointer optional value,
3921 it is invalid to pass a non-present argument on, even
3922 though there is no technical reason for this in gfortran.
3923 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3924 tree present
, null_ptr
, type
;
3926 if (attr
.allocatable
3927 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3928 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3929 "allocated or not present", e
->symtree
->n
.sym
->name
);
3930 else if (attr
.pointer
3931 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3932 asprintf (&msg
, "Pointer actual argument '%s' is not "
3933 "associated or not present",
3934 e
->symtree
->n
.sym
->name
);
3935 else if (attr
.proc_pointer
3936 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3937 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3938 "associated or not present",
3939 e
->symtree
->n
.sym
->name
);
3941 goto end_pointer_check
;
3943 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3944 type
= TREE_TYPE (present
);
3945 present
= fold_build2_loc (input_location
, EQ_EXPR
,
3946 boolean_type_node
, present
,
3948 null_pointer_node
));
3949 type
= TREE_TYPE (parmse
.expr
);
3950 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
3951 boolean_type_node
, parmse
.expr
,
3953 null_pointer_node
));
3954 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3955 boolean_type_node
, present
, null_ptr
);
3959 if (attr
.allocatable
3960 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3961 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3962 "allocated", e
->symtree
->n
.sym
->name
);
3963 else if (attr
.pointer
3964 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3965 asprintf (&msg
, "Pointer actual argument '%s' is not "
3966 "associated", e
->symtree
->n
.sym
->name
);
3967 else if (attr
.proc_pointer
3968 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3969 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3970 "associated", e
->symtree
->n
.sym
->name
);
3972 goto end_pointer_check
;
3976 /* If the argument is passed by value, we need to strip the
3978 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
3979 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3981 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3982 boolean_type_node
, tmp
,
3983 fold_convert (TREE_TYPE (tmp
),
3984 null_pointer_node
));
3987 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3993 /* Deferred length dummies pass the character length by reference
3994 so that the value can be returned. */
3995 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
3997 tmp
= parmse
.string_length
;
3998 if (TREE_CODE (tmp
) != VAR_DECL
)
3999 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4000 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4003 /* Character strings are passed as two parameters, a length and a
4004 pointer - except for Bind(c) which only passes the pointer. */
4005 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
4006 VEC_safe_push (tree
, gc
, stringargs
, parmse
.string_length
);
4008 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4009 pass the token and the offset as additional arguments. */
4010 if (fsym
&& fsym
->attr
.codimension
4011 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4012 && !fsym
->attr
.allocatable
4015 /* Token and offset. */
4016 VEC_safe_push (tree
, gc
, stringargs
, null_pointer_node
);
4017 VEC_safe_push (tree
, gc
, stringargs
,
4018 build_int_cst (gfc_array_index_type
, 0));
4019 gcc_assert (fsym
->attr
.optional
);
4021 else if (fsym
&& fsym
->attr
.codimension
4022 && !fsym
->attr
.allocatable
4023 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4025 tree caf_decl
, caf_type
;
4028 caf_decl
= get_tree_for_caf_expr (e
);
4029 caf_type
= TREE_TYPE (caf_decl
);
4031 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4032 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4033 tmp
= gfc_conv_descriptor_token (caf_decl
);
4034 else if (DECL_LANG_SPECIFIC (caf_decl
)
4035 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4036 tmp
= GFC_DECL_TOKEN (caf_decl
);
4039 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4040 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4041 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4044 VEC_safe_push (tree
, gc
, stringargs
, tmp
);
4046 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4047 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4048 offset
= build_int_cst (gfc_array_index_type
, 0);
4049 else if (DECL_LANG_SPECIFIC (caf_decl
)
4050 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4051 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4052 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4053 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4055 offset
= build_int_cst (gfc_array_index_type
, 0);
4057 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4058 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4061 gcc_assert (POINTER_TYPE_P (caf_type
));
4065 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
)
4067 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4068 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4069 (TREE_TYPE (parmse
.expr
))));
4070 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4071 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4073 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4074 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4077 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4081 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4082 gfc_array_index_type
,
4083 fold_convert (gfc_array_index_type
, tmp2
),
4084 fold_convert (gfc_array_index_type
, tmp
));
4085 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4086 gfc_array_index_type
, offset
, tmp
);
4088 VEC_safe_push (tree
, gc
, stringargs
, offset
);
4091 VEC_safe_push (tree
, gc
, arglist
, parmse
.expr
);
4093 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4100 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4101 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4102 else if (ts
.type
== BT_CHARACTER
)
4104 if (ts
.u
.cl
->length
== NULL
)
4106 /* Assumed character length results are not allowed by 5.1.1.5 of the
4107 standard and are trapped in resolve.c; except in the case of SPREAD
4108 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4109 we take the character length of the first argument for the result.
4110 For dummies, we have to look through the formal argument list for
4111 this function and use the character length found there.*/
4112 if (ts
.deferred
&& (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
4113 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4114 else if (!sym
->attr
.dummy
)
4115 cl
.backend_decl
= VEC_index (tree
, stringargs
, 0);
4118 formal
= sym
->ns
->proc_name
->formal
;
4119 for (; formal
; formal
= formal
->next
)
4120 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4121 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4128 /* Calculate the length of the returned string. */
4129 gfc_init_se (&parmse
, NULL
);
4130 if (need_interface_mapping
)
4131 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4133 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4134 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4135 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4137 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4138 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4139 gfc_charlen_type_node
, tmp
,
4140 build_int_cst (gfc_charlen_type_node
, 0));
4141 cl
.backend_decl
= tmp
;
4144 /* Set up a charlen structure for it. */
4149 len
= cl
.backend_decl
;
4152 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4153 || (!comp
&& gfc_return_by_reference (sym
));
4156 if (se
->direct_byref
)
4158 /* Sometimes, too much indirection can be applied; e.g. for
4159 function_result = array_valued_recursive_function. */
4160 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4161 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4162 && GFC_DESCRIPTOR_TYPE_P
4163 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4164 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4167 /* If the lhs of an assignment x = f(..) is allocatable and
4168 f2003 is allowed, we must do the automatic reallocation.
4169 TODO - deal with intrinsics, without using a temporary. */
4170 if (gfc_option
.flag_realloc_lhs
4171 && se
->ss
&& se
->ss
->loop_chain
4172 && se
->ss
->loop_chain
->is_alloc_lhs
4173 && !expr
->value
.function
.isym
4174 && sym
->result
->as
!= NULL
)
4176 /* Evaluate the bounds of the result, if known. */
4177 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4180 /* Perform the automatic reallocation. */
4181 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4183 gfc_add_expr_to_block (&se
->pre
, tmp
);
4185 /* Pass the temporary as the first argument. */
4186 result
= info
->descriptor
;
4189 result
= build_fold_indirect_ref_loc (input_location
,
4191 VEC_safe_push (tree
, gc
, retargs
, se
->expr
);
4193 else if (comp
&& comp
->attr
.dimension
)
4195 gcc_assert (se
->loop
&& info
);
4197 /* Set the type of the array. */
4198 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4199 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4201 /* Evaluate the bounds of the result, if known. */
4202 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4204 /* If the lhs of an assignment x = f(..) is allocatable and
4205 f2003 is allowed, we must not generate the function call
4206 here but should just send back the results of the mapping.
4207 This is signalled by the function ss being flagged. */
4208 if (gfc_option
.flag_realloc_lhs
4209 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4211 gfc_free_interface_mapping (&mapping
);
4212 return has_alternate_specifier
;
4215 /* Create a temporary to store the result. In case the function
4216 returns a pointer, the temporary will be a shallow copy and
4217 mustn't be deallocated. */
4218 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4219 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4220 tmp
, NULL_TREE
, false,
4221 !comp
->attr
.pointer
, callee_alloc
,
4222 &se
->ss
->info
->expr
->where
);
4224 /* Pass the temporary as the first argument. */
4225 result
= info
->descriptor
;
4226 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4227 VEC_safe_push (tree
, gc
, retargs
, tmp
);
4229 else if (!comp
&& sym
->result
->attr
.dimension
)
4231 gcc_assert (se
->loop
&& info
);
4233 /* Set the type of the array. */
4234 tmp
= gfc_typenode_for_spec (&ts
);
4235 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4237 /* Evaluate the bounds of the result, if known. */
4238 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
4240 /* If the lhs of an assignment x = f(..) is allocatable and
4241 f2003 is allowed, we must not generate the function call
4242 here but should just send back the results of the mapping.
4243 This is signalled by the function ss being flagged. */
4244 if (gfc_option
.flag_realloc_lhs
4245 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4247 gfc_free_interface_mapping (&mapping
);
4248 return has_alternate_specifier
;
4251 /* Create a temporary to store the result. In case the function
4252 returns a pointer, the temporary will be a shallow copy and
4253 mustn't be deallocated. */
4254 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
4255 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4256 tmp
, NULL_TREE
, false,
4257 !sym
->attr
.pointer
, callee_alloc
,
4258 &se
->ss
->info
->expr
->where
);
4260 /* Pass the temporary as the first argument. */
4261 result
= info
->descriptor
;
4262 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4263 VEC_safe_push (tree
, gc
, retargs
, tmp
);
4265 else if (ts
.type
== BT_CHARACTER
)
4267 /* Pass the string length. */
4268 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
4269 type
= build_pointer_type (type
);
4271 /* Return an address to a char[0:len-1]* temporary for
4272 character pointers. */
4273 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4274 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
4276 var
= gfc_create_var (type
, "pstr");
4278 if ((!comp
&& sym
->attr
.allocatable
)
4279 || (comp
&& comp
->attr
.allocatable
))
4280 gfc_add_modify (&se
->pre
, var
,
4281 fold_convert (TREE_TYPE (var
),
4282 null_pointer_node
));
4284 /* Provide an address expression for the function arguments. */
4285 var
= gfc_build_addr_expr (NULL_TREE
, var
);
4288 var
= gfc_conv_string_tmp (se
, type
, len
);
4290 VEC_safe_push (tree
, gc
, retargs
, var
);
4294 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
4296 type
= gfc_get_complex_type (ts
.kind
);
4297 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
4298 VEC_safe_push (tree
, gc
, retargs
, var
);
4301 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
4302 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
4305 if (TREE_CODE (tmp
) != VAR_DECL
)
4306 tmp
= gfc_evaluate_now (len
, &se
->pre
);
4307 len
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4310 /* Add the string length to the argument list. */
4311 if (ts
.type
== BT_CHARACTER
)
4312 VEC_safe_push (tree
, gc
, retargs
, len
);
4314 gfc_free_interface_mapping (&mapping
);
4316 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
4317 arglen
= (VEC_length (tree
, arglist
)
4318 + VEC_length (tree
, stringargs
) + VEC_length (tree
, append_args
));
4319 VEC_reserve_exact (tree
, gc
, retargs
, arglen
);
4321 /* Add the return arguments. */
4322 VEC_splice (tree
, retargs
, arglist
);
4324 /* Add the hidden string length parameters to the arguments. */
4325 VEC_splice (tree
, retargs
, stringargs
);
4327 /* We may want to append extra arguments here. This is used e.g. for
4328 calls to libgfortran_matmul_??, which need extra information. */
4329 if (!VEC_empty (tree
, append_args
))
4330 VEC_splice (tree
, retargs
, append_args
);
4333 /* Generate the actual call. */
4334 if (base_object
== NULL_TREE
)
4335 conv_function_val (se
, sym
, expr
);
4337 conv_base_obj_fcn_val (se
, base_object
, expr
);
4339 /* If there are alternate return labels, function type should be
4340 integer. Can't modify the type in place though, since it can be shared
4341 with other functions. For dummy arguments, the typing is done to
4342 this result, even if it has to be repeated for each call. */
4343 if (has_alternate_specifier
4344 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
4346 if (!sym
->attr
.dummy
)
4348 TREE_TYPE (sym
->backend_decl
)
4349 = build_function_type (integer_type_node
,
4350 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
4351 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
4354 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
4357 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
4358 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
4360 /* If we have a pointer function, but we don't want a pointer, e.g.
4363 where f is pointer valued, we have to dereference the result. */
4364 if (!se
->want_pointer
&& !byref
4365 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4366 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
4367 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4369 /* f2c calling conventions require a scalar default real function to
4370 return a double precision result. Convert this back to default
4371 real. We only care about the cases that can happen in Fortran 77.
4373 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
4374 && sym
->ts
.kind
== gfc_default_real_kind
4375 && !sym
->attr
.always_explicit
)
4376 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
4378 /* A pure function may still have side-effects - it may modify its
4380 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4382 if (!sym
->attr
.pure
)
4383 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4388 /* Add the function call to the pre chain. There is no expression. */
4389 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
4390 se
->expr
= NULL_TREE
;
4392 if (!se
->direct_byref
)
4394 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
4396 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4398 /* Check the data pointer hasn't been modified. This would
4399 happen in a function returning a pointer. */
4400 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
4401 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
4404 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
4407 se
->expr
= info
->descriptor
;
4408 /* Bundle in the string length. */
4409 se
->string_length
= len
;
4411 else if (ts
.type
== BT_CHARACTER
)
4413 /* Dereference for character pointer results. */
4414 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4415 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
4416 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
4421 se
->string_length
= len
;
4422 else if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
4423 se
->string_length
= cl
.backend_decl
;
4427 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
4428 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
4433 /* Follow the function call with the argument post block. */
4436 gfc_add_block_to_block (&se
->pre
, &post
);
4438 /* Transformational functions of derived types with allocatable
4439 components must have the result allocatable components copied. */
4440 arg
= expr
->value
.function
.actual
;
4441 if (result
&& arg
&& expr
->rank
4442 && expr
->value
.function
.isym
4443 && expr
->value
.function
.isym
->transformational
4444 && arg
->expr
->ts
.type
== BT_DERIVED
4445 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
4448 /* Copy the allocatable components. We have to use a
4449 temporary here to prevent source allocatable components
4450 from being corrupted. */
4451 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
4452 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
4453 result
, tmp2
, expr
->rank
);
4454 gfc_add_expr_to_block (&se
->pre
, tmp
);
4455 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
4457 gfc_add_expr_to_block (&se
->pre
, tmp
);
4459 /* Finally free the temporary's data field. */
4460 tmp
= gfc_conv_descriptor_data_get (tmp2
);
4461 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
4462 NULL_TREE
, NULL_TREE
, true,
4464 gfc_add_expr_to_block (&se
->pre
, tmp
);
4468 gfc_add_block_to_block (&se
->post
, &post
);
4470 return has_alternate_specifier
;
4474 /* Fill a character string with spaces. */
4477 fill_with_spaces (tree start
, tree type
, tree size
)
4479 stmtblock_t block
, loop
;
4480 tree i
, el
, exit_label
, cond
, tmp
;
4482 /* For a simple char type, we can call memset(). */
4483 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
4484 return build_call_expr_loc (input_location
,
4485 builtin_decl_explicit (BUILT_IN_MEMSET
),
4487 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
4488 lang_hooks
.to_target_charset (' ')),
4491 /* Otherwise, we use a loop:
4492 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
4496 /* Initialize variables. */
4497 gfc_init_block (&block
);
4498 i
= gfc_create_var (sizetype
, "i");
4499 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
4500 el
= gfc_create_var (build_pointer_type (type
), "el");
4501 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
4502 exit_label
= gfc_build_label_decl (NULL_TREE
);
4503 TREE_USED (exit_label
) = 1;
4507 gfc_init_block (&loop
);
4509 /* Exit condition. */
4510 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
4511 build_zero_cst (sizetype
));
4512 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4513 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
4514 build_empty_stmt (input_location
));
4515 gfc_add_expr_to_block (&loop
, tmp
);
4518 gfc_add_modify (&loop
,
4519 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
4520 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
4522 /* Increment loop variables. */
4523 gfc_add_modify (&loop
, i
,
4524 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
4525 TYPE_SIZE_UNIT (type
)));
4526 gfc_add_modify (&loop
, el
,
4527 fold_build_pointer_plus_loc (input_location
,
4528 el
, TYPE_SIZE_UNIT (type
)));
4530 /* Making the loop... actually loop! */
4531 tmp
= gfc_finish_block (&loop
);
4532 tmp
= build1_v (LOOP_EXPR
, tmp
);
4533 gfc_add_expr_to_block (&block
, tmp
);
4535 /* The exit label. */
4536 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4537 gfc_add_expr_to_block (&block
, tmp
);
4540 return gfc_finish_block (&block
);
4544 /* Generate code to copy a string. */
4547 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
4548 int dkind
, tree slength
, tree src
, int skind
)
4550 tree tmp
, dlen
, slen
;
4559 stmtblock_t tempblock
;
4561 gcc_assert (dkind
== skind
);
4563 if (slength
!= NULL_TREE
)
4565 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
4566 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
4570 slen
= build_int_cst (size_type_node
, 1);
4574 if (dlength
!= NULL_TREE
)
4576 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
4577 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
4581 dlen
= build_int_cst (size_type_node
, 1);
4585 /* Assign directly if the types are compatible. */
4586 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
4587 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
4589 gfc_add_modify (block
, dsc
, ssc
);
4593 /* Do nothing if the destination length is zero. */
4594 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
4595 build_int_cst (size_type_node
, 0));
4597 /* The following code was previously in _gfortran_copy_string:
4599 // The two strings may overlap so we use memmove.
4601 copy_string (GFC_INTEGER_4 destlen, char * dest,
4602 GFC_INTEGER_4 srclen, const char * src)
4604 if (srclen >= destlen)
4606 // This will truncate if too long.
4607 memmove (dest, src, destlen);
4611 memmove (dest, src, srclen);
4613 memset (&dest[srclen], ' ', destlen - srclen);
4617 We're now doing it here for better optimization, but the logic
4620 /* For non-default character kinds, we have to multiply the string
4621 length by the base type size. */
4622 chartype
= gfc_get_char_type (dkind
);
4623 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4624 fold_convert (size_type_node
, slen
),
4625 fold_convert (size_type_node
,
4626 TYPE_SIZE_UNIT (chartype
)));
4627 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4628 fold_convert (size_type_node
, dlen
),
4629 fold_convert (size_type_node
,
4630 TYPE_SIZE_UNIT (chartype
)));
4632 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
4633 dest
= fold_convert (pvoid_type_node
, dest
);
4635 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4637 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
4638 src
= fold_convert (pvoid_type_node
, src
);
4640 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4642 /* Truncate string if source is too long. */
4643 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
4645 tmp2
= build_call_expr_loc (input_location
,
4646 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
4647 3, dest
, src
, dlen
);
4649 /* Else copy and pad with spaces. */
4650 tmp3
= build_call_expr_loc (input_location
,
4651 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
4652 3, dest
, src
, slen
);
4654 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
4655 tmp4
= fill_with_spaces (tmp4
, chartype
,
4656 fold_build2_loc (input_location
, MINUS_EXPR
,
4657 TREE_TYPE(dlen
), dlen
, slen
));
4659 gfc_init_block (&tempblock
);
4660 gfc_add_expr_to_block (&tempblock
, tmp3
);
4661 gfc_add_expr_to_block (&tempblock
, tmp4
);
4662 tmp3
= gfc_finish_block (&tempblock
);
4664 /* The whole copy_string function is there. */
4665 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
4667 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
4668 build_empty_stmt (input_location
));
4669 gfc_add_expr_to_block (block
, tmp
);
4673 /* Translate a statement function.
4674 The value of a statement function reference is obtained by evaluating the
4675 expression using the values of the actual arguments for the values of the
4676 corresponding dummy arguments. */
4679 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
4683 gfc_formal_arglist
*fargs
;
4684 gfc_actual_arglist
*args
;
4687 gfc_saved_var
*saved_vars
;
4693 sym
= expr
->symtree
->n
.sym
;
4694 args
= expr
->value
.function
.actual
;
4695 gfc_init_se (&lse
, NULL
);
4696 gfc_init_se (&rse
, NULL
);
4699 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
4701 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
4702 temp_vars
= XCNEWVEC (tree
, n
);
4704 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4706 /* Each dummy shall be specified, explicitly or implicitly, to be
4708 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
4711 if (fsym
->ts
.type
== BT_CHARACTER
)
4713 /* Copy string arguments. */
4716 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
4717 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4719 /* Create a temporary to hold the value. */
4720 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
4721 fsym
->ts
.u
.cl
->backend_decl
4722 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
4724 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
4725 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
4727 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
4729 gfc_conv_expr (&rse
, args
->expr
);
4730 gfc_conv_string_parameter (&rse
);
4731 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
4732 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
4734 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
4735 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
4736 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
4737 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
4741 /* For everything else, just evaluate the expression. */
4743 /* Create a temporary to hold the value. */
4744 type
= gfc_typenode_for_spec (&fsym
->ts
);
4745 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
4747 gfc_conv_expr (&lse
, args
->expr
);
4749 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
4750 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
4751 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
4757 /* Use the temporary variables in place of the real ones. */
4758 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4759 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
4761 gfc_conv_expr (se
, sym
->value
);
4763 if (sym
->ts
.type
== BT_CHARACTER
)
4765 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4767 /* Force the expression to the correct length. */
4768 if (!INTEGER_CST_P (se
->string_length
)
4769 || tree_int_cst_lt (se
->string_length
,
4770 sym
->ts
.u
.cl
->backend_decl
))
4772 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
4773 tmp
= gfc_create_var (type
, sym
->name
);
4774 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
4775 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
4776 sym
->ts
.kind
, se
->string_length
, se
->expr
,
4780 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
4783 /* Restore the original variables. */
4784 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
4785 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
4790 /* Translate a function expression. */
4793 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
4797 if (expr
->value
.function
.isym
)
4799 gfc_conv_intrinsic_function (se
, expr
);
4803 /* We distinguish statement functions from general functions to improve
4804 runtime performance. */
4805 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
4807 gfc_conv_statement_function (se
, expr
);
4811 /* expr.value.function.esym is the resolved (specific) function symbol for
4812 most functions. However this isn't set for dummy procedures. */
4813 sym
= expr
->value
.function
.esym
;
4815 sym
= expr
->symtree
->n
.sym
;
4817 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
, NULL
);
4821 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4824 is_zero_initializer_p (gfc_expr
* expr
)
4826 if (expr
->expr_type
!= EXPR_CONSTANT
)
4829 /* We ignore constants with prescribed memory representations for now. */
4830 if (expr
->representation
.string
)
4833 switch (expr
->ts
.type
)
4836 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4839 return mpfr_zero_p (expr
->value
.real
)
4840 && MPFR_SIGN (expr
->value
.real
) >= 0;
4843 return expr
->value
.logical
== 0;
4846 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
4847 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
4848 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
4849 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
4859 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
4864 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
4865 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
4867 gfc_conv_tmp_array_ref (se
);
4871 /* Build a static initializer. EXPR is the expression for the initial value.
4872 The other parameters describe the variable of the component being
4873 initialized. EXPR may be null. */
4876 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
4877 bool array
, bool pointer
, bool procptr
)
4881 if (!(expr
|| pointer
|| procptr
))
4884 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
4885 (these are the only two iso_c_binding derived types that can be
4886 used as initialization expressions). If so, we need to modify
4887 the 'expr' to be that for a (void *). */
4888 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
4889 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
4891 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
4893 /* The derived symbol has already been converted to a (void *). Use
4895 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
4896 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
4898 gfc_init_se (&se
, NULL
);
4899 gfc_conv_constant (&se
, expr
);
4900 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4904 if (array
&& !procptr
)
4907 /* Arrays need special handling. */
4909 ctor
= gfc_build_null_descriptor (type
);
4910 /* Special case assigning an array to zero. */
4911 else if (is_zero_initializer_p (expr
))
4912 ctor
= build_constructor (type
, NULL
);
4914 ctor
= gfc_conv_array_initializer (type
, expr
);
4915 TREE_STATIC (ctor
) = 1;
4918 else if (pointer
|| procptr
)
4920 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
4921 return fold_convert (type
, null_pointer_node
);
4924 gfc_init_se (&se
, NULL
);
4925 se
.want_pointer
= 1;
4926 gfc_conv_expr (&se
, expr
);
4927 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4937 gfc_init_se (&se
, NULL
);
4938 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4939 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
4941 gfc_conv_structure (&se
, expr
, 1);
4942 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
4943 TREE_STATIC (se
.expr
) = 1;
4948 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
4949 TREE_STATIC (ctor
) = 1;
4954 gfc_init_se (&se
, NULL
);
4955 gfc_conv_constant (&se
, expr
);
4956 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
4963 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4969 gfc_array_info
*lss_array
;
4976 gfc_start_block (&block
);
4978 /* Initialize the scalarizer. */
4979 gfc_init_loopinfo (&loop
);
4981 gfc_init_se (&lse
, NULL
);
4982 gfc_init_se (&rse
, NULL
);
4985 rss
= gfc_walk_expr (expr
);
4986 if (rss
== gfc_ss_terminator
)
4987 /* The rhs is scalar. Add a ss for the expression. */
4988 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
4990 /* Create a SS for the destination. */
4991 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
4993 lss_array
= &lss
->info
->data
.array
;
4994 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
4995 lss_array
->descriptor
= dest
;
4996 lss_array
->data
= gfc_conv_array_data (dest
);
4997 lss_array
->offset
= gfc_conv_array_offset (dest
);
4998 for (n
= 0; n
< cm
->as
->rank
; n
++)
5000 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5001 lss_array
->stride
[n
] = gfc_index_one_node
;
5003 mpz_init (lss_array
->shape
[n
]);
5004 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5005 cm
->as
->lower
[n
]->value
.integer
);
5006 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5009 /* Associate the SS with the loop. */
5010 gfc_add_ss_to_loop (&loop
, lss
);
5011 gfc_add_ss_to_loop (&loop
, rss
);
5013 /* Calculate the bounds of the scalarization. */
5014 gfc_conv_ss_startstride (&loop
);
5016 /* Setup the scalarizing loops. */
5017 gfc_conv_loop_setup (&loop
, &expr
->where
);
5019 /* Setup the gfc_se structures. */
5020 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5021 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5024 gfc_mark_ss_chain_used (rss
, 1);
5026 gfc_mark_ss_chain_used (lss
, 1);
5028 /* Start the scalarized loop body. */
5029 gfc_start_scalarized_body (&loop
, &body
);
5031 gfc_conv_tmp_array_ref (&lse
);
5032 if (cm
->ts
.type
== BT_CHARACTER
)
5033 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5035 gfc_conv_expr (&rse
, expr
);
5037 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5038 gfc_add_expr_to_block (&body
, tmp
);
5040 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5042 /* Generate the copying loops. */
5043 gfc_trans_scalarizing_loops (&loop
, &body
);
5045 /* Wrap the whole thing up. */
5046 gfc_add_block_to_block (&block
, &loop
.pre
);
5047 gfc_add_block_to_block (&block
, &loop
.post
);
5049 gcc_assert (lss_array
->shape
!= NULL
);
5050 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5051 gfc_cleanup_loop (&loop
);
5053 return gfc_finish_block (&block
);
5058 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5069 gfc_expr
*arg
= NULL
;
5071 gfc_start_block (&block
);
5072 gfc_init_se (&se
, NULL
);
5074 /* Get the descriptor for the expressions. */
5075 rss
= gfc_walk_expr (expr
);
5076 se
.want_pointer
= 0;
5077 gfc_conv_expr_descriptor (&se
, expr
, rss
);
5078 gfc_add_block_to_block (&block
, &se
.pre
);
5079 gfc_add_modify (&block
, dest
, se
.expr
);
5081 /* Deal with arrays of derived types with allocatable components. */
5082 if (cm
->ts
.type
== BT_DERIVED
5083 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5084 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5088 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5089 TREE_TYPE(cm
->backend_decl
),
5092 gfc_add_expr_to_block (&block
, tmp
);
5093 gfc_add_block_to_block (&block
, &se
.post
);
5095 if (expr
->expr_type
!= EXPR_VARIABLE
)
5096 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5099 /* We need to know if the argument of a conversion function is a
5100 variable, so that the correct lower bound can be used. */
5101 if (expr
->expr_type
== EXPR_FUNCTION
5102 && expr
->value
.function
.isym
5103 && expr
->value
.function
.isym
->conversion
5104 && expr
->value
.function
.actual
->expr
5105 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5106 arg
= expr
->value
.function
.actual
->expr
;
5108 /* Obtain the array spec of full array references. */
5110 as
= gfc_get_full_arrayspec_from_expr (arg
);
5112 as
= gfc_get_full_arrayspec_from_expr (expr
);
5114 /* Shift the lbound and ubound of temporaries to being unity,
5115 rather than zero, based. Always calculate the offset. */
5116 offset
= gfc_conv_descriptor_offset_get (dest
);
5117 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5118 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5120 for (n
= 0; n
< expr
->rank
; n
++)
5125 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5126 TODO It looks as if gfc_conv_expr_descriptor should return
5127 the correct bounds and that the following should not be
5128 necessary. This would simplify gfc_conv_intrinsic_bound
5130 if (as
&& as
->lower
[n
])
5133 gfc_init_se (&lbse
, NULL
);
5134 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5135 gfc_add_block_to_block (&block
, &lbse
.pre
);
5136 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5140 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5141 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5145 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5148 lbound
= gfc_index_one_node
;
5150 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5152 /* Shift the bounds and set the offset accordingly. */
5153 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5154 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5155 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5156 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5158 gfc_conv_descriptor_ubound_set (&block
, dest
,
5159 gfc_rank_cst
[n
], tmp
);
5160 gfc_conv_descriptor_lbound_set (&block
, dest
,
5161 gfc_rank_cst
[n
], lbound
);
5163 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5164 gfc_conv_descriptor_lbound_get (dest
,
5166 gfc_conv_descriptor_stride_get (dest
,
5168 gfc_add_modify (&block
, tmp2
, tmp
);
5169 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5171 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5176 /* If a conversion expression has a null data pointer
5177 argument, nullify the allocatable component. */
5181 if (arg
->symtree
->n
.sym
->attr
.allocatable
5182 || arg
->symtree
->n
.sym
->attr
.pointer
)
5184 non_null_expr
= gfc_finish_block (&block
);
5185 gfc_start_block (&block
);
5186 gfc_conv_descriptor_data_set (&block
, dest
,
5188 null_expr
= gfc_finish_block (&block
);
5189 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5190 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5191 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5192 return build3_v (COND_EXPR
, tmp
,
5193 null_expr
, non_null_expr
);
5197 return gfc_finish_block (&block
);
5201 /* Assign a single component of a derived type constructor. */
5204 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5212 gfc_start_block (&block
);
5214 if (cm
->attr
.pointer
)
5216 gfc_init_se (&se
, NULL
);
5217 /* Pointer component. */
5218 if (cm
->attr
.dimension
)
5220 /* Array pointer. */
5221 if (expr
->expr_type
== EXPR_NULL
)
5222 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5225 rss
= gfc_walk_expr (expr
);
5226 se
.direct_byref
= 1;
5228 gfc_conv_expr_descriptor (&se
, expr
, rss
);
5229 gfc_add_block_to_block (&block
, &se
.pre
);
5230 gfc_add_block_to_block (&block
, &se
.post
);
5235 /* Scalar pointers. */
5236 se
.want_pointer
= 1;
5237 gfc_conv_expr (&se
, expr
);
5238 gfc_add_block_to_block (&block
, &se
.pre
);
5239 gfc_add_modify (&block
, dest
,
5240 fold_convert (TREE_TYPE (dest
), se
.expr
));
5241 gfc_add_block_to_block (&block
, &se
.post
);
5244 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5246 /* NULL initialization for CLASS components. */
5247 tmp
= gfc_trans_structure_assign (dest
,
5248 gfc_class_null_initializer (&cm
->ts
));
5249 gfc_add_expr_to_block (&block
, tmp
);
5251 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5253 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
5254 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5255 else if (cm
->attr
.allocatable
)
5257 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
5258 gfc_add_expr_to_block (&block
, tmp
);
5262 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
5263 gfc_add_expr_to_block (&block
, tmp
);
5266 else if (expr
->ts
.type
== BT_DERIVED
)
5268 if (expr
->expr_type
!= EXPR_STRUCTURE
)
5270 gfc_init_se (&se
, NULL
);
5271 gfc_conv_expr (&se
, expr
);
5272 gfc_add_block_to_block (&block
, &se
.pre
);
5273 gfc_add_modify (&block
, dest
,
5274 fold_convert (TREE_TYPE (dest
), se
.expr
));
5275 gfc_add_block_to_block (&block
, &se
.post
);
5279 /* Nested constructors. */
5280 tmp
= gfc_trans_structure_assign (dest
, expr
);
5281 gfc_add_expr_to_block (&block
, tmp
);
5286 /* Scalar component. */
5287 gfc_init_se (&se
, NULL
);
5288 gfc_init_se (&lse
, NULL
);
5290 gfc_conv_expr (&se
, expr
);
5291 if (cm
->ts
.type
== BT_CHARACTER
)
5292 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5294 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
5295 gfc_add_expr_to_block (&block
, tmp
);
5297 return gfc_finish_block (&block
);
5300 /* Assign a derived type constructor to a variable. */
5303 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
5311 gfc_start_block (&block
);
5312 cm
= expr
->ts
.u
.derived
->components
;
5314 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
5315 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
5316 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
5320 gcc_assert (cm
->backend_decl
== NULL
);
5321 gfc_init_se (&se
, NULL
);
5322 gfc_init_se (&lse
, NULL
);
5323 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
5325 gfc_add_modify (&block
, lse
.expr
,
5326 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
5328 return gfc_finish_block (&block
);
5331 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5332 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5334 /* Skip absent members in default initializers. */
5338 field
= cm
->backend_decl
;
5339 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
5340 dest
, field
, NULL_TREE
);
5341 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
5342 gfc_add_expr_to_block (&block
, tmp
);
5344 return gfc_finish_block (&block
);
5347 /* Build an expression for a constructor. If init is nonzero then
5348 this is part of a static variable initializer. */
5351 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
5358 VEC(constructor_elt
,gc
) *v
= NULL
;
5360 gcc_assert (se
->ss
== NULL
);
5361 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
5362 type
= gfc_typenode_for_spec (&expr
->ts
);
5366 /* Create a temporary variable and fill it in. */
5367 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
5368 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
5369 gfc_add_expr_to_block (&se
->pre
, tmp
);
5373 cm
= expr
->ts
.u
.derived
->components
;
5375 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5376 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5378 /* Skip absent members in default initializers and allocatable
5379 components. Although the latter have a default initializer
5380 of EXPR_NULL,... by default, the static nullify is not needed
5381 since this is done every time we come into scope. */
5382 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
5385 if (strcmp (cm
->name
, "_size") == 0)
5387 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
5388 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
5390 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
5391 && strcmp (cm
->name
, "_extends") == 0)
5395 vtabs
= cm
->initializer
->symtree
->n
.sym
;
5396 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
5397 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
5401 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
5402 TREE_TYPE (cm
->backend_decl
),
5403 cm
->attr
.dimension
, cm
->attr
.pointer
,
5404 cm
->attr
.proc_pointer
);
5406 /* Append it to the constructor list. */
5407 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
5410 se
->expr
= build_constructor (type
, v
);
5412 TREE_CONSTANT (se
->expr
) = 1;
5416 /* Translate a substring expression. */
5419 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
5425 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
5427 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
5428 expr
->value
.character
.length
,
5429 expr
->value
.character
.string
);
5431 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
5432 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
5435 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
5439 /* Entry point for expression translation. Evaluates a scalar quantity.
5440 EXPR is the expression to be translated, and SE is the state structure if
5441 called from within the scalarized. */
5444 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
5449 if (ss
&& ss
->info
->expr
== expr
5450 && (ss
->info
->type
== GFC_SS_SCALAR
5451 || ss
->info
->type
== GFC_SS_REFERENCE
))
5453 gfc_ss_info
*ss_info
;
5456 /* Substitute a scalar expression evaluated outside the scalarization
5458 se
->expr
= ss_info
->data
.scalar
.value
;
5459 /* If the reference can be NULL, the value field contains the reference,
5460 not the value the reference points to (see gfc_add_loop_ss_code). */
5461 if (ss_info
->can_be_null_ref
)
5462 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5464 se
->string_length
= ss_info
->string_length
;
5465 gfc_advance_se_ss_chain (se
);
5469 /* We need to convert the expressions for the iso_c_binding derived types.
5470 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
5471 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
5472 typespec for the C_PTR and C_FUNPTR symbols, which has already been
5473 updated to be an integer with a kind equal to the size of a (void *). */
5474 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
5475 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
5477 if (expr
->expr_type
== EXPR_VARIABLE
5478 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
5479 || expr
->symtree
->n
.sym
->intmod_sym_id
5480 == ISOCBINDING_NULL_FUNPTR
))
5482 /* Set expr_type to EXPR_NULL, which will result in
5483 null_pointer_node being used below. */
5484 expr
->expr_type
= EXPR_NULL
;
5488 /* Update the type/kind of the expression to be what the new
5489 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
5490 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
5491 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
5492 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
5496 gfc_fix_class_refs (expr
);
5498 switch (expr
->expr_type
)
5501 gfc_conv_expr_op (se
, expr
);
5505 gfc_conv_function_expr (se
, expr
);
5509 gfc_conv_constant (se
, expr
);
5513 gfc_conv_variable (se
, expr
);
5517 se
->expr
= null_pointer_node
;
5520 case EXPR_SUBSTRING
:
5521 gfc_conv_substring_expr (se
, expr
);
5524 case EXPR_STRUCTURE
:
5525 gfc_conv_structure (se
, expr
, 0);
5529 gfc_conv_array_constructor_expr (se
, expr
);
5538 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
5539 of an assignment. */
5541 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
5543 gfc_conv_expr (se
, expr
);
5544 /* All numeric lvalues should have empty post chains. If not we need to
5545 figure out a way of rewriting an lvalue so that it has no post chain. */
5546 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
5549 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
5550 numeric expressions. Used for scalar values where inserting cleanup code
5553 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
5557 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
5558 gfc_conv_expr (se
, expr
);
5561 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5562 gfc_add_modify (&se
->pre
, val
, se
->expr
);
5564 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5568 /* Helper to translate an expression and convert it to a particular type. */
5570 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
5572 gfc_conv_expr_val (se
, expr
);
5573 se
->expr
= convert (type
, se
->expr
);
5577 /* Converts an expression so that it can be passed by reference. Scalar
5581 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
5587 if (ss
&& ss
->info
->expr
== expr
5588 && ss
->info
->type
== GFC_SS_REFERENCE
)
5590 /* Returns a reference to the scalar evaluated outside the loop
5592 gfc_conv_expr (se
, expr
);
5593 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5597 if (expr
->ts
.type
== BT_CHARACTER
)
5599 gfc_conv_expr (se
, expr
);
5600 gfc_conv_string_parameter (se
);
5604 if (expr
->expr_type
== EXPR_VARIABLE
)
5606 se
->want_pointer
= 1;
5607 gfc_conv_expr (se
, expr
);
5610 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5611 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5612 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5618 if (expr
->expr_type
== EXPR_FUNCTION
5619 && ((expr
->value
.function
.esym
5620 && expr
->value
.function
.esym
->result
->attr
.pointer
5621 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
5622 || (!expr
->value
.function
.esym
5623 && expr
->symtree
->n
.sym
->attr
.pointer
5624 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
5626 se
->want_pointer
= 1;
5627 gfc_conv_expr (se
, expr
);
5628 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5629 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5634 gfc_conv_expr (se
, expr
);
5636 /* Create a temporary var to hold the value. */
5637 if (TREE_CONSTANT (se
->expr
))
5639 tree tmp
= se
->expr
;
5640 STRIP_TYPE_NOPS (tmp
);
5641 var
= build_decl (input_location
,
5642 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
5643 DECL_INITIAL (var
) = tmp
;
5644 TREE_STATIC (var
) = 1;
5649 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5650 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5652 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5654 /* Take the address of that value. */
5655 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5660 gfc_trans_pointer_assign (gfc_code
* code
)
5662 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
5666 /* Generate code for a pointer assignment. */
5669 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
5680 gfc_start_block (&block
);
5682 gfc_init_se (&lse
, NULL
);
5684 lss
= gfc_walk_expr (expr1
);
5685 rss
= gfc_walk_expr (expr2
);
5686 if (lss
== gfc_ss_terminator
)
5688 /* Scalar pointers. */
5689 lse
.want_pointer
= 1;
5690 gfc_conv_expr (&lse
, expr1
);
5691 gcc_assert (rss
== gfc_ss_terminator
);
5692 gfc_init_se (&rse
, NULL
);
5693 rse
.want_pointer
= 1;
5694 gfc_conv_expr (&rse
, expr2
);
5696 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
5697 && expr1
->symtree
->n
.sym
->attr
.dummy
)
5698 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
5701 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
5702 && expr2
->symtree
->n
.sym
->attr
.dummy
)
5703 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
5706 gfc_add_block_to_block (&block
, &lse
.pre
);
5707 gfc_add_block_to_block (&block
, &rse
.pre
);
5709 /* Check character lengths if character expression. The test is only
5710 really added if -fbounds-check is enabled. Exclude deferred
5711 character length lefthand sides. */
5712 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
5713 && !(expr1
->ts
.deferred
5714 && (TREE_CODE (lse
.string_length
) == VAR_DECL
))
5715 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
5716 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
5718 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5719 gcc_assert (lse
.string_length
&& rse
.string_length
);
5720 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5721 lse
.string_length
, rse
.string_length
,
5725 /* The assignment to an deferred character length sets the string
5726 length to that of the rhs. */
5727 if (expr1
->ts
.deferred
&& (TREE_CODE (lse
.string_length
) == VAR_DECL
))
5729 if (expr2
->expr_type
!= EXPR_NULL
)
5730 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
5732 gfc_add_modify (&block
, lse
.string_length
,
5733 build_int_cst (gfc_charlen_type_node
, 0));
5736 gfc_add_modify (&block
, lse
.expr
,
5737 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
5739 gfc_add_block_to_block (&block
, &rse
.post
);
5740 gfc_add_block_to_block (&block
, &lse
.post
);
5747 tree strlen_rhs
= NULL_TREE
;
5749 /* Array pointer. Find the last reference on the LHS and if it is an
5750 array section ref, we're dealing with bounds remapping. In this case,
5751 set it to AR_FULL so that gfc_conv_expr_descriptor does
5752 not see it and process the bounds remapping afterwards explicitely. */
5753 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
5754 if (!remap
->next
&& remap
->type
== REF_ARRAY
5755 && remap
->u
.ar
.type
== AR_SECTION
)
5757 remap
->u
.ar
.type
= AR_FULL
;
5760 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
5762 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
5763 strlen_lhs
= lse
.string_length
;
5766 if (expr2
->expr_type
== EXPR_NULL
)
5768 /* Just set the data pointer to null. */
5769 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
5771 else if (rank_remap
)
5773 /* If we are rank-remapping, just get the RHS's descriptor and
5774 process this later on. */
5775 gfc_init_se (&rse
, NULL
);
5776 rse
.direct_byref
= 1;
5777 rse
.byref_noassign
= 1;
5778 gfc_conv_expr_descriptor (&rse
, expr2
, rss
);
5779 strlen_rhs
= rse
.string_length
;
5781 else if (expr2
->expr_type
== EXPR_VARIABLE
)
5783 /* Assign directly to the LHS's descriptor. */
5784 lse
.direct_byref
= 1;
5785 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
5786 strlen_rhs
= lse
.string_length
;
5788 /* If this is a subreference array pointer assignment, use the rhs
5789 descriptor element size for the lhs span. */
5790 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
5792 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
5793 gfc_init_se (&rse
, NULL
);
5794 rse
.descriptor_only
= 1;
5795 gfc_conv_expr (&rse
, expr2
);
5796 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
5797 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
5798 if (!INTEGER_CST_P (tmp
))
5799 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
5800 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
5805 /* Assign to a temporary descriptor and then copy that
5806 temporary to the pointer. */
5807 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
5810 lse
.direct_byref
= 1;
5811 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
5812 strlen_rhs
= lse
.string_length
;
5813 gfc_add_modify (&lse
.pre
, desc
, tmp
);
5816 gfc_add_block_to_block (&block
, &lse
.pre
);
5818 gfc_add_block_to_block (&block
, &rse
.pre
);
5820 /* If we do bounds remapping, update LHS descriptor accordingly. */
5824 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
5828 /* Do rank remapping. We already have the RHS's descriptor
5829 converted in rse and now have to build the correct LHS
5830 descriptor for it. */
5834 tree lbound
, ubound
;
5837 dtype
= gfc_conv_descriptor_dtype (desc
);
5838 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
5839 gfc_add_modify (&block
, dtype
, tmp
);
5841 /* Copy data pointer. */
5842 data
= gfc_conv_descriptor_data_get (rse
.expr
);
5843 gfc_conv_descriptor_data_set (&block
, desc
, data
);
5845 /* Copy offset but adjust it such that it would correspond
5846 to a lbound of zero. */
5847 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
5848 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
5850 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5852 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
5854 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5855 gfc_array_index_type
, stride
, lbound
);
5856 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
5857 gfc_array_index_type
, offs
, tmp
);
5859 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5861 /* Set the bounds as declared for the LHS and calculate strides as
5862 well as another offset update accordingly. */
5863 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5865 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
5870 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
5872 /* Convert declared bounds. */
5873 gfc_init_se (&lower_se
, NULL
);
5874 gfc_init_se (&upper_se
, NULL
);
5875 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
5876 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
5878 gfc_add_block_to_block (&block
, &lower_se
.pre
);
5879 gfc_add_block_to_block (&block
, &upper_se
.pre
);
5881 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
5882 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
5884 lbound
= gfc_evaluate_now (lbound
, &block
);
5885 ubound
= gfc_evaluate_now (ubound
, &block
);
5887 gfc_add_block_to_block (&block
, &lower_se
.post
);
5888 gfc_add_block_to_block (&block
, &upper_se
.post
);
5890 /* Set bounds in descriptor. */
5891 gfc_conv_descriptor_lbound_set (&block
, desc
,
5892 gfc_rank_cst
[dim
], lbound
);
5893 gfc_conv_descriptor_ubound_set (&block
, desc
,
5894 gfc_rank_cst
[dim
], ubound
);
5897 stride
= gfc_evaluate_now (stride
, &block
);
5898 gfc_conv_descriptor_stride_set (&block
, desc
,
5899 gfc_rank_cst
[dim
], stride
);
5901 /* Update offset. */
5902 offs
= gfc_conv_descriptor_offset_get (desc
);
5903 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5904 gfc_array_index_type
, lbound
, stride
);
5905 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
5906 gfc_array_index_type
, offs
, tmp
);
5907 offs
= gfc_evaluate_now (offs
, &block
);
5908 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5910 /* Update stride. */
5911 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5912 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5913 gfc_array_index_type
, stride
, tmp
);
5918 /* Bounds remapping. Just shift the lower bounds. */
5920 gcc_assert (expr1
->rank
== expr2
->rank
);
5922 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
5926 gcc_assert (remap
->u
.ar
.start
[dim
]);
5927 gcc_assert (!remap
->u
.ar
.end
[dim
]);
5928 gfc_init_se (&lbound_se
, NULL
);
5929 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
5931 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
5932 gfc_conv_shift_descriptor_lbound (&block
, desc
,
5933 dim
, lbound_se
.expr
);
5934 gfc_add_block_to_block (&block
, &lbound_se
.post
);
5939 /* Check string lengths if applicable. The check is only really added
5940 to the output code if -fbounds-check is enabled. */
5941 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
5943 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5944 gcc_assert (strlen_lhs
&& strlen_rhs
);
5945 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5946 strlen_lhs
, strlen_rhs
, &block
);
5949 /* If rank remapping was done, check with -fcheck=bounds that
5950 the target is at least as large as the pointer. */
5951 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
5957 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
5958 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
5960 lsize
= gfc_evaluate_now (lsize
, &block
);
5961 rsize
= gfc_evaluate_now (rsize
, &block
);
5962 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
5965 msg
= _("Target of rank remapping is too small (%ld < %ld)");
5966 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
5970 gfc_add_block_to_block (&block
, &lse
.post
);
5972 gfc_add_block_to_block (&block
, &rse
.post
);
5975 return gfc_finish_block (&block
);
5979 /* Makes sure se is suitable for passing as a function string parameter. */
5980 /* TODO: Need to check all callers of this function. It may be abused. */
5983 gfc_conv_string_parameter (gfc_se
* se
)
5987 if (TREE_CODE (se
->expr
) == STRING_CST
)
5989 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
5990 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5994 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
5996 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
5998 type
= TREE_TYPE (se
->expr
);
5999 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6003 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6005 type
= build_pointer_type (type
);
6006 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6010 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6014 /* Generate code for assignment of scalar variables. Includes character
6015 strings and derived types with allocatable components.
6016 If you know that the LHS has no allocations, set dealloc to false. */
6019 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6020 bool l_is_temp
, bool r_is_var
, bool dealloc
)
6026 gfc_init_block (&block
);
6028 if (ts
.type
== BT_CHARACTER
)
6033 if (lse
->string_length
!= NULL_TREE
)
6035 gfc_conv_string_parameter (lse
);
6036 gfc_add_block_to_block (&block
, &lse
->pre
);
6037 llen
= lse
->string_length
;
6040 if (rse
->string_length
!= NULL_TREE
)
6042 gcc_assert (rse
->string_length
!= NULL_TREE
);
6043 gfc_conv_string_parameter (rse
);
6044 gfc_add_block_to_block (&block
, &rse
->pre
);
6045 rlen
= rse
->string_length
;
6048 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6049 rse
->expr
, ts
.kind
);
6051 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6055 /* Are the rhs and the lhs the same? */
6058 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6059 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6060 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6061 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6064 /* Deallocate the lhs allocated components as long as it is not
6065 the same as the rhs. This must be done following the assignment
6066 to prevent deallocating data that could be used in the rhs
6068 if (!l_is_temp
&& dealloc
)
6070 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
6071 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
6073 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6075 gfc_add_expr_to_block (&lse
->post
, tmp
);
6078 gfc_add_block_to_block (&block
, &rse
->pre
);
6079 gfc_add_block_to_block (&block
, &lse
->pre
);
6081 gfc_add_modify (&block
, lse
->expr
,
6082 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6084 /* Do a deep copy if the rhs is a variable, if it is not the
6088 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
6089 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6091 gfc_add_expr_to_block (&block
, tmp
);
6094 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
6096 gfc_add_block_to_block (&block
, &lse
->pre
);
6097 gfc_add_block_to_block (&block
, &rse
->pre
);
6098 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
6099 TREE_TYPE (lse
->expr
), rse
->expr
);
6100 gfc_add_modify (&block
, lse
->expr
, tmp
);
6104 gfc_add_block_to_block (&block
, &lse
->pre
);
6105 gfc_add_block_to_block (&block
, &rse
->pre
);
6107 gfc_add_modify (&block
, lse
->expr
,
6108 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6111 gfc_add_block_to_block (&block
, &lse
->post
);
6112 gfc_add_block_to_block (&block
, &rse
->post
);
6114 return gfc_finish_block (&block
);
6118 /* There are quite a lot of restrictions on the optimisation in using an
6119 array function assign without a temporary. */
6122 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
6125 bool seen_array_ref
;
6127 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
6129 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6130 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
6133 /* Elemental functions are scalarized so that they don't need a
6134 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6135 they would need special treatment in gfc_trans_arrayfunc_assign. */
6136 if (expr2
->value
.function
.esym
!= NULL
6137 && expr2
->value
.function
.esym
->attr
.elemental
)
6140 /* Need a temporary if rhs is not FULL or a contiguous section. */
6141 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
6144 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6145 if (gfc_ref_needs_temporary_p (expr1
->ref
))
6148 /* Functions returning pointers or allocatables need temporaries. */
6149 c
= expr2
->value
.function
.esym
6150 ? (expr2
->value
.function
.esym
->attr
.pointer
6151 || expr2
->value
.function
.esym
->attr
.allocatable
)
6152 : (expr2
->symtree
->n
.sym
->attr
.pointer
6153 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
6157 /* Character array functions need temporaries unless the
6158 character lengths are the same. */
6159 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
6161 if (expr1
->ts
.u
.cl
->length
== NULL
6162 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6165 if (expr2
->ts
.u
.cl
->length
== NULL
6166 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6169 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
6170 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
6174 /* Check that no LHS component references appear during an array
6175 reference. This is needed because we do not have the means to
6176 span any arbitrary stride with an array descriptor. This check
6177 is not needed for the rhs because the function result has to be
6179 seen_array_ref
= false;
6180 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
6182 if (ref
->type
== REF_ARRAY
)
6183 seen_array_ref
= true;
6184 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
6188 /* Check for a dependency. */
6189 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
6190 expr2
->value
.function
.esym
,
6191 expr2
->value
.function
.actual
,
6195 /* If we have reached here with an intrinsic function, we do not
6196 need a temporary except in the particular case that reallocation
6197 on assignment is active and the lhs is allocatable and a target. */
6198 if (expr2
->value
.function
.isym
)
6199 return (gfc_option
.flag_realloc_lhs
6200 && sym
->attr
.allocatable
6201 && sym
->attr
.target
);
6203 /* If the LHS is a dummy, we need a temporary if it is not
6205 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
6208 /* If the lhs has been host_associated, is in common, a pointer or is
6209 a target and the function is not using a RESULT variable, aliasing
6210 can occur and a temporary is needed. */
6211 if ((sym
->attr
.host_assoc
6212 || sym
->attr
.in_common
6213 || sym
->attr
.pointer
6214 || sym
->attr
.cray_pointee
6215 || sym
->attr
.target
)
6216 && expr2
->symtree
!= NULL
6217 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
6220 /* A PURE function can unconditionally be called without a temporary. */
6221 if (expr2
->value
.function
.esym
!= NULL
6222 && expr2
->value
.function
.esym
->attr
.pure
)
6225 /* Implicit_pure functions are those which could legally be declared
6227 if (expr2
->value
.function
.esym
!= NULL
6228 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
6231 if (!sym
->attr
.use_assoc
6232 && !sym
->attr
.in_common
6233 && !sym
->attr
.pointer
6234 && !sym
->attr
.target
6235 && !sym
->attr
.cray_pointee
6236 && expr2
->value
.function
.esym
)
6238 /* A temporary is not needed if the function is not contained and
6239 the variable is local or host associated and not a pointer or
6241 if (!expr2
->value
.function
.esym
->attr
.contained
)
6244 /* A temporary is not needed if the lhs has never been host
6245 associated and the procedure is contained. */
6246 else if (!sym
->attr
.host_assoc
)
6249 /* A temporary is not needed if the variable is local and not
6250 a pointer, a target or a result. */
6252 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
6256 /* Default to temporary use. */
6261 /* Provide the loop info so that the lhs descriptor can be built for
6262 reallocatable assignments from extrinsic function calls. */
6265 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
6268 /* Signal that the function call should not be made by
6269 gfc_conv_loop_setup. */
6270 se
->ss
->is_alloc_lhs
= 1;
6271 gfc_init_loopinfo (loop
);
6272 gfc_add_ss_to_loop (loop
, *ss
);
6273 gfc_add_ss_to_loop (loop
, se
->ss
);
6274 gfc_conv_ss_startstride (loop
);
6275 gfc_conv_loop_setup (loop
, where
);
6276 gfc_copy_loopinfo_to_se (se
, loop
);
6277 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
6278 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
6279 se
->ss
->is_alloc_lhs
= 0;
6283 /* For assignment to a reallocatable lhs from intrinsic functions,
6284 replace the se.expr (ie. the result) with a temporary descriptor.
6285 Null the data field so that the library allocates space for the
6286 result. Free the data of the original descriptor after the function,
6287 in case it appears in an argument expression and transfer the
6288 result to the original descriptor. */
6291 fcncall_realloc_result (gfc_se
*se
, int rank
)
6300 /* Use the allocation done by the library. Substitute the lhs
6301 descriptor with a copy, whose data field is nulled.*/
6302 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6303 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
6304 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
6306 /* Unallocated, the descriptor does not have a dtype. */
6307 tmp
= gfc_conv_descriptor_dtype (desc
);
6308 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
6310 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
6311 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
6312 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
6314 /* Free the lhs after the function call and copy the result data to
6315 the lhs descriptor. */
6316 tmp
= gfc_conv_descriptor_data_get (desc
);
6317 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6318 boolean_type_node
, tmp
,
6319 build_int_cst (TREE_TYPE (tmp
), 0));
6320 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
6321 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
6322 gfc_add_expr_to_block (&se
->post
, tmp
);
6324 tmp
= gfc_conv_descriptor_data_get (res_desc
);
6325 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
6327 /* Check that the shapes are the same between lhs and expression. */
6328 for (n
= 0 ; n
< rank
; n
++)
6331 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6332 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
6333 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6334 gfc_array_index_type
, tmp
, tmp1
);
6335 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
6336 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6337 gfc_array_index_type
, tmp
, tmp1
);
6338 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
6339 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6340 gfc_array_index_type
, tmp
, tmp1
);
6341 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6342 boolean_type_node
, tmp
,
6343 gfc_index_zero_node
);
6344 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
6345 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6346 boolean_type_node
, tmp
,
6350 /* 'zero_cond' being true is equal to lhs not being allocated or the
6351 shapes being different. */
6352 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
6354 /* Now reset the bounds returned from the function call to bounds based
6355 on the lhs lbounds, except where the lhs is not allocated or the shapes
6356 of 'variable and 'expr' are different. Set the offset accordingly. */
6357 offset
= gfc_index_zero_node
;
6358 for (n
= 0 ; n
< rank
; n
++)
6362 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6363 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
6364 gfc_array_index_type
, zero_cond
,
6365 gfc_index_one_node
, lbound
);
6366 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
6368 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
6369 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6370 gfc_array_index_type
, tmp
, lbound
);
6371 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
6372 gfc_rank_cst
[n
], lbound
);
6373 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
6374 gfc_rank_cst
[n
], tmp
);
6376 /* Set stride and accumulate the offset. */
6377 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
6378 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
6379 gfc_rank_cst
[n
], tmp
);
6380 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6381 gfc_array_index_type
, lbound
, tmp
);
6382 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6383 gfc_array_index_type
, offset
, tmp
);
6384 offset
= gfc_evaluate_now (offset
, &se
->post
);
6387 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
6392 /* Try to translate array(:) = func (...), where func is a transformational
6393 array function, without using a temporary. Returns NULL if this isn't the
6397 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
6401 gfc_component
*comp
= NULL
;
6404 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
6407 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
6409 gcc_assert (expr2
->value
.function
.isym
6410 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
6411 && comp
&& comp
->attr
.dimension
)
6412 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
6413 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
6415 ss
= gfc_walk_expr (expr1
);
6416 gcc_assert (ss
!= gfc_ss_terminator
);
6417 gfc_init_se (&se
, NULL
);
6418 gfc_start_block (&se
.pre
);
6419 se
.want_pointer
= 1;
6421 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
6423 if (expr1
->ts
.type
== BT_DERIVED
6424 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
6427 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
6429 gfc_add_expr_to_block (&se
.pre
, tmp
);
6432 se
.direct_byref
= 1;
6433 se
.ss
= gfc_walk_expr (expr2
);
6434 gcc_assert (se
.ss
!= gfc_ss_terminator
);
6436 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
6437 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
6438 Clearly, this cannot be done for an allocatable function result, since
6439 the shape of the result is unknown and, in any case, the function must
6440 correctly take care of the reallocation internally. For intrinsic
6441 calls, the array data is freed and the library takes care of allocation.
6442 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
6444 if (gfc_option
.flag_realloc_lhs
6445 && gfc_is_reallocatable_lhs (expr1
)
6446 && !gfc_expr_attr (expr1
).codimension
6447 && !gfc_is_coindexed (expr1
)
6448 && !(expr2
->value
.function
.esym
6449 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
6451 if (!expr2
->value
.function
.isym
)
6453 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
6454 ss
->is_alloc_lhs
= 1;
6457 fcncall_realloc_result (&se
, expr1
->rank
);
6460 gfc_conv_function_expr (&se
, expr2
);
6461 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6463 return gfc_finish_block (&se
.pre
);
6467 /* Try to efficiently translate array(:) = 0. Return NULL if this
6471 gfc_trans_zero_assign (gfc_expr
* expr
)
6473 tree dest
, len
, type
;
6477 sym
= expr
->symtree
->n
.sym
;
6478 dest
= gfc_get_symbol_decl (sym
);
6480 type
= TREE_TYPE (dest
);
6481 if (POINTER_TYPE_P (type
))
6482 type
= TREE_TYPE (type
);
6483 if (!GFC_ARRAY_TYPE_P (type
))
6486 /* Determine the length of the array. */
6487 len
= GFC_TYPE_ARRAY_SIZE (type
);
6488 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
6491 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6492 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
6493 fold_convert (gfc_array_index_type
, tmp
));
6495 /* If we are zeroing a local array avoid taking its address by emitting
6497 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
6498 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6499 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
6501 /* Convert arguments to the correct types. */
6502 dest
= fold_convert (pvoid_type_node
, dest
);
6503 len
= fold_convert (size_type_node
, len
);
6505 /* Construct call to __builtin_memset. */
6506 tmp
= build_call_expr_loc (input_location
,
6507 builtin_decl_explicit (BUILT_IN_MEMSET
),
6508 3, dest
, integer_zero_node
, len
);
6509 return fold_convert (void_type_node
, tmp
);
6513 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
6514 that constructs the call to __builtin_memcpy. */
6517 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
6521 /* Convert arguments to the correct types. */
6522 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
6523 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
6525 dst
= fold_convert (pvoid_type_node
, dst
);
6527 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
6528 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6530 src
= fold_convert (pvoid_type_node
, src
);
6532 len
= fold_convert (size_type_node
, len
);
6534 /* Construct call to __builtin_memcpy. */
6535 tmp
= build_call_expr_loc (input_location
,
6536 builtin_decl_explicit (BUILT_IN_MEMCPY
),
6538 return fold_convert (void_type_node
, tmp
);
6542 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
6543 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
6544 source/rhs, both are gfc_full_array_ref_p which have been checked for
6548 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
6550 tree dst
, dlen
, dtype
;
6551 tree src
, slen
, stype
;
6554 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
6555 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
6557 dtype
= TREE_TYPE (dst
);
6558 if (POINTER_TYPE_P (dtype
))
6559 dtype
= TREE_TYPE (dtype
);
6560 stype
= TREE_TYPE (src
);
6561 if (POINTER_TYPE_P (stype
))
6562 stype
= TREE_TYPE (stype
);
6564 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
6567 /* Determine the lengths of the arrays. */
6568 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
6569 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
6571 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
6572 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6573 dlen
, fold_convert (gfc_array_index_type
, tmp
));
6575 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
6576 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
6578 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
6579 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6580 slen
, fold_convert (gfc_array_index_type
, tmp
));
6582 /* Sanity check that they are the same. This should always be
6583 the case, as we should already have checked for conformance. */
6584 if (!tree_int_cst_equal (slen
, dlen
))
6587 return gfc_build_memcpy_call (dst
, src
, dlen
);
6591 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
6592 this can't be done. EXPR1 is the destination/lhs for which
6593 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
6596 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
6598 unsigned HOST_WIDE_INT nelem
;
6604 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
6608 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
6609 dtype
= TREE_TYPE (dst
);
6610 if (POINTER_TYPE_P (dtype
))
6611 dtype
= TREE_TYPE (dtype
);
6612 if (!GFC_ARRAY_TYPE_P (dtype
))
6615 /* Determine the lengths of the array. */
6616 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
6617 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
6620 /* Confirm that the constructor is the same size. */
6621 if (compare_tree_int (len
, nelem
) != 0)
6624 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
6625 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
6626 fold_convert (gfc_array_index_type
, tmp
));
6628 stype
= gfc_typenode_for_spec (&expr2
->ts
);
6629 src
= gfc_build_constant_array_constructor (expr2
, stype
);
6631 stype
= TREE_TYPE (src
);
6632 if (POINTER_TYPE_P (stype
))
6633 stype
= TREE_TYPE (stype
);
6635 return gfc_build_memcpy_call (dst
, src
, len
);
6639 /* Tells whether the expression is to be treated as a variable reference. */
6642 expr_is_variable (gfc_expr
*expr
)
6646 if (expr
->expr_type
== EXPR_VARIABLE
)
6649 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
6652 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
6653 return expr_is_variable (arg
);
6660 /* Is the lhs OK for automatic reallocation? */
6663 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
6667 /* An allocatable variable with no reference. */
6668 if (expr
->symtree
->n
.sym
->attr
.allocatable
6672 /* All that can be left are allocatable components. */
6673 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
6674 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
6675 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
6678 /* Find an allocatable component ref last. */
6679 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6680 if (ref
->type
== REF_COMPONENT
6682 && ref
->u
.c
.component
->attr
.allocatable
)
6689 /* Allocate or reallocate scalar lhs, as necessary. */
6692 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
6706 if (!expr1
|| expr1
->rank
)
6709 if (!expr2
|| expr2
->rank
)
6712 /* Since this is a scalar lhs, we can afford to do this. That is,
6713 there is no risk of side effects being repeated. */
6714 gfc_init_se (&lse
, NULL
);
6715 lse
.want_pointer
= 1;
6716 gfc_conv_expr (&lse
, expr1
);
6718 jump_label1
= gfc_build_label_decl (NULL_TREE
);
6719 jump_label2
= gfc_build_label_decl (NULL_TREE
);
6721 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
6722 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
6723 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6725 tmp
= build3_v (COND_EXPR
, cond
,
6726 build1_v (GOTO_EXPR
, jump_label1
),
6727 build_empty_stmt (input_location
));
6728 gfc_add_expr_to_block (block
, tmp
);
6730 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6732 /* Use the rhs string length and the lhs element size. */
6733 size
= string_length
;
6734 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
6735 tmp
= TYPE_SIZE_UNIT (tmp
);
6736 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
6737 TREE_TYPE (tmp
), tmp
,
6738 fold_convert (TREE_TYPE (tmp
), size
));
6742 /* Otherwise use the length in bytes of the rhs. */
6743 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
6744 size_in_bytes
= size
;
6747 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
6749 tmp
= build_call_expr_loc (input_location
,
6750 builtin_decl_explicit (BUILT_IN_CALLOC
),
6751 2, build_one_cst (size_type_node
),
6753 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
6754 gfc_add_modify (block
, lse
.expr
, tmp
);
6758 tmp
= build_call_expr_loc (input_location
,
6759 builtin_decl_explicit (BUILT_IN_MALLOC
),
6761 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
6762 gfc_add_modify (block
, lse
.expr
, tmp
);
6765 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6767 /* Deferred characters need checking for lhs and rhs string
6768 length. Other deferred parameter variables will have to
6770 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
6771 gfc_add_expr_to_block (block
, tmp
);
6773 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
6774 gfc_add_expr_to_block (block
, tmp
);
6776 /* For a deferred length character, reallocate if lengths of lhs and
6777 rhs are different. */
6778 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6780 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6781 expr1
->ts
.u
.cl
->backend_decl
, size
);
6782 /* Jump past the realloc if the lengths are the same. */
6783 tmp
= build3_v (COND_EXPR
, cond
,
6784 build1_v (GOTO_EXPR
, jump_label2
),
6785 build_empty_stmt (input_location
));
6786 gfc_add_expr_to_block (block
, tmp
);
6787 tmp
= build_call_expr_loc (input_location
,
6788 builtin_decl_explicit (BUILT_IN_REALLOC
),
6789 2, fold_convert (pvoid_type_node
, lse
.expr
),
6791 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
6792 gfc_add_modify (block
, lse
.expr
, tmp
);
6793 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
6794 gfc_add_expr_to_block (block
, tmp
);
6796 /* Update the lhs character length. */
6797 size
= string_length
;
6798 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
6803 /* Subroutine of gfc_trans_assignment that actually scalarizes the
6804 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
6805 init_flag indicates initialization expressions and dealloc that no
6806 deallocate prior assignment is needed (if in doubt, set true). */
6809 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
6815 gfc_ss
*lss_section
;
6822 bool scalar_to_array
;
6827 /* Assignment of the form lhs = rhs. */
6828 gfc_start_block (&block
);
6830 gfc_init_se (&lse
, NULL
);
6831 gfc_init_se (&rse
, NULL
);
6834 lss
= gfc_walk_expr (expr1
);
6835 if (gfc_is_reallocatable_lhs (expr1
)
6836 && !(expr2
->expr_type
== EXPR_FUNCTION
6837 && expr2
->value
.function
.isym
!= NULL
))
6838 lss
->is_alloc_lhs
= 1;
6840 if (lss
!= gfc_ss_terminator
)
6842 /* The assignment needs scalarization. */
6845 /* Find a non-scalar SS from the lhs. */
6846 while (lss_section
!= gfc_ss_terminator
6847 && lss_section
->info
->type
!= GFC_SS_SECTION
)
6848 lss_section
= lss_section
->next
;
6850 gcc_assert (lss_section
!= gfc_ss_terminator
);
6852 /* Initialize the scalarizer. */
6853 gfc_init_loopinfo (&loop
);
6856 rss
= gfc_walk_expr (expr2
);
6857 if (rss
== gfc_ss_terminator
)
6858 /* The rhs is scalar. Add a ss for the expression. */
6859 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
6861 /* Associate the SS with the loop. */
6862 gfc_add_ss_to_loop (&loop
, lss
);
6863 gfc_add_ss_to_loop (&loop
, rss
);
6865 /* Calculate the bounds of the scalarization. */
6866 gfc_conv_ss_startstride (&loop
);
6867 /* Enable loop reversal. */
6868 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
6869 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
6870 /* Resolve any data dependencies in the statement. */
6871 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
6872 /* Setup the scalarizing loops. */
6873 gfc_conv_loop_setup (&loop
, &expr2
->where
);
6875 /* Setup the gfc_se structures. */
6876 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6877 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6880 gfc_mark_ss_chain_used (rss
, 1);
6881 if (loop
.temp_ss
== NULL
)
6884 gfc_mark_ss_chain_used (lss
, 1);
6888 lse
.ss
= loop
.temp_ss
;
6889 gfc_mark_ss_chain_used (lss
, 3);
6890 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
6893 /* Allow the scalarizer to workshare array assignments. */
6894 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
6895 ompws_flags
|= OMPWS_SCALARIZER_WS
;
6897 /* Start the scalarized loop body. */
6898 gfc_start_scalarized_body (&loop
, &body
);
6901 gfc_init_block (&body
);
6903 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
6905 /* Translate the expression. */
6906 gfc_conv_expr (&rse
, expr2
);
6908 /* Stabilize a string length for temporaries. */
6909 if (expr2
->ts
.type
== BT_CHARACTER
)
6910 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
6912 string_length
= NULL_TREE
;
6916 gfc_conv_tmp_array_ref (&lse
);
6917 if (expr2
->ts
.type
== BT_CHARACTER
)
6918 lse
.string_length
= string_length
;
6921 gfc_conv_expr (&lse
, expr1
);
6923 /* Assignments of scalar derived types with allocatable components
6924 to arrays must be done with a deep copy and the rhs temporary
6925 must have its components deallocated afterwards. */
6926 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
6927 && expr2
->ts
.u
.derived
->attr
.alloc_comp
6928 && !expr_is_variable (expr2
)
6929 && !gfc_is_constant_expr (expr2
)
6930 && expr1
->rank
&& !expr2
->rank
);
6931 if (scalar_to_array
&& dealloc
)
6933 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
6934 gfc_add_expr_to_block (&loop
.post
, tmp
);
6937 /* For a deferred character length function, the function call must
6938 happen before the (re)allocation of the lhs, otherwise the character
6939 length of the result is not known. */
6940 def_clen_func
= (((expr2
->expr_type
== EXPR_FUNCTION
)
6941 || (expr2
->expr_type
== EXPR_COMPCALL
)
6942 || (expr2
->expr_type
== EXPR_PPC
))
6943 && expr2
->ts
.deferred
);
6944 if (gfc_option
.flag_realloc_lhs
6945 && expr2
->ts
.type
== BT_CHARACTER
6946 && (def_clen_func
|| expr2
->expr_type
== EXPR_OP
)
6947 && expr1
->ts
.deferred
)
6948 gfc_add_block_to_block (&block
, &rse
.pre
);
6950 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
6951 l_is_temp
|| init_flag
,
6952 expr_is_variable (expr2
) || scalar_to_array
6953 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
6954 gfc_add_expr_to_block (&body
, tmp
);
6956 if (lss
== gfc_ss_terminator
)
6958 /* F2003: Add the code for reallocation on assignment. */
6959 if (gfc_option
.flag_realloc_lhs
6960 && is_scalar_reallocatable_lhs (expr1
))
6961 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
6964 /* Use the scalar assignment as is. */
6965 gfc_add_block_to_block (&block
, &body
);
6969 gcc_assert (lse
.ss
== gfc_ss_terminator
6970 && rse
.ss
== gfc_ss_terminator
);
6974 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
6976 /* We need to copy the temporary to the actual lhs. */
6977 gfc_init_se (&lse
, NULL
);
6978 gfc_init_se (&rse
, NULL
);
6979 gfc_copy_loopinfo_to_se (&lse
, &loop
);
6980 gfc_copy_loopinfo_to_se (&rse
, &loop
);
6982 rse
.ss
= loop
.temp_ss
;
6985 gfc_conv_tmp_array_ref (&rse
);
6986 gfc_conv_expr (&lse
, expr1
);
6988 gcc_assert (lse
.ss
== gfc_ss_terminator
6989 && rse
.ss
== gfc_ss_terminator
);
6991 if (expr2
->ts
.type
== BT_CHARACTER
)
6992 rse
.string_length
= string_length
;
6994 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
6995 false, false, dealloc
);
6996 gfc_add_expr_to_block (&body
, tmp
);
6999 /* F2003: Allocate or reallocate lhs of allocatable array. */
7000 if (gfc_option
.flag_realloc_lhs
7001 && gfc_is_reallocatable_lhs (expr1
)
7002 && !gfc_expr_attr (expr1
).codimension
7003 && !gfc_is_coindexed (expr1
))
7005 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
7006 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
7007 if (tmp
!= NULL_TREE
)
7008 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
7011 /* Generate the copying loops. */
7012 gfc_trans_scalarizing_loops (&loop
, &body
);
7014 /* Wrap the whole thing up. */
7015 gfc_add_block_to_block (&block
, &loop
.pre
);
7016 gfc_add_block_to_block (&block
, &loop
.post
);
7018 gfc_cleanup_loop (&loop
);
7021 return gfc_finish_block (&block
);
7025 /* Check whether EXPR is a copyable array. */
7028 copyable_array_p (gfc_expr
* expr
)
7030 if (expr
->expr_type
!= EXPR_VARIABLE
)
7033 /* First check it's an array. */
7034 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
7037 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
7040 /* Next check that it's of a simple enough type. */
7041 switch (expr
->ts
.type
)
7053 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
7062 /* Translate an assignment. */
7065 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7070 /* Special case a single function returning an array. */
7071 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
7073 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
7078 /* Special case assigning an array to zero. */
7079 if (copyable_array_p (expr1
)
7080 && is_zero_initializer_p (expr2
))
7082 tmp
= gfc_trans_zero_assign (expr1
);
7087 /* Special case copying one array to another. */
7088 if (copyable_array_p (expr1
)
7089 && copyable_array_p (expr2
)
7090 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
7091 && !gfc_check_dependency (expr1
, expr2
, 0))
7093 tmp
= gfc_trans_array_copy (expr1
, expr2
);
7098 /* Special case initializing an array from a constant array constructor. */
7099 if (copyable_array_p (expr1
)
7100 && expr2
->expr_type
== EXPR_ARRAY
7101 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
7103 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
7108 /* Fallback to the scalarizer to generate explicit loops. */
7109 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
7113 gfc_trans_init_assign (gfc_code
* code
)
7115 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
7119 gfc_trans_assign (gfc_code
* code
)
7121 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);