1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
34 #include "tree-gimple.h"
35 #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 int 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_expr (&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 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
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
156 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
157 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
159 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
161 if (ts
.type
== BT_CHARACTER
)
163 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
164 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
165 se
->string_length
, tmp
);
166 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
167 se
->string_length
= tmp
;
173 /* Get the character length of an expression, looking through gfc_refs
177 gfc_get_expr_charlen (gfc_expr
*e
)
182 gcc_assert (e
->expr_type
== EXPR_VARIABLE
183 && e
->ts
.type
== BT_CHARACTER
);
185 length
= NULL
; /* To silence compiler warning. */
187 /* First candidate: if the variable is of type CHARACTER, the
188 expression's length could be the length of the character
190 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
191 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
193 /* Look through the reference chain for component references. */
194 for (r
= e
->ref
; r
; r
= r
->next
)
199 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
200 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
208 /* We should never got substring references here. These will be
209 broken down by the scalarizer. */
214 gcc_assert (length
!= NULL
);
220 /* Generate code to initialize a string length variable. Returns the
224 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
229 gfc_init_se (&se
, NULL
);
230 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
231 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
232 build_int_cst (gfc_charlen_type_node
, 0));
233 gfc_add_block_to_block (pblock
, &se
.pre
);
235 tmp
= cl
->backend_decl
;
236 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
241 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
242 const char *name
, locus
*where
)
252 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
253 type
= build_pointer_type (type
);
256 gfc_init_se (&start
, se
);
257 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
258 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
260 if (integer_onep (start
.expr
))
261 gfc_conv_string_parameter (se
);
264 /* Avoid multiple evaluation of substring start. */
265 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
266 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
268 /* Change the start of the string. */
269 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
272 tmp
= build_fold_indirect_ref (se
->expr
);
273 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
274 se
->expr
= gfc_build_addr_expr (type
, tmp
);
277 /* Length = end + 1 - start. */
278 gfc_init_se (&end
, se
);
279 if (ref
->u
.ss
.end
== NULL
)
280 end
.expr
= se
->string_length
;
283 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
284 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
286 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
287 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
289 if (flag_bounds_check
)
291 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
292 start
.expr
, end
.expr
);
294 /* Check lower bound. */
295 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
296 build_int_cst (gfc_charlen_type_node
, 1));
297 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
300 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
301 "is less than one", name
);
303 asprintf (&msg
, "Substring out of bounds: lower bound "
305 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
308 /* Check upper bound. */
309 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
311 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
314 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
315 "exceeds string length", name
);
317 asprintf (&msg
, "Substring out of bounds: upper bound "
318 "exceeds string length");
319 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
323 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
324 build_int_cst (gfc_charlen_type_node
, 1),
326 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
327 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
328 build_int_cst (gfc_charlen_type_node
, 0));
329 se
->string_length
= tmp
;
333 /* Convert a derived type component reference. */
336 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
343 c
= ref
->u
.c
.component
;
345 gcc_assert (c
->backend_decl
);
347 field
= c
->backend_decl
;
348 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
350 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
354 if (c
->ts
.type
== BT_CHARACTER
)
356 tmp
= c
->ts
.cl
->backend_decl
;
357 /* Components must always be constant length. */
358 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
359 se
->string_length
= tmp
;
362 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
363 se
->expr
= build_fold_indirect_ref (se
->expr
);
367 /* Return the contents of a variable. Also handles reference/pointer
368 variables (all Fortran pointer references are implicit). */
371 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
378 bool alternate_entry
;
381 sym
= expr
->symtree
->n
.sym
;
384 /* Check that something hasn't gone horribly wrong. */
385 gcc_assert (se
->ss
!= gfc_ss_terminator
);
386 gcc_assert (se
->ss
->expr
== expr
);
388 /* A scalarized term. We already know the descriptor. */
389 se
->expr
= se
->ss
->data
.info
.descriptor
;
390 se
->string_length
= se
->ss
->string_length
;
391 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
392 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
397 tree se_expr
= NULL_TREE
;
399 se
->expr
= gfc_get_symbol_decl (sym
);
401 /* Deal with references to a parent results or entries by storing
402 the current_function_decl and moving to the parent_decl. */
403 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
404 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
405 && sym
->result
== sym
;
406 entry_master
= sym
->attr
.result
407 && sym
->ns
->proc_name
->attr
.entry_master
408 && !gfc_return_by_reference (sym
->ns
->proc_name
);
409 parent_decl
= DECL_CONTEXT (current_function_decl
);
411 if ((se
->expr
== parent_decl
&& return_value
)
412 || (sym
->ns
&& sym
->ns
->proc_name
414 && sym
->ns
->proc_name
->backend_decl
== parent_decl
415 && (alternate_entry
|| entry_master
)))
420 /* Special case for assigning the return value of a function.
421 Self recursive functions must have an explicit return value. */
422 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
423 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
425 /* Similarly for alternate entry points. */
426 else if (alternate_entry
427 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
430 gfc_entry_list
*el
= NULL
;
432 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
435 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
440 else if (entry_master
441 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
443 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
448 /* Procedure actual arguments. */
449 else if (sym
->attr
.flavor
== FL_PROCEDURE
450 && se
->expr
!= current_function_decl
)
452 gcc_assert (se
->want_pointer
);
453 if (!sym
->attr
.dummy
)
455 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
456 se
->expr
= build_fold_addr_expr (se
->expr
);
462 /* Dereference the expression, where needed. Since characters
463 are entirely different from other types, they are treated
465 if (sym
->ts
.type
== BT_CHARACTER
)
467 /* Dereference character pointer dummy arguments
469 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
471 || sym
->attr
.function
472 || sym
->attr
.result
))
473 se
->expr
= build_fold_indirect_ref (se
->expr
);
475 /* A character with VALUE attribute needs an address
478 se
->expr
= build_fold_addr_expr (se
->expr
);
481 else if (!sym
->attr
.value
)
483 /* Dereference non-character scalar dummy arguments. */
484 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
485 se
->expr
= build_fold_indirect_ref (se
->expr
);
487 /* Dereference scalar hidden result. */
488 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
489 && (sym
->attr
.function
|| sym
->attr
.result
)
490 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
491 se
->expr
= build_fold_indirect_ref (se
->expr
);
493 /* Dereference non-character pointer variables.
494 These must be dummies, results, or scalars. */
495 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
497 || sym
->attr
.function
499 || !sym
->attr
.dimension
))
500 se
->expr
= build_fold_indirect_ref (se
->expr
);
506 /* For character variables, also get the length. */
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 /* If the character length of an entry isn't set, get the length from
510 the master function instead. */
511 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
512 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
514 se
->string_length
= sym
->ts
.cl
->backend_decl
;
515 gcc_assert (se
->string_length
);
523 /* Return the descriptor if that's what we want and this is an array
524 section reference. */
525 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
527 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
528 /* Return the descriptor for array pointers and allocations. */
530 && ref
->next
== NULL
&& (se
->descriptor_only
))
533 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
534 /* Return a pointer to an element. */
538 gfc_conv_component_ref (se
, ref
);
542 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
543 expr
->symtree
->name
, &expr
->where
);
552 /* Pointer assignment, allocation or pass by reference. Arrays are handled
554 if (se
->want_pointer
)
556 if (expr
->ts
.type
== BT_CHARACTER
)
557 gfc_conv_string_parameter (se
);
559 se
->expr
= build_fold_addr_expr (se
->expr
);
564 /* Unary ops are easy... Or they would be if ! was a valid op. */
567 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
572 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
573 /* Initialize the operand. */
574 gfc_init_se (&operand
, se
);
575 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
576 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
578 type
= gfc_typenode_for_spec (&expr
->ts
);
580 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
581 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
582 All other unary operators have an equivalent GIMPLE unary operator. */
583 if (code
== TRUTH_NOT_EXPR
)
584 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
585 build_int_cst (type
, 0));
587 se
->expr
= build1 (code
, type
, operand
.expr
);
591 /* Expand power operator to optimal multiplications when a value is raised
592 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
593 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
594 Programming", 3rd Edition, 1998. */
596 /* This code is mostly duplicated from expand_powi in the backend.
597 We establish the "optimal power tree" lookup table with the defined size.
598 The items in the table are the exponents used to calculate the index
599 exponents. Any integer n less than the value can get an "addition chain",
600 with the first node being one. */
601 #define POWI_TABLE_SIZE 256
603 /* The table is from builtins.c. */
604 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
606 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
607 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
608 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
609 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
610 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
611 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
612 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
613 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
614 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
615 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
616 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
617 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
618 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
619 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
620 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
621 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
622 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
623 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
624 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
625 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
626 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
627 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
628 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
629 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
630 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
631 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
632 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
633 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
634 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
635 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
636 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
637 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
640 /* If n is larger than lookup table's max index, we use the "window
642 #define POWI_WINDOW_SIZE 3
644 /* Recursive function to expand the power operator. The temporary
645 values are put in tmpvar. The function returns tmpvar[1] ** n. */
647 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
654 if (n
< POWI_TABLE_SIZE
)
659 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
660 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
664 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
665 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
666 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
670 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
674 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
675 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
677 if (n
< POWI_TABLE_SIZE
)
684 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
685 return 1. Else return 0 and a call to runtime library functions
686 will have to be built. */
688 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
693 tree vartmp
[POWI_TABLE_SIZE
];
695 unsigned HOST_WIDE_INT n
;
698 /* If exponent is too large, we won't expand it anyway, so don't bother
699 with large integer values. */
700 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
703 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
704 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
705 of the asymmetric range of the integer type. */
706 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
708 type
= TREE_TYPE (lhs
);
709 sgn
= tree_int_cst_sgn (rhs
);
711 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
712 || optimize_size
) && (m
> 2 || m
< -1))
718 se
->expr
= gfc_build_const (type
, integer_one_node
);
722 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
723 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
725 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
726 build_int_cst (TREE_TYPE (lhs
), -1));
727 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
728 build_int_cst (TREE_TYPE (lhs
), 1));
731 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
734 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
735 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
736 build_int_cst (type
, 0));
740 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
741 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
742 build_int_cst (type
, 0));
743 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
747 memset (vartmp
, 0, sizeof (vartmp
));
751 tmp
= gfc_build_const (type
, integer_one_node
);
752 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
755 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
761 /* Power op (**). Constant integer exponent has special handling. */
764 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
766 tree gfc_int4_type_node
;
773 gfc_init_se (&lse
, se
);
774 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
775 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
776 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
778 gfc_init_se (&rse
, se
);
779 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
780 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
782 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
783 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
784 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
787 gfc_int4_type_node
= gfc_get_int_type (4);
789 kind
= expr
->value
.op
.op1
->ts
.kind
;
790 switch (expr
->value
.op
.op2
->ts
.type
)
793 ikind
= expr
->value
.op
.op2
->ts
.kind
;
798 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
820 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
821 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
846 switch (expr
->value
.op
.op1
->ts
.type
)
849 if (kind
== 3) /* Case 16 was not handled properly above. */
851 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
855 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
859 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
871 fndecl
= built_in_decls
[BUILT_IN_POWF
];
874 fndecl
= built_in_decls
[BUILT_IN_POW
];
878 fndecl
= built_in_decls
[BUILT_IN_POWL
];
889 fndecl
= gfor_fndecl_math_cpowf
;
892 fndecl
= gfor_fndecl_math_cpow
;
895 fndecl
= gfor_fndecl_math_cpowl10
;
898 fndecl
= gfor_fndecl_math_cpowl16
;
910 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
914 /* Generate code to allocate a string temporary. */
917 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
922 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
924 if (gfc_can_put_var_on_stack (len
))
926 /* Create a temporary variable to hold the result. */
927 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
928 build_int_cst (gfc_charlen_type_node
, 1));
929 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
930 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
931 var
= gfc_create_var (tmp
, "str");
932 var
= gfc_build_addr_expr (type
, var
);
936 /* Allocate a temporary to hold the result. */
937 var
= gfc_create_var (type
, "pstr");
938 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
939 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
941 /* Free the temporary afterwards. */
942 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
943 gfc_add_expr_to_block (&se
->post
, tmp
);
950 /* Handle a string concatenation operation. A temporary will be allocated to
954 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
963 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
964 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
966 gfc_init_se (&lse
, se
);
967 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
968 gfc_conv_string_parameter (&lse
);
969 gfc_init_se (&rse
, se
);
970 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
971 gfc_conv_string_parameter (&rse
);
973 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
974 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
976 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
977 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
978 if (len
== NULL_TREE
)
980 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
981 lse
.string_length
, rse
.string_length
);
984 type
= build_pointer_type (type
);
986 var
= gfc_conv_string_tmp (se
, type
, len
);
988 /* Do the actual concatenation. */
989 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
991 lse
.string_length
, lse
.expr
,
992 rse
.string_length
, rse
.expr
);
993 gfc_add_expr_to_block (&se
->pre
, tmp
);
995 /* Add the cleanup for the operands. */
996 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
997 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1000 se
->string_length
= len
;
1003 /* Translates an op expression. Common (binary) cases are handled by this
1004 function, others are passed on. Recursion is used in either case.
1005 We use the fact that (op1.ts == op2.ts) (except for the power
1007 Operators need no special handling for scalarized expressions as long as
1008 they call gfc_conv_simple_val to get their operands.
1009 Character strings get special handling. */
1012 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1014 enum tree_code code
;
1024 switch (expr
->value
.op
.operator)
1026 case INTRINSIC_UPLUS
:
1027 case INTRINSIC_PARENTHESES
:
1028 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1031 case INTRINSIC_UMINUS
:
1032 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1036 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1039 case INTRINSIC_PLUS
:
1043 case INTRINSIC_MINUS
:
1047 case INTRINSIC_TIMES
:
1051 case INTRINSIC_DIVIDE
:
1052 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1053 an integer, we must round towards zero, so we use a
1055 if (expr
->ts
.type
== BT_INTEGER
)
1056 code
= TRUNC_DIV_EXPR
;
1061 case INTRINSIC_POWER
:
1062 gfc_conv_power_op (se
, expr
);
1065 case INTRINSIC_CONCAT
:
1066 gfc_conv_concat_op (se
, expr
);
1070 code
= TRUTH_ANDIF_EXPR
;
1075 code
= TRUTH_ORIF_EXPR
;
1079 /* EQV and NEQV only work on logicals, but since we represent them
1080 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1089 case INTRINSIC_NEQV
:
1119 case INTRINSIC_USER
:
1120 case INTRINSIC_ASSIGN
:
1121 /* These should be converted into function calls by the frontend. */
1125 fatal_error ("Unknown intrinsic op");
1129 /* The only exception to this is **, which is handled separately anyway. */
1130 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1132 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1136 gfc_init_se (&lse
, se
);
1137 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1138 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1141 gfc_init_se (&rse
, se
);
1142 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1143 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1147 gfc_conv_string_parameter (&lse
);
1148 gfc_conv_string_parameter (&rse
);
1150 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1151 rse
.string_length
, rse
.expr
);
1152 rse
.expr
= integer_zero_node
;
1153 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1156 type
= gfc_typenode_for_spec (&expr
->ts
);
1160 /* The result of logical ops is always boolean_type_node. */
1161 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1162 se
->expr
= convert (type
, tmp
);
1165 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1167 /* Add the post blocks. */
1168 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1169 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1172 /* If a string's length is one, we convert it to a single character. */
1175 gfc_to_single_character (tree len
, tree str
)
1177 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1179 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1180 && TREE_INT_CST_HIGH (len
) == 0)
1182 str
= fold_convert (pchar_type_node
, str
);
1183 return build_fold_indirect_ref (str
);
1189 /* Compare two strings. If they are all single characters, the result is the
1190 subtraction of them. Otherwise, we build a library call. */
1193 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1200 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1201 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1203 type
= gfc_get_int_type (gfc_default_integer_kind
);
1205 sc1
= gfc_to_single_character (len1
, str1
);
1206 sc2
= gfc_to_single_character (len2
, str2
);
1208 /* Deal with single character specially. */
1209 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1211 sc1
= fold_convert (type
, sc1
);
1212 sc2
= fold_convert (type
, sc2
);
1213 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1216 /* Build a call for the comparison. */
1217 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1218 len1
, str1
, len2
, str2
);
1223 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1227 if (sym
->attr
.dummy
)
1229 tmp
= gfc_get_symbol_decl (sym
);
1230 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1231 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1235 if (!sym
->backend_decl
)
1236 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1238 tmp
= sym
->backend_decl
;
1239 if (sym
->attr
.cray_pointee
)
1240 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1241 gfc_get_symbol_decl (sym
->cp_pointer
));
1242 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1244 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1245 tmp
= build_fold_addr_expr (tmp
);
1252 /* Translate the call for an elemental subroutine call used in an operator
1253 assignment. This is a simplified version of gfc_conv_function_call. */
1256 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1263 /* Only elemental subroutines with two arguments. */
1264 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1265 gcc_assert (sym
->formal
->next
->next
== NULL
);
1267 gfc_init_block (&block
);
1269 gfc_add_block_to_block (&block
, &lse
->pre
);
1270 gfc_add_block_to_block (&block
, &rse
->pre
);
1272 /* Build the argument list for the call, including hidden string lengths. */
1273 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1274 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1275 if (lse
->string_length
!= NULL_TREE
)
1276 args
= gfc_chainon_list (args
, lse
->string_length
);
1277 if (rse
->string_length
!= NULL_TREE
)
1278 args
= gfc_chainon_list (args
, rse
->string_length
);
1280 /* Build the function call. */
1281 gfc_init_se (&se
, NULL
);
1282 gfc_conv_function_val (&se
, sym
);
1283 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1284 tmp
= build_call_list (tmp
, se
.expr
, args
);
1285 gfc_add_expr_to_block (&block
, tmp
);
1287 gfc_add_block_to_block (&block
, &lse
->post
);
1288 gfc_add_block_to_block (&block
, &rse
->post
);
1290 return gfc_finish_block (&block
);
1294 /* Initialize MAPPING. */
1297 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1299 mapping
->syms
= NULL
;
1300 mapping
->charlens
= NULL
;
1304 /* Free all memory held by MAPPING (but not MAPPING itself). */
1307 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1309 gfc_interface_sym_mapping
*sym
;
1310 gfc_interface_sym_mapping
*nextsym
;
1312 gfc_charlen
*nextcl
;
1314 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1316 nextsym
= sym
->next
;
1317 gfc_free_symbol (sym
->new->n
.sym
);
1318 gfc_free (sym
->new);
1321 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1324 gfc_free_expr (cl
->length
);
1330 /* Return a copy of gfc_charlen CL. Add the returned structure to
1331 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1333 static gfc_charlen
*
1334 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1339 new = gfc_get_charlen ();
1340 new->next
= mapping
->charlens
;
1341 new->length
= gfc_copy_expr (cl
->length
);
1343 mapping
->charlens
= new;
1348 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1349 array variable that can be used as the actual argument for dummy
1350 argument SYM. Add any initialization code to BLOCK. PACKED is as
1351 for gfc_get_nodesc_array_type and DATA points to the first element
1352 in the passed array. */
1355 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1356 gfc_packed packed
, tree data
)
1361 type
= gfc_typenode_for_spec (&sym
->ts
);
1362 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1364 var
= gfc_create_var (type
, "ifm");
1365 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1371 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1372 and offset of descriptorless array type TYPE given that it has the same
1373 size as DESC. Add any set-up code to BLOCK. */
1376 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1383 offset
= gfc_index_zero_node
;
1384 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1386 dim
= gfc_rank_cst
[n
];
1387 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1388 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1390 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1391 = gfc_conv_descriptor_lbound (desc
, dim
);
1392 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1393 = gfc_conv_descriptor_ubound (desc
, dim
);
1395 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1397 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1398 gfc_conv_descriptor_ubound (desc
, dim
),
1399 gfc_conv_descriptor_lbound (desc
, dim
));
1400 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1401 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1403 tmp
= gfc_evaluate_now (tmp
, block
);
1404 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1406 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1407 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1408 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1409 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1411 offset
= gfc_evaluate_now (offset
, block
);
1412 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1416 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1417 in SE. The caller may still use se->expr and se->string_length after
1418 calling this function. */
1421 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1422 gfc_symbol
* sym
, gfc_se
* se
)
1424 gfc_interface_sym_mapping
*sm
;
1428 gfc_symbol
*new_sym
;
1430 gfc_symtree
*new_symtree
;
1432 /* Create a new symbol to represent the actual argument. */
1433 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1434 new_sym
->ts
= sym
->ts
;
1435 new_sym
->attr
.referenced
= 1;
1436 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1437 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1438 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1439 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1441 /* Create a fake symtree for it. */
1443 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1444 new_symtree
->n
.sym
= new_sym
;
1445 gcc_assert (new_symtree
== root
);
1447 /* Create a dummy->actual mapping. */
1448 sm
= gfc_getmem (sizeof (*sm
));
1449 sm
->next
= mapping
->syms
;
1451 sm
->new = new_symtree
;
1454 /* Stabilize the argument's value. */
1455 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1457 if (sym
->ts
.type
== BT_CHARACTER
)
1459 /* Create a copy of the dummy argument's length. */
1460 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1462 /* If the length is specified as "*", record the length that
1463 the caller is passing. We should use the callee's length
1464 in all other cases. */
1465 if (!new_sym
->ts
.cl
->length
)
1467 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1468 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1472 /* Use the passed value as-is if the argument is a function. */
1473 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1476 /* If the argument is either a string or a pointer to a string,
1477 convert it to a boundless character type. */
1478 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1480 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1481 tmp
= build_pointer_type (tmp
);
1482 if (sym
->attr
.pointer
)
1483 value
= build_fold_indirect_ref (se
->expr
);
1486 value
= fold_convert (tmp
, value
);
1489 /* If the argument is a scalar, a pointer to an array or an allocatable,
1491 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1492 value
= build_fold_indirect_ref (se
->expr
);
1494 /* For character(*), use the actual argument's descriptor. */
1495 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1496 value
= build_fold_indirect_ref (se
->expr
);
1498 /* If the argument is an array descriptor, use it to determine
1499 information about the actual argument's shape. */
1500 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1501 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1503 /* Get the actual argument's descriptor. */
1504 desc
= build_fold_indirect_ref (se
->expr
);
1506 /* Create the replacement variable. */
1507 tmp
= gfc_conv_descriptor_data_get (desc
);
1508 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1511 /* Use DESC to work out the upper bounds, strides and offset. */
1512 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1515 /* Otherwise we have a packed array. */
1516 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1517 PACKED_FULL
, se
->expr
);
1519 new_sym
->backend_decl
= value
;
1523 /* Called once all dummy argument mappings have been added to MAPPING,
1524 but before the mapping is used to evaluate expressions. Pre-evaluate
1525 the length of each argument, adding any initialization code to PRE and
1526 any finalization code to POST. */
1529 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1530 stmtblock_t
* pre
, stmtblock_t
* post
)
1532 gfc_interface_sym_mapping
*sym
;
1536 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1537 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1538 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1540 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1541 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1542 gfc_init_se (&se
, NULL
);
1543 gfc_conv_expr (&se
, expr
);
1545 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1546 gfc_add_block_to_block (pre
, &se
.pre
);
1547 gfc_add_block_to_block (post
, &se
.post
);
1549 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1554 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1558 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1559 gfc_constructor
* c
)
1561 for (; c
; c
= c
->next
)
1563 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1566 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1567 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1568 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1574 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1578 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1583 for (; ref
; ref
= ref
->next
)
1587 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1589 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1590 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1591 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1593 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1600 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1601 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1607 /* EXPR is a copy of an expression that appeared in the interface
1608 associated with MAPPING. Walk it recursively looking for references to
1609 dummy arguments that MAPPING maps to actual arguments. Replace each such
1610 reference with a reference to the associated actual argument. */
1613 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1616 gfc_interface_sym_mapping
*sym
;
1617 gfc_actual_arglist
*actual
;
1618 int seen_result
= 0;
1623 /* Copying an expression does not copy its length, so do that here. */
1624 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1626 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1627 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1630 /* Apply the mapping to any references. */
1631 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1633 /* ...and to the expression's symbol, if it has one. */
1635 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1636 if (sym
->old
== expr
->symtree
->n
.sym
)
1637 expr
->symtree
= sym
->new;
1639 /* ...and to subexpressions in expr->value. */
1640 switch (expr
->expr_type
)
1643 if (expr
->symtree
->n
.sym
->attr
.result
)
1647 case EXPR_SUBSTRING
:
1651 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1652 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1656 if (expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1657 && gfc_apply_interface_mapping_to_expr (mapping
,
1658 expr
->value
.function
.actual
->expr
)
1659 && expr
->value
.function
.esym
== NULL
1660 && expr
->value
.function
.isym
!= NULL
1661 && expr
->value
.function
.isym
->generic_id
== GFC_ISYM_LEN
)
1664 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1666 gfc_free (new_expr
);
1667 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1671 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1672 if (sym
->old
== expr
->value
.function
.esym
)
1673 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1675 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1676 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1680 case EXPR_STRUCTURE
:
1681 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1688 /* Evaluate interface expression EXPR using MAPPING. Store the result
1692 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1693 gfc_se
* se
, gfc_expr
* expr
)
1695 expr
= gfc_copy_expr (expr
);
1696 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1697 gfc_conv_expr (se
, expr
);
1698 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1699 gfc_free_expr (expr
);
1702 /* Returns a reference to a temporary array into which a component of
1703 an actual argument derived type array is copied and then returned
1704 after the function call.
1705 TODO Get rid of this kludge, when array descriptors are capable of
1706 handling arrays with a bigger stride in bytes than size. */
1709 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1710 int g77
, sym_intent intent
)
1726 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1728 gfc_init_se (&lse
, NULL
);
1729 gfc_init_se (&rse
, NULL
);
1731 /* Walk the argument expression. */
1732 rss
= gfc_walk_expr (expr
);
1734 gcc_assert (rss
!= gfc_ss_terminator
);
1736 /* Initialize the scalarizer. */
1737 gfc_init_loopinfo (&loop
);
1738 gfc_add_ss_to_loop (&loop
, rss
);
1740 /* Calculate the bounds of the scalarization. */
1741 gfc_conv_ss_startstride (&loop
);
1743 /* Build an ss for the temporary. */
1744 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1745 if (GFC_ARRAY_TYPE_P (base_type
)
1746 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1747 base_type
= gfc_get_element_type (base_type
);
1749 loop
.temp_ss
= gfc_get_ss ();;
1750 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1751 loop
.temp_ss
->data
.temp
.type
= base_type
;
1753 if (expr
->ts
.type
== BT_CHARACTER
)
1755 gfc_ref
*char_ref
= expr
->ref
;
1757 for (; char_ref
; char_ref
= char_ref
->next
)
1758 if (char_ref
->type
== REF_SUBSTRING
)
1762 expr
->ts
.cl
= gfc_get_charlen ();
1763 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1764 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1766 gfc_init_se (&tmp_se
, NULL
);
1767 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1768 gfc_array_index_type
);
1769 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1770 tmp_se
.expr
, gfc_index_one_node
);
1771 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1772 gfc_init_se (&tmp_se
, NULL
);
1773 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1774 gfc_array_index_type
);
1775 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1777 expr
->ts
.cl
->backend_decl
= tmp
;
1781 loop
.temp_ss
->data
.temp
.type
1782 = gfc_typenode_for_spec (&expr
->ts
);
1783 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1786 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1787 loop
.temp_ss
->next
= gfc_ss_terminator
;
1789 /* Associate the SS with the loop. */
1790 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1792 /* Setup the scalarizing loops. */
1793 gfc_conv_loop_setup (&loop
);
1795 /* Pass the temporary descriptor back to the caller. */
1796 info
= &loop
.temp_ss
->data
.info
;
1797 parmse
->expr
= info
->descriptor
;
1799 /* Setup the gfc_se structures. */
1800 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1801 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1804 lse
.ss
= loop
.temp_ss
;
1805 gfc_mark_ss_chain_used (rss
, 1);
1806 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1808 /* Start the scalarized loop body. */
1809 gfc_start_scalarized_body (&loop
, &body
);
1811 /* Translate the expression. */
1812 gfc_conv_expr (&rse
, expr
);
1814 gfc_conv_tmp_array_ref (&lse
);
1815 gfc_advance_se_ss_chain (&lse
);
1817 if (intent
!= INTENT_OUT
)
1819 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1820 gfc_add_expr_to_block (&body
, tmp
);
1821 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1822 gfc_trans_scalarizing_loops (&loop
, &body
);
1826 /* Make sure that the temporary declaration survives by merging
1827 all the loop declarations into the current context. */
1828 for (n
= 0; n
< loop
.dimen
; n
++)
1830 gfc_merge_block_scope (&body
);
1831 body
= loop
.code
[loop
.order
[n
]];
1833 gfc_merge_block_scope (&body
);
1836 /* Add the post block after the second loop, so that any
1837 freeing of allocated memory is done at the right time. */
1838 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1840 /**********Copy the temporary back again.*********/
1842 gfc_init_se (&lse
, NULL
);
1843 gfc_init_se (&rse
, NULL
);
1845 /* Walk the argument expression. */
1846 lss
= gfc_walk_expr (expr
);
1847 rse
.ss
= loop
.temp_ss
;
1850 /* Initialize the scalarizer. */
1851 gfc_init_loopinfo (&loop2
);
1852 gfc_add_ss_to_loop (&loop2
, lss
);
1854 /* Calculate the bounds of the scalarization. */
1855 gfc_conv_ss_startstride (&loop2
);
1857 /* Setup the scalarizing loops. */
1858 gfc_conv_loop_setup (&loop2
);
1860 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1861 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1863 gfc_mark_ss_chain_used (lss
, 1);
1864 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1866 /* Declare the variable to hold the temporary offset and start the
1867 scalarized loop body. */
1868 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1869 gfc_start_scalarized_body (&loop2
, &body
);
1871 /* Build the offsets for the temporary from the loop variables. The
1872 temporary array has lbounds of zero and strides of one in all
1873 dimensions, so this is very simple. The offset is only computed
1874 outside the innermost loop, so the overall transfer could be
1875 optimized further. */
1876 info
= &rse
.ss
->data
.info
;
1878 tmp_index
= gfc_index_zero_node
;
1879 for (n
= info
->dimen
- 1; n
> 0; n
--)
1882 tmp
= rse
.loop
->loopvar
[n
];
1883 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1884 tmp
, rse
.loop
->from
[n
]);
1885 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1888 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1889 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1890 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1891 tmp_str
, gfc_index_one_node
);
1893 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1897 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1898 tmp_index
, rse
.loop
->from
[0]);
1899 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1901 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1902 rse
.loop
->loopvar
[0], offset
);
1904 /* Now use the offset for the reference. */
1905 tmp
= build_fold_indirect_ref (info
->data
);
1906 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1908 if (expr
->ts
.type
== BT_CHARACTER
)
1909 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1911 gfc_conv_expr (&lse
, expr
);
1913 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1915 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1916 gfc_add_expr_to_block (&body
, tmp
);
1918 /* Generate the copying loops. */
1919 gfc_trans_scalarizing_loops (&loop2
, &body
);
1921 /* Wrap the whole thing up by adding the second loop to the post-block
1922 and following it by the post-block of the first loop. In this way,
1923 if the temporary needs freeing, it is done after use! */
1924 if (intent
!= INTENT_IN
)
1926 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1927 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1930 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1932 gfc_cleanup_loop (&loop
);
1933 gfc_cleanup_loop (&loop2
);
1935 /* Pass the string length to the argument expression. */
1936 if (expr
->ts
.type
== BT_CHARACTER
)
1937 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1939 /* We want either the address for the data or the address of the descriptor,
1940 depending on the mode of passing array arguments. */
1942 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1944 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1949 /* Is true if an array reference is followed by a component or substring
1953 is_aliased_array (gfc_expr
* e
)
1959 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1961 if (ref
->type
== REF_ARRAY
1962 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1966 && ref
->type
!= REF_ARRAY
)
1972 /* Generate the code for argument list functions. */
1975 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
1977 /* Pass by value for g77 %VAL(arg), pass the address
1978 indirectly for %LOC, else by reference. Thus %REF
1979 is a "do-nothing" and %LOC is the same as an F95
1981 if (strncmp (name
, "%VAL", 4) == 0)
1982 gfc_conv_expr (se
, expr
);
1983 else if (strncmp (name
, "%LOC", 4) == 0)
1985 gfc_conv_expr_reference (se
, expr
);
1986 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
1988 else if (strncmp (name
, "%REF", 4) == 0)
1989 gfc_conv_expr_reference (se
, expr
);
1991 gfc_error ("Unknown argument list function at %L", &expr
->where
);
1995 /* Generate code for a procedure call. Note can return se->post != NULL.
1996 If se->direct_byref is set then se->expr contains the return parameter.
1997 Return nonzero, if the call has alternate specifiers. */
2000 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2001 gfc_actual_arglist
* arg
, tree append_args
)
2003 gfc_interface_mapping mapping
;
2017 gfc_formal_arglist
*formal
;
2018 int has_alternate_specifier
= 0;
2019 bool need_interface_mapping
;
2026 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2028 arglist
= NULL_TREE
;
2029 retargs
= NULL_TREE
;
2030 stringargs
= NULL_TREE
;
2036 if (!sym
->attr
.elemental
)
2038 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2039 if (se
->ss
->useflags
)
2041 gcc_assert (gfc_return_by_reference (sym
)
2042 && sym
->result
->attr
.dimension
);
2043 gcc_assert (se
->loop
!= NULL
);
2045 /* Access the previously obtained result. */
2046 gfc_conv_tmp_array_ref (se
);
2047 gfc_advance_se_ss_chain (se
);
2051 info
= &se
->ss
->data
.info
;
2056 gfc_init_block (&post
);
2057 gfc_init_interface_mapping (&mapping
);
2058 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2059 && sym
->ts
.cl
->length
2060 && sym
->ts
.cl
->length
->expr_type
2062 || sym
->attr
.dimension
);
2063 formal
= sym
->formal
;
2064 /* Evaluate the arguments. */
2065 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2068 fsym
= formal
? formal
->sym
: NULL
;
2069 parm_kind
= MISSING
;
2073 if (se
->ignore_optional
)
2075 /* Some intrinsics have already been resolved to the correct
2079 else if (arg
->label
)
2081 has_alternate_specifier
= 1;
2086 /* Pass a NULL pointer for an absent arg. */
2087 gfc_init_se (&parmse
, NULL
);
2088 parmse
.expr
= null_pointer_node
;
2089 if (arg
->missing_arg_type
== BT_CHARACTER
)
2090 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2093 else if (se
->ss
&& se
->ss
->useflags
)
2095 /* An elemental function inside a scalarized loop. */
2096 gfc_init_se (&parmse
, se
);
2097 gfc_conv_expr_reference (&parmse
, e
);
2098 parm_kind
= ELEMENTAL
;
2102 /* A scalar or transformational function. */
2103 gfc_init_se (&parmse
, NULL
);
2104 argss
= gfc_walk_expr (e
);
2106 if (argss
== gfc_ss_terminator
)
2109 if (fsym
&& fsym
->attr
.value
)
2111 gfc_conv_expr (&parmse
, e
);
2113 else if (arg
->name
&& arg
->name
[0] == '%')
2114 /* Argument list functions %VAL, %LOC and %REF are signalled
2115 through arg->name. */
2116 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2117 else if ((e
->expr_type
== EXPR_FUNCTION
)
2118 && e
->symtree
->n
.sym
->attr
.pointer
2119 && fsym
&& fsym
->attr
.target
)
2121 gfc_conv_expr (&parmse
, e
);
2122 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2126 gfc_conv_expr_reference (&parmse
, e
);
2127 if (fsym
&& fsym
->attr
.pointer
2128 && fsym
->attr
.flavor
!= FL_PROCEDURE
2129 && e
->expr_type
!= EXPR_NULL
)
2131 /* Scalar pointer dummy args require an extra level of
2132 indirection. The null pointer already contains
2133 this level of indirection. */
2134 parm_kind
= SCALAR_POINTER
;
2135 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2141 /* If the procedure requires an explicit interface, the actual
2142 argument is passed according to the corresponding formal
2143 argument. If the corresponding formal argument is a POINTER,
2144 ALLOCATABLE or assumed shape, we do not use g77's calling
2145 convention, and pass the address of the array descriptor
2146 instead. Otherwise we use g77's calling convention. */
2149 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2150 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2151 f
= f
|| !sym
->attr
.always_explicit
;
2153 if (e
->expr_type
== EXPR_VARIABLE
2154 && is_aliased_array (e
))
2155 /* The actual argument is a component reference to an
2156 array of derived types. In this case, the argument
2157 is converted to a temporary, which is passed and then
2158 written back after the procedure call. */
2159 gfc_conv_aliased_arg (&parmse
, e
, f
,
2160 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2162 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2164 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2165 allocated on entry, it must be deallocated. */
2166 if (fsym
&& fsym
->attr
.allocatable
2167 && fsym
->attr
.intent
== INTENT_OUT
)
2169 tmp
= build_fold_indirect_ref (parmse
.expr
);
2170 tmp
= gfc_trans_dealloc_allocated (tmp
);
2171 gfc_add_expr_to_block (&se
->pre
, tmp
);
2181 /* If an optional argument is itself an optional dummy
2182 argument, check its presence and substitute a null
2184 if (e
->expr_type
== EXPR_VARIABLE
2185 && e
->symtree
->n
.sym
->attr
.optional
2186 && fsym
->attr
.optional
)
2187 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2189 /* If an INTENT(OUT) dummy of derived type has a default
2190 initializer, it must be (re)initialized here. */
2191 if (fsym
->attr
.intent
== INTENT_OUT
2192 && fsym
->ts
.type
== BT_DERIVED
2195 gcc_assert (!fsym
->attr
.allocatable
);
2196 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2197 gfc_add_expr_to_block (&se
->pre
, tmp
);
2200 /* Obtain the character length of an assumed character
2201 length procedure from the typespec. */
2202 if (fsym
->ts
.type
== BT_CHARACTER
2203 && parmse
.string_length
== NULL_TREE
2204 && e
->ts
.type
== BT_PROCEDURE
2205 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2206 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2208 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2209 parmse
.string_length
2210 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2214 if (need_interface_mapping
)
2215 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2218 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2219 gfc_add_block_to_block (&post
, &parmse
.post
);
2221 /* Allocated allocatable components of derived types must be
2222 deallocated for INTENT(OUT) dummy arguments and non-variable
2223 scalars. Non-variable arrays are dealt with in trans-array.c
2224 (gfc_conv_array_parameter). */
2225 if (e
&& e
->ts
.type
== BT_DERIVED
2226 && e
->ts
.derived
->attr
.alloc_comp
2227 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2229 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2232 tmp
= build_fold_indirect_ref (parmse
.expr
);
2233 parm_rank
= e
->rank
;
2241 case (SCALAR_POINTER
):
2242 tmp
= build_fold_indirect_ref (tmp
);
2249 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2250 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2251 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2252 tmp
, build_empty_stmt ());
2254 if (e
->expr_type
!= EXPR_VARIABLE
)
2255 /* Don't deallocate non-variables until they have been used. */
2256 gfc_add_expr_to_block (&se
->post
, tmp
);
2259 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2260 gfc_add_expr_to_block (&se
->pre
, tmp
);
2264 /* Character strings are passed as two parameters, a length and a
2266 if (parmse
.string_length
!= NULL_TREE
)
2267 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2269 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2271 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2274 if (ts
.type
== BT_CHARACTER
)
2276 if (sym
->ts
.cl
->length
== NULL
)
2278 /* Assumed character length results are not allowed by 5.1.1.5 of the
2279 standard and are trapped in resolve.c; except in the case of SPREAD
2280 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2281 we take the character length of the first argument for the result.
2282 For dummies, we have to look through the formal argument list for
2283 this function and use the character length found there.*/
2284 if (!sym
->attr
.dummy
)
2285 cl
.backend_decl
= TREE_VALUE (stringargs
);
2288 formal
= sym
->ns
->proc_name
->formal
;
2289 for (; formal
; formal
= formal
->next
)
2290 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2291 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2298 /* Calculate the length of the returned string. */
2299 gfc_init_se (&parmse
, NULL
);
2300 if (need_interface_mapping
)
2301 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2303 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2304 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2305 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2307 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2308 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2309 build_int_cst (gfc_charlen_type_node
, 0));
2310 cl
.backend_decl
= tmp
;
2313 /* Set up a charlen structure for it. */
2318 len
= cl
.backend_decl
;
2321 byref
= gfc_return_by_reference (sym
);
2324 if (se
->direct_byref
)
2326 /* Sometimes, too much indirection can be applied; eg. for
2327 function_result = array_valued_recursive_function. */
2328 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2329 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2330 && GFC_DESCRIPTOR_TYPE_P
2331 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2332 se
->expr
= build_fold_indirect_ref (se
->expr
);
2334 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2336 else if (sym
->result
->attr
.dimension
)
2338 gcc_assert (se
->loop
&& info
);
2340 /* Set the type of the array. */
2341 tmp
= gfc_typenode_for_spec (&ts
);
2342 info
->dimen
= se
->loop
->dimen
;
2344 /* Evaluate the bounds of the result, if known. */
2345 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2347 /* Create a temporary to store the result. In case the function
2348 returns a pointer, the temporary will be a shallow copy and
2349 mustn't be deallocated. */
2350 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2351 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2352 false, !sym
->attr
.pointer
, callee_alloc
);
2354 /* Pass the temporary as the first argument. */
2355 tmp
= info
->descriptor
;
2356 tmp
= build_fold_addr_expr (tmp
);
2357 retargs
= gfc_chainon_list (retargs
, tmp
);
2359 else if (ts
.type
== BT_CHARACTER
)
2361 /* Pass the string length. */
2362 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2363 type
= build_pointer_type (type
);
2365 /* Return an address to a char[0:len-1]* temporary for
2366 character pointers. */
2367 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2369 /* Build char[0:len-1] * pstr. */
2370 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2371 build_int_cst (gfc_charlen_type_node
, 1));
2372 tmp
= build_range_type (gfc_array_index_type
,
2373 gfc_index_zero_node
, tmp
);
2374 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2375 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2377 /* Provide an address expression for the function arguments. */
2378 var
= build_fold_addr_expr (var
);
2381 var
= gfc_conv_string_tmp (se
, type
, len
);
2383 retargs
= gfc_chainon_list (retargs
, var
);
2387 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2389 type
= gfc_get_complex_type (ts
.kind
);
2390 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2391 retargs
= gfc_chainon_list (retargs
, var
);
2394 /* Add the string length to the argument list. */
2395 if (ts
.type
== BT_CHARACTER
)
2396 retargs
= gfc_chainon_list (retargs
, len
);
2398 gfc_free_interface_mapping (&mapping
);
2400 /* Add the return arguments. */
2401 arglist
= chainon (retargs
, arglist
);
2403 /* Add the hidden string length parameters to the arguments. */
2404 arglist
= chainon (arglist
, stringargs
);
2406 /* We may want to append extra arguments here. This is used e.g. for
2407 calls to libgfortran_matmul_??, which need extra information. */
2408 if (append_args
!= NULL_TREE
)
2409 arglist
= chainon (arglist
, append_args
);
2411 /* Generate the actual call. */
2412 gfc_conv_function_val (se
, sym
);
2414 /* If there are alternate return labels, function type should be
2415 integer. Can't modify the type in place though, since it can be shared
2416 with other functions. For dummy arguments, the typing is done to
2417 to this result, even if it has to be repeated for each call. */
2418 if (has_alternate_specifier
2419 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2421 if (!sym
->attr
.dummy
)
2423 TREE_TYPE (sym
->backend_decl
)
2424 = build_function_type (integer_type_node
,
2425 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2426 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2429 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2432 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2433 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2435 /* If we have a pointer function, but we don't want a pointer, e.g.
2438 where f is pointer valued, we have to dereference the result. */
2439 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2440 se
->expr
= build_fold_indirect_ref (se
->expr
);
2442 /* f2c calling conventions require a scalar default real function to
2443 return a double precision result. Convert this back to default
2444 real. We only care about the cases that can happen in Fortran 77.
2446 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2447 && sym
->ts
.kind
== gfc_default_real_kind
2448 && !sym
->attr
.always_explicit
)
2449 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2451 /* A pure function may still have side-effects - it may modify its
2453 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2455 if (!sym
->attr
.pure
)
2456 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2461 /* Add the function call to the pre chain. There is no expression. */
2462 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2463 se
->expr
= NULL_TREE
;
2465 if (!se
->direct_byref
)
2467 if (sym
->attr
.dimension
)
2469 if (flag_bounds_check
)
2471 /* Check the data pointer hasn't been modified. This would
2472 happen in a function returning a pointer. */
2473 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2474 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2476 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2478 se
->expr
= info
->descriptor
;
2479 /* Bundle in the string length. */
2480 se
->string_length
= len
;
2482 else if (sym
->ts
.type
== BT_CHARACTER
)
2484 /* Dereference for character pointer results. */
2485 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2486 se
->expr
= build_fold_indirect_ref (var
);
2490 se
->string_length
= len
;
2494 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2495 se
->expr
= build_fold_indirect_ref (var
);
2500 /* Follow the function call with the argument post block. */
2502 gfc_add_block_to_block (&se
->pre
, &post
);
2504 gfc_add_block_to_block (&se
->post
, &post
);
2506 return has_alternate_specifier
;
2510 /* Generate code to copy a string. */
2513 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2514 tree slength
, tree src
)
2516 tree tmp
, dlen
, slen
;
2524 stmtblock_t tempblock
;
2526 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2527 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2529 /* Deal with single character specially. */
2530 dsc
= gfc_to_single_character (dlen
, dest
);
2531 ssc
= gfc_to_single_character (slen
, src
);
2532 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2534 gfc_add_modify_expr (block
, dsc
, ssc
);
2538 /* Do nothing if the destination length is zero. */
2539 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2540 build_int_cst (gfc_charlen_type_node
, 0));
2542 /* The following code was previously in _gfortran_copy_string:
2544 // The two strings may overlap so we use memmove.
2546 copy_string (GFC_INTEGER_4 destlen, char * dest,
2547 GFC_INTEGER_4 srclen, const char * src)
2549 if (srclen >= destlen)
2551 // This will truncate if too long.
2552 memmove (dest, src, destlen);
2556 memmove (dest, src, srclen);
2558 memset (&dest[srclen], ' ', destlen - srclen);
2562 We're now doing it here for better optimization, but the logic
2565 /* Truncate string if source is too long. */
2566 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2567 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2568 3, dest
, src
, dlen
);
2570 /* Else copy and pad with spaces. */
2571 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2572 3, dest
, src
, slen
);
2574 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2575 fold_convert (pchar_type_node
, slen
));
2576 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2578 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2579 lang_hooks
.to_target_charset (' ')),
2580 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2583 gfc_init_block (&tempblock
);
2584 gfc_add_expr_to_block (&tempblock
, tmp3
);
2585 gfc_add_expr_to_block (&tempblock
, tmp4
);
2586 tmp3
= gfc_finish_block (&tempblock
);
2588 /* The whole copy_string function is there. */
2589 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2590 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2591 gfc_add_expr_to_block (block
, tmp
);
2595 /* Translate a statement function.
2596 The value of a statement function reference is obtained by evaluating the
2597 expression using the values of the actual arguments for the values of the
2598 corresponding dummy arguments. */
2601 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2605 gfc_formal_arglist
*fargs
;
2606 gfc_actual_arglist
*args
;
2609 gfc_saved_var
*saved_vars
;
2615 sym
= expr
->symtree
->n
.sym
;
2616 args
= expr
->value
.function
.actual
;
2617 gfc_init_se (&lse
, NULL
);
2618 gfc_init_se (&rse
, NULL
);
2621 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2623 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2624 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2626 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2628 /* Each dummy shall be specified, explicitly or implicitly, to be
2630 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2633 /* Create a temporary to hold the value. */
2634 type
= gfc_typenode_for_spec (&fsym
->ts
);
2635 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2637 if (fsym
->ts
.type
== BT_CHARACTER
)
2639 /* Copy string arguments. */
2642 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2643 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2645 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2646 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2649 gfc_conv_expr (&rse
, args
->expr
);
2650 gfc_conv_string_parameter (&rse
);
2651 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2652 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2654 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2656 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2657 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2661 /* For everything else, just evaluate the expression. */
2662 gfc_conv_expr (&lse
, args
->expr
);
2664 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2665 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2666 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2672 /* Use the temporary variables in place of the real ones. */
2673 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2674 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2676 gfc_conv_expr (se
, sym
->value
);
2678 if (sym
->ts
.type
== BT_CHARACTER
)
2680 gfc_conv_const_charlen (sym
->ts
.cl
);
2682 /* Force the expression to the correct length. */
2683 if (!INTEGER_CST_P (se
->string_length
)
2684 || tree_int_cst_lt (se
->string_length
,
2685 sym
->ts
.cl
->backend_decl
))
2687 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2688 tmp
= gfc_create_var (type
, sym
->name
);
2689 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2690 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2691 se
->string_length
, se
->expr
);
2694 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2697 /* Restore the original variables. */
2698 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2699 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2700 gfc_free (saved_vars
);
2704 /* Translate a function expression. */
2707 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2711 if (expr
->value
.function
.isym
)
2713 gfc_conv_intrinsic_function (se
, expr
);
2717 /* We distinguish statement functions from general functions to improve
2718 runtime performance. */
2719 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2721 gfc_conv_statement_function (se
, expr
);
2725 /* expr.value.function.esym is the resolved (specific) function symbol for
2726 most functions. However this isn't set for dummy procedures. */
2727 sym
= expr
->value
.function
.esym
;
2729 sym
= expr
->symtree
->n
.sym
;
2730 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2735 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2737 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2738 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2740 gfc_conv_tmp_array_ref (se
);
2741 gfc_advance_se_ss_chain (se
);
2745 /* Build a static initializer. EXPR is the expression for the initial value.
2746 The other parameters describe the variable of the component being
2747 initialized. EXPR may be null. */
2750 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2751 bool array
, bool pointer
)
2755 if (!(expr
|| pointer
))
2760 /* Arrays need special handling. */
2762 return gfc_build_null_descriptor (type
);
2764 return gfc_conv_array_initializer (type
, expr
);
2767 return fold_convert (type
, null_pointer_node
);
2773 gfc_init_se (&se
, NULL
);
2774 gfc_conv_structure (&se
, expr
, 1);
2778 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2781 gfc_init_se (&se
, NULL
);
2782 gfc_conv_constant (&se
, expr
);
2789 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2801 gfc_start_block (&block
);
2803 /* Initialize the scalarizer. */
2804 gfc_init_loopinfo (&loop
);
2806 gfc_init_se (&lse
, NULL
);
2807 gfc_init_se (&rse
, NULL
);
2810 rss
= gfc_walk_expr (expr
);
2811 if (rss
== gfc_ss_terminator
)
2813 /* The rhs is scalar. Add a ss for the expression. */
2814 rss
= gfc_get_ss ();
2815 rss
->next
= gfc_ss_terminator
;
2816 rss
->type
= GFC_SS_SCALAR
;
2820 /* Create a SS for the destination. */
2821 lss
= gfc_get_ss ();
2822 lss
->type
= GFC_SS_COMPONENT
;
2824 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2825 lss
->next
= gfc_ss_terminator
;
2826 lss
->data
.info
.dimen
= cm
->as
->rank
;
2827 lss
->data
.info
.descriptor
= dest
;
2828 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2829 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2830 for (n
= 0; n
< cm
->as
->rank
; n
++)
2832 lss
->data
.info
.dim
[n
] = n
;
2833 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2834 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2836 mpz_init (lss
->shape
[n
]);
2837 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2838 cm
->as
->lower
[n
]->value
.integer
);
2839 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2842 /* Associate the SS with the loop. */
2843 gfc_add_ss_to_loop (&loop
, lss
);
2844 gfc_add_ss_to_loop (&loop
, rss
);
2846 /* Calculate the bounds of the scalarization. */
2847 gfc_conv_ss_startstride (&loop
);
2849 /* Setup the scalarizing loops. */
2850 gfc_conv_loop_setup (&loop
);
2852 /* Setup the gfc_se structures. */
2853 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2854 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2857 gfc_mark_ss_chain_used (rss
, 1);
2859 gfc_mark_ss_chain_used (lss
, 1);
2861 /* Start the scalarized loop body. */
2862 gfc_start_scalarized_body (&loop
, &body
);
2864 gfc_conv_tmp_array_ref (&lse
);
2865 if (cm
->ts
.type
== BT_CHARACTER
)
2866 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2868 gfc_conv_expr (&rse
, expr
);
2870 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2871 gfc_add_expr_to_block (&body
, tmp
);
2873 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2875 /* Generate the copying loops. */
2876 gfc_trans_scalarizing_loops (&loop
, &body
);
2878 /* Wrap the whole thing up. */
2879 gfc_add_block_to_block (&block
, &loop
.pre
);
2880 gfc_add_block_to_block (&block
, &loop
.post
);
2882 for (n
= 0; n
< cm
->as
->rank
; n
++)
2883 mpz_clear (lss
->shape
[n
]);
2884 gfc_free (lss
->shape
);
2886 gfc_cleanup_loop (&loop
);
2888 return gfc_finish_block (&block
);
2892 /* Assign a single component of a derived type constructor. */
2895 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2905 gfc_start_block (&block
);
2909 gfc_init_se (&se
, NULL
);
2910 /* Pointer component. */
2913 /* Array pointer. */
2914 if (expr
->expr_type
== EXPR_NULL
)
2915 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2918 rss
= gfc_walk_expr (expr
);
2919 se
.direct_byref
= 1;
2921 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2922 gfc_add_block_to_block (&block
, &se
.pre
);
2923 gfc_add_block_to_block (&block
, &se
.post
);
2928 /* Scalar pointers. */
2929 se
.want_pointer
= 1;
2930 gfc_conv_expr (&se
, expr
);
2931 gfc_add_block_to_block (&block
, &se
.pre
);
2932 gfc_add_modify_expr (&block
, dest
,
2933 fold_convert (TREE_TYPE (dest
), se
.expr
));
2934 gfc_add_block_to_block (&block
, &se
.post
);
2937 else if (cm
->dimension
)
2939 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2940 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2941 else if (cm
->allocatable
)
2945 gfc_init_se (&se
, NULL
);
2947 rss
= gfc_walk_expr (expr
);
2948 se
.want_pointer
= 0;
2949 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2950 gfc_add_block_to_block (&block
, &se
.pre
);
2952 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2953 gfc_add_modify_expr (&block
, dest
, tmp
);
2955 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2956 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2959 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2960 TREE_TYPE(cm
->backend_decl
),
2963 gfc_add_expr_to_block (&block
, tmp
);
2965 gfc_add_block_to_block (&block
, &se
.post
);
2966 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2968 /* Shift the lbound and ubound of temporaries to being unity, rather
2969 than zero, based. Calculate the offset for all cases. */
2970 offset
= gfc_conv_descriptor_offset (dest
);
2971 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2972 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2973 for (n
= 0; n
< expr
->rank
; n
++)
2975 if (expr
->expr_type
!= EXPR_VARIABLE
2976 && expr
->expr_type
!= EXPR_CONSTANT
)
2978 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2979 gfc_add_modify_expr (&block
, tmp
,
2980 fold_build2 (PLUS_EXPR
,
2981 gfc_array_index_type
,
2982 tmp
, gfc_index_one_node
));
2983 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2984 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2986 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2987 gfc_conv_descriptor_lbound (dest
,
2989 gfc_conv_descriptor_stride (dest
,
2991 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2992 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2993 gfc_add_modify_expr (&block
, offset
, tmp
);
2998 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2999 gfc_add_expr_to_block (&block
, tmp
);
3002 else if (expr
->ts
.type
== BT_DERIVED
)
3004 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3006 gfc_init_se (&se
, NULL
);
3007 gfc_conv_expr (&se
, expr
);
3008 gfc_add_modify_expr (&block
, dest
,
3009 fold_convert (TREE_TYPE (dest
), se
.expr
));
3013 /* Nested constructors. */
3014 tmp
= gfc_trans_structure_assign (dest
, expr
);
3015 gfc_add_expr_to_block (&block
, tmp
);
3020 /* Scalar component. */
3021 gfc_init_se (&se
, NULL
);
3022 gfc_init_se (&lse
, NULL
);
3024 gfc_conv_expr (&se
, expr
);
3025 if (cm
->ts
.type
== BT_CHARACTER
)
3026 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3028 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3029 gfc_add_expr_to_block (&block
, tmp
);
3031 return gfc_finish_block (&block
);
3034 /* Assign a derived type constructor to a variable. */
3037 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3045 gfc_start_block (&block
);
3046 cm
= expr
->ts
.derived
->components
;
3047 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3049 /* Skip absent members in default initializers. */
3053 field
= cm
->backend_decl
;
3054 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3055 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3056 gfc_add_expr_to_block (&block
, tmp
);
3058 return gfc_finish_block (&block
);
3061 /* Build an expression for a constructor. If init is nonzero then
3062 this is part of a static variable initializer. */
3065 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3072 VEC(constructor_elt
,gc
) *v
= NULL
;
3074 gcc_assert (se
->ss
== NULL
);
3075 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3076 type
= gfc_typenode_for_spec (&expr
->ts
);
3080 /* Create a temporary variable and fill it in. */
3081 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3082 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3083 gfc_add_expr_to_block (&se
->pre
, tmp
);
3087 cm
= expr
->ts
.derived
->components
;
3089 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3091 /* Skip absent members in default initializers and allocatable
3092 components. Although the latter have a default initializer
3093 of EXPR_NULL,... by default, the static nullify is not needed
3094 since this is done every time we come into scope. */
3095 if (!c
->expr
|| cm
->allocatable
)
3098 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3099 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3101 /* Append it to the constructor list. */
3102 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3104 se
->expr
= build_constructor (type
, v
);
3108 /* Translate a substring expression. */
3111 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3117 gcc_assert (ref
->type
== REF_SUBSTRING
);
3119 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3120 expr
->value
.character
.string
);
3121 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3122 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3124 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3128 /* Entry point for expression translation. Evaluates a scalar quantity.
3129 EXPR is the expression to be translated, and SE is the state structure if
3130 called from within the scalarized. */
3133 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3135 if (se
->ss
&& se
->ss
->expr
== expr
3136 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3138 /* Substitute a scalar expression evaluated outside the scalarization
3140 se
->expr
= se
->ss
->data
.scalar
.expr
;
3141 se
->string_length
= se
->ss
->string_length
;
3142 gfc_advance_se_ss_chain (se
);
3146 switch (expr
->expr_type
)
3149 gfc_conv_expr_op (se
, expr
);
3153 gfc_conv_function_expr (se
, expr
);
3157 gfc_conv_constant (se
, expr
);
3161 gfc_conv_variable (se
, expr
);
3165 se
->expr
= null_pointer_node
;
3168 case EXPR_SUBSTRING
:
3169 gfc_conv_substring_expr (se
, expr
);
3172 case EXPR_STRUCTURE
:
3173 gfc_conv_structure (se
, expr
, 0);
3177 gfc_conv_array_constructor_expr (se
, expr
);
3186 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3187 of an assignment. */
3189 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3191 gfc_conv_expr (se
, expr
);
3192 /* All numeric lvalues should have empty post chains. If not we need to
3193 figure out a way of rewriting an lvalue so that it has no post chain. */
3194 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3197 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3198 numeric expressions. Used for scalar values where inserting cleanup code
3201 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3205 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3206 gfc_conv_expr (se
, expr
);
3209 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3210 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3212 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3216 /* Helper to translate and expression and convert it to a particular type. */
3218 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3220 gfc_conv_expr_val (se
, expr
);
3221 se
->expr
= convert (type
, se
->expr
);
3225 /* Converts an expression so that it can be passed by reference. Scalar
3229 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3233 if (se
->ss
&& se
->ss
->expr
== expr
3234 && se
->ss
->type
== GFC_SS_REFERENCE
)
3236 se
->expr
= se
->ss
->data
.scalar
.expr
;
3237 se
->string_length
= se
->ss
->string_length
;
3238 gfc_advance_se_ss_chain (se
);
3242 if (expr
->ts
.type
== BT_CHARACTER
)
3244 gfc_conv_expr (se
, expr
);
3245 gfc_conv_string_parameter (se
);
3249 if (expr
->expr_type
== EXPR_VARIABLE
)
3251 se
->want_pointer
= 1;
3252 gfc_conv_expr (se
, expr
);
3255 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3256 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3257 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3263 gfc_conv_expr (se
, expr
);
3265 /* Create a temporary var to hold the value. */
3266 if (TREE_CONSTANT (se
->expr
))
3268 tree tmp
= se
->expr
;
3269 STRIP_TYPE_NOPS (tmp
);
3270 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3271 DECL_INITIAL (var
) = tmp
;
3272 TREE_STATIC (var
) = 1;
3277 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3278 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3280 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3282 /* Take the address of that value. */
3283 se
->expr
= build_fold_addr_expr (var
);
3288 gfc_trans_pointer_assign (gfc_code
* code
)
3290 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3294 /* Generate code for a pointer assignment. */
3297 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3307 gfc_start_block (&block
);
3309 gfc_init_se (&lse
, NULL
);
3311 lss
= gfc_walk_expr (expr1
);
3312 rss
= gfc_walk_expr (expr2
);
3313 if (lss
== gfc_ss_terminator
)
3315 /* Scalar pointers. */
3316 lse
.want_pointer
= 1;
3317 gfc_conv_expr (&lse
, expr1
);
3318 gcc_assert (rss
== gfc_ss_terminator
);
3319 gfc_init_se (&rse
, NULL
);
3320 rse
.want_pointer
= 1;
3321 gfc_conv_expr (&rse
, expr2
);
3322 gfc_add_block_to_block (&block
, &lse
.pre
);
3323 gfc_add_block_to_block (&block
, &rse
.pre
);
3324 gfc_add_modify_expr (&block
, lse
.expr
,
3325 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3326 gfc_add_block_to_block (&block
, &rse
.post
);
3327 gfc_add_block_to_block (&block
, &lse
.post
);
3331 /* Array pointer. */
3332 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3333 switch (expr2
->expr_type
)
3336 /* Just set the data pointer to null. */
3337 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3341 /* Assign directly to the pointer's descriptor. */
3342 lse
.direct_byref
= 1;
3343 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3347 /* Assign to a temporary descriptor and then copy that
3348 temporary to the pointer. */
3350 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3353 lse
.direct_byref
= 1;
3354 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3355 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3358 gfc_add_block_to_block (&block
, &lse
.pre
);
3359 gfc_add_block_to_block (&block
, &lse
.post
);
3361 return gfc_finish_block (&block
);
3365 /* Makes sure se is suitable for passing as a function string parameter. */
3366 /* TODO: Need to check all callers fo this function. It may be abused. */
3369 gfc_conv_string_parameter (gfc_se
* se
)
3373 if (TREE_CODE (se
->expr
) == STRING_CST
)
3375 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3379 type
= TREE_TYPE (se
->expr
);
3380 if (TYPE_STRING_FLAG (type
))
3382 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3383 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3386 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3387 gcc_assert (se
->string_length
3388 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3392 /* Generate code for assignment of scalar variables. Includes character
3393 strings and derived types with allocatable components. */
3396 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3397 bool l_is_temp
, bool r_is_var
)
3403 gfc_init_block (&block
);
3405 if (ts
.type
== BT_CHARACTER
)
3407 gcc_assert (lse
->string_length
!= NULL_TREE
3408 && rse
->string_length
!= NULL_TREE
);
3410 gfc_conv_string_parameter (lse
);
3411 gfc_conv_string_parameter (rse
);
3413 gfc_add_block_to_block (&block
, &lse
->pre
);
3414 gfc_add_block_to_block (&block
, &rse
->pre
);
3416 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3417 rse
->string_length
, rse
->expr
);
3419 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3423 /* Are the rhs and the lhs the same? */
3426 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3427 build_fold_addr_expr (lse
->expr
),
3428 build_fold_addr_expr (rse
->expr
));
3429 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3432 /* Deallocate the lhs allocated components as long as it is not
3433 the same as the rhs. */
3436 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3438 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3439 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3442 gfc_add_block_to_block (&block
, &lse
->pre
);
3443 gfc_add_block_to_block (&block
, &rse
->pre
);
3445 gfc_add_modify_expr (&block
, lse
->expr
,
3446 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3448 /* Do a deep copy if the rhs is a variable, if it is not the
3452 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3453 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3454 gfc_add_expr_to_block (&block
, tmp
);
3459 gfc_add_block_to_block (&block
, &lse
->pre
);
3460 gfc_add_block_to_block (&block
, &rse
->pre
);
3462 gfc_add_modify_expr (&block
, lse
->expr
,
3463 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3466 gfc_add_block_to_block (&block
, &lse
->post
);
3467 gfc_add_block_to_block (&block
, &rse
->post
);
3469 return gfc_finish_block (&block
);
3473 /* Try to translate array(:) = func (...), where func is a transformational
3474 array function, without using a temporary. Returns NULL is this isn't the
3478 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3483 bool seen_array_ref
;
3485 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3486 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3489 /* Elemental functions don't need a temporary anyway. */
3490 if (expr2
->value
.function
.esym
!= NULL
3491 && expr2
->value
.function
.esym
->attr
.elemental
)
3494 /* Fail if EXPR1 can't be expressed as a descriptor. */
3495 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3498 /* Functions returning pointers need temporaries. */
3499 if (expr2
->symtree
->n
.sym
->attr
.pointer
3500 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3503 /* Character array functions need temporaries unless the
3504 character lengths are the same. */
3505 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3507 if (expr1
->ts
.cl
->length
== NULL
3508 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3511 if (expr2
->ts
.cl
->length
== NULL
3512 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3515 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3516 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3520 /* Check that no LHS component references appear during an array
3521 reference. This is needed because we do not have the means to
3522 span any arbitrary stride with an array descriptor. This check
3523 is not needed for the rhs because the function result has to be
3525 seen_array_ref
= false;
3526 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3528 if (ref
->type
== REF_ARRAY
)
3529 seen_array_ref
= true;
3530 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3534 /* Check for a dependency. */
3535 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3536 expr2
->value
.function
.esym
,
3537 expr2
->value
.function
.actual
))
3540 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3542 gcc_assert (expr2
->value
.function
.isym
3543 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3544 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3546 ss
= gfc_walk_expr (expr1
);
3547 gcc_assert (ss
!= gfc_ss_terminator
);
3548 gfc_init_se (&se
, NULL
);
3549 gfc_start_block (&se
.pre
);
3550 se
.want_pointer
= 1;
3552 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3554 se
.direct_byref
= 1;
3555 se
.ss
= gfc_walk_expr (expr2
);
3556 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3557 gfc_conv_function_expr (&se
, expr2
);
3558 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3560 return gfc_finish_block (&se
.pre
);
3563 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3566 is_zero_initializer_p (gfc_expr
* expr
)
3568 if (expr
->expr_type
!= EXPR_CONSTANT
)
3570 /* We ignore Hollerith constants for the time being. */
3574 switch (expr
->ts
.type
)
3577 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3580 return mpfr_zero_p (expr
->value
.real
)
3581 && MPFR_SIGN (expr
->value
.real
) >= 0;
3584 return expr
->value
.logical
== 0;
3587 return mpfr_zero_p (expr
->value
.complex.r
)
3588 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3589 && mpfr_zero_p (expr
->value
.complex.i
)
3590 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3598 /* Try to efficiently translate array(:) = 0. Return NULL if this
3602 gfc_trans_zero_assign (gfc_expr
* expr
)
3604 tree dest
, len
, type
;
3608 sym
= expr
->symtree
->n
.sym
;
3609 dest
= gfc_get_symbol_decl (sym
);
3611 type
= TREE_TYPE (dest
);
3612 if (POINTER_TYPE_P (type
))
3613 type
= TREE_TYPE (type
);
3614 if (!GFC_ARRAY_TYPE_P (type
))
3617 /* Determine the length of the array. */
3618 len
= GFC_TYPE_ARRAY_SIZE (type
);
3619 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3622 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3623 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
3625 /* Convert arguments to the correct types. */
3626 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3627 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3629 dest
= fold_convert (pvoid_type_node
, dest
);
3630 len
= fold_convert (size_type_node
, len
);
3632 /* Construct call to __builtin_memset. */
3633 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3634 3, dest
, integer_zero_node
, len
);
3635 return fold_convert (void_type_node
, tmp
);
3639 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3640 that constructs the call to __builtin_memcpy. */
3643 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3647 /* Convert arguments to the correct types. */
3648 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3649 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3651 dst
= fold_convert (pvoid_type_node
, dst
);
3653 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3654 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3656 src
= fold_convert (pvoid_type_node
, src
);
3658 len
= fold_convert (size_type_node
, len
);
3660 /* Construct call to __builtin_memcpy. */
3661 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3662 return fold_convert (void_type_node
, tmp
);
3666 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3667 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3668 source/rhs, both are gfc_full_array_ref_p which have been checked for
3672 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3674 tree dst
, dlen
, dtype
;
3675 tree src
, slen
, stype
;
3677 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3678 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3680 dtype
= TREE_TYPE (dst
);
3681 if (POINTER_TYPE_P (dtype
))
3682 dtype
= TREE_TYPE (dtype
);
3683 stype
= TREE_TYPE (src
);
3684 if (POINTER_TYPE_P (stype
))
3685 stype
= TREE_TYPE (stype
);
3687 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3690 /* Determine the lengths of the arrays. */
3691 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3692 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3694 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3695 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3697 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3698 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3700 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3701 TYPE_SIZE_UNIT (gfc_get_element_type (stype
)));
3703 /* Sanity check that they are the same. This should always be
3704 the case, as we should already have checked for conformance. */
3705 if (!tree_int_cst_equal (slen
, dlen
))
3708 return gfc_build_memcpy_call (dst
, src
, dlen
);
3712 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3713 this can't be done. EXPR1 is the destination/lhs for which
3714 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3717 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3719 unsigned HOST_WIDE_INT nelem
;
3724 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3728 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3729 dtype
= TREE_TYPE (dst
);
3730 if (POINTER_TYPE_P (dtype
))
3731 dtype
= TREE_TYPE (dtype
);
3732 if (!GFC_ARRAY_TYPE_P (dtype
))
3735 /* Determine the lengths of the array. */
3736 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3737 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3740 /* Confirm that the constructor is the same size. */
3741 if (compare_tree_int (len
, nelem
) != 0)
3744 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3745 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3747 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3748 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3750 stype
= TREE_TYPE (src
);
3751 if (POINTER_TYPE_P (stype
))
3752 stype
= TREE_TYPE (stype
);
3754 return gfc_build_memcpy_call (dst
, src
, len
);
3758 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3759 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3762 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3767 gfc_ss
*lss_section
;
3775 /* Assignment of the form lhs = rhs. */
3776 gfc_start_block (&block
);
3778 gfc_init_se (&lse
, NULL
);
3779 gfc_init_se (&rse
, NULL
);
3782 lss
= gfc_walk_expr (expr1
);
3784 if (lss
!= gfc_ss_terminator
)
3786 /* The assignment needs scalarization. */
3789 /* Find a non-scalar SS from the lhs. */
3790 while (lss_section
!= gfc_ss_terminator
3791 && lss_section
->type
!= GFC_SS_SECTION
)
3792 lss_section
= lss_section
->next
;
3794 gcc_assert (lss_section
!= gfc_ss_terminator
);
3796 /* Initialize the scalarizer. */
3797 gfc_init_loopinfo (&loop
);
3800 rss
= gfc_walk_expr (expr2
);
3801 if (rss
== gfc_ss_terminator
)
3803 /* The rhs is scalar. Add a ss for the expression. */
3804 rss
= gfc_get_ss ();
3805 rss
->next
= gfc_ss_terminator
;
3806 rss
->type
= GFC_SS_SCALAR
;
3809 /* Associate the SS with the loop. */
3810 gfc_add_ss_to_loop (&loop
, lss
);
3811 gfc_add_ss_to_loop (&loop
, rss
);
3813 /* Calculate the bounds of the scalarization. */
3814 gfc_conv_ss_startstride (&loop
);
3815 /* Resolve any data dependencies in the statement. */
3816 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3817 /* Setup the scalarizing loops. */
3818 gfc_conv_loop_setup (&loop
);
3820 /* Setup the gfc_se structures. */
3821 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3822 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3825 gfc_mark_ss_chain_used (rss
, 1);
3826 if (loop
.temp_ss
== NULL
)
3829 gfc_mark_ss_chain_used (lss
, 1);
3833 lse
.ss
= loop
.temp_ss
;
3834 gfc_mark_ss_chain_used (lss
, 3);
3835 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3838 /* Start the scalarized loop body. */
3839 gfc_start_scalarized_body (&loop
, &body
);
3842 gfc_init_block (&body
);
3844 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3846 /* Translate the expression. */
3847 gfc_conv_expr (&rse
, expr2
);
3851 gfc_conv_tmp_array_ref (&lse
);
3852 gfc_advance_se_ss_chain (&lse
);
3855 gfc_conv_expr (&lse
, expr1
);
3857 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3858 l_is_temp
|| init_flag
,
3859 expr2
->expr_type
== EXPR_VARIABLE
);
3860 gfc_add_expr_to_block (&body
, tmp
);
3862 if (lss
== gfc_ss_terminator
)
3864 /* Use the scalar assignment as is. */
3865 gfc_add_block_to_block (&block
, &body
);
3869 gcc_assert (lse
.ss
== gfc_ss_terminator
3870 && rse
.ss
== gfc_ss_terminator
);
3874 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3876 /* We need to copy the temporary to the actual lhs. */
3877 gfc_init_se (&lse
, NULL
);
3878 gfc_init_se (&rse
, NULL
);
3879 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3880 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3882 rse
.ss
= loop
.temp_ss
;
3885 gfc_conv_tmp_array_ref (&rse
);
3886 gfc_advance_se_ss_chain (&rse
);
3887 gfc_conv_expr (&lse
, expr1
);
3889 gcc_assert (lse
.ss
== gfc_ss_terminator
3890 && rse
.ss
== gfc_ss_terminator
);
3892 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3894 gfc_add_expr_to_block (&body
, tmp
);
3897 /* Generate the copying loops. */
3898 gfc_trans_scalarizing_loops (&loop
, &body
);
3900 /* Wrap the whole thing up. */
3901 gfc_add_block_to_block (&block
, &loop
.pre
);
3902 gfc_add_block_to_block (&block
, &loop
.post
);
3904 gfc_cleanup_loop (&loop
);
3907 return gfc_finish_block (&block
);
3911 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3914 copyable_array_p (gfc_expr
* expr
)
3916 /* First check it's an array. */
3917 if (expr
->rank
< 1 || !expr
->ref
)
3920 /* Next check that it's of a simple enough type. */
3921 switch (expr
->ts
.type
)
3933 return !expr
->ts
.derived
->attr
.alloc_comp
;
3942 /* Translate an assignment. */
3945 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3949 /* Special case a single function returning an array. */
3950 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3952 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3957 /* Special case assigning an array to zero. */
3958 if (expr1
->expr_type
== EXPR_VARIABLE
3961 && expr1
->ref
->next
== NULL
3962 && gfc_full_array_ref_p (expr1
->ref
)
3963 && is_zero_initializer_p (expr2
))
3965 tmp
= gfc_trans_zero_assign (expr1
);
3970 /* Special case copying one array to another. */
3971 if (expr1
->expr_type
== EXPR_VARIABLE
3972 && copyable_array_p (expr1
)
3973 && gfc_full_array_ref_p (expr1
->ref
)
3974 && expr2
->expr_type
== EXPR_VARIABLE
3975 && copyable_array_p (expr2
)
3976 && gfc_full_array_ref_p (expr2
->ref
)
3977 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
3978 && !gfc_check_dependency (expr1
, expr2
, 0))
3980 tmp
= gfc_trans_array_copy (expr1
, expr2
);
3985 /* Special case initializing an array from a constant array constructor. */
3986 if (expr1
->expr_type
== EXPR_VARIABLE
3987 && copyable_array_p (expr1
)
3988 && gfc_full_array_ref_p (expr1
->ref
)
3989 && expr2
->expr_type
== EXPR_ARRAY
3990 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
3992 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
3997 /* Fallback to the scalarizer to generate explicit loops. */
3998 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4002 gfc_trans_init_assign (gfc_code
* code
)
4004 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4008 gfc_trans_assign (gfc_code
* code
)
4010 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);