1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return fold_build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
159 /* Create a temporary and convert it to the correct type. */
160 tmp
= gfc_get_int_type (kind
);
161 tmp
= fold_convert (tmp
, build_fold_indirect_ref (se
->expr
));
163 /* Test for a NULL value. */
164 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
, tmp
,
165 fold_convert (TREE_TYPE (tmp
), integer_one_node
));
166 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
167 se
->expr
= build_fold_addr_expr (tmp
);
171 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
172 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
173 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
177 if (ts
.type
== BT_CHARACTER
)
179 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
180 tmp
= fold_build3 (COND_EXPR
, gfc_charlen_type_node
,
181 present
, se
->string_length
, tmp
);
182 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
183 se
->string_length
= tmp
;
189 /* Get the character length of an expression, looking through gfc_refs
193 gfc_get_expr_charlen (gfc_expr
*e
)
198 gcc_assert (e
->expr_type
== EXPR_VARIABLE
199 && e
->ts
.type
== BT_CHARACTER
);
201 length
= NULL
; /* To silence compiler warning. */
203 if (is_subref_array (e
) && e
->ts
.cl
->length
)
206 gfc_init_se (&tmpse
, NULL
);
207 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
208 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
212 /* First candidate: if the variable is of type CHARACTER, the
213 expression's length could be the length of the character
215 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
216 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
218 /* Look through the reference chain for component references. */
219 for (r
= e
->ref
; r
; r
= r
->next
)
224 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
225 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
233 /* We should never got substring references here. These will be
234 broken down by the scalarizer. */
240 gcc_assert (length
!= NULL
);
245 /* For each character array constructor subexpression without a ts.cl->length,
246 replace it by its first element (if there aren't any elements, the length
247 should already be set to zero). */
250 flatten_array_ctors_without_strlen (gfc_expr
* e
)
252 gfc_actual_arglist
* arg
;
258 switch (e
->expr_type
)
262 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
263 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
267 /* TODO: Implement as with EXPR_FUNCTION when needed. */
271 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
272 flatten_array_ctors_without_strlen (arg
->expr
);
277 /* We've found what we're looking for. */
278 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.cl
->length
)
281 gcc_assert (e
->value
.constructor
);
283 new_expr
= e
->value
.constructor
->expr
;
284 e
->value
.constructor
->expr
= NULL
;
286 flatten_array_ctors_without_strlen (new_expr
);
287 gfc_replace_expr (e
, new_expr
);
291 /* Otherwise, fall through to handle constructor elements. */
293 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
294 flatten_array_ctors_without_strlen (c
->expr
);
304 /* Generate code to initialize a string length variable. Returns the
305 value. For array constructors, cl->length might be NULL and in this case,
306 the first element of the constructor is needed. expr is the original
307 expression so we can access it but can be NULL if this is not needed. */
310 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
314 gfc_init_se (&se
, NULL
);
316 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
317 "flatten" array constructors by taking their first element; all elements
318 should be the same length or a cl->length should be present. */
324 expr_flat
= gfc_copy_expr (expr
);
325 flatten_array_ctors_without_strlen (expr_flat
);
326 gfc_resolve_expr (expr_flat
);
328 gfc_conv_expr (&se
, expr_flat
);
329 gfc_add_block_to_block (pblock
, &se
.pre
);
330 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
332 gfc_free_expr (expr_flat
);
336 /* Convert cl->length. */
338 gcc_assert (cl
->length
);
340 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
341 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
342 build_int_cst (gfc_charlen_type_node
, 0));
343 gfc_add_block_to_block (pblock
, &se
.pre
);
345 if (cl
->backend_decl
)
346 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
348 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
353 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
354 const char *name
, locus
*where
)
364 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
365 type
= build_pointer_type (type
);
368 gfc_init_se (&start
, se
);
369 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
370 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
372 if (integer_onep (start
.expr
))
373 gfc_conv_string_parameter (se
);
376 /* Avoid multiple evaluation of substring start. */
377 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
378 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
380 /* Change the start of the string. */
381 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
384 tmp
= build_fold_indirect_ref (se
->expr
);
385 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
386 se
->expr
= gfc_build_addr_expr (type
, tmp
);
389 /* Length = end + 1 - start. */
390 gfc_init_se (&end
, se
);
391 if (ref
->u
.ss
.end
== NULL
)
392 end
.expr
= se
->string_length
;
395 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
396 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
398 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
399 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
401 if (flag_bounds_check
)
403 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
404 start
.expr
, end
.expr
);
406 /* Check lower bound. */
407 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
408 build_int_cst (gfc_charlen_type_node
, 1));
409 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
412 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
413 "is less than one", name
);
415 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
417 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
418 fold_convert (long_integer_type_node
,
422 /* Check upper bound. */
423 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
425 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
428 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
429 "exceeds string length (%%ld)", name
);
431 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
432 "exceeds string length (%%ld)");
433 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
434 fold_convert (long_integer_type_node
, end
.expr
),
435 fold_convert (long_integer_type_node
,
440 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
441 build_int_cst (gfc_charlen_type_node
, 1),
443 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
444 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
445 build_int_cst (gfc_charlen_type_node
, 0));
446 se
->string_length
= tmp
;
450 /* Convert a derived type component reference. */
453 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
460 c
= ref
->u
.c
.component
;
462 gcc_assert (c
->backend_decl
);
464 field
= c
->backend_decl
;
465 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
467 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
471 if (c
->ts
.type
== BT_CHARACTER
)
473 tmp
= c
->ts
.cl
->backend_decl
;
474 /* Components must always be constant length. */
475 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
476 se
->string_length
= tmp
;
479 if (c
->attr
.pointer
&& c
->attr
.dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
480 se
->expr
= build_fold_indirect_ref (se
->expr
);
484 /* This function deals with component references to components of the
485 parent type for derived type extensons. */
487 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
495 c
= ref
->u
.c
.component
;
497 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
498 parent
.type
= REF_COMPONENT
;
501 parent
.u
.c
.component
= dt
->components
;
503 if (dt
->attr
.extension
&& dt
->components
)
505 /* Return if the component is not in the parent type. */
506 for (cmp
= dt
->components
->next
; cmp
; cmp
= cmp
->next
)
507 if (strcmp (c
->name
, cmp
->name
) == 0)
510 /* Otherwise build the reference and call self. */
511 gfc_conv_component_ref (se
, &parent
);
512 parent
.u
.c
.sym
= dt
->components
->ts
.derived
;
513 parent
.u
.c
.component
= c
;
514 conv_parent_component_references (se
, &parent
);
518 /* Return the contents of a variable. Also handles reference/pointer
519 variables (all Fortran pointer references are implicit). */
522 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
529 bool alternate_entry
;
532 sym
= expr
->symtree
->n
.sym
;
535 /* Check that something hasn't gone horribly wrong. */
536 gcc_assert (se
->ss
!= gfc_ss_terminator
);
537 gcc_assert (se
->ss
->expr
== expr
);
539 /* A scalarized term. We already know the descriptor. */
540 se
->expr
= se
->ss
->data
.info
.descriptor
;
541 se
->string_length
= se
->ss
->string_length
;
542 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
543 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
548 tree se_expr
= NULL_TREE
;
550 se
->expr
= gfc_get_symbol_decl (sym
);
552 /* Deal with references to a parent results or entries by storing
553 the current_function_decl and moving to the parent_decl. */
554 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
555 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
556 && sym
->result
== sym
;
557 entry_master
= sym
->attr
.result
558 && sym
->ns
->proc_name
->attr
.entry_master
559 && !gfc_return_by_reference (sym
->ns
->proc_name
);
560 parent_decl
= DECL_CONTEXT (current_function_decl
);
562 if ((se
->expr
== parent_decl
&& return_value
)
563 || (sym
->ns
&& sym
->ns
->proc_name
565 && sym
->ns
->proc_name
->backend_decl
== parent_decl
566 && (alternate_entry
|| entry_master
)))
571 /* Special case for assigning the return value of a function.
572 Self recursive functions must have an explicit return value. */
573 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
574 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
576 /* Similarly for alternate entry points. */
577 else if (alternate_entry
578 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
581 gfc_entry_list
*el
= NULL
;
583 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
586 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
591 else if (entry_master
592 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
594 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
599 /* Procedure actual arguments. */
600 else if (sym
->attr
.flavor
== FL_PROCEDURE
601 && se
->expr
!= current_function_decl
)
603 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
605 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
606 se
->expr
= build_fold_addr_expr (se
->expr
);
612 /* Dereference the expression, where needed. Since characters
613 are entirely different from other types, they are treated
615 if (sym
->ts
.type
== BT_CHARACTER
)
617 /* Dereference character pointer dummy arguments
619 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
621 || sym
->attr
.function
622 || sym
->attr
.result
))
623 se
->expr
= build_fold_indirect_ref (se
->expr
);
626 else if (!sym
->attr
.value
)
628 /* Dereference non-character scalar dummy arguments. */
629 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
630 se
->expr
= build_fold_indirect_ref (se
->expr
);
632 /* Dereference scalar hidden result. */
633 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
634 && (sym
->attr
.function
|| sym
->attr
.result
)
635 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
636 && !sym
->attr
.always_explicit
)
637 se
->expr
= build_fold_indirect_ref (se
->expr
);
639 /* Dereference non-character pointer variables.
640 These must be dummies, results, or scalars. */
641 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
643 || sym
->attr
.function
645 || !sym
->attr
.dimension
))
646 se
->expr
= build_fold_indirect_ref (se
->expr
);
652 /* For character variables, also get the length. */
653 if (sym
->ts
.type
== BT_CHARACTER
)
655 /* If the character length of an entry isn't set, get the length from
656 the master function instead. */
657 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
658 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
660 se
->string_length
= sym
->ts
.cl
->backend_decl
;
661 gcc_assert (se
->string_length
);
669 /* Return the descriptor if that's what we want and this is an array
670 section reference. */
671 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
673 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
674 /* Return the descriptor for array pointers and allocations. */
676 && ref
->next
== NULL
&& (se
->descriptor_only
))
679 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
680 /* Return a pointer to an element. */
684 if (ref
->u
.c
.sym
->attr
.extension
)
685 conv_parent_component_references (se
, ref
);
687 gfc_conv_component_ref (se
, ref
);
691 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
692 expr
->symtree
->name
, &expr
->where
);
701 /* Pointer assignment, allocation or pass by reference. Arrays are handled
703 if (se
->want_pointer
)
705 if (expr
->ts
.type
== BT_CHARACTER
)
706 gfc_conv_string_parameter (se
);
708 se
->expr
= build_fold_addr_expr (se
->expr
);
713 /* Unary ops are easy... Or they would be if ! was a valid op. */
716 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
721 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
722 /* Initialize the operand. */
723 gfc_init_se (&operand
, se
);
724 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
725 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
727 type
= gfc_typenode_for_spec (&expr
->ts
);
729 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
730 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
731 All other unary operators have an equivalent GIMPLE unary operator. */
732 if (code
== TRUTH_NOT_EXPR
)
733 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
734 build_int_cst (type
, 0));
736 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
740 /* Expand power operator to optimal multiplications when a value is raised
741 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
742 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
743 Programming", 3rd Edition, 1998. */
745 /* This code is mostly duplicated from expand_powi in the backend.
746 We establish the "optimal power tree" lookup table with the defined size.
747 The items in the table are the exponents used to calculate the index
748 exponents. Any integer n less than the value can get an "addition chain",
749 with the first node being one. */
750 #define POWI_TABLE_SIZE 256
752 /* The table is from builtins.c. */
753 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
755 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
756 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
757 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
758 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
759 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
760 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
761 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
762 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
763 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
764 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
765 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
766 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
767 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
768 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
769 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
770 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
771 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
772 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
773 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
774 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
775 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
776 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
777 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
778 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
779 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
780 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
781 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
782 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
783 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
784 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
785 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
786 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
789 /* If n is larger than lookup table's max index, we use the "window
791 #define POWI_WINDOW_SIZE 3
793 /* Recursive function to expand the power operator. The temporary
794 values are put in tmpvar. The function returns tmpvar[1] ** n. */
796 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
803 if (n
< POWI_TABLE_SIZE
)
808 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
809 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
813 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
814 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
815 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
819 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
823 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
824 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
826 if (n
< POWI_TABLE_SIZE
)
833 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
834 return 1. Else return 0 and a call to runtime library functions
835 will have to be built. */
837 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
842 tree vartmp
[POWI_TABLE_SIZE
];
844 unsigned HOST_WIDE_INT n
;
847 /* If exponent is too large, we won't expand it anyway, so don't bother
848 with large integer values. */
849 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
852 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
853 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
854 of the asymmetric range of the integer type. */
855 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
857 type
= TREE_TYPE (lhs
);
858 sgn
= tree_int_cst_sgn (rhs
);
860 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
861 || optimize_size
) && (m
> 2 || m
< -1))
867 se
->expr
= gfc_build_const (type
, integer_one_node
);
871 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
872 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
874 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
875 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
876 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
877 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
880 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
883 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
884 se
->expr
= fold_build3 (COND_EXPR
, type
,
885 tmp
, build_int_cst (type
, 1),
886 build_int_cst (type
, 0));
890 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
891 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
892 build_int_cst (type
, 0));
893 se
->expr
= fold_build3 (COND_EXPR
, type
,
894 cond
, build_int_cst (type
, 1), tmp
);
898 memset (vartmp
, 0, sizeof (vartmp
));
902 tmp
= gfc_build_const (type
, integer_one_node
);
903 vartmp
[1] = fold_build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
906 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
912 /* Power op (**). Constant integer exponent has special handling. */
915 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
917 tree gfc_int4_type_node
;
924 gfc_init_se (&lse
, se
);
925 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
926 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
927 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
929 gfc_init_se (&rse
, se
);
930 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
931 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
933 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
934 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
935 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
938 gfc_int4_type_node
= gfc_get_int_type (4);
940 kind
= expr
->value
.op
.op1
->ts
.kind
;
941 switch (expr
->value
.op
.op2
->ts
.type
)
944 ikind
= expr
->value
.op
.op2
->ts
.kind
;
949 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
971 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
972 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
997 switch (expr
->value
.op
.op1
->ts
.type
)
1000 if (kind
== 3) /* Case 16 was not handled properly above. */
1002 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1006 /* Use builtins for real ** int4. */
1012 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1016 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1021 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1029 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1033 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1045 fndecl
= built_in_decls
[BUILT_IN_POWF
];
1048 fndecl
= built_in_decls
[BUILT_IN_POW
];
1052 fndecl
= built_in_decls
[BUILT_IN_POWL
];
1063 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
1066 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
1070 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
1082 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
1086 /* Generate code to allocate a string temporary. */
1089 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1094 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
1096 if (gfc_can_put_var_on_stack (len
))
1098 /* Create a temporary variable to hold the result. */
1099 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
1100 build_int_cst (gfc_charlen_type_node
, 1));
1101 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1103 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1104 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1106 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1108 var
= gfc_create_var (tmp
, "str");
1109 var
= gfc_build_addr_expr (type
, var
);
1113 /* Allocate a temporary to hold the result. */
1114 var
= gfc_create_var (type
, "pstr");
1115 tmp
= gfc_call_malloc (&se
->pre
, type
,
1116 fold_build2 (MULT_EXPR
, TREE_TYPE (len
), len
,
1117 fold_convert (TREE_TYPE (len
),
1118 TYPE_SIZE (type
))));
1119 gfc_add_modify (&se
->pre
, var
, tmp
);
1121 /* Free the temporary afterwards. */
1122 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1123 gfc_add_expr_to_block (&se
->post
, tmp
);
1130 /* Handle a string concatenation operation. A temporary will be allocated to
1134 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1137 tree len
, type
, var
, tmp
, fndecl
;
1139 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1140 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1141 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1143 gfc_init_se (&lse
, se
);
1144 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1145 gfc_conv_string_parameter (&lse
);
1146 gfc_init_se (&rse
, se
);
1147 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1148 gfc_conv_string_parameter (&rse
);
1150 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1151 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1153 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1154 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1155 if (len
== NULL_TREE
)
1157 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1158 lse
.string_length
, rse
.string_length
);
1161 type
= build_pointer_type (type
);
1163 var
= gfc_conv_string_tmp (se
, type
, len
);
1165 /* Do the actual concatenation. */
1166 if (expr
->ts
.kind
== 1)
1167 fndecl
= gfor_fndecl_concat_string
;
1168 else if (expr
->ts
.kind
== 4)
1169 fndecl
= gfor_fndecl_concat_string_char4
;
1173 tmp
= build_call_expr (fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1174 rse
.string_length
, rse
.expr
);
1175 gfc_add_expr_to_block (&se
->pre
, tmp
);
1177 /* Add the cleanup for the operands. */
1178 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1179 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1182 se
->string_length
= len
;
1185 /* Translates an op expression. Common (binary) cases are handled by this
1186 function, others are passed on. Recursion is used in either case.
1187 We use the fact that (op1.ts == op2.ts) (except for the power
1189 Operators need no special handling for scalarized expressions as long as
1190 they call gfc_conv_simple_val to get their operands.
1191 Character strings get special handling. */
1194 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1196 enum tree_code code
;
1205 switch (expr
->value
.op
.op
)
1207 case INTRINSIC_PARENTHESES
:
1208 if (expr
->ts
.type
== BT_REAL
1209 || expr
->ts
.type
== BT_COMPLEX
)
1211 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1212 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1217 case INTRINSIC_UPLUS
:
1218 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1221 case INTRINSIC_UMINUS
:
1222 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1226 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1229 case INTRINSIC_PLUS
:
1233 case INTRINSIC_MINUS
:
1237 case INTRINSIC_TIMES
:
1241 case INTRINSIC_DIVIDE
:
1242 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1243 an integer, we must round towards zero, so we use a
1245 if (expr
->ts
.type
== BT_INTEGER
)
1246 code
= TRUNC_DIV_EXPR
;
1251 case INTRINSIC_POWER
:
1252 gfc_conv_power_op (se
, expr
);
1255 case INTRINSIC_CONCAT
:
1256 gfc_conv_concat_op (se
, expr
);
1260 code
= TRUTH_ANDIF_EXPR
;
1265 code
= TRUTH_ORIF_EXPR
;
1269 /* EQV and NEQV only work on logicals, but since we represent them
1270 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1272 case INTRINSIC_EQ_OS
:
1280 case INTRINSIC_NE_OS
:
1281 case INTRINSIC_NEQV
:
1288 case INTRINSIC_GT_OS
:
1295 case INTRINSIC_GE_OS
:
1302 case INTRINSIC_LT_OS
:
1309 case INTRINSIC_LE_OS
:
1315 case INTRINSIC_USER
:
1316 case INTRINSIC_ASSIGN
:
1317 /* These should be converted into function calls by the frontend. */
1321 fatal_error ("Unknown intrinsic op");
1325 /* The only exception to this is **, which is handled separately anyway. */
1326 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1328 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1332 gfc_init_se (&lse
, se
);
1333 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1334 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1337 gfc_init_se (&rse
, se
);
1338 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1339 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1343 gfc_conv_string_parameter (&lse
);
1344 gfc_conv_string_parameter (&rse
);
1346 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1347 rse
.string_length
, rse
.expr
,
1348 expr
->value
.op
.op1
->ts
.kind
);
1349 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1350 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1353 type
= gfc_typenode_for_spec (&expr
->ts
);
1357 /* The result of logical ops is always boolean_type_node. */
1358 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1359 se
->expr
= convert (type
, tmp
);
1362 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1364 /* Add the post blocks. */
1365 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1366 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1369 /* If a string's length is one, we convert it to a single character. */
1372 string_to_single_character (tree len
, tree str
, int kind
)
1374 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1376 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1377 && TREE_INT_CST_HIGH (len
) == 0)
1379 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1380 return build_fold_indirect_ref (str
);
1388 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1391 if (sym
->backend_decl
)
1393 /* This becomes the nominal_type in
1394 function.c:assign_parm_find_data_types. */
1395 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1396 /* This becomes the passed_type in
1397 function.c:assign_parm_find_data_types. C promotes char to
1398 integer for argument passing. */
1399 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1401 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1406 /* If we have a constant character expression, make it into an
1408 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1413 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1414 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1416 /* The expr needs to be compatible with a C int. If the
1417 conversion fails, then the 2 causes an ICE. */
1418 ts
.type
= BT_INTEGER
;
1419 ts
.kind
= gfc_c_int_kind
;
1420 gfc_convert_type (*expr
, &ts
, 2);
1423 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1425 if ((*expr
)->ref
== NULL
)
1427 se
->expr
= string_to_single_character
1428 (build_int_cst (integer_type_node
, 1),
1429 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1431 ((*expr
)->symtree
->n
.sym
)),
1436 gfc_conv_variable (se
, *expr
);
1437 se
->expr
= string_to_single_character
1438 (build_int_cst (integer_type_node
, 1),
1439 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1448 /* Compare two strings. If they are all single characters, the result is the
1449 subtraction of them. Otherwise, we build a library call. */
1452 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
)
1458 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1459 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1461 sc1
= string_to_single_character (len1
, str1
, kind
);
1462 sc2
= string_to_single_character (len2
, str2
, kind
);
1464 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1466 /* Deal with single character specially. */
1467 sc1
= fold_convert (integer_type_node
, sc1
);
1468 sc2
= fold_convert (integer_type_node
, sc2
);
1469 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1473 /* Build a call for the comparison. */
1477 fndecl
= gfor_fndecl_compare_string
;
1479 fndecl
= gfor_fndecl_compare_string_char4
;
1483 tmp
= build_call_expr (fndecl
, 4, len1
, str1
, len2
, str2
);
1490 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1494 if (sym
->attr
.dummy
)
1496 tmp
= gfc_get_symbol_decl (sym
);
1497 if (sym
->attr
.proc_pointer
)
1498 tmp
= build_fold_indirect_ref (tmp
);
1499 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1500 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1504 if (!sym
->backend_decl
)
1505 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1507 tmp
= sym
->backend_decl
;
1508 if (sym
->attr
.cray_pointee
)
1509 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1510 gfc_get_symbol_decl (sym
->cp_pointer
));
1511 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1513 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1514 tmp
= build_fold_addr_expr (tmp
);
1521 /* Translate the call for an elemental subroutine call used in an operator
1522 assignment. This is a simplified version of gfc_conv_function_call. */
1525 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1532 /* Only elemental subroutines with two arguments. */
1533 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1534 gcc_assert (sym
->formal
->next
->next
== NULL
);
1536 gfc_init_block (&block
);
1538 gfc_add_block_to_block (&block
, &lse
->pre
);
1539 gfc_add_block_to_block (&block
, &rse
->pre
);
1541 /* Build the argument list for the call, including hidden string lengths. */
1542 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1543 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1544 if (lse
->string_length
!= NULL_TREE
)
1545 args
= gfc_chainon_list (args
, lse
->string_length
);
1546 if (rse
->string_length
!= NULL_TREE
)
1547 args
= gfc_chainon_list (args
, rse
->string_length
);
1549 /* Build the function call. */
1550 gfc_init_se (&se
, NULL
);
1551 gfc_conv_function_val (&se
, sym
);
1552 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1553 tmp
= build_call_list (tmp
, se
.expr
, args
);
1554 gfc_add_expr_to_block (&block
, tmp
);
1556 gfc_add_block_to_block (&block
, &lse
->post
);
1557 gfc_add_block_to_block (&block
, &rse
->post
);
1559 return gfc_finish_block (&block
);
1563 /* Initialize MAPPING. */
1566 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1568 mapping
->syms
= NULL
;
1569 mapping
->charlens
= NULL
;
1573 /* Free all memory held by MAPPING (but not MAPPING itself). */
1576 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1578 gfc_interface_sym_mapping
*sym
;
1579 gfc_interface_sym_mapping
*nextsym
;
1581 gfc_charlen
*nextcl
;
1583 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1585 nextsym
= sym
->next
;
1586 sym
->new_sym
->n
.sym
->formal
= NULL
;
1587 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1588 gfc_free_expr (sym
->expr
);
1589 gfc_free (sym
->new_sym
);
1592 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1595 gfc_free_expr (cl
->length
);
1601 /* Return a copy of gfc_charlen CL. Add the returned structure to
1602 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1604 static gfc_charlen
*
1605 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1608 gfc_charlen
*new_charlen
;
1610 new_charlen
= gfc_get_charlen ();
1611 new_charlen
->next
= mapping
->charlens
;
1612 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1614 mapping
->charlens
= new_charlen
;
1619 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1620 array variable that can be used as the actual argument for dummy
1621 argument SYM. Add any initialization code to BLOCK. PACKED is as
1622 for gfc_get_nodesc_array_type and DATA points to the first element
1623 in the passed array. */
1626 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1627 gfc_packed packed
, tree data
)
1632 type
= gfc_typenode_for_spec (&sym
->ts
);
1633 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1635 var
= gfc_create_var (type
, "ifm");
1636 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1642 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1643 and offset of descriptorless array type TYPE given that it has the same
1644 size as DESC. Add any set-up code to BLOCK. */
1647 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1654 offset
= gfc_index_zero_node
;
1655 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1657 dim
= gfc_rank_cst
[n
];
1658 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1659 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1661 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1662 = gfc_conv_descriptor_lbound (desc
, dim
);
1663 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1664 = gfc_conv_descriptor_ubound (desc
, dim
);
1666 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1668 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1669 gfc_conv_descriptor_ubound (desc
, dim
),
1670 gfc_conv_descriptor_lbound (desc
, dim
));
1671 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1672 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1674 tmp
= gfc_evaluate_now (tmp
, block
);
1675 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1677 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1678 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1679 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1680 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1682 offset
= gfc_evaluate_now (offset
, block
);
1683 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1687 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1688 in SE. The caller may still use se->expr and se->string_length after
1689 calling this function. */
1692 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1693 gfc_symbol
* sym
, gfc_se
* se
,
1696 gfc_interface_sym_mapping
*sm
;
1700 gfc_symbol
*new_sym
;
1702 gfc_symtree
*new_symtree
;
1704 /* Create a new symbol to represent the actual argument. */
1705 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1706 new_sym
->ts
= sym
->ts
;
1707 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1708 new_sym
->attr
.referenced
= 1;
1709 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1710 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1711 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1712 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1713 new_sym
->attr
.function
= sym
->attr
.function
;
1715 /* Ensure that the interface is available and that
1716 descriptors are passed for array actual arguments. */
1717 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1719 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1720 new_sym
->attr
.always_explicit
1721 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1724 /* Create a fake symtree for it. */
1726 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1727 new_symtree
->n
.sym
= new_sym
;
1728 gcc_assert (new_symtree
== root
);
1730 /* Create a dummy->actual mapping. */
1731 sm
= XCNEW (gfc_interface_sym_mapping
);
1732 sm
->next
= mapping
->syms
;
1734 sm
->new_sym
= new_symtree
;
1735 sm
->expr
= gfc_copy_expr (expr
);
1738 /* Stabilize the argument's value. */
1739 if (!sym
->attr
.function
&& se
)
1740 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1742 if (sym
->ts
.type
== BT_CHARACTER
)
1744 /* Create a copy of the dummy argument's length. */
1745 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1746 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1748 /* If the length is specified as "*", record the length that
1749 the caller is passing. We should use the callee's length
1750 in all other cases. */
1751 if (!new_sym
->ts
.cl
->length
&& se
)
1753 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1754 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1761 /* Use the passed value as-is if the argument is a function. */
1762 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1765 /* If the argument is either a string or a pointer to a string,
1766 convert it to a boundless character type. */
1767 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1769 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1770 tmp
= build_pointer_type (tmp
);
1771 if (sym
->attr
.pointer
)
1772 value
= build_fold_indirect_ref (se
->expr
);
1775 value
= fold_convert (tmp
, value
);
1778 /* If the argument is a scalar, a pointer to an array or an allocatable,
1780 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1781 value
= build_fold_indirect_ref (se
->expr
);
1783 /* For character(*), use the actual argument's descriptor. */
1784 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1785 value
= build_fold_indirect_ref (se
->expr
);
1787 /* If the argument is an array descriptor, use it to determine
1788 information about the actual argument's shape. */
1789 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1790 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1792 /* Get the actual argument's descriptor. */
1793 desc
= build_fold_indirect_ref (se
->expr
);
1795 /* Create the replacement variable. */
1796 tmp
= gfc_conv_descriptor_data_get (desc
);
1797 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1800 /* Use DESC to work out the upper bounds, strides and offset. */
1801 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1804 /* Otherwise we have a packed array. */
1805 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1806 PACKED_FULL
, se
->expr
);
1808 new_sym
->backend_decl
= value
;
1812 /* Called once all dummy argument mappings have been added to MAPPING,
1813 but before the mapping is used to evaluate expressions. Pre-evaluate
1814 the length of each argument, adding any initialization code to PRE and
1815 any finalization code to POST. */
1818 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1819 stmtblock_t
* pre
, stmtblock_t
* post
)
1821 gfc_interface_sym_mapping
*sym
;
1825 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1826 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1827 && !sym
->new_sym
->n
.sym
->ts
.cl
->backend_decl
)
1829 expr
= sym
->new_sym
->n
.sym
->ts
.cl
->length
;
1830 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1831 gfc_init_se (&se
, NULL
);
1832 gfc_conv_expr (&se
, expr
);
1833 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1834 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1835 gfc_add_block_to_block (pre
, &se
.pre
);
1836 gfc_add_block_to_block (post
, &se
.post
);
1838 sym
->new_sym
->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1843 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1847 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1848 gfc_constructor
* c
)
1850 for (; c
; c
= c
->next
)
1852 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1855 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1856 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1857 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1863 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1867 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1872 for (; ref
; ref
= ref
->next
)
1876 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1878 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1879 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1880 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1882 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1889 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1890 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1896 /* Convert intrinsic function calls into result expressions. */
1899 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
1907 arg1
= expr
->value
.function
.actual
->expr
;
1908 if (expr
->value
.function
.actual
->next
)
1909 arg2
= expr
->value
.function
.actual
->next
->expr
;
1913 sym
= arg1
->symtree
->n
.sym
;
1915 if (sym
->attr
.dummy
)
1920 switch (expr
->value
.function
.isym
->id
)
1923 /* TODO figure out why this condition is necessary. */
1924 if (sym
->attr
.function
1925 && (arg1
->ts
.cl
->length
== NULL
1926 || (arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1927 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
1930 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1937 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1939 dup
= mpz_get_si (arg2
->value
.integer
);
1944 dup
= sym
->as
->rank
;
1948 for (; d
< dup
; d
++)
1952 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
1954 gfc_free_expr (new_expr
);
1958 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1959 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1961 new_expr
= gfc_multiply (new_expr
, tmp
);
1967 case GFC_ISYM_LBOUND
:
1968 case GFC_ISYM_UBOUND
:
1969 /* TODO These implementations of lbound and ubound do not limit if
1970 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1975 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1976 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1978 /* TODO: If the need arises, this could produce an array of
1982 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1984 if (sym
->as
->lower
[d
])
1985 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1989 if (sym
->as
->upper
[d
])
1990 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1998 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2002 gfc_replace_expr (expr
, new_expr
);
2008 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2009 gfc_interface_mapping
* mapping
)
2011 gfc_formal_arglist
*f
;
2012 gfc_actual_arglist
*actual
;
2014 actual
= expr
->value
.function
.actual
;
2015 f
= map_expr
->symtree
->n
.sym
->formal
;
2017 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2022 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2025 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2030 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2032 for (d
= 0; d
< as
->rank
; d
++)
2034 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2035 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2038 expr
->value
.function
.esym
->as
= as
;
2041 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2043 expr
->value
.function
.esym
->ts
.cl
->length
2044 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
2046 gfc_apply_interface_mapping_to_expr (mapping
,
2047 expr
->value
.function
.esym
->ts
.cl
->length
);
2052 /* EXPR is a copy of an expression that appeared in the interface
2053 associated with MAPPING. Walk it recursively looking for references to
2054 dummy arguments that MAPPING maps to actual arguments. Replace each such
2055 reference with a reference to the associated actual argument. */
2058 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2061 gfc_interface_sym_mapping
*sym
;
2062 gfc_actual_arglist
*actual
;
2067 /* Copying an expression does not copy its length, so do that here. */
2068 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
2070 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
2071 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
2074 /* Apply the mapping to any references. */
2075 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2077 /* ...and to the expression's symbol, if it has one. */
2078 /* TODO Find out why the condition on expr->symtree had to be moved into
2079 the loop rather than being outside it, as originally. */
2080 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2081 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2083 if (sym
->new_sym
->n
.sym
->backend_decl
)
2084 expr
->symtree
= sym
->new_sym
;
2086 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2089 /* ...and to subexpressions in expr->value. */
2090 switch (expr
->expr_type
)
2095 case EXPR_SUBSTRING
:
2099 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2100 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2104 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2105 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2107 if (expr
->value
.function
.esym
== NULL
2108 && expr
->value
.function
.isym
!= NULL
2109 && expr
->value
.function
.actual
->expr
->symtree
2110 && gfc_map_intrinsic_function (expr
, mapping
))
2113 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2114 if (sym
->old
== expr
->value
.function
.esym
)
2116 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2117 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2118 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2123 case EXPR_STRUCTURE
:
2124 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2136 /* Evaluate interface expression EXPR using MAPPING. Store the result
2140 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2141 gfc_se
* se
, gfc_expr
* expr
)
2143 expr
= gfc_copy_expr (expr
);
2144 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2145 gfc_conv_expr (se
, expr
);
2146 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2147 gfc_free_expr (expr
);
2151 /* Returns a reference to a temporary array into which a component of
2152 an actual argument derived type array is copied and then returned
2153 after the function call. */
2155 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
2156 int g77
, sym_intent intent
)
2172 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2174 gfc_init_se (&lse
, NULL
);
2175 gfc_init_se (&rse
, NULL
);
2177 /* Walk the argument expression. */
2178 rss
= gfc_walk_expr (expr
);
2180 gcc_assert (rss
!= gfc_ss_terminator
);
2182 /* Initialize the scalarizer. */
2183 gfc_init_loopinfo (&loop
);
2184 gfc_add_ss_to_loop (&loop
, rss
);
2186 /* Calculate the bounds of the scalarization. */
2187 gfc_conv_ss_startstride (&loop
);
2189 /* Build an ss for the temporary. */
2190 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
2191 gfc_conv_string_length (expr
->ts
.cl
, expr
, &parmse
->pre
);
2193 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2194 if (GFC_ARRAY_TYPE_P (base_type
)
2195 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2196 base_type
= gfc_get_element_type (base_type
);
2198 loop
.temp_ss
= gfc_get_ss ();;
2199 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2200 loop
.temp_ss
->data
.temp
.type
= base_type
;
2202 if (expr
->ts
.type
== BT_CHARACTER
)
2203 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2205 loop
.temp_ss
->string_length
= NULL
;
2207 parmse
->string_length
= loop
.temp_ss
->string_length
;
2208 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2209 loop
.temp_ss
->next
= gfc_ss_terminator
;
2211 /* Associate the SS with the loop. */
2212 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2214 /* Setup the scalarizing loops. */
2215 gfc_conv_loop_setup (&loop
, &expr
->where
);
2217 /* Pass the temporary descriptor back to the caller. */
2218 info
= &loop
.temp_ss
->data
.info
;
2219 parmse
->expr
= info
->descriptor
;
2221 /* Setup the gfc_se structures. */
2222 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2223 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2226 lse
.ss
= loop
.temp_ss
;
2227 gfc_mark_ss_chain_used (rss
, 1);
2228 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2230 /* Start the scalarized loop body. */
2231 gfc_start_scalarized_body (&loop
, &body
);
2233 /* Translate the expression. */
2234 gfc_conv_expr (&rse
, expr
);
2236 gfc_conv_tmp_array_ref (&lse
);
2237 gfc_advance_se_ss_chain (&lse
);
2239 if (intent
!= INTENT_OUT
)
2241 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2242 gfc_add_expr_to_block (&body
, tmp
);
2243 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2244 gfc_trans_scalarizing_loops (&loop
, &body
);
2248 /* Make sure that the temporary declaration survives by merging
2249 all the loop declarations into the current context. */
2250 for (n
= 0; n
< loop
.dimen
; n
++)
2252 gfc_merge_block_scope (&body
);
2253 body
= loop
.code
[loop
.order
[n
]];
2255 gfc_merge_block_scope (&body
);
2258 /* Add the post block after the second loop, so that any
2259 freeing of allocated memory is done at the right time. */
2260 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2262 /**********Copy the temporary back again.*********/
2264 gfc_init_se (&lse
, NULL
);
2265 gfc_init_se (&rse
, NULL
);
2267 /* Walk the argument expression. */
2268 lss
= gfc_walk_expr (expr
);
2269 rse
.ss
= loop
.temp_ss
;
2272 /* Initialize the scalarizer. */
2273 gfc_init_loopinfo (&loop2
);
2274 gfc_add_ss_to_loop (&loop2
, lss
);
2276 /* Calculate the bounds of the scalarization. */
2277 gfc_conv_ss_startstride (&loop2
);
2279 /* Setup the scalarizing loops. */
2280 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2282 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2283 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2285 gfc_mark_ss_chain_used (lss
, 1);
2286 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2288 /* Declare the variable to hold the temporary offset and start the
2289 scalarized loop body. */
2290 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2291 gfc_start_scalarized_body (&loop2
, &body
);
2293 /* Build the offsets for the temporary from the loop variables. The
2294 temporary array has lbounds of zero and strides of one in all
2295 dimensions, so this is very simple. The offset is only computed
2296 outside the innermost loop, so the overall transfer could be
2297 optimized further. */
2298 info
= &rse
.ss
->data
.info
;
2300 tmp_index
= gfc_index_zero_node
;
2301 for (n
= info
->dimen
- 1; n
> 0; n
--)
2304 tmp
= rse
.loop
->loopvar
[n
];
2305 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2306 tmp
, rse
.loop
->from
[n
]);
2307 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2310 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2311 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2312 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2313 tmp_str
, gfc_index_one_node
);
2315 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2319 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2320 tmp_index
, rse
.loop
->from
[0]);
2321 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2323 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2324 rse
.loop
->loopvar
[0], offset
);
2326 /* Now use the offset for the reference. */
2327 tmp
= build_fold_indirect_ref (info
->data
);
2328 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2330 if (expr
->ts
.type
== BT_CHARACTER
)
2331 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2333 gfc_conv_expr (&lse
, expr
);
2335 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2337 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2338 gfc_add_expr_to_block (&body
, tmp
);
2340 /* Generate the copying loops. */
2341 gfc_trans_scalarizing_loops (&loop2
, &body
);
2343 /* Wrap the whole thing up by adding the second loop to the post-block
2344 and following it by the post-block of the first loop. In this way,
2345 if the temporary needs freeing, it is done after use! */
2346 if (intent
!= INTENT_IN
)
2348 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2349 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2352 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2354 gfc_cleanup_loop (&loop
);
2355 gfc_cleanup_loop (&loop2
);
2357 /* Pass the string length to the argument expression. */
2358 if (expr
->ts
.type
== BT_CHARACTER
)
2359 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2361 /* We want either the address for the data or the address of the descriptor,
2362 depending on the mode of passing array arguments. */
2364 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2366 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2372 /* Generate the code for argument list functions. */
2375 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2377 /* Pass by value for g77 %VAL(arg), pass the address
2378 indirectly for %LOC, else by reference. Thus %REF
2379 is a "do-nothing" and %LOC is the same as an F95
2381 if (strncmp (name
, "%VAL", 4) == 0)
2382 gfc_conv_expr (se
, expr
);
2383 else if (strncmp (name
, "%LOC", 4) == 0)
2385 gfc_conv_expr_reference (se
, expr
);
2386 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2388 else if (strncmp (name
, "%REF", 4) == 0)
2389 gfc_conv_expr_reference (se
, expr
);
2391 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2395 /* Generate code for a procedure call. Note can return se->post != NULL.
2396 If se->direct_byref is set then se->expr contains the return parameter.
2397 Return nonzero, if the call has alternate specifiers. */
2400 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2401 gfc_actual_arglist
* arg
, tree append_args
)
2403 gfc_interface_mapping mapping
;
2417 gfc_formal_arglist
*formal
;
2418 int has_alternate_specifier
= 0;
2419 bool need_interface_mapping
;
2426 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2428 arglist
= NULL_TREE
;
2429 retargs
= NULL_TREE
;
2430 stringargs
= NULL_TREE
;
2435 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2437 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2439 if (arg
->expr
->rank
== 0)
2440 gfc_conv_expr_reference (se
, arg
->expr
);
2444 /* This is really the actual arg because no formal arglist is
2445 created for C_LOC. */
2446 fsym
= arg
->expr
->symtree
->n
.sym
;
2448 /* We should want it to do g77 calling convention. */
2450 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2451 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2452 f
= f
|| !sym
->attr
.always_explicit
;
2454 argss
= gfc_walk_expr (arg
->expr
);
2455 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
, NULL
, NULL
);
2458 /* TODO -- the following two lines shouldn't be necessary, but
2459 they're removed a bug is exposed later in the codepath.
2460 This is workaround was thus introduced, but will have to be
2461 removed; please see PR 35150 for details about the issue. */
2462 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2463 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2467 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2469 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2470 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2471 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2472 gfc_conv_expr_reference (se
, arg
->expr
);
2476 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2477 && arg
->next
->expr
->rank
== 0)
2478 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2480 /* Convert c_f_pointer if fptr is a scalar
2481 and convert c_f_procpointer. */
2485 gfc_init_se (&cptrse
, NULL
);
2486 gfc_conv_expr (&cptrse
, arg
->expr
);
2487 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2488 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2490 gfc_init_se (&fptrse
, NULL
);
2491 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2492 fptrse
.want_pointer
= 1;
2494 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2495 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2496 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2498 tmp
= arg
->next
->expr
->symtree
->n
.sym
->backend_decl
;
2499 se
->expr
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (tmp
), fptrse
.expr
,
2500 fold_convert (TREE_TYPE (tmp
), cptrse
.expr
));
2504 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2509 /* Build the addr_expr for the first argument. The argument is
2510 already an *address* so we don't need to set want_pointer in
2512 gfc_init_se (&arg1se
, NULL
);
2513 gfc_conv_expr (&arg1se
, arg
->expr
);
2514 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2515 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2517 /* See if we were given two arguments. */
2518 if (arg
->next
== NULL
)
2519 /* Only given one arg so generate a null and do a
2520 not-equal comparison against the first arg. */
2521 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2522 fold_convert (TREE_TYPE (arg1se
.expr
),
2523 null_pointer_node
));
2529 /* Given two arguments so build the arg2se from second arg. */
2530 gfc_init_se (&arg2se
, NULL
);
2531 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2532 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2533 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2535 /* Generate test to compare that the two args are equal. */
2536 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2537 arg1se
.expr
, arg2se
.expr
);
2538 /* Generate test to ensure that the first arg is not null. */
2539 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2540 arg1se
.expr
, null_pointer_node
);
2542 /* Finally, the generated test must check that both arg1 is not
2543 NULL and that it is equal to the second arg. */
2544 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2545 not_null_expr
, eq_expr
);
2554 if (!sym
->attr
.elemental
)
2556 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2557 if (se
->ss
->useflags
)
2559 gcc_assert (gfc_return_by_reference (sym
)
2560 && sym
->result
->attr
.dimension
);
2561 gcc_assert (se
->loop
!= NULL
);
2563 /* Access the previously obtained result. */
2564 gfc_conv_tmp_array_ref (se
);
2565 gfc_advance_se_ss_chain (se
);
2569 info
= &se
->ss
->data
.info
;
2574 gfc_init_block (&post
);
2575 gfc_init_interface_mapping (&mapping
);
2576 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2577 && sym
->ts
.cl
->length
2578 && sym
->ts
.cl
->length
->expr_type
2580 || sym
->attr
.dimension
);
2581 formal
= sym
->formal
;
2582 /* Evaluate the arguments. */
2583 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2586 fsym
= formal
? formal
->sym
: NULL
;
2587 parm_kind
= MISSING
;
2591 if (se
->ignore_optional
)
2593 /* Some intrinsics have already been resolved to the correct
2597 else if (arg
->label
)
2599 has_alternate_specifier
= 1;
2604 /* Pass a NULL pointer for an absent arg. */
2605 gfc_init_se (&parmse
, NULL
);
2606 parmse
.expr
= null_pointer_node
;
2607 if (arg
->missing_arg_type
== BT_CHARACTER
)
2608 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2611 else if (se
->ss
&& se
->ss
->useflags
)
2613 /* An elemental function inside a scalarized loop. */
2614 gfc_init_se (&parmse
, se
);
2615 gfc_conv_expr_reference (&parmse
, e
);
2616 parm_kind
= ELEMENTAL
;
2620 /* A scalar or transformational function. */
2621 gfc_init_se (&parmse
, NULL
);
2622 argss
= gfc_walk_expr (e
);
2624 if (argss
== gfc_ss_terminator
)
2626 if (fsym
&& fsym
->attr
.value
)
2628 if (fsym
->ts
.type
== BT_CHARACTER
2629 && fsym
->ts
.is_c_interop
2630 && fsym
->ns
->proc_name
!= NULL
2631 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2634 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2635 if (parmse
.expr
== NULL
)
2636 gfc_conv_expr (&parmse
, e
);
2639 gfc_conv_expr (&parmse
, e
);
2641 else if (arg
->name
&& arg
->name
[0] == '%')
2642 /* Argument list functions %VAL, %LOC and %REF are signalled
2643 through arg->name. */
2644 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2645 else if ((e
->expr_type
== EXPR_FUNCTION
)
2646 && e
->symtree
->n
.sym
->attr
.pointer
2647 && fsym
&& fsym
->attr
.target
)
2649 gfc_conv_expr (&parmse
, e
);
2650 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2654 gfc_conv_expr_reference (&parmse
, e
);
2655 if (fsym
&& e
->expr_type
!= EXPR_NULL
2656 && ((fsym
->attr
.pointer
2657 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
2658 || fsym
->attr
.proc_pointer
))
2660 /* Scalar pointer dummy args require an extra level of
2661 indirection. The null pointer already contains
2662 this level of indirection. */
2663 parm_kind
= SCALAR_POINTER
;
2664 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2670 /* If the procedure requires an explicit interface, the actual
2671 argument is passed according to the corresponding formal
2672 argument. If the corresponding formal argument is a POINTER,
2673 ALLOCATABLE or assumed shape, we do not use g77's calling
2674 convention, and pass the address of the array descriptor
2675 instead. Otherwise we use g77's calling convention. */
2678 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2679 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2680 f
= f
|| !sym
->attr
.always_explicit
;
2682 if (e
->expr_type
== EXPR_VARIABLE
2683 && is_subref_array (e
))
2684 /* The actual argument is a component reference to an
2685 array of derived types. In this case, the argument
2686 is converted to a temporary, which is passed and then
2687 written back after the procedure call. */
2688 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2689 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2691 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
2694 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2695 allocated on entry, it must be deallocated. */
2696 if (fsym
&& fsym
->attr
.allocatable
2697 && fsym
->attr
.intent
== INTENT_OUT
)
2699 tmp
= build_fold_indirect_ref (parmse
.expr
);
2700 tmp
= gfc_trans_dealloc_allocated (tmp
);
2701 gfc_add_expr_to_block (&se
->pre
, tmp
);
2707 /* The case with fsym->attr.optional is that of a user subroutine
2708 with an interface indicating an optional argument. When we call
2709 an intrinsic subroutine, however, fsym is NULL, but we might still
2710 have an optional argument, so we proceed to the substitution
2712 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2714 /* If an optional argument is itself an optional dummy argument,
2715 check its presence and substitute a null if absent. */
2716 if (e
->expr_type
== EXPR_VARIABLE
2717 && e
->symtree
->n
.sym
->attr
.optional
)
2718 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2719 e
->representation
.length
);
2724 /* Obtain the character length of an assumed character length
2725 length procedure from the typespec. */
2726 if (fsym
->ts
.type
== BT_CHARACTER
2727 && parmse
.string_length
== NULL_TREE
2728 && e
->ts
.type
== BT_PROCEDURE
2729 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2730 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
2731 && e
->symtree
->n
.sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2733 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2734 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2738 if (fsym
&& need_interface_mapping
&& e
)
2739 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2741 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2742 gfc_add_block_to_block (&post
, &parmse
.post
);
2744 /* Allocated allocatable components of derived types must be
2745 deallocated for non-variable scalars. Non-variable arrays are
2746 dealt with in trans-array.c(gfc_conv_array_parameter). */
2747 if (e
&& e
->ts
.type
== BT_DERIVED
2748 && e
->ts
.derived
->attr
.alloc_comp
2749 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
2752 tmp
= build_fold_indirect_ref (parmse
.expr
);
2753 parm_rank
= e
->rank
;
2761 case (SCALAR_POINTER
):
2762 tmp
= build_fold_indirect_ref (tmp
);
2766 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2767 gfc_add_expr_to_block (&se
->post
, tmp
);
2770 /* Character strings are passed as two parameters, a length and a
2771 pointer - except for Bind(c) which only passes the pointer. */
2772 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2773 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2775 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2777 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2780 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
2781 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2782 else if (ts
.type
== BT_CHARACTER
)
2784 if (sym
->ts
.cl
->length
== NULL
)
2786 /* Assumed character length results are not allowed by 5.1.1.5 of the
2787 standard and are trapped in resolve.c; except in the case of SPREAD
2788 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2789 we take the character length of the first argument for the result.
2790 For dummies, we have to look through the formal argument list for
2791 this function and use the character length found there.*/
2792 if (!sym
->attr
.dummy
)
2793 cl
.backend_decl
= TREE_VALUE (stringargs
);
2796 formal
= sym
->ns
->proc_name
->formal
;
2797 for (; formal
; formal
= formal
->next
)
2798 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2799 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2806 /* Calculate the length of the returned string. */
2807 gfc_init_se (&parmse
, NULL
);
2808 if (need_interface_mapping
)
2809 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2811 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2812 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2813 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2815 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2816 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2817 build_int_cst (gfc_charlen_type_node
, 0));
2818 cl
.backend_decl
= tmp
;
2821 /* Set up a charlen structure for it. */
2826 len
= cl
.backend_decl
;
2829 byref
= gfc_return_by_reference (sym
);
2832 if (se
->direct_byref
)
2834 /* Sometimes, too much indirection can be applied; e.g. for
2835 function_result = array_valued_recursive_function. */
2836 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2837 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2838 && GFC_DESCRIPTOR_TYPE_P
2839 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2840 se
->expr
= build_fold_indirect_ref (se
->expr
);
2842 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2844 else if (sym
->result
->attr
.dimension
)
2846 gcc_assert (se
->loop
&& info
);
2848 /* Set the type of the array. */
2849 tmp
= gfc_typenode_for_spec (&ts
);
2850 info
->dimen
= se
->loop
->dimen
;
2852 /* Evaluate the bounds of the result, if known. */
2853 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2855 /* Create a temporary to store the result. In case the function
2856 returns a pointer, the temporary will be a shallow copy and
2857 mustn't be deallocated. */
2858 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2859 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2860 NULL_TREE
, false, !sym
->attr
.pointer
,
2861 callee_alloc
, &se
->ss
->expr
->where
);
2863 /* Pass the temporary as the first argument. */
2864 tmp
= info
->descriptor
;
2865 tmp
= build_fold_addr_expr (tmp
);
2866 retargs
= gfc_chainon_list (retargs
, tmp
);
2868 else if (ts
.type
== BT_CHARACTER
)
2870 /* Pass the string length. */
2871 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2872 type
= build_pointer_type (type
);
2874 /* Return an address to a char[0:len-1]* temporary for
2875 character pointers. */
2876 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2878 var
= gfc_create_var (type
, "pstr");
2880 /* Provide an address expression for the function arguments. */
2881 var
= build_fold_addr_expr (var
);
2884 var
= gfc_conv_string_tmp (se
, type
, len
);
2886 retargs
= gfc_chainon_list (retargs
, var
);
2890 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2892 type
= gfc_get_complex_type (ts
.kind
);
2893 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2894 retargs
= gfc_chainon_list (retargs
, var
);
2897 /* Add the string length to the argument list. */
2898 if (ts
.type
== BT_CHARACTER
)
2899 retargs
= gfc_chainon_list (retargs
, len
);
2901 gfc_free_interface_mapping (&mapping
);
2903 /* Add the return arguments. */
2904 arglist
= chainon (retargs
, arglist
);
2906 /* Add the hidden string length parameters to the arguments. */
2907 arglist
= chainon (arglist
, stringargs
);
2909 /* We may want to append extra arguments here. This is used e.g. for
2910 calls to libgfortran_matmul_??, which need extra information. */
2911 if (append_args
!= NULL_TREE
)
2912 arglist
= chainon (arglist
, append_args
);
2914 /* Generate the actual call. */
2915 gfc_conv_function_val (se
, sym
);
2917 /* If there are alternate return labels, function type should be
2918 integer. Can't modify the type in place though, since it can be shared
2919 with other functions. For dummy arguments, the typing is done to
2920 to this result, even if it has to be repeated for each call. */
2921 if (has_alternate_specifier
2922 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2924 if (!sym
->attr
.dummy
)
2926 TREE_TYPE (sym
->backend_decl
)
2927 = build_function_type (integer_type_node
,
2928 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2929 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2932 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2935 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2936 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2938 /* If we have a pointer function, but we don't want a pointer, e.g.
2941 where f is pointer valued, we have to dereference the result. */
2942 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2943 se
->expr
= build_fold_indirect_ref (se
->expr
);
2945 /* f2c calling conventions require a scalar default real function to
2946 return a double precision result. Convert this back to default
2947 real. We only care about the cases that can happen in Fortran 77.
2949 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2950 && sym
->ts
.kind
== gfc_default_real_kind
2951 && !sym
->attr
.always_explicit
)
2952 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2954 /* A pure function may still have side-effects - it may modify its
2956 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2958 if (!sym
->attr
.pure
)
2959 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2964 /* Add the function call to the pre chain. There is no expression. */
2965 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2966 se
->expr
= NULL_TREE
;
2968 if (!se
->direct_byref
)
2970 if (sym
->attr
.dimension
)
2972 if (flag_bounds_check
)
2974 /* Check the data pointer hasn't been modified. This would
2975 happen in a function returning a pointer. */
2976 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2977 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2979 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
2982 se
->expr
= info
->descriptor
;
2983 /* Bundle in the string length. */
2984 se
->string_length
= len
;
2986 else if (sym
->ts
.type
== BT_CHARACTER
)
2988 /* Dereference for character pointer results. */
2989 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2990 se
->expr
= build_fold_indirect_ref (var
);
2994 se
->string_length
= len
;
2998 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2999 se
->expr
= build_fold_indirect_ref (var
);
3004 /* Follow the function call with the argument post block. */
3006 gfc_add_block_to_block (&se
->pre
, &post
);
3008 gfc_add_block_to_block (&se
->post
, &post
);
3010 return has_alternate_specifier
;
3014 /* Fill a character string with spaces. */
3017 fill_with_spaces (tree start
, tree type
, tree size
)
3019 stmtblock_t block
, loop
;
3020 tree i
, el
, exit_label
, cond
, tmp
;
3022 /* For a simple char type, we can call memset(). */
3023 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3024 return build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3025 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3026 lang_hooks
.to_target_charset (' ')),
3029 /* Otherwise, we use a loop:
3030 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3034 /* Initialize variables. */
3035 gfc_init_block (&block
);
3036 i
= gfc_create_var (sizetype
, "i");
3037 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3038 el
= gfc_create_var (build_pointer_type (type
), "el");
3039 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3040 exit_label
= gfc_build_label_decl (NULL_TREE
);
3041 TREE_USED (exit_label
) = 1;
3045 gfc_init_block (&loop
);
3047 /* Exit condition. */
3048 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
3049 fold_convert (sizetype
, integer_zero_node
));
3050 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3051 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
3052 gfc_add_expr_to_block (&loop
, tmp
);
3055 gfc_add_modify (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
3056 build_int_cst (type
,
3057 lang_hooks
.to_target_charset (' ')));
3059 /* Increment loop variables. */
3060 gfc_add_modify (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
3061 TYPE_SIZE_UNIT (type
)));
3062 gfc_add_modify (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
3064 TYPE_SIZE_UNIT (type
)));
3066 /* Making the loop... actually loop! */
3067 tmp
= gfc_finish_block (&loop
);
3068 tmp
= build1_v (LOOP_EXPR
, tmp
);
3069 gfc_add_expr_to_block (&block
, tmp
);
3071 /* The exit label. */
3072 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3073 gfc_add_expr_to_block (&block
, tmp
);
3076 return gfc_finish_block (&block
);
3080 /* Generate code to copy a string. */
3083 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3084 int dkind
, tree slength
, tree src
, int skind
)
3086 tree tmp
, dlen
, slen
;
3095 stmtblock_t tempblock
;
3097 gcc_assert (dkind
== skind
);
3099 if (slength
!= NULL_TREE
)
3101 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3102 ssc
= string_to_single_character (slen
, src
, skind
);
3106 slen
= build_int_cst (size_type_node
, 1);
3110 if (dlength
!= NULL_TREE
)
3112 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3113 dsc
= string_to_single_character (slen
, dest
, dkind
);
3117 dlen
= build_int_cst (size_type_node
, 1);
3121 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3122 ssc
= string_to_single_character (slen
, src
, skind
);
3123 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3124 dsc
= string_to_single_character (dlen
, dest
, dkind
);
3127 /* Assign directly if the types are compatible. */
3128 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3129 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3131 gfc_add_modify (block
, dsc
, ssc
);
3135 /* Do nothing if the destination length is zero. */
3136 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
3137 build_int_cst (size_type_node
, 0));
3139 /* The following code was previously in _gfortran_copy_string:
3141 // The two strings may overlap so we use memmove.
3143 copy_string (GFC_INTEGER_4 destlen, char * dest,
3144 GFC_INTEGER_4 srclen, const char * src)
3146 if (srclen >= destlen)
3148 // This will truncate if too long.
3149 memmove (dest, src, destlen);
3153 memmove (dest, src, srclen);
3155 memset (&dest[srclen], ' ', destlen - srclen);
3159 We're now doing it here for better optimization, but the logic
3162 /* For non-default character kinds, we have to multiply the string
3163 length by the base type size. */
3164 chartype
= gfc_get_char_type (dkind
);
3165 slen
= fold_build2 (MULT_EXPR
, size_type_node
,
3166 fold_convert (size_type_node
, slen
),
3167 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3168 dlen
= fold_build2 (MULT_EXPR
, size_type_node
,
3169 fold_convert (size_type_node
, dlen
),
3170 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3173 dest
= fold_convert (pvoid_type_node
, dest
);
3175 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3178 src
= fold_convert (pvoid_type_node
, src
);
3180 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3182 /* Truncate string if source is too long. */
3183 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3184 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
3185 3, dest
, src
, dlen
);
3187 /* Else copy and pad with spaces. */
3188 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
3189 3, dest
, src
, slen
);
3191 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3192 fold_convert (sizetype
, slen
));
3193 tmp4
= fill_with_spaces (tmp4
, chartype
,
3194 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3197 gfc_init_block (&tempblock
);
3198 gfc_add_expr_to_block (&tempblock
, tmp3
);
3199 gfc_add_expr_to_block (&tempblock
, tmp4
);
3200 tmp3
= gfc_finish_block (&tempblock
);
3202 /* The whole copy_string function is there. */
3203 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3204 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
3205 gfc_add_expr_to_block (block
, tmp
);
3209 /* Translate a statement function.
3210 The value of a statement function reference is obtained by evaluating the
3211 expression using the values of the actual arguments for the values of the
3212 corresponding dummy arguments. */
3215 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3219 gfc_formal_arglist
*fargs
;
3220 gfc_actual_arglist
*args
;
3223 gfc_saved_var
*saved_vars
;
3229 sym
= expr
->symtree
->n
.sym
;
3230 args
= expr
->value
.function
.actual
;
3231 gfc_init_se (&lse
, NULL
);
3232 gfc_init_se (&rse
, NULL
);
3235 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3237 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3238 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3240 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3242 /* Each dummy shall be specified, explicitly or implicitly, to be
3244 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3247 /* Create a temporary to hold the value. */
3248 type
= gfc_typenode_for_spec (&fsym
->ts
);
3249 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3251 if (fsym
->ts
.type
== BT_CHARACTER
)
3253 /* Copy string arguments. */
3256 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
3257 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3259 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3260 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3263 gfc_conv_expr (&rse
, args
->expr
);
3264 gfc_conv_string_parameter (&rse
);
3265 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3266 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3268 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3269 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3270 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3271 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3275 /* For everything else, just evaluate the expression. */
3276 gfc_conv_expr (&lse
, args
->expr
);
3278 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3279 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3280 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3286 /* Use the temporary variables in place of the real ones. */
3287 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3288 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3290 gfc_conv_expr (se
, sym
->value
);
3292 if (sym
->ts
.type
== BT_CHARACTER
)
3294 gfc_conv_const_charlen (sym
->ts
.cl
);
3296 /* Force the expression to the correct length. */
3297 if (!INTEGER_CST_P (se
->string_length
)
3298 || tree_int_cst_lt (se
->string_length
,
3299 sym
->ts
.cl
->backend_decl
))
3301 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3302 tmp
= gfc_create_var (type
, sym
->name
);
3303 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3304 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3305 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3309 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3312 /* Restore the original variables. */
3313 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3314 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3315 gfc_free (saved_vars
);
3319 /* Translate a function expression. */
3322 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3326 if (expr
->value
.function
.isym
)
3328 gfc_conv_intrinsic_function (se
, expr
);
3332 /* We distinguish statement functions from general functions to improve
3333 runtime performance. */
3334 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3336 gfc_conv_statement_function (se
, expr
);
3340 /* expr.value.function.esym is the resolved (specific) function symbol for
3341 most functions. However this isn't set for dummy procedures. */
3342 sym
= expr
->value
.function
.esym
;
3344 sym
= expr
->symtree
->n
.sym
;
3345 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
3350 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3352 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3353 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3355 gfc_conv_tmp_array_ref (se
);
3356 gfc_advance_se_ss_chain (se
);
3360 /* Build a static initializer. EXPR is the expression for the initial value.
3361 The other parameters describe the variable of the component being
3362 initialized. EXPR may be null. */
3365 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3366 bool array
, bool pointer
)
3370 if (!(expr
|| pointer
))
3373 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3374 (these are the only two iso_c_binding derived types that can be
3375 used as initialization expressions). If so, we need to modify
3376 the 'expr' to be that for a (void *). */
3377 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3378 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3380 gfc_symbol
*derived
= expr
->ts
.derived
;
3382 expr
= gfc_int_expr (0);
3384 /* The derived symbol has already been converted to a (void *). Use
3386 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3387 expr
->ts
.kind
= derived
->ts
.kind
;
3392 /* Arrays need special handling. */
3394 return gfc_build_null_descriptor (type
);
3396 return gfc_conv_array_initializer (type
, expr
);
3399 return fold_convert (type
, null_pointer_node
);
3405 gfc_init_se (&se
, NULL
);
3406 gfc_conv_structure (&se
, expr
, 1);
3410 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3413 gfc_init_se (&se
, NULL
);
3414 gfc_conv_constant (&se
, expr
);
3421 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3433 gfc_start_block (&block
);
3435 /* Initialize the scalarizer. */
3436 gfc_init_loopinfo (&loop
);
3438 gfc_init_se (&lse
, NULL
);
3439 gfc_init_se (&rse
, NULL
);
3442 rss
= gfc_walk_expr (expr
);
3443 if (rss
== gfc_ss_terminator
)
3445 /* The rhs is scalar. Add a ss for the expression. */
3446 rss
= gfc_get_ss ();
3447 rss
->next
= gfc_ss_terminator
;
3448 rss
->type
= GFC_SS_SCALAR
;
3452 /* Create a SS for the destination. */
3453 lss
= gfc_get_ss ();
3454 lss
->type
= GFC_SS_COMPONENT
;
3456 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3457 lss
->next
= gfc_ss_terminator
;
3458 lss
->data
.info
.dimen
= cm
->as
->rank
;
3459 lss
->data
.info
.descriptor
= dest
;
3460 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3461 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3462 for (n
= 0; n
< cm
->as
->rank
; n
++)
3464 lss
->data
.info
.dim
[n
] = n
;
3465 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3466 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3468 mpz_init (lss
->shape
[n
]);
3469 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3470 cm
->as
->lower
[n
]->value
.integer
);
3471 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3474 /* Associate the SS with the loop. */
3475 gfc_add_ss_to_loop (&loop
, lss
);
3476 gfc_add_ss_to_loop (&loop
, rss
);
3478 /* Calculate the bounds of the scalarization. */
3479 gfc_conv_ss_startstride (&loop
);
3481 /* Setup the scalarizing loops. */
3482 gfc_conv_loop_setup (&loop
, &expr
->where
);
3484 /* Setup the gfc_se structures. */
3485 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3486 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3489 gfc_mark_ss_chain_used (rss
, 1);
3491 gfc_mark_ss_chain_used (lss
, 1);
3493 /* Start the scalarized loop body. */
3494 gfc_start_scalarized_body (&loop
, &body
);
3496 gfc_conv_tmp_array_ref (&lse
);
3497 if (cm
->ts
.type
== BT_CHARACTER
)
3498 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3500 gfc_conv_expr (&rse
, expr
);
3502 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3503 gfc_add_expr_to_block (&body
, tmp
);
3505 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3507 /* Generate the copying loops. */
3508 gfc_trans_scalarizing_loops (&loop
, &body
);
3510 /* Wrap the whole thing up. */
3511 gfc_add_block_to_block (&block
, &loop
.pre
);
3512 gfc_add_block_to_block (&block
, &loop
.post
);
3514 for (n
= 0; n
< cm
->as
->rank
; n
++)
3515 mpz_clear (lss
->shape
[n
]);
3516 gfc_free (lss
->shape
);
3518 gfc_cleanup_loop (&loop
);
3520 return gfc_finish_block (&block
);
3524 /* Assign a single component of a derived type constructor. */
3527 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3537 gfc_start_block (&block
);
3539 if (cm
->attr
.pointer
)
3541 gfc_init_se (&se
, NULL
);
3542 /* Pointer component. */
3543 if (cm
->attr
.dimension
)
3545 /* Array pointer. */
3546 if (expr
->expr_type
== EXPR_NULL
)
3547 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3550 rss
= gfc_walk_expr (expr
);
3551 se
.direct_byref
= 1;
3553 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3554 gfc_add_block_to_block (&block
, &se
.pre
);
3555 gfc_add_block_to_block (&block
, &se
.post
);
3560 /* Scalar pointers. */
3561 se
.want_pointer
= 1;
3562 gfc_conv_expr (&se
, expr
);
3563 gfc_add_block_to_block (&block
, &se
.pre
);
3564 gfc_add_modify (&block
, dest
,
3565 fold_convert (TREE_TYPE (dest
), se
.expr
));
3566 gfc_add_block_to_block (&block
, &se
.post
);
3569 else if (cm
->attr
.dimension
)
3571 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
3572 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3573 else if (cm
->attr
.allocatable
)
3577 gfc_init_se (&se
, NULL
);
3579 rss
= gfc_walk_expr (expr
);
3580 se
.want_pointer
= 0;
3581 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3582 gfc_add_block_to_block (&block
, &se
.pre
);
3584 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3585 gfc_add_modify (&block
, dest
, tmp
);
3587 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3588 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3591 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3592 TREE_TYPE(cm
->backend_decl
),
3595 gfc_add_expr_to_block (&block
, tmp
);
3596 gfc_add_block_to_block (&block
, &se
.post
);
3598 if (expr
->expr_type
!= EXPR_VARIABLE
)
3599 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3601 /* Shift the lbound and ubound of temporaries to being unity, rather
3602 than zero, based. Calculate the offset for all cases. */
3603 offset
= gfc_conv_descriptor_offset (dest
);
3604 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
3605 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3606 for (n
= 0; n
< expr
->rank
; n
++)
3608 if (expr
->expr_type
!= EXPR_VARIABLE
3609 && expr
->expr_type
!= EXPR_CONSTANT
)
3612 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3613 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3614 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3615 gfc_add_modify (&block
, tmp
,
3616 fold_build2 (PLUS_EXPR
,
3617 gfc_array_index_type
,
3618 span
, gfc_index_one_node
));
3619 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3620 gfc_add_modify (&block
, tmp
, gfc_index_one_node
);
3622 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3623 gfc_conv_descriptor_lbound (dest
,
3625 gfc_conv_descriptor_stride (dest
,
3627 gfc_add_modify (&block
, tmp2
, tmp
);
3628 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3629 gfc_add_modify (&block
, offset
, tmp
);
3632 if (expr
->expr_type
== EXPR_FUNCTION
3633 && expr
->value
.function
.isym
3634 && expr
->value
.function
.isym
->conversion
3635 && expr
->value
.function
.actual
->expr
3636 && expr
->value
.function
.actual
->expr
->expr_type
3639 /* If a conversion expression has a null data pointer
3640 argument, nullify the allocatable component. */
3644 s
= expr
->value
.function
.actual
->expr
->symtree
->n
.sym
;
3645 if (s
->attr
.allocatable
|| s
->attr
.pointer
)
3647 non_null_expr
= gfc_finish_block (&block
);
3648 gfc_start_block (&block
);
3649 gfc_conv_descriptor_data_set (&block
, dest
,
3651 null_expr
= gfc_finish_block (&block
);
3652 tmp
= gfc_conv_descriptor_data_get (s
->backend_decl
);
3653 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
,
3654 fold_convert (TREE_TYPE (tmp
),
3655 null_pointer_node
));
3656 return build3_v (COND_EXPR
, tmp
, null_expr
,
3663 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3664 gfc_add_expr_to_block (&block
, tmp
);
3667 else if (expr
->ts
.type
== BT_DERIVED
)
3669 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3671 gfc_init_se (&se
, NULL
);
3672 gfc_conv_expr (&se
, expr
);
3673 gfc_add_block_to_block (&block
, &se
.pre
);
3674 gfc_add_modify (&block
, dest
,
3675 fold_convert (TREE_TYPE (dest
), se
.expr
));
3676 gfc_add_block_to_block (&block
, &se
.post
);
3680 /* Nested constructors. */
3681 tmp
= gfc_trans_structure_assign (dest
, expr
);
3682 gfc_add_expr_to_block (&block
, tmp
);
3687 /* Scalar component. */
3688 gfc_init_se (&se
, NULL
);
3689 gfc_init_se (&lse
, NULL
);
3691 gfc_conv_expr (&se
, expr
);
3692 if (cm
->ts
.type
== BT_CHARACTER
)
3693 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3695 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3696 gfc_add_expr_to_block (&block
, tmp
);
3698 return gfc_finish_block (&block
);
3701 /* Assign a derived type constructor to a variable. */
3704 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3712 gfc_start_block (&block
);
3713 cm
= expr
->ts
.derived
->components
;
3714 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3716 /* Skip absent members in default initializers. */
3720 field
= cm
->backend_decl
;
3721 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
3722 dest
, field
, NULL_TREE
);
3723 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3724 gfc_add_expr_to_block (&block
, tmp
);
3726 return gfc_finish_block (&block
);
3729 /* Build an expression for a constructor. If init is nonzero then
3730 this is part of a static variable initializer. */
3733 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3740 VEC(constructor_elt
,gc
) *v
= NULL
;
3742 gcc_assert (se
->ss
== NULL
);
3743 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3744 type
= gfc_typenode_for_spec (&expr
->ts
);
3748 /* Create a temporary variable and fill it in. */
3749 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3750 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3751 gfc_add_expr_to_block (&se
->pre
, tmp
);
3755 cm
= expr
->ts
.derived
->components
;
3757 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3759 /* Skip absent members in default initializers and allocatable
3760 components. Although the latter have a default initializer
3761 of EXPR_NULL,... by default, the static nullify is not needed
3762 since this is done every time we come into scope. */
3763 if (!c
->expr
|| cm
->attr
.allocatable
)
3766 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3767 TREE_TYPE (cm
->backend_decl
), cm
->attr
.dimension
, cm
->attr
.pointer
);
3769 /* Append it to the constructor list. */
3770 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3772 se
->expr
= build_constructor (type
, v
);
3774 TREE_CONSTANT (se
->expr
) = 1;
3778 /* Translate a substring expression. */
3781 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3787 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3789 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
3790 expr
->value
.character
.length
,
3791 expr
->value
.character
.string
);
3793 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3794 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3797 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3801 /* Entry point for expression translation. Evaluates a scalar quantity.
3802 EXPR is the expression to be translated, and SE is the state structure if
3803 called from within the scalarized. */
3806 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3808 if (se
->ss
&& se
->ss
->expr
== expr
3809 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3811 /* Substitute a scalar expression evaluated outside the scalarization
3813 se
->expr
= se
->ss
->data
.scalar
.expr
;
3814 se
->string_length
= se
->ss
->string_length
;
3815 gfc_advance_se_ss_chain (se
);
3819 /* We need to convert the expressions for the iso_c_binding derived types.
3820 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3821 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3822 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3823 updated to be an integer with a kind equal to the size of a (void *). */
3824 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3825 && expr
->ts
.derived
->attr
.is_iso_c
)
3827 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3828 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3830 /* Set expr_type to EXPR_NULL, which will result in
3831 null_pointer_node being used below. */
3832 expr
->expr_type
= EXPR_NULL
;
3836 /* Update the type/kind of the expression to be what the new
3837 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3838 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3839 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3840 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3844 switch (expr
->expr_type
)
3847 gfc_conv_expr_op (se
, expr
);
3851 gfc_conv_function_expr (se
, expr
);
3855 gfc_conv_constant (se
, expr
);
3859 gfc_conv_variable (se
, expr
);
3863 se
->expr
= null_pointer_node
;
3866 case EXPR_SUBSTRING
:
3867 gfc_conv_substring_expr (se
, expr
);
3870 case EXPR_STRUCTURE
:
3871 gfc_conv_structure (se
, expr
, 0);
3875 gfc_conv_array_constructor_expr (se
, expr
);
3884 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3885 of an assignment. */
3887 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3889 gfc_conv_expr (se
, expr
);
3890 /* All numeric lvalues should have empty post chains. If not we need to
3891 figure out a way of rewriting an lvalue so that it has no post chain. */
3892 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3895 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3896 numeric expressions. Used for scalar values where inserting cleanup code
3899 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3903 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3904 gfc_conv_expr (se
, expr
);
3907 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3908 gfc_add_modify (&se
->pre
, val
, se
->expr
);
3910 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3914 /* Helper to translate an expression and convert it to a particular type. */
3916 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3918 gfc_conv_expr_val (se
, expr
);
3919 se
->expr
= convert (type
, se
->expr
);
3923 /* Converts an expression so that it can be passed by reference. Scalar
3927 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3931 if (se
->ss
&& se
->ss
->expr
== expr
3932 && se
->ss
->type
== GFC_SS_REFERENCE
)
3934 se
->expr
= se
->ss
->data
.scalar
.expr
;
3935 se
->string_length
= se
->ss
->string_length
;
3936 gfc_advance_se_ss_chain (se
);
3940 if (expr
->ts
.type
== BT_CHARACTER
)
3942 gfc_conv_expr (se
, expr
);
3943 gfc_conv_string_parameter (se
);
3947 if (expr
->expr_type
== EXPR_VARIABLE
)
3949 se
->want_pointer
= 1;
3950 gfc_conv_expr (se
, expr
);
3953 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3954 gfc_add_modify (&se
->pre
, var
, se
->expr
);
3955 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3961 if (expr
->expr_type
== EXPR_FUNCTION
3962 && expr
->symtree
->n
.sym
->attr
.pointer
3963 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3965 se
->want_pointer
= 1;
3966 gfc_conv_expr (se
, expr
);
3967 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3968 gfc_add_modify (&se
->pre
, var
, se
->expr
);
3974 gfc_conv_expr (se
, expr
);
3976 /* Create a temporary var to hold the value. */
3977 if (TREE_CONSTANT (se
->expr
))
3979 tree tmp
= se
->expr
;
3980 STRIP_TYPE_NOPS (tmp
);
3981 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3982 DECL_INITIAL (var
) = tmp
;
3983 TREE_STATIC (var
) = 1;
3988 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3989 gfc_add_modify (&se
->pre
, var
, se
->expr
);
3991 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3993 /* Take the address of that value. */
3994 se
->expr
= build_fold_addr_expr (var
);
3999 gfc_trans_pointer_assign (gfc_code
* code
)
4001 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
4005 /* Generate code for a pointer assignment. */
4008 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4019 gfc_start_block (&block
);
4021 gfc_init_se (&lse
, NULL
);
4023 lss
= gfc_walk_expr (expr1
);
4024 rss
= gfc_walk_expr (expr2
);
4025 if (lss
== gfc_ss_terminator
)
4027 /* Scalar pointers. */
4028 lse
.want_pointer
= 1;
4029 gfc_conv_expr (&lse
, expr1
);
4030 gcc_assert (rss
== gfc_ss_terminator
);
4031 gfc_init_se (&rse
, NULL
);
4032 rse
.want_pointer
= 1;
4033 gfc_conv_expr (&rse
, expr2
);
4035 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4036 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4037 lse
.expr
= build_fold_indirect_ref (lse
.expr
);
4039 gfc_add_block_to_block (&block
, &lse
.pre
);
4040 gfc_add_block_to_block (&block
, &rse
.pre
);
4042 /* Check character lengths if character expression. The test is only
4043 really added if -fbounds-check is enabled. */
4044 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4046 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4047 gcc_assert (lse
.string_length
&& rse
.string_length
);
4048 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4049 lse
.string_length
, rse
.string_length
,
4053 gfc_add_modify (&block
, lse
.expr
,
4054 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4056 gfc_add_block_to_block (&block
, &rse
.post
);
4057 gfc_add_block_to_block (&block
, &lse
.post
);
4062 tree strlen_rhs
= NULL_TREE
;
4064 /* Array pointer. */
4065 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4066 strlen_lhs
= lse
.string_length
;
4067 switch (expr2
->expr_type
)
4070 /* Just set the data pointer to null. */
4071 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4075 /* Assign directly to the pointer's descriptor. */
4076 lse
.direct_byref
= 1;
4077 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4078 strlen_rhs
= lse
.string_length
;
4080 /* If this is a subreference array pointer assignment, use the rhs
4081 descriptor element size for the lhs span. */
4082 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4084 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4085 gfc_init_se (&rse
, NULL
);
4086 rse
.descriptor_only
= 1;
4087 gfc_conv_expr (&rse
, expr2
);
4088 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4089 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4090 if (!INTEGER_CST_P (tmp
))
4091 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4092 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4098 /* Assign to a temporary descriptor and then copy that
4099 temporary to the pointer. */
4101 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4104 lse
.direct_byref
= 1;
4105 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4106 strlen_rhs
= lse
.string_length
;
4107 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4111 gfc_add_block_to_block (&block
, &lse
.pre
);
4113 /* Check string lengths if applicable. The check is only really added
4114 to the output code if -fbounds-check is enabled. */
4115 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4117 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4118 gcc_assert (strlen_lhs
&& strlen_rhs
);
4119 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4120 strlen_lhs
, strlen_rhs
, &block
);
4123 gfc_add_block_to_block (&block
, &lse
.post
);
4125 return gfc_finish_block (&block
);
4129 /* Makes sure se is suitable for passing as a function string parameter. */
4130 /* TODO: Need to check all callers of this function. It may be abused. */
4133 gfc_conv_string_parameter (gfc_se
* se
)
4137 if (TREE_CODE (se
->expr
) == STRING_CST
)
4139 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
4140 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4144 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
4146 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
4148 type
= TREE_TYPE (se
->expr
);
4149 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4153 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4155 type
= build_pointer_type (type
);
4156 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
4160 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
4161 gcc_assert (se
->string_length
4162 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
4166 /* Generate code for assignment of scalar variables. Includes character
4167 strings and derived types with allocatable components. */
4170 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
4171 bool l_is_temp
, bool r_is_var
)
4177 gfc_init_block (&block
);
4179 if (ts
.type
== BT_CHARACTER
)
4184 if (lse
->string_length
!= NULL_TREE
)
4186 gfc_conv_string_parameter (lse
);
4187 gfc_add_block_to_block (&block
, &lse
->pre
);
4188 llen
= lse
->string_length
;
4191 if (rse
->string_length
!= NULL_TREE
)
4193 gcc_assert (rse
->string_length
!= NULL_TREE
);
4194 gfc_conv_string_parameter (rse
);
4195 gfc_add_block_to_block (&block
, &rse
->pre
);
4196 rlen
= rse
->string_length
;
4199 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4200 rse
->expr
, ts
.kind
);
4202 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
4206 /* Are the rhs and the lhs the same? */
4209 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4210 build_fold_addr_expr (lse
->expr
),
4211 build_fold_addr_expr (rse
->expr
));
4212 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4215 /* Deallocate the lhs allocated components as long as it is not
4216 the same as the rhs. This must be done following the assignment
4217 to prevent deallocating data that could be used in the rhs
4221 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4222 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
4224 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
4225 gfc_add_expr_to_block (&lse
->post
, tmp
);
4228 gfc_add_block_to_block (&block
, &rse
->pre
);
4229 gfc_add_block_to_block (&block
, &lse
->pre
);
4231 gfc_add_modify (&block
, lse
->expr
,
4232 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4234 /* Do a deep copy if the rhs is a variable, if it is not the
4238 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
4239 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
4240 gfc_add_expr_to_block (&block
, tmp
);
4245 gfc_add_block_to_block (&block
, &lse
->pre
);
4246 gfc_add_block_to_block (&block
, &rse
->pre
);
4248 gfc_add_modify (&block
, lse
->expr
,
4249 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4252 gfc_add_block_to_block (&block
, &lse
->post
);
4253 gfc_add_block_to_block (&block
, &rse
->post
);
4255 return gfc_finish_block (&block
);
4259 /* Try to translate array(:) = func (...), where func is a transformational
4260 array function, without using a temporary. Returns NULL is this isn't the
4264 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4269 bool seen_array_ref
;
4271 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4272 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
4275 /* Elemental functions don't need a temporary anyway. */
4276 if (expr2
->value
.function
.esym
!= NULL
4277 && expr2
->value
.function
.esym
->attr
.elemental
)
4280 /* Fail if EXPR1 can't be expressed as a descriptor. */
4281 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4284 /* Functions returning pointers need temporaries. */
4285 if (expr2
->symtree
->n
.sym
->attr
.pointer
4286 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4289 /* Character array functions need temporaries unless the
4290 character lengths are the same. */
4291 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4293 if (expr1
->ts
.cl
->length
== NULL
4294 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4297 if (expr2
->ts
.cl
->length
== NULL
4298 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4301 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
4302 expr2
->ts
.cl
->length
->value
.integer
) != 0)
4306 /* Check that no LHS component references appear during an array
4307 reference. This is needed because we do not have the means to
4308 span any arbitrary stride with an array descriptor. This check
4309 is not needed for the rhs because the function result has to be
4311 seen_array_ref
= false;
4312 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
4314 if (ref
->type
== REF_ARRAY
)
4315 seen_array_ref
= true;
4316 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
4320 /* Check for a dependency. */
4321 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
4322 expr2
->value
.function
.esym
,
4323 expr2
->value
.function
.actual
,
4327 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4329 gcc_assert (expr2
->value
.function
.isym
4330 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
4331 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
4333 ss
= gfc_walk_expr (expr1
);
4334 gcc_assert (ss
!= gfc_ss_terminator
);
4335 gfc_init_se (&se
, NULL
);
4336 gfc_start_block (&se
.pre
);
4337 se
.want_pointer
= 1;
4339 gfc_conv_array_parameter (&se
, expr1
, ss
, 0, NULL
, NULL
);
4341 se
.direct_byref
= 1;
4342 se
.ss
= gfc_walk_expr (expr2
);
4343 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4344 gfc_conv_function_expr (&se
, expr2
);
4345 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4347 return gfc_finish_block (&se
.pre
);
4350 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4353 is_zero_initializer_p (gfc_expr
* expr
)
4355 if (expr
->expr_type
!= EXPR_CONSTANT
)
4358 /* We ignore constants with prescribed memory representations for now. */
4359 if (expr
->representation
.string
)
4362 switch (expr
->ts
.type
)
4365 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4368 return mpfr_zero_p (expr
->value
.real
)
4369 && MPFR_SIGN (expr
->value
.real
) >= 0;
4372 return expr
->value
.logical
== 0;
4375 return mpfr_zero_p (expr
->value
.complex.r
)
4376 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
4377 && mpfr_zero_p (expr
->value
.complex.i
)
4378 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
4386 /* Try to efficiently translate array(:) = 0. Return NULL if this
4390 gfc_trans_zero_assign (gfc_expr
* expr
)
4392 tree dest
, len
, type
;
4396 sym
= expr
->symtree
->n
.sym
;
4397 dest
= gfc_get_symbol_decl (sym
);
4399 type
= TREE_TYPE (dest
);
4400 if (POINTER_TYPE_P (type
))
4401 type
= TREE_TYPE (type
);
4402 if (!GFC_ARRAY_TYPE_P (type
))
4405 /* Determine the length of the array. */
4406 len
= GFC_TYPE_ARRAY_SIZE (type
);
4407 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4410 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4411 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4412 fold_convert (gfc_array_index_type
, tmp
));
4414 /* Convert arguments to the correct types. */
4415 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4416 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4418 dest
= fold_convert (pvoid_type_node
, dest
);
4419 len
= fold_convert (size_type_node
, len
);
4421 /* Construct call to __builtin_memset. */
4422 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4423 3, dest
, integer_zero_node
, len
);
4424 return fold_convert (void_type_node
, tmp
);
4428 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4429 that constructs the call to __builtin_memcpy. */
4432 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4436 /* Convert arguments to the correct types. */
4437 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4438 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4440 dst
= fold_convert (pvoid_type_node
, dst
);
4442 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4443 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4445 src
= fold_convert (pvoid_type_node
, src
);
4447 len
= fold_convert (size_type_node
, len
);
4449 /* Construct call to __builtin_memcpy. */
4450 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4451 return fold_convert (void_type_node
, tmp
);
4455 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4456 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4457 source/rhs, both are gfc_full_array_ref_p which have been checked for
4461 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4463 tree dst
, dlen
, dtype
;
4464 tree src
, slen
, stype
;
4467 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4468 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4470 dtype
= TREE_TYPE (dst
);
4471 if (POINTER_TYPE_P (dtype
))
4472 dtype
= TREE_TYPE (dtype
);
4473 stype
= TREE_TYPE (src
);
4474 if (POINTER_TYPE_P (stype
))
4475 stype
= TREE_TYPE (stype
);
4477 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4480 /* Determine the lengths of the arrays. */
4481 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4482 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4484 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4485 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4486 fold_convert (gfc_array_index_type
, tmp
));
4488 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4489 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4491 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4492 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4493 fold_convert (gfc_array_index_type
, tmp
));
4495 /* Sanity check that they are the same. This should always be
4496 the case, as we should already have checked for conformance. */
4497 if (!tree_int_cst_equal (slen
, dlen
))
4500 return gfc_build_memcpy_call (dst
, src
, dlen
);
4504 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4505 this can't be done. EXPR1 is the destination/lhs for which
4506 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4509 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4511 unsigned HOST_WIDE_INT nelem
;
4517 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4521 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4522 dtype
= TREE_TYPE (dst
);
4523 if (POINTER_TYPE_P (dtype
))
4524 dtype
= TREE_TYPE (dtype
);
4525 if (!GFC_ARRAY_TYPE_P (dtype
))
4528 /* Determine the lengths of the array. */
4529 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4530 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4533 /* Confirm that the constructor is the same size. */
4534 if (compare_tree_int (len
, nelem
) != 0)
4537 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4538 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4539 fold_convert (gfc_array_index_type
, tmp
));
4541 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4542 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4544 stype
= TREE_TYPE (src
);
4545 if (POINTER_TYPE_P (stype
))
4546 stype
= TREE_TYPE (stype
);
4548 return gfc_build_memcpy_call (dst
, src
, len
);
4552 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4553 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4556 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4561 gfc_ss
*lss_section
;
4568 bool scalar_to_array
;
4570 /* Assignment of the form lhs = rhs. */
4571 gfc_start_block (&block
);
4573 gfc_init_se (&lse
, NULL
);
4574 gfc_init_se (&rse
, NULL
);
4577 lss
= gfc_walk_expr (expr1
);
4579 if (lss
!= gfc_ss_terminator
)
4581 /* The assignment needs scalarization. */
4584 /* Find a non-scalar SS from the lhs. */
4585 while (lss_section
!= gfc_ss_terminator
4586 && lss_section
->type
!= GFC_SS_SECTION
)
4587 lss_section
= lss_section
->next
;
4589 gcc_assert (lss_section
!= gfc_ss_terminator
);
4591 /* Initialize the scalarizer. */
4592 gfc_init_loopinfo (&loop
);
4595 rss
= gfc_walk_expr (expr2
);
4596 if (rss
== gfc_ss_terminator
)
4598 /* The rhs is scalar. Add a ss for the expression. */
4599 rss
= gfc_get_ss ();
4600 rss
->next
= gfc_ss_terminator
;
4601 rss
->type
= GFC_SS_SCALAR
;
4604 /* Associate the SS with the loop. */
4605 gfc_add_ss_to_loop (&loop
, lss
);
4606 gfc_add_ss_to_loop (&loop
, rss
);
4608 /* Calculate the bounds of the scalarization. */
4609 gfc_conv_ss_startstride (&loop
);
4610 /* Resolve any data dependencies in the statement. */
4611 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4612 /* Setup the scalarizing loops. */
4613 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4615 /* Setup the gfc_se structures. */
4616 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4617 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4620 gfc_mark_ss_chain_used (rss
, 1);
4621 if (loop
.temp_ss
== NULL
)
4624 gfc_mark_ss_chain_used (lss
, 1);
4628 lse
.ss
= loop
.temp_ss
;
4629 gfc_mark_ss_chain_used (lss
, 3);
4630 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4633 /* Start the scalarized loop body. */
4634 gfc_start_scalarized_body (&loop
, &body
);
4637 gfc_init_block (&body
);
4639 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4641 /* Translate the expression. */
4642 gfc_conv_expr (&rse
, expr2
);
4646 gfc_conv_tmp_array_ref (&lse
);
4647 gfc_advance_se_ss_chain (&lse
);
4650 gfc_conv_expr (&lse
, expr1
);
4652 /* Assignments of scalar derived types with allocatable components
4653 to arrays must be done with a deep copy and the rhs temporary
4654 must have its components deallocated afterwards. */
4655 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
4656 && expr2
->ts
.derived
->attr
.alloc_comp
4657 && expr2
->expr_type
!= EXPR_VARIABLE
4658 && !gfc_is_constant_expr (expr2
)
4659 && expr1
->rank
&& !expr2
->rank
);
4660 if (scalar_to_array
)
4662 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.derived
, rse
.expr
, 0);
4663 gfc_add_expr_to_block (&loop
.post
, tmp
);
4666 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4667 l_is_temp
|| init_flag
,
4668 (expr2
->expr_type
== EXPR_VARIABLE
)
4669 || scalar_to_array
);
4670 gfc_add_expr_to_block (&body
, tmp
);
4672 if (lss
== gfc_ss_terminator
)
4674 /* Use the scalar assignment as is. */
4675 gfc_add_block_to_block (&block
, &body
);
4679 gcc_assert (lse
.ss
== gfc_ss_terminator
4680 && rse
.ss
== gfc_ss_terminator
);
4684 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4686 /* We need to copy the temporary to the actual lhs. */
4687 gfc_init_se (&lse
, NULL
);
4688 gfc_init_se (&rse
, NULL
);
4689 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4690 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4692 rse
.ss
= loop
.temp_ss
;
4695 gfc_conv_tmp_array_ref (&rse
);
4696 gfc_advance_se_ss_chain (&rse
);
4697 gfc_conv_expr (&lse
, expr1
);
4699 gcc_assert (lse
.ss
== gfc_ss_terminator
4700 && rse
.ss
== gfc_ss_terminator
);
4702 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4704 gfc_add_expr_to_block (&body
, tmp
);
4707 /* Generate the copying loops. */
4708 gfc_trans_scalarizing_loops (&loop
, &body
);
4710 /* Wrap the whole thing up. */
4711 gfc_add_block_to_block (&block
, &loop
.pre
);
4712 gfc_add_block_to_block (&block
, &loop
.post
);
4714 gfc_cleanup_loop (&loop
);
4717 return gfc_finish_block (&block
);
4721 /* Check whether EXPR is a copyable array. */
4724 copyable_array_p (gfc_expr
* expr
)
4726 if (expr
->expr_type
!= EXPR_VARIABLE
)
4729 /* First check it's an array. */
4730 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4733 if (!gfc_full_array_ref_p (expr
->ref
))
4736 /* Next check that it's of a simple enough type. */
4737 switch (expr
->ts
.type
)
4749 return !expr
->ts
.derived
->attr
.alloc_comp
;
4758 /* Translate an assignment. */
4761 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4765 /* Special case a single function returning an array. */
4766 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4768 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4773 /* Special case assigning an array to zero. */
4774 if (copyable_array_p (expr1
)
4775 && is_zero_initializer_p (expr2
))
4777 tmp
= gfc_trans_zero_assign (expr1
);
4782 /* Special case copying one array to another. */
4783 if (copyable_array_p (expr1
)
4784 && copyable_array_p (expr2
)
4785 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4786 && !gfc_check_dependency (expr1
, expr2
, 0))
4788 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4793 /* Special case initializing an array from a constant array constructor. */
4794 if (copyable_array_p (expr1
)
4795 && expr2
->expr_type
== EXPR_ARRAY
4796 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4798 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4803 /* Fallback to the scalarizer to generate explicit loops. */
4804 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4808 gfc_trans_init_assign (gfc_code
* code
)
4810 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4814 gfc_trans_assign (gfc_code
* code
)
4816 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);