1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
30 #include "diagnostic-core.h" /* For fatal_error. */
31 #include "langhooks.h"
35 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar
, symbol_attribute attr
)
51 enum gfc_array_kind akind
;
54 akind
= GFC_ARRAY_POINTER_CONT
;
55 else if (attr
.allocatable
)
56 akind
= GFC_ARRAY_ALLOCATABLE
;
58 akind
= GFC_ARRAY_ASSUMED_SHAPE_CONT
;
60 return gfc_get_array_type_bounds (TREE_TYPE (scalar
), 0, 0, NULL
, NULL
, 1,
61 akind
, !(attr
.pointer
|| attr
.target
));
65 conv_scalar_to_descriptor (gfc_se
*se
, tree scalar
, symbol_attribute attr
)
69 type
= get_scalar_to_descriptor_type (scalar
, attr
);
70 desc
= gfc_create_var (type
, "desc");
71 DECL_ARTIFICIAL (desc
) = 1;
72 gfc_add_modify (&se
->pre
, gfc_conv_descriptor_dtype (desc
),
73 gfc_get_dtype (type
));
74 gfc_conv_descriptor_data_set (&se
->pre
, desc
, scalar
);
76 /* Copy pointer address back - but only if it could have changed and
77 if the actual argument is a pointer and not, e.g., NULL(). */
78 if ((attr
.pointer
|| attr
.allocatable
)
79 && attr
.intent
!= INTENT_IN
&& POINTER_TYPE_P (TREE_TYPE (scalar
)))
80 gfc_add_modify (&se
->post
, scalar
,
81 fold_convert (TREE_TYPE (scalar
),
82 gfc_conv_descriptor_data_get (desc
)));
87 /* This is the seed for an eventual trans-class.c
89 The following parameters should not be used directly since they might
90 in future implementations. Use the corresponding APIs. */
91 #define CLASS_DATA_FIELD 0
92 #define CLASS_VPTR_FIELD 1
93 #define VTABLE_HASH_FIELD 0
94 #define VTABLE_SIZE_FIELD 1
95 #define VTABLE_EXTENDS_FIELD 2
96 #define VTABLE_DEF_INIT_FIELD 3
97 #define VTABLE_COPY_FIELD 4
101 gfc_class_data_get (tree decl
)
104 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
105 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
106 data
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
108 return fold_build3_loc (input_location
, COMPONENT_REF
,
109 TREE_TYPE (data
), decl
, data
,
115 gfc_class_vptr_get (tree decl
)
118 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
119 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
120 vptr
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl
)),
122 return fold_build3_loc (input_location
, COMPONENT_REF
,
123 TREE_TYPE (vptr
), decl
, vptr
,
129 gfc_vtable_field_get (tree decl
, int field
)
133 vptr
= gfc_class_vptr_get (decl
);
134 vptr
= build_fold_indirect_ref_loc (input_location
, vptr
);
135 size
= gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr
)),
137 size
= fold_build3_loc (input_location
, COMPONENT_REF
,
138 TREE_TYPE (size
), vptr
, size
,
140 /* Always return size as an array index type. */
141 if (field
== VTABLE_SIZE_FIELD
)
142 size
= fold_convert (gfc_array_index_type
, size
);
149 gfc_vtable_hash_get (tree decl
)
151 return gfc_vtable_field_get (decl
, VTABLE_HASH_FIELD
);
156 gfc_vtable_size_get (tree decl
)
158 return gfc_vtable_field_get (decl
, VTABLE_SIZE_FIELD
);
163 gfc_vtable_extends_get (tree decl
)
165 return gfc_vtable_field_get (decl
, VTABLE_EXTENDS_FIELD
);
170 gfc_vtable_def_init_get (tree decl
)
172 return gfc_vtable_field_get (decl
, VTABLE_DEF_INIT_FIELD
);
177 gfc_vtable_copy_get (tree decl
)
179 return gfc_vtable_field_get (decl
, VTABLE_COPY_FIELD
);
183 #undef CLASS_DATA_FIELD
184 #undef CLASS_VPTR_FIELD
185 #undef VTABLE_HASH_FIELD
186 #undef VTABLE_SIZE_FIELD
187 #undef VTABLE_EXTENDS_FIELD
188 #undef VTABLE_DEF_INIT_FIELD
189 #undef VTABLE_COPY_FIELD
192 /* Obtain the vptr of the last class reference in an expression. */
195 gfc_get_vptr_from_expr (tree expr
)
198 while (tmp
&& !GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
199 tmp
= TREE_OPERAND (tmp
, 0);
200 tmp
= gfc_class_vptr_get (tmp
);
206 class_array_data_assign (stmtblock_t
*block
, tree lhs_desc
, tree rhs_desc
,
209 tree tmp
, tmp2
, type
;
211 gfc_conv_descriptor_data_set (block
, lhs_desc
,
212 gfc_conv_descriptor_data_get (rhs_desc
));
213 gfc_conv_descriptor_offset_set (block
, lhs_desc
,
214 gfc_conv_descriptor_offset_get (rhs_desc
));
216 gfc_add_modify (block
, gfc_conv_descriptor_dtype (lhs_desc
),
217 gfc_conv_descriptor_dtype (rhs_desc
));
219 /* Assign the dimension as range-ref. */
220 tmp
= gfc_get_descriptor_dimension (lhs_desc
);
221 tmp2
= gfc_get_descriptor_dimension (rhs_desc
);
223 type
= lhs_type
? TREE_TYPE (tmp
) : TREE_TYPE (tmp2
);
224 tmp
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp
,
225 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
226 tmp2
= build4_loc (input_location
, ARRAY_RANGE_REF
, type
, tmp2
,
227 gfc_index_zero_node
, NULL_TREE
, NULL_TREE
);
228 gfc_add_modify (block
, tmp
, tmp2
);
232 /* Takes a derived type expression and returns the address of a temporary
233 class object of the 'declared' type. If vptr is not NULL, this is
234 used for the temporary class object. */
236 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
237 gfc_typespec class_ts
, tree vptr
)
245 /* The derived type needs to be converted to a temporary
247 tmp
= gfc_typenode_for_spec (&class_ts
);
248 var
= gfc_create_var (tmp
, "class");
251 ctree
= gfc_class_vptr_get (var
);
253 if (vptr
!= NULL_TREE
)
255 /* Use the dynamic vptr. */
260 /* In this case the vtab corresponds to the derived type and the
261 vptr must point to it. */
262 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
264 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
266 gfc_add_modify (&parmse
->pre
, ctree
,
267 fold_convert (TREE_TYPE (ctree
), tmp
));
269 /* Now set the data field. */
270 ctree
= gfc_class_data_get (var
);
272 if (parmse
->ss
&& parmse
->ss
->info
->useflags
)
274 /* For an array reference in an elemental procedure call we need
275 to retain the ss to provide the scalarized array reference. */
276 gfc_conv_expr_reference (parmse
, e
);
277 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
278 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
282 ss
= gfc_walk_expr (e
);
283 if (ss
== gfc_ss_terminator
)
286 gfc_conv_expr_reference (parmse
, e
);
288 /* Scalar to an assumed-rank array. */
289 if (class_ts
.u
.derived
->components
->as
)
292 type
= get_scalar_to_descriptor_type (parmse
->expr
,
294 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
295 gfc_get_dtype (type
));
296 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
, parmse
->expr
);
300 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
301 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
307 gfc_conv_expr_descriptor (parmse
, e
);
309 if (e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
310 class_array_data_assign (&parmse
->pre
, ctree
, parmse
->expr
, true);
312 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
316 /* Pass the address of the class object. */
317 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
321 /* Takes a scalarized class array expression and returns the
322 address of a temporary scalar class object of the 'declared'
324 OOP-TODO: This could be improved by adding code that branched on
325 the dynamic type being the same as the declared type. In this case
326 the original class expression can be passed directly. */
328 gfc_conv_class_to_class (gfc_se
*parmse
, gfc_expr
*e
,
329 gfc_typespec class_ts
, bool elemental
)
337 bool full_array
= false;
340 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
342 if (ref
->type
== REF_COMPONENT
343 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
346 if (ref
->next
== NULL
)
350 if ((ref
== NULL
|| class_ref
== ref
)
351 && (!class_ts
.u
.derived
->components
->as
352 || class_ts
.u
.derived
->components
->as
->rank
!= -1))
355 /* Test for FULL_ARRAY. */
356 gfc_is_class_array_ref (e
, &full_array
);
358 /* The derived type needs to be converted to a temporary
360 tmp
= gfc_typenode_for_spec (&class_ts
);
361 var
= gfc_create_var (tmp
, "class");
364 ctree
= gfc_class_data_get (var
);
365 if (class_ts
.u
.derived
->components
->as
366 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
370 tree type
= get_scalar_to_descriptor_type (parmse
->expr
,
372 gfc_add_modify (&parmse
->pre
, gfc_conv_descriptor_dtype (ctree
),
373 gfc_get_dtype (type
));
374 gfc_conv_descriptor_data_set (&parmse
->pre
, ctree
,
375 gfc_class_data_get (parmse
->expr
));
379 class_array_data_assign (&parmse
->pre
, ctree
, parmse
->expr
, false);
382 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
384 /* Return the data component, except in the case of scalarized array
385 references, where nullification of the cannot occur and so there
387 if (!elemental
&& full_array
)
389 if (class_ts
.u
.derived
->components
->as
390 && e
->rank
!= class_ts
.u
.derived
->components
->as
->rank
)
393 gfc_add_modify (&parmse
->post
, gfc_class_data_get (parmse
->expr
),
394 gfc_conv_descriptor_data_get (ctree
));
396 class_array_data_assign (&parmse
->post
, parmse
->expr
, ctree
, true);
399 gfc_add_modify (&parmse
->post
, parmse
->expr
, ctree
);
403 ctree
= gfc_class_vptr_get (var
);
405 /* The vptr is the second field of the actual argument.
406 First we have to find the corresponding class reference. */
409 if (class_ref
== NULL
410 && e
->symtree
&& e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
411 tmp
= e
->symtree
->n
.sym
->backend_decl
;
414 /* Remove everything after the last class reference, convert the
415 expression and then recover its tailend once more. */
417 ref
= class_ref
->next
;
418 class_ref
->next
= NULL
;
419 gfc_init_se (&tmpse
, NULL
);
420 gfc_conv_expr (&tmpse
, e
);
421 class_ref
->next
= ref
;
425 gcc_assert (tmp
!= NULL_TREE
);
427 /* Dereference if needs be. */
428 if (TREE_CODE (TREE_TYPE (tmp
)) == REFERENCE_TYPE
)
429 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
431 vptr
= gfc_class_vptr_get (tmp
);
432 gfc_add_modify (&parmse
->pre
, ctree
,
433 fold_convert (TREE_TYPE (ctree
), vptr
));
435 /* Return the vptr component, except in the case of scalarized array
436 references, where the dynamic type cannot change. */
437 if (!elemental
&& full_array
)
438 gfc_add_modify (&parmse
->post
, vptr
,
439 fold_convert (TREE_TYPE (vptr
), ctree
));
441 /* Pass the address of the class object. */
442 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
446 /* Given a class array declaration and an index, returns the address
447 of the referenced element. */
450 gfc_get_class_array_ref (tree index
, tree class_decl
)
452 tree data
= gfc_class_data_get (class_decl
);
453 tree size
= gfc_vtable_size_get (class_decl
);
454 tree offset
= fold_build2_loc (input_location
, MULT_EXPR
,
455 gfc_array_index_type
,
458 data
= gfc_conv_descriptor_data_get (data
);
459 ptr
= fold_convert (pvoid_type_node
, data
);
460 ptr
= fold_build_pointer_plus_loc (input_location
, ptr
, offset
);
461 return fold_convert (TREE_TYPE (data
), ptr
);
465 /* Copies one class expression to another, assuming that if either
466 'to' or 'from' are arrays they are packed. Should 'from' be
467 NULL_TREE, the initialization expression for 'to' is used, assuming
468 that the _vptr is set. */
471 gfc_copy_class_to_class (tree from
, tree to
, tree nelems
)
482 stmtblock_t loopbody
;
488 if (from
!= NULL_TREE
)
489 fcn
= gfc_vtable_copy_get (from
);
491 fcn
= gfc_vtable_copy_get (to
);
493 fcn_type
= TREE_TYPE (TREE_TYPE (fcn
));
495 if (from
!= NULL_TREE
)
496 from_data
= gfc_class_data_get (from
);
498 from_data
= gfc_vtable_def_init_get (to
);
500 to_data
= gfc_class_data_get (to
);
502 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data
)))
504 gfc_init_block (&body
);
505 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
506 gfc_array_index_type
, nelems
,
508 nelems
= gfc_evaluate_now (tmp
, &body
);
509 index
= gfc_create_var (gfc_array_index_type
, "S");
511 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)))
513 from_ref
= gfc_get_class_array_ref (index
, from
);
514 VEC_safe_push (tree
, gc
, args
, from_ref
);
517 VEC_safe_push (tree
, gc
, args
, from_data
);
519 to_ref
= gfc_get_class_array_ref (index
, to
);
520 VEC_safe_push (tree
, gc
, args
, to_ref
);
522 tmp
= build_call_vec (fcn_type
, fcn
, args
);
524 /* Build the body of the loop. */
525 gfc_init_block (&loopbody
);
526 gfc_add_expr_to_block (&loopbody
, tmp
);
528 /* Build the loop and return. */
529 gfc_init_loopinfo (&loop
);
531 loop
.from
[0] = gfc_index_zero_node
;
532 loop
.loopvar
[0] = index
;
534 gfc_trans_scalarizing_loops (&loop
, &loopbody
);
535 gfc_add_block_to_block (&body
, &loop
.pre
);
536 tmp
= gfc_finish_block (&body
);
537 gfc_cleanup_loop (&loop
);
541 gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data
)));
542 VEC_safe_push (tree
, gc
, args
, from_data
);
543 VEC_safe_push (tree
, gc
, args
, to_data
);
544 tmp
= build_call_vec (fcn_type
, fcn
, args
);
551 gfc_trans_class_array_init_assign (gfc_expr
*rhs
, gfc_expr
*lhs
, gfc_expr
*obj
)
553 gfc_actual_arglist
*actual
;
558 actual
= gfc_get_actual_arglist ();
559 actual
->expr
= gfc_copy_expr (rhs
);
560 actual
->next
= gfc_get_actual_arglist ();
561 actual
->next
->expr
= gfc_copy_expr (lhs
);
562 ppc
= gfc_copy_expr (obj
);
563 gfc_add_vptr_component (ppc
);
564 gfc_add_component_ref (ppc
, "_copy");
565 ppc_code
= gfc_get_code ();
566 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
567 /* Although '_copy' is set to be elemental in class.c, it is
568 not staying that way. Find out why, sometime.... */
569 ppc_code
->resolved_sym
->attr
.elemental
= 1;
570 ppc_code
->ext
.actual
= actual
;
571 ppc_code
->expr1
= ppc
;
572 ppc_code
->op
= EXEC_CALL
;
573 /* Since '_copy' is elemental, the scalarizer will take care
574 of arrays in gfc_trans_call. */
575 res
= gfc_trans_call (ppc_code
, false, NULL
, NULL
, false);
576 gfc_free_statements (ppc_code
);
580 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
581 A MEMCPY is needed to copy the full data from the default initializer
582 of the dynamic type. */
585 gfc_trans_class_init_assign (gfc_code
*code
)
589 gfc_se dst
,src
,memsz
;
590 gfc_expr
*lhs
, *rhs
, *sz
;
592 gfc_start_block (&block
);
594 lhs
= gfc_copy_expr (code
->expr1
);
595 gfc_add_data_component (lhs
);
597 rhs
= gfc_copy_expr (code
->expr1
);
598 gfc_add_vptr_component (rhs
);
600 /* Make sure that the component backend_decls have been built, which
601 will not have happened if the derived types concerned have not
603 gfc_get_derived_type (rhs
->ts
.u
.derived
);
604 gfc_add_def_init_component (rhs
);
606 if (code
->expr1
->ts
.type
== BT_CLASS
607 && CLASS_DATA (code
->expr1
)->attr
.dimension
)
608 tmp
= gfc_trans_class_array_init_assign (rhs
, lhs
, code
->expr1
);
611 sz
= gfc_copy_expr (code
->expr1
);
612 gfc_add_vptr_component (sz
);
613 gfc_add_size_component (sz
);
615 gfc_init_se (&dst
, NULL
);
616 gfc_init_se (&src
, NULL
);
617 gfc_init_se (&memsz
, NULL
);
618 gfc_conv_expr (&dst
, lhs
);
619 gfc_conv_expr (&src
, rhs
);
620 gfc_conv_expr (&memsz
, sz
);
621 gfc_add_block_to_block (&block
, &src
.pre
);
622 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
625 if (code
->expr1
->symtree
->n
.sym
->attr
.optional
626 || code
->expr1
->symtree
->n
.sym
->ns
->proc_name
->attr
.entry_master
)
628 tree present
= gfc_conv_expr_present (code
->expr1
->symtree
->n
.sym
);
629 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
631 build_empty_stmt (input_location
));
634 gfc_add_expr_to_block (&block
, tmp
);
636 return gfc_finish_block (&block
);
640 /* Translate an assignment to a CLASS object
641 (pointer or ordinary assignment). */
644 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
652 gfc_start_block (&block
);
655 while (ref
&& ref
->next
)
658 /* Class valued proc_pointer assignments do not need any further
660 if (ref
&& ref
->type
== REF_COMPONENT
661 && ref
->u
.c
.component
->attr
.proc_pointer
662 && expr2
->expr_type
== EXPR_VARIABLE
663 && expr2
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
664 && op
== EXEC_POINTER_ASSIGN
)
667 if (expr2
->ts
.type
!= BT_CLASS
)
669 /* Insert an additional assignment which sets the '_vptr' field. */
670 gfc_symbol
*vtab
= NULL
;
673 lhs
= gfc_copy_expr (expr1
);
674 gfc_add_vptr_component (lhs
);
676 if (expr2
->ts
.type
== BT_DERIVED
)
677 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
678 else if (expr2
->expr_type
== EXPR_NULL
)
679 vtab
= gfc_find_derived_vtab (expr1
->ts
.u
.derived
);
682 rhs
= gfc_get_expr ();
683 rhs
->expr_type
= EXPR_VARIABLE
;
684 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
688 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
689 gfc_add_expr_to_block (&block
, tmp
);
694 else if (CLASS_DATA (expr2
)->attr
.dimension
)
696 /* Insert an additional assignment which sets the '_vptr' field. */
697 lhs
= gfc_copy_expr (expr1
);
698 gfc_add_vptr_component (lhs
);
700 rhs
= gfc_copy_expr (expr2
);
701 gfc_add_vptr_component (rhs
);
703 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
704 gfc_add_expr_to_block (&block
, tmp
);
710 /* Do the actual CLASS assignment. */
711 if (expr2
->ts
.type
== BT_CLASS
712 && !CLASS_DATA (expr2
)->attr
.dimension
)
715 gfc_add_data_component (expr1
);
719 if (op
== EXEC_ASSIGN
)
720 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
721 else if (op
== EXEC_POINTER_ASSIGN
)
722 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
726 gfc_add_expr_to_block (&block
, tmp
);
728 return gfc_finish_block (&block
);
732 /* End of prototype trans-class.c */
736 realloc_lhs_warning (bt type
, bool array
, locus
*where
)
738 if (array
&& type
!= BT_CLASS
&& type
!= BT_DERIVED
739 && gfc_option
.warn_realloc_lhs
)
740 gfc_warning ("Code for reallocating the allocatable array at %L will "
742 else if (gfc_option
.warn_realloc_lhs_all
)
743 gfc_warning ("Code for reallocating the allocatable variable at %L "
744 "will be added", where
);
748 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
749 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
752 /* Copy the scalarization loop variables. */
755 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
758 dest
->loop
= src
->loop
;
762 /* Initialize a simple expression holder.
764 Care must be taken when multiple se are created with the same parent.
765 The child se must be kept in sync. The easiest way is to delay creation
766 of a child se until after after the previous se has been translated. */
769 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
771 memset (se
, 0, sizeof (gfc_se
));
772 gfc_init_block (&se
->pre
);
773 gfc_init_block (&se
->post
);
778 gfc_copy_se_loopvars (se
, parent
);
782 /* Advances to the next SS in the chain. Use this rather than setting
783 se->ss = se->ss->next because all the parents needs to be kept in sync.
787 gfc_advance_se_ss_chain (gfc_se
* se
)
792 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
795 /* Walk down the parent chain. */
798 /* Simple consistency check. */
799 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
800 || p
->parent
->ss
->nested_ss
== p
->ss
);
802 /* If we were in a nested loop, the next scalarized expression can be
803 on the parent ss' next pointer. Thus we should not take the next
804 pointer blindly, but rather go up one nest level as long as next
805 is the end of chain. */
807 while (ss
->next
== gfc_ss_terminator
&& ss
->parent
!= NULL
)
817 /* Ensures the result of the expression as either a temporary variable
818 or a constant so that it can be used repeatedly. */
821 gfc_make_safe_expr (gfc_se
* se
)
825 if (CONSTANT_CLASS_P (se
->expr
))
828 /* We need a temporary for this result. */
829 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
830 gfc_add_modify (&se
->pre
, var
, se
->expr
);
835 /* Return an expression which determines if a dummy parameter is present.
836 Also used for arguments to procedures with multiple entry points. */
839 gfc_conv_expr_present (gfc_symbol
* sym
)
843 gcc_assert (sym
->attr
.dummy
);
845 decl
= gfc_get_symbol_decl (sym
);
846 if (TREE_CODE (decl
) != PARM_DECL
)
848 /* Array parameters use a temporary descriptor, we want the real
850 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
851 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
852 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
855 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, decl
,
856 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
858 /* Fortran 2008 allows to pass null pointers and non-associated pointers
859 as actual argument to denote absent dummies. For array descriptors,
860 we thus also need to check the array descriptor. */
861 if (!sym
->attr
.pointer
&& !sym
->attr
.allocatable
862 && sym
->as
&& (sym
->as
->type
== AS_ASSUMED_SHAPE
863 || sym
->as
->type
== AS_ASSUMED_RANK
)
864 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
867 tmp
= build_fold_indirect_ref_loc (input_location
, decl
);
868 tmp
= gfc_conv_array_data (tmp
);
869 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
870 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
871 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
872 boolean_type_node
, cond
, tmp
);
879 /* Converts a missing, dummy argument into a null or zero. */
882 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
887 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
891 /* Create a temporary and convert it to the correct type. */
892 tmp
= gfc_get_int_type (kind
);
893 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
896 /* Test for a NULL value. */
897 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
898 tmp
, fold_convert (TREE_TYPE (tmp
), integer_one_node
));
899 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
900 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
904 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (se
->expr
),
906 build_zero_cst (TREE_TYPE (se
->expr
)));
907 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
911 if (ts
.type
== BT_CHARACTER
)
913 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
914 tmp
= fold_build3_loc (input_location
, COND_EXPR
, gfc_charlen_type_node
,
915 present
, se
->string_length
, tmp
);
916 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
917 se
->string_length
= tmp
;
923 /* Get the character length of an expression, looking through gfc_refs
927 gfc_get_expr_charlen (gfc_expr
*e
)
932 gcc_assert (e
->expr_type
== EXPR_VARIABLE
933 && e
->ts
.type
== BT_CHARACTER
);
935 length
= NULL
; /* To silence compiler warning. */
937 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
940 gfc_init_se (&tmpse
, NULL
);
941 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
942 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
946 /* First candidate: if the variable is of type CHARACTER, the
947 expression's length could be the length of the character
949 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
950 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
952 /* Look through the reference chain for component references. */
953 for (r
= e
->ref
; r
; r
= r
->next
)
958 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
959 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
967 /* We should never got substring references here. These will be
968 broken down by the scalarizer. */
974 gcc_assert (length
!= NULL
);
979 /* Return for an expression the backend decl of the coarray. */
982 get_tree_for_caf_expr (gfc_expr
*expr
)
984 tree caf_decl
= NULL_TREE
;
987 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
);
988 if (expr
->symtree
->n
.sym
->attr
.codimension
)
989 caf_decl
= expr
->symtree
->n
.sym
->backend_decl
;
991 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
992 if (ref
->type
== REF_COMPONENT
)
994 gfc_component
*comp
= ref
->u
.c
.component
;
995 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
996 caf_decl
= NULL_TREE
;
997 if (comp
->attr
.codimension
)
998 caf_decl
= comp
->backend_decl
;
1001 gcc_assert (caf_decl
!= NULL_TREE
);
1006 /* For each character array constructor subexpression without a ts.u.cl->length,
1007 replace it by its first element (if there aren't any elements, the length
1008 should already be set to zero). */
1011 flatten_array_ctors_without_strlen (gfc_expr
* e
)
1013 gfc_actual_arglist
* arg
;
1019 switch (e
->expr_type
)
1023 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
1024 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
1028 /* TODO: Implement as with EXPR_FUNCTION when needed. */
1032 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1033 flatten_array_ctors_without_strlen (arg
->expr
);
1038 /* We've found what we're looking for. */
1039 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
1044 gcc_assert (e
->value
.constructor
);
1046 c
= gfc_constructor_first (e
->value
.constructor
);
1050 flatten_array_ctors_without_strlen (new_expr
);
1051 gfc_replace_expr (e
, new_expr
);
1055 /* Otherwise, fall through to handle constructor elements. */
1056 case EXPR_STRUCTURE
:
1057 for (c
= gfc_constructor_first (e
->value
.constructor
);
1058 c
; c
= gfc_constructor_next (c
))
1059 flatten_array_ctors_without_strlen (c
->expr
);
1069 /* Generate code to initialize a string length variable. Returns the
1070 value. For array constructors, cl->length might be NULL and in this case,
1071 the first element of the constructor is needed. expr is the original
1072 expression so we can access it but can be NULL if this is not needed. */
1075 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
1079 gfc_init_se (&se
, NULL
);
1083 && TREE_CODE (cl
->backend_decl
) == VAR_DECL
)
1086 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
1087 "flatten" array constructors by taking their first element; all elements
1088 should be the same length or a cl->length should be present. */
1091 gfc_expr
* expr_flat
;
1093 expr_flat
= gfc_copy_expr (expr
);
1094 flatten_array_ctors_without_strlen (expr_flat
);
1095 gfc_resolve_expr (expr_flat
);
1097 gfc_conv_expr (&se
, expr_flat
);
1098 gfc_add_block_to_block (pblock
, &se
.pre
);
1099 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
1101 gfc_free_expr (expr_flat
);
1105 /* Convert cl->length. */
1107 gcc_assert (cl
->length
);
1109 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
1110 se
.expr
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1111 se
.expr
, build_int_cst (gfc_charlen_type_node
, 0));
1112 gfc_add_block_to_block (pblock
, &se
.pre
);
1114 if (cl
->backend_decl
)
1115 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
1117 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
1122 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
1123 const char *name
, locus
*where
)
1132 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
1133 type
= build_pointer_type (type
);
1135 gfc_init_se (&start
, se
);
1136 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
1137 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
1139 if (integer_onep (start
.expr
))
1140 gfc_conv_string_parameter (se
);
1145 /* Avoid multiple evaluation of substring start. */
1146 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1147 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
1149 /* Change the start of the string. */
1150 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
1153 tmp
= build_fold_indirect_ref_loc (input_location
,
1155 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
1156 se
->expr
= gfc_build_addr_expr (type
, tmp
);
1159 /* Length = end + 1 - start. */
1160 gfc_init_se (&end
, se
);
1161 if (ref
->u
.ss
.end
== NULL
)
1162 end
.expr
= se
->string_length
;
1165 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
1166 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
1170 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
1171 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
1173 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1175 tree nonempty
= fold_build2_loc (input_location
, LE_EXPR
,
1176 boolean_type_node
, start
.expr
,
1179 /* Check lower bound. */
1180 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1182 build_int_cst (gfc_charlen_type_node
, 1));
1183 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1184 boolean_type_node
, nonempty
, fault
);
1186 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
1187 "is less than one", name
);
1189 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
1190 "is less than one");
1191 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1192 fold_convert (long_integer_type_node
,
1196 /* Check upper bound. */
1197 fault
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1198 end
.expr
, se
->string_length
);
1199 fault
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1200 boolean_type_node
, nonempty
, fault
);
1202 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
1203 "exceeds string length (%%ld)", name
);
1205 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
1206 "exceeds string length (%%ld)");
1207 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
1208 fold_convert (long_integer_type_node
, end
.expr
),
1209 fold_convert (long_integer_type_node
,
1210 se
->string_length
));
1214 /* If the start and end expressions are equal, the length is one. */
1216 && gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) == 0)
1217 tmp
= build_int_cst (gfc_charlen_type_node
, 1);
1220 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_charlen_type_node
,
1221 end
.expr
, start
.expr
);
1222 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_charlen_type_node
,
1223 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
1224 tmp
= fold_build2_loc (input_location
, MAX_EXPR
, gfc_charlen_type_node
,
1225 tmp
, build_int_cst (gfc_charlen_type_node
, 0));
1228 se
->string_length
= tmp
;
1232 /* Convert a derived type component reference. */
1235 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
1242 c
= ref
->u
.c
.component
;
1244 gcc_assert (c
->backend_decl
);
1246 field
= c
->backend_decl
;
1247 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
1250 /* Components can correspond to fields of different containing
1251 types, as components are created without context, whereas
1252 a concrete use of a component has the type of decl as context.
1253 So, if the type doesn't match, we search the corresponding
1254 FIELD_DECL in the parent type. To not waste too much time
1255 we cache this result in norestrict_decl. */
1257 if (DECL_FIELD_CONTEXT (field
) != TREE_TYPE (decl
))
1259 tree f2
= c
->norestrict_decl
;
1260 if (!f2
|| DECL_FIELD_CONTEXT (f2
) != TREE_TYPE (decl
))
1261 for (f2
= TYPE_FIELDS (TREE_TYPE (decl
)); f2
; f2
= DECL_CHAIN (f2
))
1262 if (TREE_CODE (f2
) == FIELD_DECL
1263 && DECL_NAME (f2
) == DECL_NAME (field
))
1266 c
->norestrict_decl
= f2
;
1269 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
1270 decl
, field
, NULL_TREE
);
1274 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
1276 tmp
= c
->ts
.u
.cl
->backend_decl
;
1277 /* Components must always be constant length. */
1278 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
1279 se
->string_length
= tmp
;
1282 if (((c
->attr
.pointer
|| c
->attr
.allocatable
)
1283 && (!c
->attr
.dimension
&& !c
->attr
.codimension
)
1284 && c
->ts
.type
!= BT_CHARACTER
)
1285 || c
->attr
.proc_pointer
)
1286 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1291 /* This function deals with component references to components of the
1292 parent type for derived type extensions. */
1294 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
1302 c
= ref
->u
.c
.component
;
1304 /* Return if the component is not in the parent type. */
1305 for (cmp
= dt
->components
; cmp
; cmp
= cmp
->next
)
1306 if (strcmp (c
->name
, cmp
->name
) == 0)
1309 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
1310 parent
.type
= REF_COMPONENT
;
1312 parent
.u
.c
.sym
= dt
;
1313 parent
.u
.c
.component
= dt
->components
;
1315 if (dt
->backend_decl
== NULL
)
1316 gfc_get_derived_type (dt
);
1318 /* Build the reference and call self. */
1319 gfc_conv_component_ref (se
, &parent
);
1320 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
1321 parent
.u
.c
.component
= c
;
1322 conv_parent_component_references (se
, &parent
);
1325 /* Return the contents of a variable. Also handles reference/pointer
1326 variables (all Fortran pointer references are implicit). */
1329 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
1334 tree parent_decl
= NULL_TREE
;
1337 bool alternate_entry
;
1340 sym
= expr
->symtree
->n
.sym
;
1344 gfc_ss_info
*ss_info
= ss
->info
;
1346 /* Check that something hasn't gone horribly wrong. */
1347 gcc_assert (ss
!= gfc_ss_terminator
);
1348 gcc_assert (ss_info
->expr
== expr
);
1350 /* A scalarized term. We already know the descriptor. */
1351 se
->expr
= ss_info
->data
.array
.descriptor
;
1352 se
->string_length
= ss_info
->string_length
;
1353 for (ref
= ss_info
->data
.array
.ref
; ref
; ref
= ref
->next
)
1354 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1359 tree se_expr
= NULL_TREE
;
1361 se
->expr
= gfc_get_symbol_decl (sym
);
1363 /* Deal with references to a parent results or entries by storing
1364 the current_function_decl and moving to the parent_decl. */
1365 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
1366 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
1367 && sym
->result
== sym
;
1368 entry_master
= sym
->attr
.result
1369 && sym
->ns
->proc_name
->attr
.entry_master
1370 && !gfc_return_by_reference (sym
->ns
->proc_name
);
1371 if (current_function_decl
)
1372 parent_decl
= DECL_CONTEXT (current_function_decl
);
1374 if ((se
->expr
== parent_decl
&& return_value
)
1375 || (sym
->ns
&& sym
->ns
->proc_name
1377 && sym
->ns
->proc_name
->backend_decl
== parent_decl
1378 && (alternate_entry
|| entry_master
)))
1383 /* Special case for assigning the return value of a function.
1384 Self recursive functions must have an explicit return value. */
1385 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
1386 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1388 /* Similarly for alternate entry points. */
1389 else if (alternate_entry
1390 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1393 gfc_entry_list
*el
= NULL
;
1395 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1398 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1403 else if (entry_master
1404 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1406 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
1411 /* Procedure actual arguments. */
1412 else if (sym
->attr
.flavor
== FL_PROCEDURE
1413 && se
->expr
!= current_function_decl
)
1415 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
1417 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
1418 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1424 /* Dereference the expression, where needed. Since characters
1425 are entirely different from other types, they are treated
1427 if (sym
->ts
.type
== BT_CHARACTER
)
1429 /* Dereference character pointer dummy arguments
1431 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1433 || sym
->attr
.function
1434 || sym
->attr
.result
))
1435 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1439 else if (!sym
->attr
.value
)
1441 /* Dereference non-character scalar dummy arguments. */
1442 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
1443 && !(sym
->attr
.codimension
&& sym
->attr
.allocatable
))
1444 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1447 /* Dereference scalar hidden result. */
1448 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
1449 && (sym
->attr
.function
|| sym
->attr
.result
)
1450 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
1451 && !sym
->attr
.always_explicit
)
1452 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1455 /* Dereference non-character pointer variables.
1456 These must be dummies, results, or scalars. */
1457 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
1458 || gfc_is_associate_pointer (sym
)
1459 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
1461 || sym
->attr
.function
1463 || (!sym
->attr
.dimension
1464 && (!sym
->attr
.codimension
|| !sym
->attr
.allocatable
))))
1465 se
->expr
= build_fold_indirect_ref_loc (input_location
,
1472 /* For character variables, also get the length. */
1473 if (sym
->ts
.type
== BT_CHARACTER
)
1475 /* If the character length of an entry isn't set, get the length from
1476 the master function instead. */
1477 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
1478 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
1480 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
1481 gcc_assert (se
->string_length
);
1489 /* Return the descriptor if that's what we want and this is an array
1490 section reference. */
1491 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
1493 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
1494 /* Return the descriptor for array pointers and allocations. */
1495 if (se
->want_pointer
1496 && ref
->next
== NULL
&& (se
->descriptor_only
))
1499 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
1500 /* Return a pointer to an element. */
1504 if (ref
->u
.c
.sym
->attr
.extension
)
1505 conv_parent_component_references (se
, ref
);
1507 gfc_conv_component_ref (se
, ref
);
1512 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
1513 expr
->symtree
->name
, &expr
->where
);
1522 /* Pointer assignment, allocation or pass by reference. Arrays are handled
1524 if (se
->want_pointer
)
1526 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
))
1527 gfc_conv_string_parameter (se
);
1529 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
1534 /* Unary ops are easy... Or they would be if ! was a valid op. */
1537 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
1542 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1543 /* Initialize the operand. */
1544 gfc_init_se (&operand
, se
);
1545 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
1546 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
1548 type
= gfc_typenode_for_spec (&expr
->ts
);
1550 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
1551 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
1552 All other unary operators have an equivalent GIMPLE unary operator. */
1553 if (code
== TRUTH_NOT_EXPR
)
1554 se
->expr
= fold_build2_loc (input_location
, EQ_EXPR
, type
, operand
.expr
,
1555 build_int_cst (type
, 0));
1557 se
->expr
= fold_build1_loc (input_location
, code
, type
, operand
.expr
);
1561 /* Expand power operator to optimal multiplications when a value is raised
1562 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
1563 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
1564 Programming", 3rd Edition, 1998. */
1566 /* This code is mostly duplicated from expand_powi in the backend.
1567 We establish the "optimal power tree" lookup table with the defined size.
1568 The items in the table are the exponents used to calculate the index
1569 exponents. Any integer n less than the value can get an "addition chain",
1570 with the first node being one. */
1571 #define POWI_TABLE_SIZE 256
1573 /* The table is from builtins.c. */
1574 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
1576 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
1577 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
1578 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
1579 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
1580 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
1581 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
1582 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
1583 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
1584 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
1585 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
1586 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
1587 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
1588 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
1589 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
1590 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
1591 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
1592 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
1593 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
1594 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
1595 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
1596 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
1597 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
1598 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
1599 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
1600 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
1601 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
1602 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
1603 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
1604 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
1605 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
1606 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
1607 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
1610 /* If n is larger than lookup table's max index, we use the "window
1612 #define POWI_WINDOW_SIZE 3
1614 /* Recursive function to expand the power operator. The temporary
1615 values are put in tmpvar. The function returns tmpvar[1] ** n. */
1617 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
1624 if (n
< POWI_TABLE_SIZE
)
1629 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
1630 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
1634 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
1635 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
1636 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
1640 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
1644 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
1645 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1647 if (n
< POWI_TABLE_SIZE
)
1654 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
1655 return 1. Else return 0 and a call to runtime library functions
1656 will have to be built. */
1658 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
1663 tree vartmp
[POWI_TABLE_SIZE
];
1665 unsigned HOST_WIDE_INT n
;
1668 /* If exponent is too large, we won't expand it anyway, so don't bother
1669 with large integer values. */
1670 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
1673 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
1674 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
1675 of the asymmetric range of the integer type. */
1676 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
1678 type
= TREE_TYPE (lhs
);
1679 sgn
= tree_int_cst_sgn (rhs
);
1681 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
1682 || optimize_size
) && (m
> 2 || m
< -1))
1688 se
->expr
= gfc_build_const (type
, integer_one_node
);
1692 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
1693 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
1695 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1696 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
1697 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1698 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
1701 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
1704 tmp
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1705 boolean_type_node
, tmp
, cond
);
1706 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1707 tmp
, build_int_cst (type
, 1),
1708 build_int_cst (type
, 0));
1712 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
1713 tmp
= fold_build3_loc (input_location
, COND_EXPR
, type
, tmp
,
1714 build_int_cst (type
, -1),
1715 build_int_cst (type
, 0));
1716 se
->expr
= fold_build3_loc (input_location
, COND_EXPR
, type
,
1717 cond
, build_int_cst (type
, 1), tmp
);
1721 memset (vartmp
, 0, sizeof (vartmp
));
1725 tmp
= gfc_build_const (type
, integer_one_node
);
1726 vartmp
[1] = fold_build2_loc (input_location
, RDIV_EXPR
, type
, tmp
,
1730 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
1736 /* Power op (**). Constant integer exponent has special handling. */
1739 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
1741 tree gfc_int4_type_node
;
1744 int res_ikind_1
, res_ikind_2
;
1749 gfc_init_se (&lse
, se
);
1750 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
1751 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
1752 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1754 gfc_init_se (&rse
, se
);
1755 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
1756 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1758 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
1759 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
1760 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
1763 gfc_int4_type_node
= gfc_get_int_type (4);
1765 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
1766 library routine. But in the end, we have to convert the result back
1767 if this case applies -- with res_ikind_K, we keep track whether operand K
1768 falls into this case. */
1772 kind
= expr
->value
.op
.op1
->ts
.kind
;
1773 switch (expr
->value
.op
.op2
->ts
.type
)
1776 ikind
= expr
->value
.op
.op2
->ts
.kind
;
1781 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
1782 res_ikind_2
= ikind
;
1804 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
1806 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1833 switch (expr
->value
.op
.op1
->ts
.type
)
1836 if (kind
== 3) /* Case 16 was not handled properly above. */
1838 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1842 /* Use builtins for real ** int4. */
1848 fndecl
= builtin_decl_explicit (BUILT_IN_POWIF
);
1852 fndecl
= builtin_decl_explicit (BUILT_IN_POWI
);
1856 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
1860 /* Use the __builtin_powil() only if real(kind=16) is
1861 actually the C long double type. */
1862 if (!gfc_real16_is_float128
)
1863 fndecl
= builtin_decl_explicit (BUILT_IN_POWIL
);
1871 /* If we don't have a good builtin for this, go for the
1872 library function. */
1874 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1878 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1887 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_POW
, kind
);
1891 fndecl
= gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW
, kind
);
1899 se
->expr
= build_call_expr_loc (input_location
,
1900 fndecl
, 2, lse
.expr
, rse
.expr
);
1902 /* Convert the result back if it is of wrong integer kind. */
1903 if (res_ikind_1
!= -1 && res_ikind_2
!= -1)
1905 /* We want the maximum of both operand kinds as result. */
1906 if (res_ikind_1
< res_ikind_2
)
1907 res_ikind_1
= res_ikind_2
;
1908 se
->expr
= convert (gfc_get_int_type (res_ikind_1
), se
->expr
);
1913 /* Generate code to allocate a string temporary. */
1916 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1921 if (gfc_can_put_var_on_stack (len
))
1923 /* Create a temporary variable to hold the result. */
1924 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1925 gfc_charlen_type_node
, len
,
1926 build_int_cst (gfc_charlen_type_node
, 1));
1927 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1929 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1930 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1932 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1934 var
= gfc_create_var (tmp
, "str");
1935 var
= gfc_build_addr_expr (type
, var
);
1939 /* Allocate a temporary to hold the result. */
1940 var
= gfc_create_var (type
, "pstr");
1941 tmp
= gfc_call_malloc (&se
->pre
, type
,
1942 fold_build2_loc (input_location
, MULT_EXPR
,
1943 TREE_TYPE (len
), len
,
1944 fold_convert (TREE_TYPE (len
),
1945 TYPE_SIZE (type
))));
1946 gfc_add_modify (&se
->pre
, var
, tmp
);
1948 /* Free the temporary afterwards. */
1949 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1950 gfc_add_expr_to_block (&se
->post
, tmp
);
1957 /* Handle a string concatenation operation. A temporary will be allocated to
1961 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1964 tree len
, type
, var
, tmp
, fndecl
;
1966 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1967 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1968 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1970 gfc_init_se (&lse
, se
);
1971 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1972 gfc_conv_string_parameter (&lse
);
1973 gfc_init_se (&rse
, se
);
1974 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1975 gfc_conv_string_parameter (&rse
);
1977 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1978 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1980 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1981 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1982 if (len
== NULL_TREE
)
1984 len
= fold_build2_loc (input_location
, PLUS_EXPR
,
1985 TREE_TYPE (lse
.string_length
),
1986 lse
.string_length
, rse
.string_length
);
1989 type
= build_pointer_type (type
);
1991 var
= gfc_conv_string_tmp (se
, type
, len
);
1993 /* Do the actual concatenation. */
1994 if (expr
->ts
.kind
== 1)
1995 fndecl
= gfor_fndecl_concat_string
;
1996 else if (expr
->ts
.kind
== 4)
1997 fndecl
= gfor_fndecl_concat_string_char4
;
2001 tmp
= build_call_expr_loc (input_location
,
2002 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
2003 rse
.string_length
, rse
.expr
);
2004 gfc_add_expr_to_block (&se
->pre
, tmp
);
2006 /* Add the cleanup for the operands. */
2007 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2008 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2011 se
->string_length
= len
;
2014 /* Translates an op expression. Common (binary) cases are handled by this
2015 function, others are passed on. Recursion is used in either case.
2016 We use the fact that (op1.ts == op2.ts) (except for the power
2018 Operators need no special handling for scalarized expressions as long as
2019 they call gfc_conv_simple_val to get their operands.
2020 Character strings get special handling. */
2023 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
2025 enum tree_code code
;
2034 switch (expr
->value
.op
.op
)
2036 case INTRINSIC_PARENTHESES
:
2037 if ((expr
->ts
.type
== BT_REAL
2038 || expr
->ts
.type
== BT_COMPLEX
)
2039 && gfc_option
.flag_protect_parens
)
2041 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
2042 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
2047 case INTRINSIC_UPLUS
:
2048 gfc_conv_expr (se
, expr
->value
.op
.op1
);
2051 case INTRINSIC_UMINUS
:
2052 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
2056 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
2059 case INTRINSIC_PLUS
:
2063 case INTRINSIC_MINUS
:
2067 case INTRINSIC_TIMES
:
2071 case INTRINSIC_DIVIDE
:
2072 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
2073 an integer, we must round towards zero, so we use a
2075 if (expr
->ts
.type
== BT_INTEGER
)
2076 code
= TRUNC_DIV_EXPR
;
2081 case INTRINSIC_POWER
:
2082 gfc_conv_power_op (se
, expr
);
2085 case INTRINSIC_CONCAT
:
2086 gfc_conv_concat_op (se
, expr
);
2090 code
= TRUTH_ANDIF_EXPR
;
2095 code
= TRUTH_ORIF_EXPR
;
2099 /* EQV and NEQV only work on logicals, but since we represent them
2100 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
2102 case INTRINSIC_EQ_OS
:
2110 case INTRINSIC_NE_OS
:
2111 case INTRINSIC_NEQV
:
2118 case INTRINSIC_GT_OS
:
2125 case INTRINSIC_GE_OS
:
2132 case INTRINSIC_LT_OS
:
2139 case INTRINSIC_LE_OS
:
2145 case INTRINSIC_USER
:
2146 case INTRINSIC_ASSIGN
:
2147 /* These should be converted into function calls by the frontend. */
2151 fatal_error ("Unknown intrinsic op");
2155 /* The only exception to this is **, which is handled separately anyway. */
2156 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
2158 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
2162 gfc_init_se (&lse
, se
);
2163 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
2164 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2167 gfc_init_se (&rse
, se
);
2168 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
2169 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2173 gfc_conv_string_parameter (&lse
);
2174 gfc_conv_string_parameter (&rse
);
2176 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
2177 rse
.string_length
, rse
.expr
,
2178 expr
->value
.op
.op1
->ts
.kind
,
2180 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
2181 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
2184 type
= gfc_typenode_for_spec (&expr
->ts
);
2188 /* The result of logical ops is always boolean_type_node. */
2189 tmp
= fold_build2_loc (input_location
, code
, boolean_type_node
,
2190 lse
.expr
, rse
.expr
);
2191 se
->expr
= convert (type
, tmp
);
2194 se
->expr
= fold_build2_loc (input_location
, code
, type
, lse
.expr
, rse
.expr
);
2196 /* Add the post blocks. */
2197 gfc_add_block_to_block (&se
->post
, &rse
.post
);
2198 gfc_add_block_to_block (&se
->post
, &lse
.post
);
2201 /* If a string's length is one, we convert it to a single character. */
2204 gfc_string_to_single_character (tree len
, tree str
, int kind
)
2208 || !INTEGER_CST_P (len
) || TREE_INT_CST_HIGH (len
) != 0
2209 || !POINTER_TYPE_P (TREE_TYPE (str
)))
2212 if (TREE_INT_CST_LOW (len
) == 1)
2214 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
2215 return build_fold_indirect_ref_loc (input_location
, str
);
2219 && TREE_CODE (str
) == ADDR_EXPR
2220 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2221 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2222 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2223 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2224 && TREE_INT_CST_LOW (len
) > 1
2225 && TREE_INT_CST_LOW (len
)
2226 == (unsigned HOST_WIDE_INT
)
2227 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2229 tree ret
= fold_convert (gfc_get_pchar_type (kind
), str
);
2230 ret
= build_fold_indirect_ref_loc (input_location
, ret
);
2231 if (TREE_CODE (ret
) == INTEGER_CST
)
2233 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2234 int i
, length
= TREE_STRING_LENGTH (string_cst
);
2235 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2237 for (i
= 1; i
< length
; i
++)
2250 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
2253 if (sym
->backend_decl
)
2255 /* This becomes the nominal_type in
2256 function.c:assign_parm_find_data_types. */
2257 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
2258 /* This becomes the passed_type in
2259 function.c:assign_parm_find_data_types. C promotes char to
2260 integer for argument passing. */
2261 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
2263 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
2268 /* If we have a constant character expression, make it into an
2270 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
2275 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
2276 (int)(*expr
)->value
.character
.string
[0]);
2277 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
2279 /* The expr needs to be compatible with a C int. If the
2280 conversion fails, then the 2 causes an ICE. */
2281 ts
.type
= BT_INTEGER
;
2282 ts
.kind
= gfc_c_int_kind
;
2283 gfc_convert_type (*expr
, &ts
, 2);
2286 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
2288 if ((*expr
)->ref
== NULL
)
2290 se
->expr
= gfc_string_to_single_character
2291 (build_int_cst (integer_type_node
, 1),
2292 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2294 ((*expr
)->symtree
->n
.sym
)),
2299 gfc_conv_variable (se
, *expr
);
2300 se
->expr
= gfc_string_to_single_character
2301 (build_int_cst (integer_type_node
, 1),
2302 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
2310 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
2311 if STR is a string literal, otherwise return -1. */
2314 gfc_optimize_len_trim (tree len
, tree str
, int kind
)
2317 && TREE_CODE (str
) == ADDR_EXPR
2318 && TREE_CODE (TREE_OPERAND (str
, 0)) == ARRAY_REF
2319 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)) == STRING_CST
2320 && array_ref_low_bound (TREE_OPERAND (str
, 0))
2321 == TREE_OPERAND (TREE_OPERAND (str
, 0), 1)
2322 && TREE_INT_CST_LOW (len
) >= 1
2323 && TREE_INT_CST_LOW (len
)
2324 == (unsigned HOST_WIDE_INT
)
2325 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str
, 0), 0)))
2327 tree folded
= fold_convert (gfc_get_pchar_type (kind
), str
);
2328 folded
= build_fold_indirect_ref_loc (input_location
, folded
);
2329 if (TREE_CODE (folded
) == INTEGER_CST
)
2331 tree string_cst
= TREE_OPERAND (TREE_OPERAND (str
, 0), 0);
2332 int length
= TREE_STRING_LENGTH (string_cst
);
2333 const char *ptr
= TREE_STRING_POINTER (string_cst
);
2335 for (; length
> 0; length
--)
2336 if (ptr
[length
- 1] != ' ')
2345 /* Compare two strings. If they are all single characters, the result is the
2346 subtraction of them. Otherwise, we build a library call. */
2349 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
,
2350 enum tree_code code
)
2356 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
2357 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
2359 sc1
= gfc_string_to_single_character (len1
, str1
, kind
);
2360 sc2
= gfc_string_to_single_character (len2
, str2
, kind
);
2362 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
2364 /* Deal with single character specially. */
2365 sc1
= fold_convert (integer_type_node
, sc1
);
2366 sc2
= fold_convert (integer_type_node
, sc2
);
2367 return fold_build2_loc (input_location
, MINUS_EXPR
, integer_type_node
,
2371 if ((code
== EQ_EXPR
|| code
== NE_EXPR
)
2373 && INTEGER_CST_P (len1
) && INTEGER_CST_P (len2
))
2375 /* If one string is a string literal with LEN_TRIM longer
2376 than the length of the second string, the strings
2378 int len
= gfc_optimize_len_trim (len1
, str1
, kind
);
2379 if (len
> 0 && compare_tree_int (len2
, len
) < 0)
2380 return integer_one_node
;
2381 len
= gfc_optimize_len_trim (len2
, str2
, kind
);
2382 if (len
> 0 && compare_tree_int (len1
, len
) < 0)
2383 return integer_one_node
;
2386 /* Build a call for the comparison. */
2388 fndecl
= gfor_fndecl_compare_string
;
2390 fndecl
= gfor_fndecl_compare_string_char4
;
2394 return build_call_expr_loc (input_location
, fndecl
, 4,
2395 len1
, str1
, len2
, str2
);
2399 /* Return the backend_decl for a procedure pointer component. */
2402 get_proc_ptr_comp (gfc_expr
*e
)
2408 gfc_init_se (&comp_se
, NULL
);
2409 e2
= gfc_copy_expr (e
);
2410 /* We have to restore the expr type later so that gfc_free_expr frees
2411 the exact same thing that was allocated.
2412 TODO: This is ugly. */
2413 old_type
= e2
->expr_type
;
2414 e2
->expr_type
= EXPR_VARIABLE
;
2415 gfc_conv_expr (&comp_se
, e2
);
2416 e2
->expr_type
= old_type
;
2418 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
2422 /* Convert a typebound function reference from a class object. */
2424 conv_base_obj_fcn_val (gfc_se
* se
, tree base_object
, gfc_expr
* expr
)
2429 if (TREE_CODE (base_object
) != VAR_DECL
)
2431 var
= gfc_create_var (TREE_TYPE (base_object
), NULL
);
2432 gfc_add_modify (&se
->pre
, var
, base_object
);
2434 se
->expr
= gfc_class_vptr_get (base_object
);
2435 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
2437 while (ref
&& ref
->next
)
2439 gcc_assert (ref
&& ref
->type
== REF_COMPONENT
);
2440 if (ref
->u
.c
.sym
->attr
.extension
)
2441 conv_parent_component_references (se
, ref
);
2442 gfc_conv_component_ref (se
, ref
);
2443 se
->expr
= build_fold_addr_expr_loc (input_location
, se
->expr
);
2448 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
2452 if (gfc_is_proc_ptr_comp (expr
))
2453 tmp
= get_proc_ptr_comp (expr
);
2454 else if (sym
->attr
.dummy
)
2456 tmp
= gfc_get_symbol_decl (sym
);
2457 if (sym
->attr
.proc_pointer
)
2458 tmp
= build_fold_indirect_ref_loc (input_location
,
2460 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
2461 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
2465 if (!sym
->backend_decl
)
2466 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
2468 tmp
= sym
->backend_decl
;
2470 if (sym
->attr
.cray_pointee
)
2472 /* TODO - make the cray pointee a pointer to a procedure,
2473 assign the pointer to it and use it for the call. This
2475 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
2476 gfc_get_symbol_decl (sym
->cp_pointer
));
2477 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2480 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
2482 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
2483 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2490 /* Initialize MAPPING. */
2493 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
2495 mapping
->syms
= NULL
;
2496 mapping
->charlens
= NULL
;
2500 /* Free all memory held by MAPPING (but not MAPPING itself). */
2503 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
2505 gfc_interface_sym_mapping
*sym
;
2506 gfc_interface_sym_mapping
*nextsym
;
2508 gfc_charlen
*nextcl
;
2510 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
2512 nextsym
= sym
->next
;
2513 sym
->new_sym
->n
.sym
->formal
= NULL
;
2514 gfc_free_symbol (sym
->new_sym
->n
.sym
);
2515 gfc_free_expr (sym
->expr
);
2516 free (sym
->new_sym
);
2519 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
2522 gfc_free_expr (cl
->length
);
2528 /* Return a copy of gfc_charlen CL. Add the returned structure to
2529 MAPPING so that it will be freed by gfc_free_interface_mapping. */
2531 static gfc_charlen
*
2532 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
2535 gfc_charlen
*new_charlen
;
2537 new_charlen
= gfc_get_charlen ();
2538 new_charlen
->next
= mapping
->charlens
;
2539 new_charlen
->length
= gfc_copy_expr (cl
->length
);
2541 mapping
->charlens
= new_charlen
;
2546 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
2547 array variable that can be used as the actual argument for dummy
2548 argument SYM. Add any initialization code to BLOCK. PACKED is as
2549 for gfc_get_nodesc_array_type and DATA points to the first element
2550 in the passed array. */
2553 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
2554 gfc_packed packed
, tree data
)
2559 type
= gfc_typenode_for_spec (&sym
->ts
);
2560 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
2561 !sym
->attr
.target
&& !sym
->attr
.pointer
2562 && !sym
->attr
.proc_pointer
);
2564 var
= gfc_create_var (type
, "ifm");
2565 gfc_add_modify (block
, var
, fold_convert (type
, data
));
2571 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
2572 and offset of descriptorless array type TYPE given that it has the same
2573 size as DESC. Add any set-up code to BLOCK. */
2576 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
2583 offset
= gfc_index_zero_node
;
2584 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
2586 dim
= gfc_rank_cst
[n
];
2587 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
2588 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
2590 GFC_TYPE_ARRAY_LBOUND (type
, n
)
2591 = gfc_conv_descriptor_lbound_get (desc
, dim
);
2592 GFC_TYPE_ARRAY_UBOUND (type
, n
)
2593 = gfc_conv_descriptor_ubound_get (desc
, dim
);
2595 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
2597 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2598 gfc_array_index_type
,
2599 gfc_conv_descriptor_ubound_get (desc
, dim
),
2600 gfc_conv_descriptor_lbound_get (desc
, dim
));
2601 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2602 gfc_array_index_type
,
2603 GFC_TYPE_ARRAY_LBOUND (type
, n
), tmp
);
2604 tmp
= gfc_evaluate_now (tmp
, block
);
2605 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
2607 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
2608 GFC_TYPE_ARRAY_LBOUND (type
, n
),
2609 GFC_TYPE_ARRAY_STRIDE (type
, n
));
2610 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2611 gfc_array_index_type
, offset
, tmp
);
2613 offset
= gfc_evaluate_now (offset
, block
);
2614 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
2618 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
2619 in SE. The caller may still use se->expr and se->string_length after
2620 calling this function. */
2623 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
2624 gfc_symbol
* sym
, gfc_se
* se
,
2627 gfc_interface_sym_mapping
*sm
;
2631 gfc_symbol
*new_sym
;
2633 gfc_symtree
*new_symtree
;
2635 /* Create a new symbol to represent the actual argument. */
2636 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
2637 new_sym
->ts
= sym
->ts
;
2638 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
2639 new_sym
->attr
.referenced
= 1;
2640 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
2641 new_sym
->attr
.contiguous
= sym
->attr
.contiguous
;
2642 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
2643 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
2644 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
2645 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
2646 new_sym
->attr
.function
= sym
->attr
.function
;
2648 /* Ensure that the interface is available and that
2649 descriptors are passed for array actual arguments. */
2650 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2652 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
2653 new_sym
->attr
.always_explicit
2654 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
2657 /* Create a fake symtree for it. */
2659 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
2660 new_symtree
->n
.sym
= new_sym
;
2661 gcc_assert (new_symtree
== root
);
2663 /* Create a dummy->actual mapping. */
2664 sm
= XCNEW (gfc_interface_sym_mapping
);
2665 sm
->next
= mapping
->syms
;
2667 sm
->new_sym
= new_symtree
;
2668 sm
->expr
= gfc_copy_expr (expr
);
2671 /* Stabilize the argument's value. */
2672 if (!sym
->attr
.function
&& se
)
2673 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2675 if (sym
->ts
.type
== BT_CHARACTER
)
2677 /* Create a copy of the dummy argument's length. */
2678 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
2679 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
2681 /* If the length is specified as "*", record the length that
2682 the caller is passing. We should use the callee's length
2683 in all other cases. */
2684 if (!new_sym
->ts
.u
.cl
->length
&& se
)
2686 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
2687 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
2694 /* Use the passed value as-is if the argument is a function. */
2695 if (sym
->attr
.flavor
== FL_PROCEDURE
)
2698 /* If the argument is either a string or a pointer to a string,
2699 convert it to a boundless character type. */
2700 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
2702 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
2703 tmp
= build_pointer_type (tmp
);
2704 if (sym
->attr
.pointer
)
2705 value
= build_fold_indirect_ref_loc (input_location
,
2709 value
= fold_convert (tmp
, value
);
2712 /* If the argument is a scalar, a pointer to an array or an allocatable,
2714 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2715 value
= build_fold_indirect_ref_loc (input_location
,
2718 /* For character(*), use the actual argument's descriptor. */
2719 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
2720 value
= build_fold_indirect_ref_loc (input_location
,
2723 /* If the argument is an array descriptor, use it to determine
2724 information about the actual argument's shape. */
2725 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
2726 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
2728 /* Get the actual argument's descriptor. */
2729 desc
= build_fold_indirect_ref_loc (input_location
,
2732 /* Create the replacement variable. */
2733 tmp
= gfc_conv_descriptor_data_get (desc
);
2734 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2737 /* Use DESC to work out the upper bounds, strides and offset. */
2738 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
2741 /* Otherwise we have a packed array. */
2742 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
2743 PACKED_FULL
, se
->expr
);
2745 new_sym
->backend_decl
= value
;
2749 /* Called once all dummy argument mappings have been added to MAPPING,
2750 but before the mapping is used to evaluate expressions. Pre-evaluate
2751 the length of each argument, adding any initialization code to PRE and
2752 any finalization code to POST. */
2755 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
2756 stmtblock_t
* pre
, stmtblock_t
* post
)
2758 gfc_interface_sym_mapping
*sym
;
2762 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2763 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
2764 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
2766 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
2767 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2768 gfc_init_se (&se
, NULL
);
2769 gfc_conv_expr (&se
, expr
);
2770 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
2771 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
2772 gfc_add_block_to_block (pre
, &se
.pre
);
2773 gfc_add_block_to_block (post
, &se
.post
);
2775 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
2780 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2784 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
2785 gfc_constructor_base base
)
2788 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2790 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
2793 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
2794 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
2795 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2801 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2805 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2810 for (; ref
; ref
= ref
->next
)
2814 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2816 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2817 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2818 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2826 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2827 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2833 /* Convert intrinsic function calls into result expressions. */
2836 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2844 arg1
= expr
->value
.function
.actual
->expr
;
2845 if (expr
->value
.function
.actual
->next
)
2846 arg2
= expr
->value
.function
.actual
->next
->expr
;
2850 sym
= arg1
->symtree
->n
.sym
;
2852 if (sym
->attr
.dummy
)
2857 switch (expr
->value
.function
.isym
->id
)
2860 /* TODO figure out why this condition is necessary. */
2861 if (sym
->attr
.function
2862 && (arg1
->ts
.u
.cl
->length
== NULL
2863 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2864 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2867 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2871 if (!sym
->as
|| sym
->as
->rank
== 0)
2874 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2876 dup
= mpz_get_si (arg2
->value
.integer
);
2881 dup
= sym
->as
->rank
;
2885 for (; d
< dup
; d
++)
2889 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2891 gfc_free_expr (new_expr
);
2895 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
2896 gfc_get_int_expr (gfc_default_integer_kind
,
2898 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2900 new_expr
= gfc_multiply (new_expr
, tmp
);
2906 case GFC_ISYM_LBOUND
:
2907 case GFC_ISYM_UBOUND
:
2908 /* TODO These implementations of lbound and ubound do not limit if
2909 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2911 if (!sym
->as
|| sym
->as
->rank
== 0)
2914 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2915 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2917 /* TODO: If the need arises, this could produce an array of
2921 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2923 if (sym
->as
->lower
[d
])
2924 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2928 if (sym
->as
->upper
[d
])
2929 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2937 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2941 gfc_replace_expr (expr
, new_expr
);
2947 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2948 gfc_interface_mapping
* mapping
)
2950 gfc_formal_arglist
*f
;
2951 gfc_actual_arglist
*actual
;
2953 actual
= expr
->value
.function
.actual
;
2954 f
= map_expr
->symtree
->n
.sym
->formal
;
2956 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2961 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2964 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2969 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2971 for (d
= 0; d
< as
->rank
; d
++)
2973 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2974 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2977 expr
->value
.function
.esym
->as
= as
;
2980 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2982 expr
->value
.function
.esym
->ts
.u
.cl
->length
2983 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2985 gfc_apply_interface_mapping_to_expr (mapping
,
2986 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2991 /* EXPR is a copy of an expression that appeared in the interface
2992 associated with MAPPING. Walk it recursively looking for references to
2993 dummy arguments that MAPPING maps to actual arguments. Replace each such
2994 reference with a reference to the associated actual argument. */
2997 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
3000 gfc_interface_sym_mapping
*sym
;
3001 gfc_actual_arglist
*actual
;
3006 /* Copying an expression does not copy its length, so do that here. */
3007 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
3009 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
3010 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
3013 /* Apply the mapping to any references. */
3014 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
3016 /* ...and to the expression's symbol, if it has one. */
3017 /* TODO Find out why the condition on expr->symtree had to be moved into
3018 the loop rather than being outside it, as originally. */
3019 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3020 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
3022 if (sym
->new_sym
->n
.sym
->backend_decl
)
3023 expr
->symtree
= sym
->new_sym
;
3025 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
3026 /* Replace base type for polymorphic arguments. */
3027 if (expr
->ref
&& expr
->ref
->type
== REF_COMPONENT
3028 && sym
->expr
&& sym
->expr
->ts
.type
== BT_CLASS
)
3029 expr
->ref
->u
.c
.sym
= sym
->expr
->ts
.u
.derived
;
3032 /* ...and to subexpressions in expr->value. */
3033 switch (expr
->expr_type
)
3038 case EXPR_SUBSTRING
:
3042 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
3043 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
3047 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
3048 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
3050 if (expr
->value
.function
.esym
== NULL
3051 && expr
->value
.function
.isym
!= NULL
3052 && expr
->value
.function
.actual
->expr
->symtree
3053 && gfc_map_intrinsic_function (expr
, mapping
))
3056 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
3057 if (sym
->old
== expr
->value
.function
.esym
)
3059 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
3060 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
3061 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
3066 case EXPR_STRUCTURE
:
3067 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
3080 /* Evaluate interface expression EXPR using MAPPING. Store the result
3084 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
3085 gfc_se
* se
, gfc_expr
* expr
)
3087 expr
= gfc_copy_expr (expr
);
3088 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
3089 gfc_conv_expr (se
, expr
);
3090 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3091 gfc_free_expr (expr
);
3095 /* Returns a reference to a temporary array into which a component of
3096 an actual argument derived type array is copied and then returned
3097 after the function call. */
3099 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
3100 sym_intent intent
, bool formal_ptr
)
3108 gfc_array_info
*info
;
3118 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3120 gfc_init_se (&lse
, NULL
);
3121 gfc_init_se (&rse
, NULL
);
3123 /* Walk the argument expression. */
3124 rss
= gfc_walk_expr (expr
);
3126 gcc_assert (rss
!= gfc_ss_terminator
);
3128 /* Initialize the scalarizer. */
3129 gfc_init_loopinfo (&loop
);
3130 gfc_add_ss_to_loop (&loop
, rss
);
3132 /* Calculate the bounds of the scalarization. */
3133 gfc_conv_ss_startstride (&loop
);
3135 /* Build an ss for the temporary. */
3136 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
3137 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
3139 base_type
= gfc_typenode_for_spec (&expr
->ts
);
3140 if (GFC_ARRAY_TYPE_P (base_type
)
3141 || GFC_DESCRIPTOR_TYPE_P (base_type
))
3142 base_type
= gfc_get_element_type (base_type
);
3144 if (expr
->ts
.type
== BT_CLASS
)
3145 base_type
= gfc_typenode_for_spec (&CLASS_DATA (expr
)->ts
);
3147 loop
.temp_ss
= gfc_get_temp_ss (base_type
, ((expr
->ts
.type
== BT_CHARACTER
)
3148 ? expr
->ts
.u
.cl
->backend_decl
3152 parmse
->string_length
= loop
.temp_ss
->info
->string_length
;
3154 /* Associate the SS with the loop. */
3155 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
3157 /* Setup the scalarizing loops. */
3158 gfc_conv_loop_setup (&loop
, &expr
->where
);
3160 /* Pass the temporary descriptor back to the caller. */
3161 info
= &loop
.temp_ss
->info
->data
.array
;
3162 parmse
->expr
= info
->descriptor
;
3164 /* Setup the gfc_se structures. */
3165 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3166 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3169 lse
.ss
= loop
.temp_ss
;
3170 gfc_mark_ss_chain_used (rss
, 1);
3171 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3173 /* Start the scalarized loop body. */
3174 gfc_start_scalarized_body (&loop
, &body
);
3176 /* Translate the expression. */
3177 gfc_conv_expr (&rse
, expr
);
3179 gfc_conv_tmp_array_ref (&lse
);
3181 if (intent
!= INTENT_OUT
)
3183 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
3184 gfc_add_expr_to_block (&body
, tmp
);
3185 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3186 gfc_trans_scalarizing_loops (&loop
, &body
);
3190 /* Make sure that the temporary declaration survives by merging
3191 all the loop declarations into the current context. */
3192 for (n
= 0; n
< loop
.dimen
; n
++)
3194 gfc_merge_block_scope (&body
);
3195 body
= loop
.code
[loop
.order
[n
]];
3197 gfc_merge_block_scope (&body
);
3200 /* Add the post block after the second loop, so that any
3201 freeing of allocated memory is done at the right time. */
3202 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
3204 /**********Copy the temporary back again.*********/
3206 gfc_init_se (&lse
, NULL
);
3207 gfc_init_se (&rse
, NULL
);
3209 /* Walk the argument expression. */
3210 lss
= gfc_walk_expr (expr
);
3211 rse
.ss
= loop
.temp_ss
;
3214 /* Initialize the scalarizer. */
3215 gfc_init_loopinfo (&loop2
);
3216 gfc_add_ss_to_loop (&loop2
, lss
);
3218 /* Calculate the bounds of the scalarization. */
3219 gfc_conv_ss_startstride (&loop2
);
3221 /* Setup the scalarizing loops. */
3222 gfc_conv_loop_setup (&loop2
, &expr
->where
);
3224 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
3225 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
3227 gfc_mark_ss_chain_used (lss
, 1);
3228 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
3230 /* Declare the variable to hold the temporary offset and start the
3231 scalarized loop body. */
3232 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
3233 gfc_start_scalarized_body (&loop2
, &body
);
3235 /* Build the offsets for the temporary from the loop variables. The
3236 temporary array has lbounds of zero and strides of one in all
3237 dimensions, so this is very simple. The offset is only computed
3238 outside the innermost loop, so the overall transfer could be
3239 optimized further. */
3240 info
= &rse
.ss
->info
->data
.array
;
3241 dimen
= rse
.ss
->dimen
;
3243 tmp_index
= gfc_index_zero_node
;
3244 for (n
= dimen
- 1; n
> 0; n
--)
3247 tmp
= rse
.loop
->loopvar
[n
];
3248 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3249 tmp
, rse
.loop
->from
[n
]);
3250 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3253 tmp_str
= fold_build2_loc (input_location
, MINUS_EXPR
,
3254 gfc_array_index_type
,
3255 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
3256 tmp_str
= fold_build2_loc (input_location
, PLUS_EXPR
,
3257 gfc_array_index_type
,
3258 tmp_str
, gfc_index_one_node
);
3260 tmp_index
= fold_build2_loc (input_location
, MULT_EXPR
,
3261 gfc_array_index_type
, tmp
, tmp_str
);
3264 tmp_index
= fold_build2_loc (input_location
, MINUS_EXPR
,
3265 gfc_array_index_type
,
3266 tmp_index
, rse
.loop
->from
[0]);
3267 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
3269 tmp_index
= fold_build2_loc (input_location
, PLUS_EXPR
,
3270 gfc_array_index_type
,
3271 rse
.loop
->loopvar
[0], offset
);
3273 /* Now use the offset for the reference. */
3274 tmp
= build_fold_indirect_ref_loc (input_location
,
3276 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
3278 if (expr
->ts
.type
== BT_CHARACTER
)
3279 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
3281 gfc_conv_expr (&lse
, expr
);
3283 gcc_assert (lse
.ss
== gfc_ss_terminator
);
3285 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
3286 gfc_add_expr_to_block (&body
, tmp
);
3288 /* Generate the copying loops. */
3289 gfc_trans_scalarizing_loops (&loop2
, &body
);
3291 /* Wrap the whole thing up by adding the second loop to the post-block
3292 and following it by the post-block of the first loop. In this way,
3293 if the temporary needs freeing, it is done after use! */
3294 if (intent
!= INTENT_IN
)
3296 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
3297 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
3300 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
3302 gfc_cleanup_loop (&loop
);
3303 gfc_cleanup_loop (&loop2
);
3305 /* Pass the string length to the argument expression. */
3306 if (expr
->ts
.type
== BT_CHARACTER
)
3307 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
3309 /* Determine the offset for pointer formal arguments and set the
3313 size
= gfc_index_one_node
;
3314 offset
= gfc_index_zero_node
;
3315 for (n
= 0; n
< dimen
; n
++)
3317 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
3319 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3320 gfc_array_index_type
, tmp
,
3321 gfc_index_one_node
);
3322 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
3326 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
3329 gfc_index_one_node
);
3330 size
= gfc_evaluate_now (size
, &parmse
->pre
);
3331 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
3332 gfc_array_index_type
,
3334 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
3335 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3336 gfc_array_index_type
,
3337 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
3338 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3339 gfc_array_index_type
,
3340 tmp
, gfc_index_one_node
);
3341 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3342 gfc_array_index_type
, size
, tmp
);
3345 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
3349 /* We want either the address for the data or the address of the descriptor,
3350 depending on the mode of passing array arguments. */
3352 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
3354 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
3360 /* Generate the code for argument list functions. */
3363 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
3365 /* Pass by value for g77 %VAL(arg), pass the address
3366 indirectly for %LOC, else by reference. Thus %REF
3367 is a "do-nothing" and %LOC is the same as an F95
3369 if (strncmp (name
, "%VAL", 4) == 0)
3370 gfc_conv_expr (se
, expr
);
3371 else if (strncmp (name
, "%LOC", 4) == 0)
3373 gfc_conv_expr_reference (se
, expr
);
3374 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
3376 else if (strncmp (name
, "%REF", 4) == 0)
3377 gfc_conv_expr_reference (se
, expr
);
3379 gfc_error ("Unknown argument list function at %L", &expr
->where
);
3383 /* The following routine generates code for the intrinsic
3384 procedures from the ISO_C_BINDING module:
3386 * C_FUNLOC (function)
3387 * C_F_POINTER (subroutine)
3388 * C_F_PROCPOINTER (subroutine)
3389 * C_ASSOCIATED (function)
3390 One exception which is not handled here is C_F_POINTER with non-scalar
3391 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
3394 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
3395 gfc_actual_arglist
* arg
)
3399 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
3401 if (arg
->expr
->rank
== 0)
3402 gfc_conv_expr_reference (se
, arg
->expr
);
3406 /* This is really the actual arg because no formal arglist is
3407 created for C_LOC. */
3408 fsym
= arg
->expr
->symtree
->n
.sym
;
3410 /* We should want it to do g77 calling convention. */
3412 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3413 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3414 f
= f
|| !sym
->attr
.always_explicit
;
3416 gfc_conv_array_parameter (se
, arg
->expr
, f
, NULL
, NULL
, NULL
);
3419 /* TODO -- the following two lines shouldn't be necessary, but if
3420 they're removed, a bug is exposed later in the code path.
3421 This workaround was thus introduced, but will have to be
3422 removed; please see PR 35150 for details about the issue. */
3423 se
->expr
= convert (pvoid_type_node
, se
->expr
);
3424 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
3428 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3430 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
3431 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
3432 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
3433 gfc_conv_expr_reference (se
, arg
->expr
);
3437 else if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
3438 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
3440 /* Convert c_f_pointer and c_f_procpointer. */
3445 tree desc
, dim
, tmp
, stride
, offset
;
3446 stmtblock_t body
, block
;
3449 gfc_init_se (&cptrse
, NULL
);
3450 gfc_conv_expr (&cptrse
, arg
->expr
);
3451 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
3452 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
3454 gfc_init_se (&fptrse
, NULL
);
3455 if (arg
->next
->expr
->rank
== 0)
3457 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
3458 || gfc_is_proc_ptr_comp (arg
->next
->expr
))
3459 fptrse
.want_pointer
= 1;
3461 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
3462 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
3463 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
3464 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
3465 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
3466 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
3468 se
->expr
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3469 TREE_TYPE (fptrse
.expr
),
3471 fold_convert (TREE_TYPE (fptrse
.expr
),
3476 gfc_start_block (&block
);
3478 /* Get the descriptor of the Fortran pointer. */
3479 fptrse
.descriptor_only
= 1;
3480 gfc_conv_expr_descriptor (&fptrse
, arg
->next
->expr
);
3481 gfc_add_block_to_block (&block
, &fptrse
.pre
);
3484 /* Set data value, dtype, and offset. */
3485 tmp
= GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc
));
3486 gfc_conv_descriptor_data_set (&block
, desc
,
3487 fold_convert (tmp
, cptrse
.expr
));
3488 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (desc
),
3489 gfc_get_dtype (TREE_TYPE (desc
)));
3491 /* Start scalarization of the bounds, using the shape argument. */
3493 shape_ss
= gfc_walk_expr (arg
->next
->next
->expr
);
3494 gcc_assert (shape_ss
!= gfc_ss_terminator
);
3495 gfc_init_se (&shapese
, NULL
);
3497 gfc_init_loopinfo (&loop
);
3498 gfc_add_ss_to_loop (&loop
, shape_ss
);
3499 gfc_conv_ss_startstride (&loop
);
3500 gfc_conv_loop_setup (&loop
, &arg
->next
->expr
->where
);
3501 gfc_mark_ss_chain_used (shape_ss
, 1);
3503 gfc_copy_loopinfo_to_se (&shapese
, &loop
);
3504 shapese
.ss
= shape_ss
;
3506 stride
= gfc_create_var (gfc_array_index_type
, "stride");
3507 offset
= gfc_create_var (gfc_array_index_type
, "offset");
3508 gfc_add_modify (&block
, stride
, gfc_index_one_node
);
3509 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
3512 gfc_start_scalarized_body (&loop
, &body
);
3514 dim
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3515 loop
.loopvar
[0], loop
.from
[0]);
3517 /* Set bounds and stride. */
3518 gfc_conv_descriptor_lbound_set (&body
, desc
, dim
, gfc_index_one_node
);
3519 gfc_conv_descriptor_stride_set (&body
, desc
, dim
, stride
);
3521 gfc_conv_expr (&shapese
, arg
->next
->next
->expr
);
3522 gfc_add_block_to_block (&body
, &shapese
.pre
);
3523 gfc_conv_descriptor_ubound_set (&body
, desc
, dim
, shapese
.expr
);
3524 gfc_add_block_to_block (&body
, &shapese
.post
);
3526 /* Calculate offset. */
3527 gfc_add_modify (&body
, offset
,
3528 fold_build2_loc (input_location
, PLUS_EXPR
,
3529 gfc_array_index_type
, offset
, stride
));
3530 /* Update stride. */
3531 gfc_add_modify (&body
, stride
,
3532 fold_build2_loc (input_location
, MULT_EXPR
,
3533 gfc_array_index_type
, stride
,
3534 fold_convert (gfc_array_index_type
,
3536 /* Finish scalarization loop. */
3537 gfc_trans_scalarizing_loops (&loop
, &body
);
3538 gfc_add_block_to_block (&block
, &loop
.pre
);
3539 gfc_add_block_to_block (&block
, &loop
.post
);
3540 gfc_add_block_to_block (&block
, &fptrse
.post
);
3541 gfc_cleanup_loop (&loop
);
3543 gfc_add_modify (&block
, offset
,
3544 fold_build1_loc (input_location
, NEGATE_EXPR
,
3545 gfc_array_index_type
, offset
));
3546 gfc_conv_descriptor_offset_set (&block
, desc
, offset
);
3548 se
->expr
= gfc_finish_block (&block
);
3551 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
3556 /* Build the addr_expr for the first argument. The argument is
3557 already an *address* so we don't need to set want_pointer in
3559 gfc_init_se (&arg1se
, NULL
);
3560 gfc_conv_expr (&arg1se
, arg
->expr
);
3561 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
3562 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
3564 /* See if we were given two arguments. */
3565 if (arg
->next
== NULL
)
3566 /* Only given one arg so generate a null and do a
3567 not-equal comparison against the first arg. */
3568 se
->expr
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
3570 fold_convert (TREE_TYPE (arg1se
.expr
),
3571 null_pointer_node
));
3577 /* Given two arguments so build the arg2se from second arg. */
3578 gfc_init_se (&arg2se
, NULL
);
3579 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
3580 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
3581 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
3583 /* Generate test to compare that the two args are equal. */
3584 eq_expr
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3585 arg1se
.expr
, arg2se
.expr
);
3586 /* Generate test to ensure that the first arg is not null. */
3587 not_null_expr
= fold_build2_loc (input_location
, NE_EXPR
,
3589 arg1se
.expr
, null_pointer_node
);
3591 /* Finally, the generated test must check that both arg1 is not
3592 NULL and that it is equal to the second arg. */
3593 se
->expr
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
3595 not_null_expr
, eq_expr
);
3601 /* Nothing was done. */
3606 /* Generate code for a procedure call. Note can return se->post != NULL.
3607 If se->direct_byref is set then se->expr contains the return parameter.
3608 Return nonzero, if the call has alternate specifiers.
3609 'expr' is only needed for procedure pointer components. */
3612 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
3613 gfc_actual_arglist
* args
, gfc_expr
* expr
,
3614 VEC(tree
,gc
) *append_args
)
3616 gfc_interface_mapping mapping
;
3617 VEC(tree
,gc
) *arglist
;
3618 VEC(tree
,gc
) *retargs
;
3622 gfc_array_info
*info
;
3629 VEC(tree
,gc
) *stringargs
;
3631 gfc_formal_arglist
*formal
;
3632 gfc_actual_arglist
*arg
;
3633 int has_alternate_specifier
= 0;
3634 bool need_interface_mapping
;
3641 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
3642 gfc_component
*comp
= NULL
;
3652 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3653 && conv_isocbinding_procedure (se
, sym
, args
))
3656 comp
= gfc_get_proc_ptr_comp (expr
);
3660 if (!sym
->attr
.elemental
&& !(comp
&& comp
->attr
.elemental
))
3662 gcc_assert (se
->ss
->info
->type
== GFC_SS_FUNCTION
);
3663 if (se
->ss
->info
->useflags
)
3665 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
3666 && sym
->result
->attr
.dimension
)
3667 || (comp
&& comp
->attr
.dimension
));
3668 gcc_assert (se
->loop
!= NULL
);
3670 /* Access the previously obtained result. */
3671 gfc_conv_tmp_array_ref (se
);
3675 info
= &se
->ss
->info
->data
.array
;
3680 gfc_init_block (&post
);
3681 gfc_init_interface_mapping (&mapping
);
3684 formal
= sym
->formal
;
3685 need_interface_mapping
= sym
->attr
.dimension
||
3686 (sym
->ts
.type
== BT_CHARACTER
3687 && sym
->ts
.u
.cl
->length
3688 && sym
->ts
.u
.cl
->length
->expr_type
3693 formal
= comp
->formal
;
3694 need_interface_mapping
= comp
->attr
.dimension
||
3695 (comp
->ts
.type
== BT_CHARACTER
3696 && comp
->ts
.u
.cl
->length
3697 && comp
->ts
.u
.cl
->length
->expr_type
3701 base_object
= NULL_TREE
;
3703 /* Evaluate the arguments. */
3704 for (arg
= args
; arg
!= NULL
;
3705 arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
3708 fsym
= formal
? formal
->sym
: NULL
;
3709 parm_kind
= MISSING
;
3711 /* Class array expressions are sometimes coming completely unadorned
3712 with either arrayspec or _data component. Correct that here.
3713 OOP-TODO: Move this to the frontend. */
3714 if (e
&& e
->expr_type
== EXPR_VARIABLE
3716 && e
->ts
.type
== BT_CLASS
3717 && CLASS_DATA (e
)->attr
.dimension
)
3719 gfc_typespec temp_ts
= e
->ts
;
3720 gfc_add_class_array_ref (e
);
3726 if (se
->ignore_optional
)
3728 /* Some intrinsics have already been resolved to the correct
3732 else if (arg
->label
)
3734 has_alternate_specifier
= 1;
3739 /* Pass a NULL pointer for an absent arg. */
3740 gfc_init_se (&parmse
, NULL
);
3741 parmse
.expr
= null_pointer_node
;
3742 if (arg
->missing_arg_type
== BT_CHARACTER
)
3743 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3746 else if (arg
->expr
->expr_type
== EXPR_NULL
3747 && fsym
&& !fsym
->attr
.pointer
3748 && (fsym
->ts
.type
!= BT_CLASS
3749 || !CLASS_DATA (fsym
)->attr
.class_pointer
))
3751 /* Pass a NULL pointer to denote an absent arg. */
3752 gcc_assert (fsym
->attr
.optional
&& !fsym
->attr
.allocatable
3753 && (fsym
->ts
.type
!= BT_CLASS
3754 || !CLASS_DATA (fsym
)->attr
.allocatable
));
3755 gfc_init_se (&parmse
, NULL
);
3756 parmse
.expr
= null_pointer_node
;
3757 if (arg
->missing_arg_type
== BT_CHARACTER
)
3758 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
3760 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
3761 && e
->ts
.type
== BT_DERIVED
)
3763 /* The derived type needs to be converted to a temporary
3765 gfc_init_se (&parmse
, se
);
3766 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
, NULL
);
3768 else if (se
->ss
&& se
->ss
->info
->useflags
)
3774 /* An elemental function inside a scalarized loop. */
3775 gfc_init_se (&parmse
, se
);
3776 parm_kind
= ELEMENTAL
;
3778 if (ss
->dimen
> 0 && e
->expr_type
== EXPR_VARIABLE
3779 && ss
->info
->data
.array
.ref
== NULL
)
3781 gfc_conv_tmp_array_ref (&parmse
);
3782 if (e
->ts
.type
== BT_CHARACTER
)
3783 gfc_conv_string_parameter (&parmse
);
3785 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3788 gfc_conv_expr_reference (&parmse
, e
);
3790 if (fsym
&& fsym
->ts
.type
== BT_DERIVED
3791 && gfc_is_class_container_ref (e
))
3792 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
3794 /* If we are passing an absent array as optional dummy to an
3795 elemental procedure, make sure that we pass NULL when the data
3796 pointer is NULL. We need this extra conditional because of
3797 scalarization which passes arrays elements to the procedure,
3798 ignoring the fact that the array can be absent/unallocated/... */
3799 if (ss
->info
->can_be_null_ref
&& ss
->info
->type
!= GFC_SS_REFERENCE
)
3801 tree descriptor_data
;
3803 descriptor_data
= ss
->info
->data
.array
.data
;
3804 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
3806 fold_convert (TREE_TYPE (descriptor_data
),
3807 null_pointer_node
));
3809 = fold_build3_loc (input_location
, COND_EXPR
,
3810 TREE_TYPE (parmse
.expr
),
3812 fold_convert (TREE_TYPE (parmse
.expr
),
3817 /* The scalarizer does not repackage the reference to a class
3818 array - instead it returns a pointer to the data element. */
3819 if (fsym
&& fsym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
)
3820 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, true);
3827 /* Check whether the expression is a scalar or not; we cannot use
3828 e->rank as it can be nonzero for functions arguments. */
3829 argss
= gfc_walk_expr (e
);
3830 scalar
= argss
== gfc_ss_terminator
;
3832 gfc_free_ss_chain (argss
);
3834 /* A scalar or transformational function. */
3835 gfc_init_se (&parmse
, NULL
);
3839 if (e
->expr_type
== EXPR_VARIABLE
3840 && e
->symtree
->n
.sym
->attr
.cray_pointee
3841 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
3843 /* The Cray pointer needs to be converted to a pointer to
3844 a type given by the expression. */
3845 gfc_conv_expr (&parmse
, e
);
3846 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
3847 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
3848 parmse
.expr
= convert (type
, tmp
);
3850 else if (fsym
&& fsym
->attr
.value
)
3852 if (fsym
->ts
.type
== BT_CHARACTER
3853 && fsym
->ts
.is_c_interop
3854 && fsym
->ns
->proc_name
!= NULL
3855 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
3858 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
3859 if (parmse
.expr
== NULL
)
3860 gfc_conv_expr (&parmse
, e
);
3863 gfc_conv_expr (&parmse
, e
);
3865 else if (arg
->name
&& arg
->name
[0] == '%')
3866 /* Argument list functions %VAL, %LOC and %REF are signalled
3867 through arg->name. */
3868 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
3869 else if ((e
->expr_type
== EXPR_FUNCTION
)
3870 && ((e
->value
.function
.esym
3871 && e
->value
.function
.esym
->result
->attr
.pointer
)
3872 || (!e
->value
.function
.esym
3873 && e
->symtree
->n
.sym
->attr
.pointer
))
3874 && fsym
&& fsym
->attr
.target
)
3876 gfc_conv_expr (&parmse
, e
);
3877 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3879 else if (e
->expr_type
== EXPR_FUNCTION
3880 && e
->symtree
->n
.sym
->result
3881 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
3882 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3884 /* Functions returning procedure pointers. */
3885 gfc_conv_expr (&parmse
, e
);
3886 if (fsym
&& fsym
->attr
.proc_pointer
)
3887 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3891 gfc_conv_expr_reference (&parmse
, e
);
3893 /* Catch base objects that are not variables. */
3894 if (e
->ts
.type
== BT_CLASS
3895 && e
->expr_type
!= EXPR_VARIABLE
3896 && expr
&& e
== expr
->base_expr
)
3897 base_object
= build_fold_indirect_ref_loc (input_location
,
3900 /* A class array element needs converting back to be a
3901 class object, if the formal argument is a class object. */
3902 if (fsym
&& fsym
->ts
.type
== BT_CLASS
3903 && e
->ts
.type
== BT_CLASS
3904 && ((CLASS_DATA (fsym
)->as
3905 && CLASS_DATA (fsym
)->as
->type
== AS_ASSUMED_RANK
)
3906 || CLASS_DATA (e
)->attr
.dimension
))
3907 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false);
3909 if (fsym
&& (fsym
->ts
.type
== BT_DERIVED
3910 || fsym
->ts
.type
== BT_ASSUMED
)
3911 && e
->ts
.type
== BT_CLASS
3912 && !CLASS_DATA (e
)->attr
.dimension
3913 && !CLASS_DATA (e
)->attr
.codimension
)
3914 parmse
.expr
= gfc_class_data_get (parmse
.expr
);
3916 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3917 allocated on entry, it must be deallocated. */
3918 if (fsym
&& fsym
->attr
.intent
== INTENT_OUT
3919 && (fsym
->attr
.allocatable
3920 || (fsym
->ts
.type
== BT_CLASS
3921 && CLASS_DATA (e
)->attr
.allocatable
)))
3926 gfc_init_block (&block
);
3928 if (e
->ts
.type
== BT_CLASS
)
3929 ptr
= gfc_class_data_get (ptr
);
3931 tmp
= gfc_deallocate_with_status (ptr
, NULL_TREE
,
3932 NULL_TREE
, NULL_TREE
,
3933 NULL_TREE
, true, NULL
,
3935 gfc_add_expr_to_block (&block
, tmp
);
3936 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3937 void_type_node
, ptr
,
3939 gfc_add_expr_to_block (&block
, tmp
);
3941 if (fsym
->ts
.type
== BT_CLASS
)
3944 gcc_assert (fsym
->ts
.u
.derived
== e
->ts
.u
.derived
);
3945 vtab
= gfc_find_derived_vtab (fsym
->ts
.u
.derived
);
3946 tmp
= gfc_get_symbol_decl (vtab
);
3947 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3948 ptr
= gfc_class_vptr_get (parmse
.expr
);
3949 gfc_add_modify (&block
, ptr
,
3950 fold_convert (TREE_TYPE (ptr
), tmp
));
3951 gfc_add_expr_to_block (&block
, tmp
);
3954 if (fsym
->attr
.optional
3955 && e
->expr_type
== EXPR_VARIABLE
3956 && e
->symtree
->n
.sym
->attr
.optional
)
3958 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
3960 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3961 gfc_finish_block (&block
),
3962 build_empty_stmt (input_location
));
3965 tmp
= gfc_finish_block (&block
);
3967 gfc_add_expr_to_block (&se
->pre
, tmp
);
3970 /* Wrap scalar variable in a descriptor. We need to convert
3971 the address of a pointer back to the pointer itself before,
3972 we can assign it to the data field. */
3974 if (fsym
&& fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_RANK
3975 && fsym
->ts
.type
!= BT_CLASS
&& e
->expr_type
!= EXPR_NULL
)
3978 if (TREE_CODE (tmp
) == ADDR_EXPR
3979 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp
, 0))))
3980 tmp
= TREE_OPERAND (tmp
, 0);
3981 parmse
.expr
= conv_scalar_to_descriptor (&parmse
, tmp
,
3983 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
,
3986 else if (fsym
&& e
->expr_type
!= EXPR_NULL
3987 && ((fsym
->attr
.pointer
3988 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3989 || (fsym
->attr
.proc_pointer
3990 && !(e
->expr_type
== EXPR_VARIABLE
3991 && e
->symtree
->n
.sym
->attr
.dummy
))
3992 || (fsym
->attr
.proc_pointer
3993 && e
->expr_type
== EXPR_VARIABLE
3994 && gfc_is_proc_ptr_comp (e
))
3995 || (fsym
->attr
.allocatable
3996 && fsym
->attr
.flavor
!= FL_PROCEDURE
)))
3998 /* Scalar pointer dummy args require an extra level of
3999 indirection. The null pointer already contains
4000 this level of indirection. */
4001 parm_kind
= SCALAR_POINTER
;
4002 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
4006 else if (e
->ts
.type
== BT_CLASS
4007 && fsym
&& fsym
->ts
.type
== BT_CLASS
4008 && CLASS_DATA (fsym
)->attr
.dimension
)
4010 /* Pass a class array. */
4011 gfc_init_se (&parmse
, se
);
4012 gfc_conv_expr_descriptor (&parmse
, e
);
4013 /* The conversion does not repackage the reference to a class
4014 array - _data descriptor. */
4015 gfc_conv_class_to_class (&parmse
, e
, fsym
->ts
, false);
4019 /* If the procedure requires an explicit interface, the actual
4020 argument is passed according to the corresponding formal
4021 argument. If the corresponding formal argument is a POINTER,
4022 ALLOCATABLE or assumed shape, we do not use g77's calling
4023 convention, and pass the address of the array descriptor
4024 instead. Otherwise we use g77's calling convention. */
4027 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
4028 && fsym
->as
&& fsym
->as
->type
!= AS_ASSUMED_SHAPE
4029 && fsym
->as
->type
!= AS_ASSUMED_RANK
;
4031 f
= f
|| !comp
->attr
.always_explicit
;
4033 f
= f
|| !sym
->attr
.always_explicit
;
4035 /* If the argument is a function call that may not create
4036 a temporary for the result, we have to check that we
4037 can do it, i.e. that there is no alias between this
4038 argument and another one. */
4039 if (gfc_get_noncopying_intrinsic_argument (e
) != NULL
)
4045 intent
= fsym
->attr
.intent
;
4047 intent
= INTENT_UNKNOWN
;
4049 if (gfc_check_fncall_dependency (e
, intent
, sym
, args
,
4051 parmse
.force_tmp
= 1;
4053 iarg
= e
->value
.function
.actual
->expr
;
4055 /* Temporary needed if aliasing due to host association. */
4056 if (sym
->attr
.contained
4058 && !sym
->attr
.implicit_pure
4059 && !sym
->attr
.use_assoc
4060 && iarg
->expr_type
== EXPR_VARIABLE
4061 && sym
->ns
== iarg
->symtree
->n
.sym
->ns
)
4062 parmse
.force_tmp
= 1;
4064 /* Ditto within module. */
4065 if (sym
->attr
.use_assoc
4067 && !sym
->attr
.implicit_pure
4068 && iarg
->expr_type
== EXPR_VARIABLE
4069 && sym
->module
== iarg
->symtree
->n
.sym
->module
)
4070 parmse
.force_tmp
= 1;
4073 if (e
->expr_type
== EXPR_VARIABLE
4074 && is_subref_array (e
))
4075 /* The actual argument is a component reference to an
4076 array of derived types. In this case, the argument
4077 is converted to a temporary, which is passed and then
4078 written back after the procedure call. */
4079 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4080 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4081 fsym
&& fsym
->attr
.pointer
);
4082 else if (gfc_is_class_array_ref (e
, NULL
)
4083 && fsym
&& fsym
->ts
.type
== BT_DERIVED
)
4084 /* The actual argument is a component reference to an
4085 array of derived types. In this case, the argument
4086 is converted to a temporary, which is passed and then
4087 written back after the procedure call.
4088 OOP-TODO: Insert code so that if the dynamic type is
4089 the same as the declared type, copy-in/copy-out does
4091 gfc_conv_subref_array_arg (&parmse
, e
, f
,
4092 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
4093 fsym
&& fsym
->attr
.pointer
);
4095 gfc_conv_array_parameter (&parmse
, e
, f
, fsym
, sym
->name
, NULL
);
4097 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
4098 allocated on entry, it must be deallocated. */
4099 if (fsym
&& fsym
->attr
.allocatable
4100 && fsym
->attr
.intent
== INTENT_OUT
)
4102 tmp
= build_fold_indirect_ref_loc (input_location
,
4104 tmp
= gfc_trans_dealloc_allocated (tmp
, false);
4105 if (fsym
->attr
.optional
4106 && e
->expr_type
== EXPR_VARIABLE
4107 && e
->symtree
->n
.sym
->attr
.optional
)
4108 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
4110 gfc_conv_expr_present (e
->symtree
->n
.sym
),
4111 tmp
, build_empty_stmt (input_location
));
4112 gfc_add_expr_to_block (&se
->pre
, tmp
);
4117 /* The case with fsym->attr.optional is that of a user subroutine
4118 with an interface indicating an optional argument. When we call
4119 an intrinsic subroutine, however, fsym is NULL, but we might still
4120 have an optional argument, so we proceed to the substitution
4122 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
4124 /* If an optional argument is itself an optional dummy argument,
4125 check its presence and substitute a null if absent. This is
4126 only needed when passing an array to an elemental procedure
4127 as then array elements are accessed - or no NULL pointer is
4128 allowed and a "1" or "0" should be passed if not present.
4129 When passing a non-array-descriptor full array to a
4130 non-array-descriptor dummy, no check is needed. For
4131 array-descriptor actual to array-descriptor dummy, see
4132 PR 41911 for why a check has to be inserted.
4133 fsym == NULL is checked as intrinsics required the descriptor
4134 but do not always set fsym. */
4135 if (e
->expr_type
== EXPR_VARIABLE
4136 && e
->symtree
->n
.sym
->attr
.optional
4137 && ((e
->rank
!= 0 && sym
->attr
.elemental
)
4138 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
4142 && (fsym
->as
->type
== AS_ASSUMED_SHAPE
4143 || fsym
->as
->type
== AS_ASSUMED_RANK
4144 || fsym
->as
->type
== AS_DEFERRED
))))))
4145 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
4146 e
->representation
.length
);
4151 /* Obtain the character length of an assumed character length
4152 length procedure from the typespec. */
4153 if (fsym
->ts
.type
== BT_CHARACTER
4154 && parmse
.string_length
== NULL_TREE
4155 && e
->ts
.type
== BT_PROCEDURE
4156 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
4157 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
4158 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4160 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
4161 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
4165 if (fsym
&& need_interface_mapping
&& e
)
4166 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
4168 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4169 gfc_add_block_to_block (&post
, &parmse
.post
);
4171 /* Allocated allocatable components of derived types must be
4172 deallocated for non-variable scalars. Non-variable arrays are
4173 dealt with in trans-array.c(gfc_conv_array_parameter). */
4174 if (e
&& (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
)
4175 && e
->ts
.u
.derived
->attr
.alloc_comp
4176 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
4177 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
4180 tmp
= build_fold_indirect_ref_loc (input_location
,
4182 parm_rank
= e
->rank
;
4190 case (SCALAR_POINTER
):
4191 tmp
= build_fold_indirect_ref_loc (input_location
,
4196 if (e
->expr_type
== EXPR_OP
4197 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
4198 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
4201 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
4202 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
4203 gfc_add_expr_to_block (&se
->post
, local_tmp
);
4206 if (e
->ts
.type
== BT_DERIVED
&& fsym
&& fsym
->ts
.type
== BT_CLASS
)
4208 /* The derived type is passed to gfc_deallocate_alloc_comp.
4209 Therefore, class actuals can handled correctly but derived
4210 types passed to class formals need the _data component. */
4211 tmp
= gfc_class_data_get (tmp
);
4212 if (!CLASS_DATA (fsym
)->attr
.dimension
)
4213 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4216 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
4218 gfc_add_expr_to_block (&se
->post
, tmp
);
4221 /* Add argument checking of passing an unallocated/NULL actual to
4222 a nonallocatable/nonpointer dummy. */
4224 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
4226 symbol_attribute attr
;
4230 if (e
->expr_type
== EXPR_VARIABLE
|| e
->expr_type
== EXPR_FUNCTION
)
4231 attr
= gfc_expr_attr (e
);
4233 goto end_pointer_check
;
4235 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
4236 allocatable to an optional dummy, cf. 12.5.2.12. */
4237 if (fsym
!= NULL
&& fsym
->attr
.optional
&& !attr
.proc_pointer
4238 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4239 goto end_pointer_check
;
4243 /* If the actual argument is an optional pointer/allocatable and
4244 the formal argument takes an nonpointer optional value,
4245 it is invalid to pass a non-present argument on, even
4246 though there is no technical reason for this in gfortran.
4247 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
4248 tree present
, null_ptr
, type
;
4250 if (attr
.allocatable
4251 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4252 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4253 "allocated or not present", e
->symtree
->n
.sym
->name
);
4254 else if (attr
.pointer
4255 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4256 asprintf (&msg
, "Pointer actual argument '%s' is not "
4257 "associated or not present",
4258 e
->symtree
->n
.sym
->name
);
4259 else if (attr
.proc_pointer
4260 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4261 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4262 "associated or not present",
4263 e
->symtree
->n
.sym
->name
);
4265 goto end_pointer_check
;
4267 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
4268 type
= TREE_TYPE (present
);
4269 present
= fold_build2_loc (input_location
, EQ_EXPR
,
4270 boolean_type_node
, present
,
4272 null_pointer_node
));
4273 type
= TREE_TYPE (parmse
.expr
);
4274 null_ptr
= fold_build2_loc (input_location
, EQ_EXPR
,
4275 boolean_type_node
, parmse
.expr
,
4277 null_pointer_node
));
4278 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
4279 boolean_type_node
, present
, null_ptr
);
4283 if (attr
.allocatable
4284 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
4285 asprintf (&msg
, "Allocatable actual argument '%s' is not "
4286 "allocated", e
->symtree
->n
.sym
->name
);
4287 else if (attr
.pointer
4288 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
4289 asprintf (&msg
, "Pointer actual argument '%s' is not "
4290 "associated", e
->symtree
->n
.sym
->name
);
4291 else if (attr
.proc_pointer
4292 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
4293 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
4294 "associated", e
->symtree
->n
.sym
->name
);
4296 goto end_pointer_check
;
4300 /* If the argument is passed by value, we need to strip the
4302 if (!POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)))
4303 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4305 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
4306 boolean_type_node
, tmp
,
4307 fold_convert (TREE_TYPE (tmp
),
4308 null_pointer_node
));
4311 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
4317 /* Deferred length dummies pass the character length by reference
4318 so that the value can be returned. */
4319 if (parmse
.string_length
&& fsym
&& fsym
->ts
.deferred
)
4321 tmp
= parmse
.string_length
;
4322 if (TREE_CODE (tmp
) != VAR_DECL
)
4323 tmp
= gfc_evaluate_now (parmse
.string_length
, &se
->pre
);
4324 parmse
.string_length
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4327 /* Character strings are passed as two parameters, a length and a
4328 pointer - except for Bind(c) which only passes the pointer. */
4329 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
4330 VEC_safe_push (tree
, gc
, stringargs
, parmse
.string_length
);
4332 /* For descriptorless coarrays and assumed-shape coarray dummies, we
4333 pass the token and the offset as additional arguments. */
4334 if (fsym
&& fsym
->attr
.codimension
4335 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
4336 && !fsym
->attr
.allocatable
4339 /* Token and offset. */
4340 VEC_safe_push (tree
, gc
, stringargs
, null_pointer_node
);
4341 VEC_safe_push (tree
, gc
, stringargs
,
4342 build_int_cst (gfc_array_index_type
, 0));
4343 gcc_assert (fsym
->attr
.optional
);
4345 else if (fsym
&& fsym
->attr
.codimension
4346 && !fsym
->attr
.allocatable
4347 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
4349 tree caf_decl
, caf_type
;
4352 caf_decl
= get_tree_for_caf_expr (e
);
4353 caf_type
= TREE_TYPE (caf_decl
);
4355 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4356 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4357 tmp
= gfc_conv_descriptor_token (caf_decl
);
4358 else if (DECL_LANG_SPECIFIC (caf_decl
)
4359 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
4360 tmp
= GFC_DECL_TOKEN (caf_decl
);
4363 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
4364 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
4365 tmp
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
4368 VEC_safe_push (tree
, gc
, stringargs
, tmp
);
4370 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
4371 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
4372 offset
= build_int_cst (gfc_array_index_type
, 0);
4373 else if (DECL_LANG_SPECIFIC (caf_decl
)
4374 && GFC_DECL_CAF_OFFSET (caf_decl
) != NULL_TREE
)
4375 offset
= GFC_DECL_CAF_OFFSET (caf_decl
);
4376 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) != NULL_TREE
)
4377 offset
= GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
);
4379 offset
= build_int_cst (gfc_array_index_type
, 0);
4381 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
4382 tmp
= gfc_conv_descriptor_data_get (caf_decl
);
4385 gcc_assert (POINTER_TYPE_P (caf_type
));
4389 if (fsym
->as
->type
== AS_ASSUMED_SHAPE
4390 || (fsym
->as
->type
== AS_ASSUMED_RANK
&& !fsym
->attr
.pointer
4391 && !fsym
->attr
.allocatable
))
4393 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4394 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
4395 (TREE_TYPE (parmse
.expr
))));
4396 tmp2
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
4397 tmp2
= gfc_conv_descriptor_data_get (tmp2
);
4399 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse
.expr
)))
4400 tmp2
= gfc_conv_descriptor_data_get (parmse
.expr
);
4403 gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse
.expr
)));
4407 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4408 gfc_array_index_type
,
4409 fold_convert (gfc_array_index_type
, tmp2
),
4410 fold_convert (gfc_array_index_type
, tmp
));
4411 offset
= fold_build2_loc (input_location
, PLUS_EXPR
,
4412 gfc_array_index_type
, offset
, tmp
);
4414 VEC_safe_push (tree
, gc
, stringargs
, offset
);
4417 VEC_safe_push (tree
, gc
, arglist
, parmse
.expr
);
4419 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
4426 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
4427 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
4428 else if (ts
.type
== BT_CHARACTER
)
4430 if (ts
.u
.cl
->length
== NULL
)
4432 /* Assumed character length results are not allowed by 5.1.1.5 of the
4433 standard and are trapped in resolve.c; except in the case of SPREAD
4434 (and other intrinsics?) and dummy functions. In the case of SPREAD,
4435 we take the character length of the first argument for the result.
4436 For dummies, we have to look through the formal argument list for
4437 this function and use the character length found there.*/
4439 cl
.backend_decl
= gfc_create_var (gfc_charlen_type_node
, "slen");
4440 else if (!sym
->attr
.dummy
)
4441 cl
.backend_decl
= VEC_index (tree
, stringargs
, 0);
4444 formal
= sym
->ns
->proc_name
->formal
;
4445 for (; formal
; formal
= formal
->next
)
4446 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
4447 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
4449 len
= cl
.backend_decl
;
4455 /* Calculate the length of the returned string. */
4456 gfc_init_se (&parmse
, NULL
);
4457 if (need_interface_mapping
)
4458 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
4460 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
4461 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
4462 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
4464 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
4465 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
4466 gfc_charlen_type_node
, tmp
,
4467 build_int_cst (gfc_charlen_type_node
, 0));
4468 cl
.backend_decl
= tmp
;
4471 /* Set up a charlen structure for it. */
4476 len
= cl
.backend_decl
;
4479 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
4480 || (!comp
&& gfc_return_by_reference (sym
));
4483 if (se
->direct_byref
)
4485 /* Sometimes, too much indirection can be applied; e.g. for
4486 function_result = array_valued_recursive_function. */
4487 if (TREE_TYPE (TREE_TYPE (se
->expr
))
4488 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
4489 && GFC_DESCRIPTOR_TYPE_P
4490 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
4491 se
->expr
= build_fold_indirect_ref_loc (input_location
,
4494 /* If the lhs of an assignment x = f(..) is allocatable and
4495 f2003 is allowed, we must do the automatic reallocation.
4496 TODO - deal with intrinsics, without using a temporary. */
4497 if (gfc_option
.flag_realloc_lhs
4498 && se
->ss
&& se
->ss
->loop_chain
4499 && se
->ss
->loop_chain
->is_alloc_lhs
4500 && !expr
->value
.function
.isym
4501 && sym
->result
->as
!= NULL
)
4503 /* Evaluate the bounds of the result, if known. */
4504 gfc_set_loop_bounds_from_array_spec (&mapping
, se
,
4507 /* Perform the automatic reallocation. */
4508 tmp
= gfc_alloc_allocatable_for_assignment (se
->loop
,
4510 gfc_add_expr_to_block (&se
->pre
, tmp
);
4512 /* Pass the temporary as the first argument. */
4513 result
= info
->descriptor
;
4516 result
= build_fold_indirect_ref_loc (input_location
,
4518 VEC_safe_push (tree
, gc
, retargs
, se
->expr
);
4520 else if (comp
&& comp
->attr
.dimension
)
4522 gcc_assert (se
->loop
&& info
);
4524 /* Set the type of the array. */
4525 tmp
= gfc_typenode_for_spec (&comp
->ts
);
4526 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4528 /* Evaluate the bounds of the result, if known. */
4529 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
4531 /* If the lhs of an assignment x = f(..) is allocatable and
4532 f2003 is allowed, we must not generate the function call
4533 here but should just send back the results of the mapping.
4534 This is signalled by the function ss being flagged. */
4535 if (gfc_option
.flag_realloc_lhs
4536 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4538 gfc_free_interface_mapping (&mapping
);
4539 return has_alternate_specifier
;
4542 /* Create a temporary to store the result. In case the function
4543 returns a pointer, the temporary will be a shallow copy and
4544 mustn't be deallocated. */
4545 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
4546 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4547 tmp
, NULL_TREE
, false,
4548 !comp
->attr
.pointer
, callee_alloc
,
4549 &se
->ss
->info
->expr
->where
);
4551 /* Pass the temporary as the first argument. */
4552 result
= info
->descriptor
;
4553 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4554 VEC_safe_push (tree
, gc
, retargs
, tmp
);
4556 else if (!comp
&& sym
->result
->attr
.dimension
)
4558 gcc_assert (se
->loop
&& info
);
4560 /* Set the type of the array. */
4561 tmp
= gfc_typenode_for_spec (&ts
);
4562 gcc_assert (se
->ss
->dimen
== se
->loop
->dimen
);
4564 /* Evaluate the bounds of the result, if known. */
4565 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
4567 /* If the lhs of an assignment x = f(..) is allocatable and
4568 f2003 is allowed, we must not generate the function call
4569 here but should just send back the results of the mapping.
4570 This is signalled by the function ss being flagged. */
4571 if (gfc_option
.flag_realloc_lhs
4572 && se
->ss
&& se
->ss
->is_alloc_lhs
)
4574 gfc_free_interface_mapping (&mapping
);
4575 return has_alternate_specifier
;
4578 /* Create a temporary to store the result. In case the function
4579 returns a pointer, the temporary will be a shallow copy and
4580 mustn't be deallocated. */
4581 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
4582 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->ss
,
4583 tmp
, NULL_TREE
, false,
4584 !sym
->attr
.pointer
, callee_alloc
,
4585 &se
->ss
->info
->expr
->where
);
4587 /* Pass the temporary as the first argument. */
4588 result
= info
->descriptor
;
4589 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
4590 VEC_safe_push (tree
, gc
, retargs
, tmp
);
4592 else if (ts
.type
== BT_CHARACTER
)
4594 /* Pass the string length. */
4595 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
4596 type
= build_pointer_type (type
);
4598 /* Return an address to a char[0:len-1]* temporary for
4599 character pointers. */
4600 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4601 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
4603 var
= gfc_create_var (type
, "pstr");
4605 if ((!comp
&& sym
->attr
.allocatable
)
4606 || (comp
&& comp
->attr
.allocatable
))
4608 gfc_add_modify (&se
->pre
, var
,
4609 fold_convert (TREE_TYPE (var
),
4610 null_pointer_node
));
4611 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
4612 gfc_add_expr_to_block (&se
->post
, tmp
);
4615 /* Provide an address expression for the function arguments. */
4616 var
= gfc_build_addr_expr (NULL_TREE
, var
);
4619 var
= gfc_conv_string_tmp (se
, type
, len
);
4621 VEC_safe_push (tree
, gc
, retargs
, var
);
4625 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
4627 type
= gfc_get_complex_type (ts
.kind
);
4628 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
4629 VEC_safe_push (tree
, gc
, retargs
, var
);
4632 /* Add the string length to the argument list. */
4633 if (ts
.type
== BT_CHARACTER
&& ts
.deferred
)
4636 if (TREE_CODE (tmp
) != VAR_DECL
)
4637 tmp
= gfc_evaluate_now (len
, &se
->pre
);
4638 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
4639 VEC_safe_push (tree
, gc
, retargs
, tmp
);
4641 else if (ts
.type
== BT_CHARACTER
)
4642 VEC_safe_push (tree
, gc
, retargs
, len
);
4644 gfc_free_interface_mapping (&mapping
);
4646 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
4647 arglen
= (VEC_length (tree
, arglist
)
4648 + VEC_length (tree
, stringargs
) + VEC_length (tree
, append_args
));
4649 VEC_reserve_exact (tree
, gc
, retargs
, arglen
);
4651 /* Add the return arguments. */
4652 VEC_splice (tree
, retargs
, arglist
);
4654 /* Add the hidden string length parameters to the arguments. */
4655 VEC_splice (tree
, retargs
, stringargs
);
4657 /* We may want to append extra arguments here. This is used e.g. for
4658 calls to libgfortran_matmul_??, which need extra information. */
4659 if (!VEC_empty (tree
, append_args
))
4660 VEC_splice (tree
, retargs
, append_args
);
4663 /* Generate the actual call. */
4664 if (base_object
== NULL_TREE
)
4665 conv_function_val (se
, sym
, expr
);
4667 conv_base_obj_fcn_val (se
, base_object
, expr
);
4669 /* If there are alternate return labels, function type should be
4670 integer. Can't modify the type in place though, since it can be shared
4671 with other functions. For dummy arguments, the typing is done to
4672 this result, even if it has to be repeated for each call. */
4673 if (has_alternate_specifier
4674 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
4676 if (!sym
->attr
.dummy
)
4678 TREE_TYPE (sym
->backend_decl
)
4679 = build_function_type (integer_type_node
,
4680 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
4681 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
4684 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
4687 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
4688 se
->expr
= build_call_vec (TREE_TYPE (fntype
), se
->expr
, arglist
);
4690 /* If we have a pointer function, but we don't want a pointer, e.g.
4693 where f is pointer valued, we have to dereference the result. */
4694 if (!se
->want_pointer
&& !byref
4695 && ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4696 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
))))
4697 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
4699 /* f2c calling conventions require a scalar default real function to
4700 return a double precision result. Convert this back to default
4701 real. We only care about the cases that can happen in Fortran 77.
4703 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
4704 && sym
->ts
.kind
== gfc_default_real_kind
4705 && !sym
->attr
.always_explicit
)
4706 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
4708 /* A pure function may still have side-effects - it may modify its
4710 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4712 if (!sym
->attr
.pure
)
4713 TREE_SIDE_EFFECTS (se
->expr
) = 1;
4718 /* Add the function call to the pre chain. There is no expression. */
4719 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
4720 se
->expr
= NULL_TREE
;
4722 if (!se
->direct_byref
)
4724 if ((sym
->attr
.dimension
&& !comp
) || (comp
&& comp
->attr
.dimension
))
4726 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4728 /* Check the data pointer hasn't been modified. This would
4729 happen in a function returning a pointer. */
4730 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
4731 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
4734 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
4737 se
->expr
= info
->descriptor
;
4738 /* Bundle in the string length. */
4739 se
->string_length
= len
;
4741 else if (ts
.type
== BT_CHARACTER
)
4743 /* Dereference for character pointer results. */
4744 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
4745 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
4746 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
4750 se
->string_length
= len
;
4754 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
4755 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
4760 /* Follow the function call with the argument post block. */
4763 gfc_add_block_to_block (&se
->pre
, &post
);
4765 /* Transformational functions of derived types with allocatable
4766 components must have the result allocatable components copied. */
4767 arg
= expr
->value
.function
.actual
;
4768 if (result
&& arg
&& expr
->rank
4769 && expr
->value
.function
.isym
4770 && expr
->value
.function
.isym
->transformational
4771 && arg
->expr
->ts
.type
== BT_DERIVED
4772 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
4775 /* Copy the allocatable components. We have to use a
4776 temporary here to prevent source allocatable components
4777 from being corrupted. */
4778 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
4779 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
4780 result
, tmp2
, expr
->rank
);
4781 gfc_add_expr_to_block (&se
->pre
, tmp
);
4782 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
4784 gfc_add_expr_to_block (&se
->pre
, tmp
);
4786 /* Finally free the temporary's data field. */
4787 tmp
= gfc_conv_descriptor_data_get (tmp2
);
4788 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, NULL_TREE
,
4789 NULL_TREE
, NULL_TREE
, true,
4791 gfc_add_expr_to_block (&se
->pre
, tmp
);
4795 gfc_add_block_to_block (&se
->post
, &post
);
4797 return has_alternate_specifier
;
4801 /* Fill a character string with spaces. */
4804 fill_with_spaces (tree start
, tree type
, tree size
)
4806 stmtblock_t block
, loop
;
4807 tree i
, el
, exit_label
, cond
, tmp
;
4809 /* For a simple char type, we can call memset(). */
4810 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
4811 return build_call_expr_loc (input_location
,
4812 builtin_decl_explicit (BUILT_IN_MEMSET
),
4814 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
4815 lang_hooks
.to_target_charset (' ')),
4818 /* Otherwise, we use a loop:
4819 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
4823 /* Initialize variables. */
4824 gfc_init_block (&block
);
4825 i
= gfc_create_var (sizetype
, "i");
4826 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
4827 el
= gfc_create_var (build_pointer_type (type
), "el");
4828 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
4829 exit_label
= gfc_build_label_decl (NULL_TREE
);
4830 TREE_USED (exit_label
) = 1;
4834 gfc_init_block (&loop
);
4836 /* Exit condition. */
4837 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, i
,
4838 build_zero_cst (sizetype
));
4839 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4840 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
4841 build_empty_stmt (input_location
));
4842 gfc_add_expr_to_block (&loop
, tmp
);
4845 gfc_add_modify (&loop
,
4846 fold_build1_loc (input_location
, INDIRECT_REF
, type
, el
),
4847 build_int_cst (type
, lang_hooks
.to_target_charset (' ')));
4849 /* Increment loop variables. */
4850 gfc_add_modify (&loop
, i
,
4851 fold_build2_loc (input_location
, MINUS_EXPR
, sizetype
, i
,
4852 TYPE_SIZE_UNIT (type
)));
4853 gfc_add_modify (&loop
, el
,
4854 fold_build_pointer_plus_loc (input_location
,
4855 el
, TYPE_SIZE_UNIT (type
)));
4857 /* Making the loop... actually loop! */
4858 tmp
= gfc_finish_block (&loop
);
4859 tmp
= build1_v (LOOP_EXPR
, tmp
);
4860 gfc_add_expr_to_block (&block
, tmp
);
4862 /* The exit label. */
4863 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4864 gfc_add_expr_to_block (&block
, tmp
);
4867 return gfc_finish_block (&block
);
4871 /* Generate code to copy a string. */
4874 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
4875 int dkind
, tree slength
, tree src
, int skind
)
4877 tree tmp
, dlen
, slen
;
4886 stmtblock_t tempblock
;
4888 gcc_assert (dkind
== skind
);
4890 if (slength
!= NULL_TREE
)
4892 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
4893 ssc
= gfc_string_to_single_character (slen
, src
, skind
);
4897 slen
= build_int_cst (size_type_node
, 1);
4901 if (dlength
!= NULL_TREE
)
4903 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
4904 dsc
= gfc_string_to_single_character (dlen
, dest
, dkind
);
4908 dlen
= build_int_cst (size_type_node
, 1);
4912 /* Assign directly if the types are compatible. */
4913 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
4914 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
4916 gfc_add_modify (block
, dsc
, ssc
);
4920 /* Do nothing if the destination length is zero. */
4921 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, dlen
,
4922 build_int_cst (size_type_node
, 0));
4924 /* The following code was previously in _gfortran_copy_string:
4926 // The two strings may overlap so we use memmove.
4928 copy_string (GFC_INTEGER_4 destlen, char * dest,
4929 GFC_INTEGER_4 srclen, const char * src)
4931 if (srclen >= destlen)
4933 // This will truncate if too long.
4934 memmove (dest, src, destlen);
4938 memmove (dest, src, srclen);
4940 memset (&dest[srclen], ' ', destlen - srclen);
4944 We're now doing it here for better optimization, but the logic
4947 /* For non-default character kinds, we have to multiply the string
4948 length by the base type size. */
4949 chartype
= gfc_get_char_type (dkind
);
4950 slen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4951 fold_convert (size_type_node
, slen
),
4952 fold_convert (size_type_node
,
4953 TYPE_SIZE_UNIT (chartype
)));
4954 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4955 fold_convert (size_type_node
, dlen
),
4956 fold_convert (size_type_node
,
4957 TYPE_SIZE_UNIT (chartype
)));
4959 if (dlength
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
4960 dest
= fold_convert (pvoid_type_node
, dest
);
4962 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4964 if (slength
&& POINTER_TYPE_P (TREE_TYPE (src
)))
4965 src
= fold_convert (pvoid_type_node
, src
);
4967 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4969 /* Truncate string if source is too long. */
4970 cond2
= fold_build2_loc (input_location
, GE_EXPR
, boolean_type_node
, slen
,
4972 tmp2
= build_call_expr_loc (input_location
,
4973 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
4974 3, dest
, src
, dlen
);
4976 /* Else copy and pad with spaces. */
4977 tmp3
= build_call_expr_loc (input_location
,
4978 builtin_decl_explicit (BUILT_IN_MEMMOVE
),
4979 3, dest
, src
, slen
);
4981 tmp4
= fold_build_pointer_plus_loc (input_location
, dest
, slen
);
4982 tmp4
= fill_with_spaces (tmp4
, chartype
,
4983 fold_build2_loc (input_location
, MINUS_EXPR
,
4984 TREE_TYPE(dlen
), dlen
, slen
));
4986 gfc_init_block (&tempblock
);
4987 gfc_add_expr_to_block (&tempblock
, tmp3
);
4988 gfc_add_expr_to_block (&tempblock
, tmp4
);
4989 tmp3
= gfc_finish_block (&tempblock
);
4991 /* The whole copy_string function is there. */
4992 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
4994 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
4995 build_empty_stmt (input_location
));
4996 gfc_add_expr_to_block (block
, tmp
);
5000 /* Translate a statement function.
5001 The value of a statement function reference is obtained by evaluating the
5002 expression using the values of the actual arguments for the values of the
5003 corresponding dummy arguments. */
5006 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
5010 gfc_formal_arglist
*fargs
;
5011 gfc_actual_arglist
*args
;
5014 gfc_saved_var
*saved_vars
;
5020 sym
= expr
->symtree
->n
.sym
;
5021 args
= expr
->value
.function
.actual
;
5022 gfc_init_se (&lse
, NULL
);
5023 gfc_init_se (&rse
, NULL
);
5026 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
5028 saved_vars
= XCNEWVEC (gfc_saved_var
, n
);
5029 temp_vars
= XCNEWVEC (tree
, n
);
5031 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
5033 /* Each dummy shall be specified, explicitly or implicitly, to be
5035 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
5038 if (fsym
->ts
.type
== BT_CHARACTER
)
5040 /* Copy string arguments. */
5043 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
5044 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
5046 /* Create a temporary to hold the value. */
5047 if (fsym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
5048 fsym
->ts
.u
.cl
->backend_decl
5049 = gfc_conv_constant_to_tree (fsym
->ts
.u
.cl
->length
);
5051 type
= gfc_get_character_type (fsym
->ts
.kind
, fsym
->ts
.u
.cl
);
5052 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5054 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
5056 gfc_conv_expr (&rse
, args
->expr
);
5057 gfc_conv_string_parameter (&rse
);
5058 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5059 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
5061 gfc_trans_string_copy (&se
->pre
, arglen
, temp_vars
[n
], fsym
->ts
.kind
,
5062 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
5063 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5064 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
5068 /* For everything else, just evaluate the expression. */
5070 /* Create a temporary to hold the value. */
5071 type
= gfc_typenode_for_spec (&fsym
->ts
);
5072 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
5074 gfc_conv_expr (&lse
, args
->expr
);
5076 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
5077 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
5078 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
5084 /* Use the temporary variables in place of the real ones. */
5085 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
5086 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
5088 gfc_conv_expr (se
, sym
->value
);
5090 if (sym
->ts
.type
== BT_CHARACTER
)
5092 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5094 /* Force the expression to the correct length. */
5095 if (!INTEGER_CST_P (se
->string_length
)
5096 || tree_int_cst_lt (se
->string_length
,
5097 sym
->ts
.u
.cl
->backend_decl
))
5099 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
5100 tmp
= gfc_create_var (type
, sym
->name
);
5101 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
5102 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
5103 sym
->ts
.kind
, se
->string_length
, se
->expr
,
5107 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
5110 /* Restore the original variables. */
5111 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
5112 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
5118 /* Translate a function expression. */
5121 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
5125 if (expr
->value
.function
.isym
)
5127 gfc_conv_intrinsic_function (se
, expr
);
5131 /* We distinguish statement functions from general functions to improve
5132 runtime performance. */
5133 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
5135 gfc_conv_statement_function (se
, expr
);
5139 /* expr.value.function.esym is the resolved (specific) function symbol for
5140 most functions. However this isn't set for dummy procedures. */
5141 sym
= expr
->value
.function
.esym
;
5143 sym
= expr
->symtree
->n
.sym
;
5145 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
, NULL
);
5149 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5152 is_zero_initializer_p (gfc_expr
* expr
)
5154 if (expr
->expr_type
!= EXPR_CONSTANT
)
5157 /* We ignore constants with prescribed memory representations for now. */
5158 if (expr
->representation
.string
)
5161 switch (expr
->ts
.type
)
5164 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5167 return mpfr_zero_p (expr
->value
.real
)
5168 && MPFR_SIGN (expr
->value
.real
) >= 0;
5171 return expr
->value
.logical
== 0;
5174 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5175 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5176 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5177 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5187 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
5192 gcc_assert (ss
!= NULL
&& ss
!= gfc_ss_terminator
);
5193 gcc_assert (ss
->info
->expr
== expr
&& ss
->info
->type
== GFC_SS_CONSTRUCTOR
);
5195 gfc_conv_tmp_array_ref (se
);
5199 /* Build a static initializer. EXPR is the expression for the initial value.
5200 The other parameters describe the variable of the component being
5201 initialized. EXPR may be null. */
5204 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
5205 bool array
, bool pointer
, bool procptr
)
5209 if (!(expr
|| pointer
|| procptr
))
5212 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
5213 (these are the only two iso_c_binding derived types that can be
5214 used as initialization expressions). If so, we need to modify
5215 the 'expr' to be that for a (void *). */
5216 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
5217 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
5219 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
5221 /* The derived symbol has already been converted to a (void *). Use
5223 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
5224 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
5226 gfc_init_se (&se
, NULL
);
5227 gfc_conv_constant (&se
, expr
);
5228 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5232 if (array
&& !procptr
)
5235 /* Arrays need special handling. */
5237 ctor
= gfc_build_null_descriptor (type
);
5238 /* Special case assigning an array to zero. */
5239 else if (is_zero_initializer_p (expr
))
5240 ctor
= build_constructor (type
, NULL
);
5242 ctor
= gfc_conv_array_initializer (type
, expr
);
5243 TREE_STATIC (ctor
) = 1;
5246 else if (pointer
|| procptr
)
5248 if (!expr
|| expr
->expr_type
== EXPR_NULL
)
5249 return fold_convert (type
, null_pointer_node
);
5252 gfc_init_se (&se
, NULL
);
5253 se
.want_pointer
= 1;
5254 gfc_conv_expr (&se
, expr
);
5255 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5265 gfc_init_se (&se
, NULL
);
5266 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5267 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
5269 gfc_conv_structure (&se
, expr
, 1);
5270 gcc_assert (TREE_CODE (se
.expr
) == CONSTRUCTOR
);
5271 TREE_STATIC (se
.expr
) = 1;
5276 tree ctor
= gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
5277 TREE_STATIC (ctor
) = 1;
5282 gfc_init_se (&se
, NULL
);
5283 gfc_conv_constant (&se
, expr
);
5284 gcc_assert (TREE_CODE (se
.expr
) != CONSTRUCTOR
);
5291 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5297 gfc_array_info
*lss_array
;
5304 gfc_start_block (&block
);
5306 /* Initialize the scalarizer. */
5307 gfc_init_loopinfo (&loop
);
5309 gfc_init_se (&lse
, NULL
);
5310 gfc_init_se (&rse
, NULL
);
5313 rss
= gfc_walk_expr (expr
);
5314 if (rss
== gfc_ss_terminator
)
5315 /* The rhs is scalar. Add a ss for the expression. */
5316 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr
);
5318 /* Create a SS for the destination. */
5319 lss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, cm
->as
->rank
,
5321 lss_array
= &lss
->info
->data
.array
;
5322 lss_array
->shape
= gfc_get_shape (cm
->as
->rank
);
5323 lss_array
->descriptor
= dest
;
5324 lss_array
->data
= gfc_conv_array_data (dest
);
5325 lss_array
->offset
= gfc_conv_array_offset (dest
);
5326 for (n
= 0; n
< cm
->as
->rank
; n
++)
5328 lss_array
->start
[n
] = gfc_conv_array_lbound (dest
, n
);
5329 lss_array
->stride
[n
] = gfc_index_one_node
;
5331 mpz_init (lss_array
->shape
[n
]);
5332 mpz_sub (lss_array
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
5333 cm
->as
->lower
[n
]->value
.integer
);
5334 mpz_add_ui (lss_array
->shape
[n
], lss_array
->shape
[n
], 1);
5337 /* Associate the SS with the loop. */
5338 gfc_add_ss_to_loop (&loop
, lss
);
5339 gfc_add_ss_to_loop (&loop
, rss
);
5341 /* Calculate the bounds of the scalarization. */
5342 gfc_conv_ss_startstride (&loop
);
5344 /* Setup the scalarizing loops. */
5345 gfc_conv_loop_setup (&loop
, &expr
->where
);
5347 /* Setup the gfc_se structures. */
5348 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5349 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5352 gfc_mark_ss_chain_used (rss
, 1);
5354 gfc_mark_ss_chain_used (lss
, 1);
5356 /* Start the scalarized loop body. */
5357 gfc_start_scalarized_body (&loop
, &body
);
5359 gfc_conv_tmp_array_ref (&lse
);
5360 if (cm
->ts
.type
== BT_CHARACTER
)
5361 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5363 gfc_conv_expr (&rse
, expr
);
5365 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
5366 gfc_add_expr_to_block (&body
, tmp
);
5368 gcc_assert (rse
.ss
== gfc_ss_terminator
);
5370 /* Generate the copying loops. */
5371 gfc_trans_scalarizing_loops (&loop
, &body
);
5373 /* Wrap the whole thing up. */
5374 gfc_add_block_to_block (&block
, &loop
.pre
);
5375 gfc_add_block_to_block (&block
, &loop
.post
);
5377 gcc_assert (lss_array
->shape
!= NULL
);
5378 gfc_free_shape (&lss_array
->shape
, cm
->as
->rank
);
5379 gfc_cleanup_loop (&loop
);
5381 return gfc_finish_block (&block
);
5386 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
5396 gfc_expr
*arg
= NULL
;
5398 gfc_start_block (&block
);
5399 gfc_init_se (&se
, NULL
);
5401 /* Get the descriptor for the expressions. */
5402 se
.want_pointer
= 0;
5403 gfc_conv_expr_descriptor (&se
, expr
);
5404 gfc_add_block_to_block (&block
, &se
.pre
);
5405 gfc_add_modify (&block
, dest
, se
.expr
);
5407 /* Deal with arrays of derived types with allocatable components. */
5408 if (cm
->ts
.type
== BT_DERIVED
5409 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
5410 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
5414 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
5415 TREE_TYPE(cm
->backend_decl
),
5418 gfc_add_expr_to_block (&block
, tmp
);
5419 gfc_add_block_to_block (&block
, &se
.post
);
5421 if (expr
->expr_type
!= EXPR_VARIABLE
)
5422 gfc_conv_descriptor_data_set (&block
, se
.expr
,
5425 /* We need to know if the argument of a conversion function is a
5426 variable, so that the correct lower bound can be used. */
5427 if (expr
->expr_type
== EXPR_FUNCTION
5428 && expr
->value
.function
.isym
5429 && expr
->value
.function
.isym
->conversion
5430 && expr
->value
.function
.actual
->expr
5431 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
5432 arg
= expr
->value
.function
.actual
->expr
;
5434 /* Obtain the array spec of full array references. */
5436 as
= gfc_get_full_arrayspec_from_expr (arg
);
5438 as
= gfc_get_full_arrayspec_from_expr (expr
);
5440 /* Shift the lbound and ubound of temporaries to being unity,
5441 rather than zero, based. Always calculate the offset. */
5442 offset
= gfc_conv_descriptor_offset_get (dest
);
5443 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
5444 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
5446 for (n
= 0; n
< expr
->rank
; n
++)
5451 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
5452 TODO It looks as if gfc_conv_expr_descriptor should return
5453 the correct bounds and that the following should not be
5454 necessary. This would simplify gfc_conv_intrinsic_bound
5456 if (as
&& as
->lower
[n
])
5459 gfc_init_se (&lbse
, NULL
);
5460 gfc_conv_expr (&lbse
, as
->lower
[n
]);
5461 gfc_add_block_to_block (&block
, &lbse
.pre
);
5462 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
5466 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
5467 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
5471 lbound
= gfc_conv_descriptor_lbound_get (dest
,
5474 lbound
= gfc_index_one_node
;
5476 lbound
= fold_convert (gfc_array_index_type
, lbound
);
5478 /* Shift the bounds and set the offset accordingly. */
5479 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
5480 span
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5481 tmp
, gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
5482 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5484 gfc_conv_descriptor_ubound_set (&block
, dest
,
5485 gfc_rank_cst
[n
], tmp
);
5486 gfc_conv_descriptor_lbound_set (&block
, dest
,
5487 gfc_rank_cst
[n
], lbound
);
5489 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5490 gfc_conv_descriptor_lbound_get (dest
,
5492 gfc_conv_descriptor_stride_get (dest
,
5494 gfc_add_modify (&block
, tmp2
, tmp
);
5495 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
5497 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
5502 /* If a conversion expression has a null data pointer
5503 argument, nullify the allocatable component. */
5507 if (arg
->symtree
->n
.sym
->attr
.allocatable
5508 || arg
->symtree
->n
.sym
->attr
.pointer
)
5510 non_null_expr
= gfc_finish_block (&block
);
5511 gfc_start_block (&block
);
5512 gfc_conv_descriptor_data_set (&block
, dest
,
5514 null_expr
= gfc_finish_block (&block
);
5515 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
5516 tmp
= build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
5517 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
5518 return build3_v (COND_EXPR
, tmp
,
5519 null_expr
, non_null_expr
);
5523 return gfc_finish_block (&block
);
5527 /* Assign a single component of a derived type constructor. */
5530 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
5537 gfc_start_block (&block
);
5539 if (cm
->attr
.pointer
|| cm
->attr
.proc_pointer
)
5541 gfc_init_se (&se
, NULL
);
5542 /* Pointer component. */
5543 if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5545 /* Array pointer. */
5546 if (expr
->expr_type
== EXPR_NULL
)
5547 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5550 se
.direct_byref
= 1;
5552 gfc_conv_expr_descriptor (&se
, expr
);
5553 gfc_add_block_to_block (&block
, &se
.pre
);
5554 gfc_add_block_to_block (&block
, &se
.post
);
5559 /* Scalar pointers. */
5560 se
.want_pointer
= 1;
5561 gfc_conv_expr (&se
, expr
);
5562 gfc_add_block_to_block (&block
, &se
.pre
);
5564 if (expr
->symtree
&& expr
->symtree
->n
.sym
->attr
.proc_pointer
5565 && expr
->symtree
->n
.sym
->attr
.dummy
)
5566 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5568 gfc_add_modify (&block
, dest
,
5569 fold_convert (TREE_TYPE (dest
), se
.expr
));
5570 gfc_add_block_to_block (&block
, &se
.post
);
5573 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
5575 /* NULL initialization for CLASS components. */
5576 tmp
= gfc_trans_structure_assign (dest
,
5577 gfc_class_null_initializer (&cm
->ts
));
5578 gfc_add_expr_to_block (&block
, tmp
);
5580 else if (cm
->attr
.dimension
&& !cm
->attr
.proc_pointer
)
5582 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
5583 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
5584 else if (cm
->attr
.allocatable
)
5586 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
5587 gfc_add_expr_to_block (&block
, tmp
);
5591 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
5592 gfc_add_expr_to_block (&block
, tmp
);
5595 else if (expr
->ts
.type
== BT_DERIVED
)
5597 if (expr
->expr_type
!= EXPR_STRUCTURE
)
5599 gfc_init_se (&se
, NULL
);
5600 gfc_conv_expr (&se
, expr
);
5601 gfc_add_block_to_block (&block
, &se
.pre
);
5602 gfc_add_modify (&block
, dest
,
5603 fold_convert (TREE_TYPE (dest
), se
.expr
));
5604 gfc_add_block_to_block (&block
, &se
.post
);
5608 /* Nested constructors. */
5609 tmp
= gfc_trans_structure_assign (dest
, expr
);
5610 gfc_add_expr_to_block (&block
, tmp
);
5615 /* Scalar component. */
5616 gfc_init_se (&se
, NULL
);
5617 gfc_init_se (&lse
, NULL
);
5619 gfc_conv_expr (&se
, expr
);
5620 if (cm
->ts
.type
== BT_CHARACTER
)
5621 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
5623 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
5624 gfc_add_expr_to_block (&block
, tmp
);
5626 return gfc_finish_block (&block
);
5629 /* Assign a derived type constructor to a variable. */
5632 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
5640 gfc_start_block (&block
);
5641 cm
= expr
->ts
.u
.derived
->components
;
5643 if (expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
5644 && (expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
5645 || expr
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
5649 gcc_assert (cm
->backend_decl
== NULL
);
5650 gfc_init_se (&se
, NULL
);
5651 gfc_init_se (&lse
, NULL
);
5652 gfc_conv_expr (&se
, gfc_constructor_first (expr
->value
.constructor
)->expr
);
5654 gfc_add_modify (&block
, lse
.expr
,
5655 fold_convert (TREE_TYPE (lse
.expr
), se
.expr
));
5657 return gfc_finish_block (&block
);
5660 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5661 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5663 /* Skip absent members in default initializers. */
5667 field
= cm
->backend_decl
;
5668 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
5669 dest
, field
, NULL_TREE
);
5670 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
5671 gfc_add_expr_to_block (&block
, tmp
);
5673 return gfc_finish_block (&block
);
5676 /* Build an expression for a constructor. If init is nonzero then
5677 this is part of a static variable initializer. */
5680 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
5687 VEC(constructor_elt
,gc
) *v
= NULL
;
5689 gcc_assert (se
->ss
== NULL
);
5690 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
5691 type
= gfc_typenode_for_spec (&expr
->ts
);
5695 /* Create a temporary variable and fill it in. */
5696 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
5697 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
5698 gfc_add_expr_to_block (&se
->pre
, tmp
);
5702 cm
= expr
->ts
.u
.derived
->components
;
5704 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5705 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5707 /* Skip absent members in default initializers and allocatable
5708 components. Although the latter have a default initializer
5709 of EXPR_NULL,... by default, the static nullify is not needed
5710 since this is done every time we come into scope. */
5711 if (!c
->expr
|| (cm
->attr
.allocatable
&& cm
->attr
.flavor
!= FL_PROCEDURE
))
5714 if (strcmp (cm
->name
, "_size") == 0)
5716 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
5717 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
5719 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
5720 && strcmp (cm
->name
, "_extends") == 0)
5724 vtabs
= cm
->initializer
->symtree
->n
.sym
;
5725 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
5726 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
5730 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
5731 TREE_TYPE (cm
->backend_decl
),
5732 cm
->attr
.dimension
, cm
->attr
.pointer
,
5733 cm
->attr
.proc_pointer
);
5735 /* Append it to the constructor list. */
5736 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
5739 se
->expr
= build_constructor (type
, v
);
5741 TREE_CONSTANT (se
->expr
) = 1;
5745 /* Translate a substring expression. */
5748 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
5754 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
5756 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
5757 expr
->value
.character
.length
,
5758 expr
->value
.character
.string
);
5760 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
5761 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
5764 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
5768 /* Entry point for expression translation. Evaluates a scalar quantity.
5769 EXPR is the expression to be translated, and SE is the state structure if
5770 called from within the scalarized. */
5773 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
5778 if (ss
&& ss
->info
->expr
== expr
5779 && (ss
->info
->type
== GFC_SS_SCALAR
5780 || ss
->info
->type
== GFC_SS_REFERENCE
))
5782 gfc_ss_info
*ss_info
;
5785 /* Substitute a scalar expression evaluated outside the scalarization
5787 se
->expr
= ss_info
->data
.scalar
.value
;
5788 /* If the reference can be NULL, the value field contains the reference,
5789 not the value the reference points to (see gfc_add_loop_ss_code). */
5790 if (ss_info
->can_be_null_ref
)
5791 se
->expr
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5793 se
->string_length
= ss_info
->string_length
;
5794 gfc_advance_se_ss_chain (se
);
5798 /* We need to convert the expressions for the iso_c_binding derived types.
5799 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
5800 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
5801 typespec for the C_PTR and C_FUNPTR symbols, which has already been
5802 updated to be an integer with a kind equal to the size of a (void *). */
5803 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
5804 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
5806 if (expr
->expr_type
== EXPR_VARIABLE
5807 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
5808 || expr
->symtree
->n
.sym
->intmod_sym_id
5809 == ISOCBINDING_NULL_FUNPTR
))
5811 /* Set expr_type to EXPR_NULL, which will result in
5812 null_pointer_node being used below. */
5813 expr
->expr_type
= EXPR_NULL
;
5817 /* Update the type/kind of the expression to be what the new
5818 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
5819 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
5820 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
5821 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
5825 gfc_fix_class_refs (expr
);
5827 switch (expr
->expr_type
)
5830 gfc_conv_expr_op (se
, expr
);
5834 gfc_conv_function_expr (se
, expr
);
5838 gfc_conv_constant (se
, expr
);
5842 gfc_conv_variable (se
, expr
);
5846 se
->expr
= null_pointer_node
;
5849 case EXPR_SUBSTRING
:
5850 gfc_conv_substring_expr (se
, expr
);
5853 case EXPR_STRUCTURE
:
5854 gfc_conv_structure (se
, expr
, 0);
5858 gfc_conv_array_constructor_expr (se
, expr
);
5867 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
5868 of an assignment. */
5870 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
5872 gfc_conv_expr (se
, expr
);
5873 /* All numeric lvalues should have empty post chains. If not we need to
5874 figure out a way of rewriting an lvalue so that it has no post chain. */
5875 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
5878 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
5879 numeric expressions. Used for scalar values where inserting cleanup code
5882 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
5886 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
5887 gfc_conv_expr (se
, expr
);
5890 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5891 gfc_add_modify (&se
->pre
, val
, se
->expr
);
5893 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5897 /* Helper to translate an expression and convert it to a particular type. */
5899 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
5901 gfc_conv_expr_val (se
, expr
);
5902 se
->expr
= convert (type
, se
->expr
);
5906 /* Converts an expression so that it can be passed by reference. Scalar
5910 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
5916 if (ss
&& ss
->info
->expr
== expr
5917 && ss
->info
->type
== GFC_SS_REFERENCE
)
5919 /* Returns a reference to the scalar evaluated outside the loop
5921 gfc_conv_expr (se
, expr
);
5922 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
5926 if (expr
->ts
.type
== BT_CHARACTER
)
5928 gfc_conv_expr (se
, expr
);
5929 gfc_conv_string_parameter (se
);
5933 if (expr
->expr_type
== EXPR_VARIABLE
)
5935 se
->want_pointer
= 1;
5936 gfc_conv_expr (se
, expr
);
5939 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5940 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5941 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5947 if (expr
->expr_type
== EXPR_FUNCTION
5948 && ((expr
->value
.function
.esym
5949 && expr
->value
.function
.esym
->result
->attr
.pointer
5950 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
5951 || (!expr
->value
.function
.esym
&& !expr
->ref
5952 && expr
->symtree
->n
.sym
->attr
.pointer
5953 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
5955 se
->want_pointer
= 1;
5956 gfc_conv_expr (se
, expr
);
5957 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5958 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5963 gfc_conv_expr (se
, expr
);
5965 /* Create a temporary var to hold the value. */
5966 if (TREE_CONSTANT (se
->expr
))
5968 tree tmp
= se
->expr
;
5969 STRIP_TYPE_NOPS (tmp
);
5970 var
= build_decl (input_location
,
5971 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
5972 DECL_INITIAL (var
) = tmp
;
5973 TREE_STATIC (var
) = 1;
5978 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
5979 gfc_add_modify (&se
->pre
, var
, se
->expr
);
5981 gfc_add_block_to_block (&se
->pre
, &se
->post
);
5983 /* Take the address of that value. */
5984 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
5989 gfc_trans_pointer_assign (gfc_code
* code
)
5991 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
5995 /* Generate code for a pointer assignment. */
5998 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
6009 gfc_start_block (&block
);
6011 gfc_init_se (&lse
, NULL
);
6013 /* Check whether the expression is a scalar or not; we cannot use
6014 expr1->rank as it can be nonzero for proc pointers. */
6015 ss
= gfc_walk_expr (expr1
);
6016 scalar
= ss
== gfc_ss_terminator
;
6018 gfc_free_ss_chain (ss
);
6022 /* Scalar pointers. */
6023 lse
.want_pointer
= 1;
6024 gfc_conv_expr (&lse
, expr1
);
6025 gfc_init_se (&rse
, NULL
);
6026 rse
.want_pointer
= 1;
6027 gfc_conv_expr (&rse
, expr2
);
6029 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
6030 && expr1
->symtree
->n
.sym
->attr
.dummy
)
6031 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
6034 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
6035 && expr2
->symtree
->n
.sym
->attr
.dummy
)
6036 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
6039 gfc_add_block_to_block (&block
, &lse
.pre
);
6040 gfc_add_block_to_block (&block
, &rse
.pre
);
6042 /* Check character lengths if character expression. The test is only
6043 really added if -fbounds-check is enabled. Exclude deferred
6044 character length lefthand sides. */
6045 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
6046 && !expr1
->ts
.deferred
6047 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
6048 && !gfc_is_proc_ptr_comp (expr1
))
6050 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6051 gcc_assert (lse
.string_length
&& rse
.string_length
);
6052 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6053 lse
.string_length
, rse
.string_length
,
6057 /* The assignment to an deferred character length sets the string
6058 length to that of the rhs. */
6059 if (expr1
->ts
.deferred
)
6061 if (expr2
->expr_type
!= EXPR_NULL
&& lse
.string_length
!= NULL
)
6062 gfc_add_modify (&block
, lse
.string_length
, rse
.string_length
);
6063 else if (lse
.string_length
!= NULL
)
6064 gfc_add_modify (&block
, lse
.string_length
,
6065 build_int_cst (gfc_charlen_type_node
, 0));
6068 gfc_add_modify (&block
, lse
.expr
,
6069 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
6071 gfc_add_block_to_block (&block
, &rse
.post
);
6072 gfc_add_block_to_block (&block
, &lse
.post
);
6079 tree strlen_rhs
= NULL_TREE
;
6081 /* Array pointer. Find the last reference on the LHS and if it is an
6082 array section ref, we're dealing with bounds remapping. In this case,
6083 set it to AR_FULL so that gfc_conv_expr_descriptor does
6084 not see it and process the bounds remapping afterwards explicitly. */
6085 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
6086 if (!remap
->next
&& remap
->type
== REF_ARRAY
6087 && remap
->u
.ar
.type
== AR_SECTION
)
6089 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
6092 lse
.descriptor_only
= 1;
6093 gfc_conv_expr_descriptor (&lse
, expr1
);
6094 strlen_lhs
= lse
.string_length
;
6097 if (expr2
->expr_type
== EXPR_NULL
)
6099 /* Just set the data pointer to null. */
6100 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
6102 else if (rank_remap
)
6104 /* If we are rank-remapping, just get the RHS's descriptor and
6105 process this later on. */
6106 gfc_init_se (&rse
, NULL
);
6107 rse
.direct_byref
= 1;
6108 rse
.byref_noassign
= 1;
6109 gfc_conv_expr_descriptor (&rse
, expr2
);
6110 strlen_rhs
= rse
.string_length
;
6112 else if (expr2
->expr_type
== EXPR_VARIABLE
)
6114 /* Assign directly to the LHS's descriptor. */
6115 lse
.direct_byref
= 1;
6116 gfc_conv_expr_descriptor (&lse
, expr2
);
6117 strlen_rhs
= lse
.string_length
;
6119 /* If this is a subreference array pointer assignment, use the rhs
6120 descriptor element size for the lhs span. */
6121 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
6123 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
6124 gfc_init_se (&rse
, NULL
);
6125 rse
.descriptor_only
= 1;
6126 gfc_conv_expr (&rse
, expr2
);
6127 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
6128 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
6129 if (!INTEGER_CST_P (tmp
))
6130 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
6131 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
6136 /* Assign to a temporary descriptor and then copy that
6137 temporary to the pointer. */
6138 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
6141 lse
.direct_byref
= 1;
6142 gfc_conv_expr_descriptor (&lse
, expr2
);
6143 strlen_rhs
= lse
.string_length
;
6144 gfc_add_modify (&lse
.pre
, desc
, tmp
);
6147 gfc_add_block_to_block (&block
, &lse
.pre
);
6149 gfc_add_block_to_block (&block
, &rse
.pre
);
6151 /* If we do bounds remapping, update LHS descriptor accordingly. */
6155 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
6159 /* Do rank remapping. We already have the RHS's descriptor
6160 converted in rse and now have to build the correct LHS
6161 descriptor for it. */
6165 tree lbound
, ubound
;
6168 dtype
= gfc_conv_descriptor_dtype (desc
);
6169 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
6170 gfc_add_modify (&block
, dtype
, tmp
);
6172 /* Copy data pointer. */
6173 data
= gfc_conv_descriptor_data_get (rse
.expr
);
6174 gfc_conv_descriptor_data_set (&block
, desc
, data
);
6176 /* Copy offset but adjust it such that it would correspond
6177 to a lbound of zero. */
6178 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
6179 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
6181 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6183 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
6185 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6186 gfc_array_index_type
, stride
, lbound
);
6187 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
6188 gfc_array_index_type
, offs
, tmp
);
6190 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6192 /* Set the bounds as declared for the LHS and calculate strides as
6193 well as another offset update accordingly. */
6194 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
6196 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
6201 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
6203 /* Convert declared bounds. */
6204 gfc_init_se (&lower_se
, NULL
);
6205 gfc_init_se (&upper_se
, NULL
);
6206 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
6207 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
6209 gfc_add_block_to_block (&block
, &lower_se
.pre
);
6210 gfc_add_block_to_block (&block
, &upper_se
.pre
);
6212 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
6213 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
6215 lbound
= gfc_evaluate_now (lbound
, &block
);
6216 ubound
= gfc_evaluate_now (ubound
, &block
);
6218 gfc_add_block_to_block (&block
, &lower_se
.post
);
6219 gfc_add_block_to_block (&block
, &upper_se
.post
);
6221 /* Set bounds in descriptor. */
6222 gfc_conv_descriptor_lbound_set (&block
, desc
,
6223 gfc_rank_cst
[dim
], lbound
);
6224 gfc_conv_descriptor_ubound_set (&block
, desc
,
6225 gfc_rank_cst
[dim
], ubound
);
6228 stride
= gfc_evaluate_now (stride
, &block
);
6229 gfc_conv_descriptor_stride_set (&block
, desc
,
6230 gfc_rank_cst
[dim
], stride
);
6232 /* Update offset. */
6233 offs
= gfc_conv_descriptor_offset_get (desc
);
6234 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6235 gfc_array_index_type
, lbound
, stride
);
6236 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
6237 gfc_array_index_type
, offs
, tmp
);
6238 offs
= gfc_evaluate_now (offs
, &block
);
6239 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
6241 /* Update stride. */
6242 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
6243 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
6244 gfc_array_index_type
, stride
, tmp
);
6249 /* Bounds remapping. Just shift the lower bounds. */
6251 gcc_assert (expr1
->rank
== expr2
->rank
);
6253 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
6257 gcc_assert (remap
->u
.ar
.start
[dim
]);
6258 gcc_assert (!remap
->u
.ar
.end
[dim
]);
6259 gfc_init_se (&lbound_se
, NULL
);
6260 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
6262 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
6263 gfc_conv_shift_descriptor_lbound (&block
, desc
,
6264 dim
, lbound_se
.expr
);
6265 gfc_add_block_to_block (&block
, &lbound_se
.post
);
6270 /* Check string lengths if applicable. The check is only really added
6271 to the output code if -fbounds-check is enabled. */
6272 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
6274 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
6275 gcc_assert (strlen_lhs
&& strlen_rhs
);
6276 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
6277 strlen_lhs
, strlen_rhs
, &block
);
6280 /* If rank remapping was done, check with -fcheck=bounds that
6281 the target is at least as large as the pointer. */
6282 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
6288 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
6289 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
6291 lsize
= gfc_evaluate_now (lsize
, &block
);
6292 rsize
= gfc_evaluate_now (rsize
, &block
);
6293 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6296 msg
= _("Target of rank remapping is too small (%ld < %ld)");
6297 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
6301 gfc_add_block_to_block (&block
, &lse
.post
);
6303 gfc_add_block_to_block (&block
, &rse
.post
);
6306 return gfc_finish_block (&block
);
6310 /* Makes sure se is suitable for passing as a function string parameter. */
6311 /* TODO: Need to check all callers of this function. It may be abused. */
6314 gfc_conv_string_parameter (gfc_se
* se
)
6318 if (TREE_CODE (se
->expr
) == STRING_CST
)
6320 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
6321 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6325 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
6327 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
6329 type
= TREE_TYPE (se
->expr
);
6330 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
6334 type
= gfc_get_character_type_len (gfc_default_character_kind
,
6336 type
= build_pointer_type (type
);
6337 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
6341 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
6345 /* Generate code for assignment of scalar variables. Includes character
6346 strings and derived types with allocatable components.
6347 If you know that the LHS has no allocations, set dealloc to false.
6349 DEEP_COPY has no effect if the typespec TS is not a derived type with
6350 allocatable components. Otherwise, if it is set, an explicit copy of each
6351 allocatable component is made. This is necessary as a simple copy of the
6352 whole object would copy array descriptors as is, so that the lhs's
6353 allocatable components would point to the rhs's after the assignment.
6354 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
6355 necessary if the rhs is a non-pointer function, as the allocatable components
6356 are not accessible by other means than the function's result after the
6357 function has returned. It is even more subtle when temporaries are involved,
6358 as the two following examples show:
6359 1. When we evaluate an array constructor, a temporary is created. Thus
6360 there is theoretically no alias possible. However, no deep copy is
6361 made for this temporary, so that if the constructor is made of one or
6362 more variable with allocatable components, those components still point
6363 to the variable's: DEEP_COPY should be set for the assignment from the
6364 temporary to the lhs in that case.
6365 2. When assigning a scalar to an array, we evaluate the scalar value out
6366 of the loop, store it into a temporary variable, and assign from that.
6367 In that case, deep copying when assigning to the temporary would be a
6368 waste of resources; however deep copies should happen when assigning from
6369 the temporary to each array element: again DEEP_COPY should be set for
6370 the assignment from the temporary to the lhs. */
6373 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
6374 bool l_is_temp
, bool deep_copy
, bool dealloc
)
6380 gfc_init_block (&block
);
6382 if (ts
.type
== BT_CHARACTER
)
6387 if (lse
->string_length
!= NULL_TREE
)
6389 gfc_conv_string_parameter (lse
);
6390 gfc_add_block_to_block (&block
, &lse
->pre
);
6391 llen
= lse
->string_length
;
6394 if (rse
->string_length
!= NULL_TREE
)
6396 gcc_assert (rse
->string_length
!= NULL_TREE
);
6397 gfc_conv_string_parameter (rse
);
6398 gfc_add_block_to_block (&block
, &rse
->pre
);
6399 rlen
= rse
->string_length
;
6402 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
6403 rse
->expr
, ts
.kind
);
6405 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
6409 /* Are the rhs and the lhs the same? */
6412 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6413 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
6414 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
6415 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
6418 /* Deallocate the lhs allocated components as long as it is not
6419 the same as the rhs. This must be done following the assignment
6420 to prevent deallocating data that could be used in the rhs
6422 if (!l_is_temp
&& dealloc
)
6424 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
6425 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
6427 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6429 gfc_add_expr_to_block (&lse
->post
, tmp
);
6432 gfc_add_block_to_block (&block
, &rse
->pre
);
6433 gfc_add_block_to_block (&block
, &lse
->pre
);
6435 gfc_add_modify (&block
, lse
->expr
,
6436 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6438 /* Do a deep copy if the rhs is a variable, if it is not the
6442 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
6443 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
6445 gfc_add_expr_to_block (&block
, tmp
);
6448 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
6450 gfc_add_block_to_block (&block
, &lse
->pre
);
6451 gfc_add_block_to_block (&block
, &rse
->pre
);
6452 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
6453 TREE_TYPE (lse
->expr
), rse
->expr
);
6454 gfc_add_modify (&block
, lse
->expr
, tmp
);
6458 gfc_add_block_to_block (&block
, &lse
->pre
);
6459 gfc_add_block_to_block (&block
, &rse
->pre
);
6461 gfc_add_modify (&block
, lse
->expr
,
6462 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
6465 gfc_add_block_to_block (&block
, &lse
->post
);
6466 gfc_add_block_to_block (&block
, &rse
->post
);
6468 return gfc_finish_block (&block
);
6472 /* There are quite a lot of restrictions on the optimisation in using an
6473 array function assign without a temporary. */
6476 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
6479 bool seen_array_ref
;
6481 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
6483 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
6484 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
6487 /* Elemental functions are scalarized so that they don't need a
6488 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
6489 they would need special treatment in gfc_trans_arrayfunc_assign. */
6490 if (expr2
->value
.function
.esym
!= NULL
6491 && expr2
->value
.function
.esym
->attr
.elemental
)
6494 /* Need a temporary if rhs is not FULL or a contiguous section. */
6495 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
6498 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
6499 if (gfc_ref_needs_temporary_p (expr1
->ref
))
6502 /* Functions returning pointers or allocatables need temporaries. */
6503 c
= expr2
->value
.function
.esym
6504 ? (expr2
->value
.function
.esym
->attr
.pointer
6505 || expr2
->value
.function
.esym
->attr
.allocatable
)
6506 : (expr2
->symtree
->n
.sym
->attr
.pointer
6507 || expr2
->symtree
->n
.sym
->attr
.allocatable
);
6511 /* Character array functions need temporaries unless the
6512 character lengths are the same. */
6513 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
6515 if (expr1
->ts
.u
.cl
->length
== NULL
6516 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6519 if (expr2
->ts
.u
.cl
->length
== NULL
6520 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6523 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
6524 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
6528 /* Check that no LHS component references appear during an array
6529 reference. This is needed because we do not have the means to
6530 span any arbitrary stride with an array descriptor. This check
6531 is not needed for the rhs because the function result has to be
6533 seen_array_ref
= false;
6534 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
6536 if (ref
->type
== REF_ARRAY
)
6537 seen_array_ref
= true;
6538 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
6542 /* Check for a dependency. */
6543 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
6544 expr2
->value
.function
.esym
,
6545 expr2
->value
.function
.actual
,
6549 /* If we have reached here with an intrinsic function, we do not
6550 need a temporary except in the particular case that reallocation
6551 on assignment is active and the lhs is allocatable and a target. */
6552 if (expr2
->value
.function
.isym
)
6553 return (gfc_option
.flag_realloc_lhs
6554 && sym
->attr
.allocatable
6555 && sym
->attr
.target
);
6557 /* If the LHS is a dummy, we need a temporary if it is not
6559 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
6562 /* If the lhs has been host_associated, is in common, a pointer or is
6563 a target and the function is not using a RESULT variable, aliasing
6564 can occur and a temporary is needed. */
6565 if ((sym
->attr
.host_assoc
6566 || sym
->attr
.in_common
6567 || sym
->attr
.pointer
6568 || sym
->attr
.cray_pointee
6569 || sym
->attr
.target
)
6570 && expr2
->symtree
!= NULL
6571 && expr2
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
->result
)
6574 /* A PURE function can unconditionally be called without a temporary. */
6575 if (expr2
->value
.function
.esym
!= NULL
6576 && expr2
->value
.function
.esym
->attr
.pure
)
6579 /* Implicit_pure functions are those which could legally be declared
6581 if (expr2
->value
.function
.esym
!= NULL
6582 && expr2
->value
.function
.esym
->attr
.implicit_pure
)
6585 if (!sym
->attr
.use_assoc
6586 && !sym
->attr
.in_common
6587 && !sym
->attr
.pointer
6588 && !sym
->attr
.target
6589 && !sym
->attr
.cray_pointee
6590 && expr2
->value
.function
.esym
)
6592 /* A temporary is not needed if the function is not contained and
6593 the variable is local or host associated and not a pointer or
6595 if (!expr2
->value
.function
.esym
->attr
.contained
)
6598 /* A temporary is not needed if the lhs has never been host
6599 associated and the procedure is contained. */
6600 else if (!sym
->attr
.host_assoc
)
6603 /* A temporary is not needed if the variable is local and not
6604 a pointer, a target or a result. */
6606 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
6610 /* Default to temporary use. */
6615 /* Provide the loop info so that the lhs descriptor can be built for
6616 reallocatable assignments from extrinsic function calls. */
6619 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
,
6622 /* Signal that the function call should not be made by
6623 gfc_conv_loop_setup. */
6624 se
->ss
->is_alloc_lhs
= 1;
6625 gfc_init_loopinfo (loop
);
6626 gfc_add_ss_to_loop (loop
, *ss
);
6627 gfc_add_ss_to_loop (loop
, se
->ss
);
6628 gfc_conv_ss_startstride (loop
);
6629 gfc_conv_loop_setup (loop
, where
);
6630 gfc_copy_loopinfo_to_se (se
, loop
);
6631 gfc_add_block_to_block (&se
->pre
, &loop
->pre
);
6632 gfc_add_block_to_block (&se
->pre
, &loop
->post
);
6633 se
->ss
->is_alloc_lhs
= 0;
6637 /* For assignment to a reallocatable lhs from intrinsic functions,
6638 replace the se.expr (ie. the result) with a temporary descriptor.
6639 Null the data field so that the library allocates space for the
6640 result. Free the data of the original descriptor after the function,
6641 in case it appears in an argument expression and transfer the
6642 result to the original descriptor. */
6645 fcncall_realloc_result (gfc_se
*se
, int rank
)
6654 /* Use the allocation done by the library. Substitute the lhs
6655 descriptor with a copy, whose data field is nulled.*/
6656 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
6657 if (POINTER_TYPE_P (TREE_TYPE (desc
)))
6658 desc
= build_fold_indirect_ref_loc (input_location
, desc
);
6660 /* Unallocated, the descriptor does not have a dtype. */
6661 tmp
= gfc_conv_descriptor_dtype (desc
);
6662 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
6664 res_desc
= gfc_evaluate_now (desc
, &se
->pre
);
6665 gfc_conv_descriptor_data_set (&se
->pre
, res_desc
, null_pointer_node
);
6666 se
->expr
= gfc_build_addr_expr (TREE_TYPE (se
->expr
), res_desc
);
6668 /* Free the lhs after the function call and copy the result data to
6669 the lhs descriptor. */
6670 tmp
= gfc_conv_descriptor_data_get (desc
);
6671 zero_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
6672 boolean_type_node
, tmp
,
6673 build_int_cst (TREE_TYPE (tmp
), 0));
6674 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
6675 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
6676 gfc_add_expr_to_block (&se
->post
, tmp
);
6678 tmp
= gfc_conv_descriptor_data_get (res_desc
);
6679 gfc_conv_descriptor_data_set (&se
->post
, desc
, tmp
);
6681 /* Check that the shapes are the same between lhs and expression. */
6682 for (n
= 0 ; n
< rank
; n
++)
6685 tmp
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6686 tmp1
= gfc_conv_descriptor_lbound_get (res_desc
, gfc_rank_cst
[n
]);
6687 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6688 gfc_array_index_type
, tmp
, tmp1
);
6689 tmp1
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
6690 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
6691 gfc_array_index_type
, tmp
, tmp1
);
6692 tmp1
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
6693 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6694 gfc_array_index_type
, tmp
, tmp1
);
6695 tmp
= fold_build2_loc (input_location
, NE_EXPR
,
6696 boolean_type_node
, tmp
,
6697 gfc_index_zero_node
);
6698 tmp
= gfc_evaluate_now (tmp
, &se
->post
);
6699 zero_cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6700 boolean_type_node
, tmp
,
6704 /* 'zero_cond' being true is equal to lhs not being allocated or the
6705 shapes being different. */
6706 zero_cond
= gfc_evaluate_now (zero_cond
, &se
->post
);
6708 /* Now reset the bounds returned from the function call to bounds based
6709 on the lhs lbounds, except where the lhs is not allocated or the shapes
6710 of 'variable and 'expr' are different. Set the offset accordingly. */
6711 offset
= gfc_index_zero_node
;
6712 for (n
= 0 ; n
< rank
; n
++)
6716 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]);
6717 lbound
= fold_build3_loc (input_location
, COND_EXPR
,
6718 gfc_array_index_type
, zero_cond
,
6719 gfc_index_one_node
, lbound
);
6720 lbound
= gfc_evaluate_now (lbound
, &se
->post
);
6722 tmp
= gfc_conv_descriptor_ubound_get (res_desc
, gfc_rank_cst
[n
]);
6723 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
6724 gfc_array_index_type
, tmp
, lbound
);
6725 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
6726 gfc_rank_cst
[n
], lbound
);
6727 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
6728 gfc_rank_cst
[n
], tmp
);
6730 /* Set stride and accumulate the offset. */
6731 tmp
= gfc_conv_descriptor_stride_get (res_desc
, gfc_rank_cst
[n
]);
6732 gfc_conv_descriptor_stride_set (&se
->post
, desc
,
6733 gfc_rank_cst
[n
], tmp
);
6734 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6735 gfc_array_index_type
, lbound
, tmp
);
6736 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
6737 gfc_array_index_type
, offset
, tmp
);
6738 offset
= gfc_evaluate_now (offset
, &se
->post
);
6741 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
6746 /* Try to translate array(:) = func (...), where func is a transformational
6747 array function, without using a temporary. Returns NULL if this isn't the
6751 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
6755 gfc_component
*comp
= NULL
;
6758 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
6761 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
6763 comp
= gfc_get_proc_ptr_comp (expr2
);
6764 gcc_assert (expr2
->value
.function
.isym
6765 || (comp
&& comp
->attr
.dimension
)
6766 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
6767 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
6769 gfc_init_se (&se
, NULL
);
6770 gfc_start_block (&se
.pre
);
6771 se
.want_pointer
= 1;
6773 gfc_conv_array_parameter (&se
, expr1
, false, NULL
, NULL
, NULL
);
6775 if (expr1
->ts
.type
== BT_DERIVED
6776 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
6779 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
6781 gfc_add_expr_to_block (&se
.pre
, tmp
);
6784 se
.direct_byref
= 1;
6785 se
.ss
= gfc_walk_expr (expr2
);
6786 gcc_assert (se
.ss
!= gfc_ss_terminator
);
6788 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
6789 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
6790 Clearly, this cannot be done for an allocatable function result, since
6791 the shape of the result is unknown and, in any case, the function must
6792 correctly take care of the reallocation internally. For intrinsic
6793 calls, the array data is freed and the library takes care of allocation.
6794 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
6796 if (gfc_option
.flag_realloc_lhs
6797 && gfc_is_reallocatable_lhs (expr1
)
6798 && !gfc_expr_attr (expr1
).codimension
6799 && !gfc_is_coindexed (expr1
)
6800 && !(expr2
->value
.function
.esym
6801 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
6803 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
6805 if (!expr2
->value
.function
.isym
)
6807 ss
= gfc_walk_expr (expr1
);
6808 gcc_assert (ss
!= gfc_ss_terminator
);
6810 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
, &loop
);
6811 ss
->is_alloc_lhs
= 1;
6814 fcncall_realloc_result (&se
, expr1
->rank
);
6817 gfc_conv_function_expr (&se
, expr2
);
6818 gfc_add_block_to_block (&se
.pre
, &se
.post
);
6821 gfc_cleanup_loop (&loop
);
6823 gfc_free_ss_chain (se
.ss
);
6825 return gfc_finish_block (&se
.pre
);
6829 /* Try to efficiently translate array(:) = 0. Return NULL if this
6833 gfc_trans_zero_assign (gfc_expr
* expr
)
6835 tree dest
, len
, type
;
6839 sym
= expr
->symtree
->n
.sym
;
6840 dest
= gfc_get_symbol_decl (sym
);
6842 type
= TREE_TYPE (dest
);
6843 if (POINTER_TYPE_P (type
))
6844 type
= TREE_TYPE (type
);
6845 if (!GFC_ARRAY_TYPE_P (type
))
6848 /* Determine the length of the array. */
6849 len
= GFC_TYPE_ARRAY_SIZE (type
);
6850 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
6853 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
6854 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
6855 fold_convert (gfc_array_index_type
, tmp
));
6857 /* If we are zeroing a local array avoid taking its address by emitting
6859 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
6860 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6861 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
6863 /* Convert arguments to the correct types. */
6864 dest
= fold_convert (pvoid_type_node
, dest
);
6865 len
= fold_convert (size_type_node
, len
);
6867 /* Construct call to __builtin_memset. */
6868 tmp
= build_call_expr_loc (input_location
,
6869 builtin_decl_explicit (BUILT_IN_MEMSET
),
6870 3, dest
, integer_zero_node
, len
);
6871 return fold_convert (void_type_node
, tmp
);
6875 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
6876 that constructs the call to __builtin_memcpy. */
6879 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
6883 /* Convert arguments to the correct types. */
6884 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
6885 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
6887 dst
= fold_convert (pvoid_type_node
, dst
);
6889 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
6890 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
6892 src
= fold_convert (pvoid_type_node
, src
);
6894 len
= fold_convert (size_type_node
, len
);
6896 /* Construct call to __builtin_memcpy. */
6897 tmp
= build_call_expr_loc (input_location
,
6898 builtin_decl_explicit (BUILT_IN_MEMCPY
),
6900 return fold_convert (void_type_node
, tmp
);
6904 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
6905 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
6906 source/rhs, both are gfc_full_array_ref_p which have been checked for
6910 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
6912 tree dst
, dlen
, dtype
;
6913 tree src
, slen
, stype
;
6916 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
6917 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
6919 dtype
= TREE_TYPE (dst
);
6920 if (POINTER_TYPE_P (dtype
))
6921 dtype
= TREE_TYPE (dtype
);
6922 stype
= TREE_TYPE (src
);
6923 if (POINTER_TYPE_P (stype
))
6924 stype
= TREE_TYPE (stype
);
6926 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
6929 /* Determine the lengths of the arrays. */
6930 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
6931 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
6933 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
6934 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6935 dlen
, fold_convert (gfc_array_index_type
, tmp
));
6937 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
6938 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
6940 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
6941 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
6942 slen
, fold_convert (gfc_array_index_type
, tmp
));
6944 /* Sanity check that they are the same. This should always be
6945 the case, as we should already have checked for conformance. */
6946 if (!tree_int_cst_equal (slen
, dlen
))
6949 return gfc_build_memcpy_call (dst
, src
, dlen
);
6953 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
6954 this can't be done. EXPR1 is the destination/lhs for which
6955 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
6958 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
6960 unsigned HOST_WIDE_INT nelem
;
6966 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
6970 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
6971 dtype
= TREE_TYPE (dst
);
6972 if (POINTER_TYPE_P (dtype
))
6973 dtype
= TREE_TYPE (dtype
);
6974 if (!GFC_ARRAY_TYPE_P (dtype
))
6977 /* Determine the lengths of the array. */
6978 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
6979 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
6982 /* Confirm that the constructor is the same size. */
6983 if (compare_tree_int (len
, nelem
) != 0)
6986 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
6987 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
6988 fold_convert (gfc_array_index_type
, tmp
));
6990 stype
= gfc_typenode_for_spec (&expr2
->ts
);
6991 src
= gfc_build_constant_array_constructor (expr2
, stype
);
6993 stype
= TREE_TYPE (src
);
6994 if (POINTER_TYPE_P (stype
))
6995 stype
= TREE_TYPE (stype
);
6997 return gfc_build_memcpy_call (dst
, src
, len
);
7001 /* Tells whether the expression is to be treated as a variable reference. */
7004 expr_is_variable (gfc_expr
*expr
)
7007 gfc_component
*comp
;
7008 gfc_symbol
*func_ifc
;
7010 if (expr
->expr_type
== EXPR_VARIABLE
)
7013 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
7016 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
7017 return expr_is_variable (arg
);
7020 /* A data-pointer-returning function should be considered as a variable
7022 if (expr
->expr_type
== EXPR_FUNCTION
7023 && expr
->ref
== NULL
)
7025 if (expr
->value
.function
.isym
!= NULL
)
7028 if (expr
->value
.function
.esym
!= NULL
)
7030 func_ifc
= expr
->value
.function
.esym
;
7035 gcc_assert (expr
->symtree
);
7036 func_ifc
= expr
->symtree
->n
.sym
;
7043 comp
= gfc_get_proc_ptr_comp (expr
);
7044 if ((expr
->expr_type
== EXPR_PPC
|| expr
->expr_type
== EXPR_FUNCTION
)
7047 func_ifc
= comp
->ts
.interface
;
7051 if (expr
->expr_type
== EXPR_COMPCALL
)
7053 gcc_assert (!expr
->value
.compcall
.tbp
->is_generic
);
7054 func_ifc
= expr
->value
.compcall
.tbp
->u
.specific
->n
.sym
;
7061 gcc_assert (func_ifc
->attr
.function
7062 && func_ifc
->result
!= NULL
);
7063 return func_ifc
->result
->attr
.pointer
;
7067 /* Is the lhs OK for automatic reallocation? */
7070 is_scalar_reallocatable_lhs (gfc_expr
*expr
)
7074 /* An allocatable variable with no reference. */
7075 if (expr
->symtree
->n
.sym
->attr
.allocatable
7079 /* All that can be left are allocatable components. */
7080 if ((expr
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
7081 && expr
->symtree
->n
.sym
->ts
.type
!= BT_CLASS
)
7082 || !expr
->symtree
->n
.sym
->ts
.u
.derived
->attr
.alloc_comp
)
7085 /* Find an allocatable component ref last. */
7086 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7087 if (ref
->type
== REF_COMPONENT
7089 && ref
->u
.c
.component
->attr
.allocatable
)
7096 /* Allocate or reallocate scalar lhs, as necessary. */
7099 alloc_scalar_allocatable_for_assignment (stmtblock_t
*block
,
7113 if (!expr1
|| expr1
->rank
)
7116 if (!expr2
|| expr2
->rank
)
7119 realloc_lhs_warning (expr2
->ts
.type
, false, &expr2
->where
);
7121 /* Since this is a scalar lhs, we can afford to do this. That is,
7122 there is no risk of side effects being repeated. */
7123 gfc_init_se (&lse
, NULL
);
7124 lse
.want_pointer
= 1;
7125 gfc_conv_expr (&lse
, expr1
);
7127 jump_label1
= gfc_build_label_decl (NULL_TREE
);
7128 jump_label2
= gfc_build_label_decl (NULL_TREE
);
7130 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
7131 tmp
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
7132 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7134 tmp
= build3_v (COND_EXPR
, cond
,
7135 build1_v (GOTO_EXPR
, jump_label1
),
7136 build_empty_stmt (input_location
));
7137 gfc_add_expr_to_block (block
, tmp
);
7139 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7141 /* Use the rhs string length and the lhs element size. */
7142 size
= string_length
;
7143 tmp
= TREE_TYPE (gfc_typenode_for_spec (&expr1
->ts
));
7144 tmp
= TYPE_SIZE_UNIT (tmp
);
7145 size_in_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
7146 TREE_TYPE (tmp
), tmp
,
7147 fold_convert (TREE_TYPE (tmp
), size
));
7151 /* Otherwise use the length in bytes of the rhs. */
7152 size
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1
->ts
));
7153 size_in_bytes
= size
;
7156 if (expr1
->ts
.type
== BT_DERIVED
&& expr1
->ts
.u
.derived
->attr
.alloc_comp
)
7158 tmp
= build_call_expr_loc (input_location
,
7159 builtin_decl_explicit (BUILT_IN_CALLOC
),
7160 2, build_one_cst (size_type_node
),
7162 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7163 gfc_add_modify (block
, lse
.expr
, tmp
);
7167 tmp
= build_call_expr_loc (input_location
,
7168 builtin_decl_explicit (BUILT_IN_MALLOC
),
7170 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7171 gfc_add_modify (block
, lse
.expr
, tmp
);
7174 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7176 /* Deferred characters need checking for lhs and rhs string
7177 length. Other deferred parameter variables will have to
7179 tmp
= build1_v (GOTO_EXPR
, jump_label2
);
7180 gfc_add_expr_to_block (block
, tmp
);
7182 tmp
= build1_v (LABEL_EXPR
, jump_label1
);
7183 gfc_add_expr_to_block (block
, tmp
);
7185 /* For a deferred length character, reallocate if lengths of lhs and
7186 rhs are different. */
7187 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
7189 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7190 expr1
->ts
.u
.cl
->backend_decl
, size
);
7191 /* Jump past the realloc if the lengths are the same. */
7192 tmp
= build3_v (COND_EXPR
, cond
,
7193 build1_v (GOTO_EXPR
, jump_label2
),
7194 build_empty_stmt (input_location
));
7195 gfc_add_expr_to_block (block
, tmp
);
7196 tmp
= build_call_expr_loc (input_location
,
7197 builtin_decl_explicit (BUILT_IN_REALLOC
),
7198 2, fold_convert (pvoid_type_node
, lse
.expr
),
7200 tmp
= fold_convert (TREE_TYPE (lse
.expr
), tmp
);
7201 gfc_add_modify (block
, lse
.expr
, tmp
);
7202 tmp
= build1_v (LABEL_EXPR
, jump_label2
);
7203 gfc_add_expr_to_block (block
, tmp
);
7205 /* Update the lhs character length. */
7206 size
= string_length
;
7207 gfc_add_modify (block
, expr1
->ts
.u
.cl
->backend_decl
, size
);
7212 /* Subroutine of gfc_trans_assignment that actually scalarizes the
7213 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
7214 init_flag indicates initialization expressions and dealloc that no
7215 deallocate prior assignment is needed (if in doubt, set true). */
7218 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7224 gfc_ss
*lss_section
;
7231 bool scalar_to_array
;
7235 /* Assignment of the form lhs = rhs. */
7236 gfc_start_block (&block
);
7238 gfc_init_se (&lse
, NULL
);
7239 gfc_init_se (&rse
, NULL
);
7242 lss
= gfc_walk_expr (expr1
);
7243 if (gfc_is_reallocatable_lhs (expr1
)
7244 && !(expr2
->expr_type
== EXPR_FUNCTION
7245 && expr2
->value
.function
.isym
!= NULL
))
7246 lss
->is_alloc_lhs
= 1;
7248 if (lss
!= gfc_ss_terminator
)
7250 /* The assignment needs scalarization. */
7253 /* Find a non-scalar SS from the lhs. */
7254 while (lss_section
!= gfc_ss_terminator
7255 && lss_section
->info
->type
!= GFC_SS_SECTION
)
7256 lss_section
= lss_section
->next
;
7258 gcc_assert (lss_section
!= gfc_ss_terminator
);
7260 /* Initialize the scalarizer. */
7261 gfc_init_loopinfo (&loop
);
7264 rss
= gfc_walk_expr (expr2
);
7265 if (rss
== gfc_ss_terminator
)
7266 /* The rhs is scalar. Add a ss for the expression. */
7267 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
7269 /* Associate the SS with the loop. */
7270 gfc_add_ss_to_loop (&loop
, lss
);
7271 gfc_add_ss_to_loop (&loop
, rss
);
7273 /* Calculate the bounds of the scalarization. */
7274 gfc_conv_ss_startstride (&loop
);
7275 /* Enable loop reversal. */
7276 for (n
= 0; n
< GFC_MAX_DIMENSIONS
; n
++)
7277 loop
.reverse
[n
] = GFC_ENABLE_REVERSE
;
7278 /* Resolve any data dependencies in the statement. */
7279 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
7280 /* Setup the scalarizing loops. */
7281 gfc_conv_loop_setup (&loop
, &expr2
->where
);
7283 /* Setup the gfc_se structures. */
7284 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7285 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7288 gfc_mark_ss_chain_used (rss
, 1);
7289 if (loop
.temp_ss
== NULL
)
7292 gfc_mark_ss_chain_used (lss
, 1);
7296 lse
.ss
= loop
.temp_ss
;
7297 gfc_mark_ss_chain_used (lss
, 3);
7298 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
7301 /* Allow the scalarizer to workshare array assignments. */
7302 if ((ompws_flags
& OMPWS_WORKSHARE_FLAG
) && loop
.temp_ss
== NULL
)
7303 ompws_flags
|= OMPWS_SCALARIZER_WS
;
7305 /* Start the scalarized loop body. */
7306 gfc_start_scalarized_body (&loop
, &body
);
7309 gfc_init_block (&body
);
7311 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
7313 /* Translate the expression. */
7314 gfc_conv_expr (&rse
, expr2
);
7316 /* Stabilize a string length for temporaries. */
7317 if (expr2
->ts
.type
== BT_CHARACTER
)
7318 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
7320 string_length
= NULL_TREE
;
7324 gfc_conv_tmp_array_ref (&lse
);
7325 if (expr2
->ts
.type
== BT_CHARACTER
)
7326 lse
.string_length
= string_length
;
7329 gfc_conv_expr (&lse
, expr1
);
7331 /* Assignments of scalar derived types with allocatable components
7332 to arrays must be done with a deep copy and the rhs temporary
7333 must have its components deallocated afterwards. */
7334 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
7335 && expr2
->ts
.u
.derived
->attr
.alloc_comp
7336 && !expr_is_variable (expr2
)
7337 && !gfc_is_constant_expr (expr2
)
7338 && expr1
->rank
&& !expr2
->rank
);
7339 if (scalar_to_array
&& dealloc
)
7341 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
7342 gfc_add_expr_to_block (&loop
.post
, tmp
);
7345 /* When assigning a character function result to a deferred-length variable,
7346 the function call must happen before the (re)allocation of the lhs -
7347 otherwise the character length of the result is not known.
7348 NOTE: This relies on having the exact dependence of the length type
7349 parameter available to the caller; gfortran saves it in the .mod files. */
7350 if (gfc_option
.flag_realloc_lhs
&& expr2
->ts
.type
== BT_CHARACTER
7351 && expr1
->ts
.deferred
)
7352 gfc_add_block_to_block (&block
, &rse
.pre
);
7354 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7355 l_is_temp
|| init_flag
,
7356 expr_is_variable (expr2
) || scalar_to_array
7357 || expr2
->expr_type
== EXPR_ARRAY
, dealloc
);
7358 gfc_add_expr_to_block (&body
, tmp
);
7360 if (lss
== gfc_ss_terminator
)
7362 /* F2003: Add the code for reallocation on assignment. */
7363 if (gfc_option
.flag_realloc_lhs
7364 && is_scalar_reallocatable_lhs (expr1
))
7365 alloc_scalar_allocatable_for_assignment (&block
, rse
.string_length
,
7368 /* Use the scalar assignment as is. */
7369 gfc_add_block_to_block (&block
, &body
);
7373 gcc_assert (lse
.ss
== gfc_ss_terminator
7374 && rse
.ss
== gfc_ss_terminator
);
7378 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
7380 /* We need to copy the temporary to the actual lhs. */
7381 gfc_init_se (&lse
, NULL
);
7382 gfc_init_se (&rse
, NULL
);
7383 gfc_copy_loopinfo_to_se (&lse
, &loop
);
7384 gfc_copy_loopinfo_to_se (&rse
, &loop
);
7386 rse
.ss
= loop
.temp_ss
;
7389 gfc_conv_tmp_array_ref (&rse
);
7390 gfc_conv_expr (&lse
, expr1
);
7392 gcc_assert (lse
.ss
== gfc_ss_terminator
7393 && rse
.ss
== gfc_ss_terminator
);
7395 if (expr2
->ts
.type
== BT_CHARACTER
)
7396 rse
.string_length
= string_length
;
7398 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
7399 false, false, dealloc
);
7400 gfc_add_expr_to_block (&body
, tmp
);
7403 /* F2003: Allocate or reallocate lhs of allocatable array. */
7404 if (gfc_option
.flag_realloc_lhs
7405 && gfc_is_reallocatable_lhs (expr1
)
7406 && !gfc_expr_attr (expr1
).codimension
7407 && !gfc_is_coindexed (expr1
)
7410 realloc_lhs_warning (expr1
->ts
.type
, true, &expr1
->where
);
7411 ompws_flags
&= ~OMPWS_SCALARIZER_WS
;
7412 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
7413 if (tmp
!= NULL_TREE
)
7414 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
7417 /* Generate the copying loops. */
7418 gfc_trans_scalarizing_loops (&loop
, &body
);
7420 /* Wrap the whole thing up. */
7421 gfc_add_block_to_block (&block
, &loop
.pre
);
7422 gfc_add_block_to_block (&block
, &loop
.post
);
7424 gfc_cleanup_loop (&loop
);
7427 return gfc_finish_block (&block
);
7431 /* Check whether EXPR is a copyable array. */
7434 copyable_array_p (gfc_expr
* expr
)
7436 if (expr
->expr_type
!= EXPR_VARIABLE
)
7439 /* First check it's an array. */
7440 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
7443 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
7446 /* Next check that it's of a simple enough type. */
7447 switch (expr
->ts
.type
)
7459 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
7468 /* Translate an assignment. */
7471 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
7476 /* Special case a single function returning an array. */
7477 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
7479 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
7484 /* Special case assigning an array to zero. */
7485 if (copyable_array_p (expr1
)
7486 && is_zero_initializer_p (expr2
))
7488 tmp
= gfc_trans_zero_assign (expr1
);
7493 /* Special case copying one array to another. */
7494 if (copyable_array_p (expr1
)
7495 && copyable_array_p (expr2
)
7496 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
7497 && !gfc_check_dependency (expr1
, expr2
, 0))
7499 tmp
= gfc_trans_array_copy (expr1
, expr2
);
7504 /* Special case initializing an array from a constant array constructor. */
7505 if (copyable_array_p (expr1
)
7506 && expr2
->expr_type
== EXPR_ARRAY
7507 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
7509 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
7514 /* Fallback to the scalarizer to generate explicit loops. */
7515 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
7519 gfc_trans_init_assign (gfc_code
* code
)
7521 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
7525 gfc_trans_assign (gfc_code
* code
)
7527 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);