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 /* Use builtins for real ** int4. */
861 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
865 fndecl
= built_in_decls
[BUILT_IN_POWI
];
870 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
878 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
882 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
894 fndecl
= built_in_decls
[BUILT_IN_POWF
];
897 fndecl
= built_in_decls
[BUILT_IN_POW
];
901 fndecl
= built_in_decls
[BUILT_IN_POWL
];
912 fndecl
= gfor_fndecl_math_cpowf
;
915 fndecl
= gfor_fndecl_math_cpow
;
918 fndecl
= gfor_fndecl_math_cpowl10
;
921 fndecl
= gfor_fndecl_math_cpowl16
;
933 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
937 /* Generate code to allocate a string temporary. */
940 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
945 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
947 if (gfc_can_put_var_on_stack (len
))
949 /* Create a temporary variable to hold the result. */
950 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
951 build_int_cst (gfc_charlen_type_node
, 1));
952 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
953 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
954 var
= gfc_create_var (tmp
, "str");
955 var
= gfc_build_addr_expr (type
, var
);
959 /* Allocate a temporary to hold the result. */
960 var
= gfc_create_var (type
, "pstr");
961 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
962 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
964 /* Free the temporary afterwards. */
965 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
966 gfc_add_expr_to_block (&se
->post
, tmp
);
973 /* Handle a string concatenation operation. A temporary will be allocated to
977 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
986 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
987 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
989 gfc_init_se (&lse
, se
);
990 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
991 gfc_conv_string_parameter (&lse
);
992 gfc_init_se (&rse
, se
);
993 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
994 gfc_conv_string_parameter (&rse
);
996 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
997 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
999 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1000 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1001 if (len
== NULL_TREE
)
1003 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1004 lse
.string_length
, rse
.string_length
);
1007 type
= build_pointer_type (type
);
1009 var
= gfc_conv_string_tmp (se
, type
, len
);
1011 /* Do the actual concatenation. */
1012 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1014 lse
.string_length
, lse
.expr
,
1015 rse
.string_length
, rse
.expr
);
1016 gfc_add_expr_to_block (&se
->pre
, tmp
);
1018 /* Add the cleanup for the operands. */
1019 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1020 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1023 se
->string_length
= len
;
1026 /* Translates an op expression. Common (binary) cases are handled by this
1027 function, others are passed on. Recursion is used in either case.
1028 We use the fact that (op1.ts == op2.ts) (except for the power
1030 Operators need no special handling for scalarized expressions as long as
1031 they call gfc_conv_simple_val to get their operands.
1032 Character strings get special handling. */
1035 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1037 enum tree_code code
;
1047 switch (expr
->value
.op
.operator)
1049 case INTRINSIC_UPLUS
:
1050 case INTRINSIC_PARENTHESES
:
1051 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1054 case INTRINSIC_UMINUS
:
1055 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1059 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1062 case INTRINSIC_PLUS
:
1066 case INTRINSIC_MINUS
:
1070 case INTRINSIC_TIMES
:
1074 case INTRINSIC_DIVIDE
:
1075 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1076 an integer, we must round towards zero, so we use a
1078 if (expr
->ts
.type
== BT_INTEGER
)
1079 code
= TRUNC_DIV_EXPR
;
1084 case INTRINSIC_POWER
:
1085 gfc_conv_power_op (se
, expr
);
1088 case INTRINSIC_CONCAT
:
1089 gfc_conv_concat_op (se
, expr
);
1093 code
= TRUTH_ANDIF_EXPR
;
1098 code
= TRUTH_ORIF_EXPR
;
1102 /* EQV and NEQV only work on logicals, but since we represent them
1103 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1112 case INTRINSIC_NEQV
:
1142 case INTRINSIC_USER
:
1143 case INTRINSIC_ASSIGN
:
1144 /* These should be converted into function calls by the frontend. */
1148 fatal_error ("Unknown intrinsic op");
1152 /* The only exception to this is **, which is handled separately anyway. */
1153 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1155 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1159 gfc_init_se (&lse
, se
);
1160 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1161 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1164 gfc_init_se (&rse
, se
);
1165 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1166 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1170 gfc_conv_string_parameter (&lse
);
1171 gfc_conv_string_parameter (&rse
);
1173 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1174 rse
.string_length
, rse
.expr
);
1175 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1176 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1179 type
= gfc_typenode_for_spec (&expr
->ts
);
1183 /* The result of logical ops is always boolean_type_node. */
1184 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1185 se
->expr
= convert (type
, tmp
);
1188 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1190 /* Add the post blocks. */
1191 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1192 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1195 /* If a string's length is one, we convert it to a single character. */
1198 gfc_to_single_character (tree len
, tree str
)
1200 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1202 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1203 && TREE_INT_CST_HIGH (len
) == 0)
1205 str
= fold_convert (pchar_type_node
, str
);
1206 return build_fold_indirect_ref (str
);
1212 /* Compare two strings. If they are all single characters, the result is the
1213 subtraction of them. Otherwise, we build a library call. */
1216 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1223 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1224 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1226 type
= gfc_get_int_type (gfc_default_integer_kind
);
1228 sc1
= gfc_to_single_character (len1
, str1
);
1229 sc2
= gfc_to_single_character (len2
, str2
);
1231 /* Deal with single character specially. */
1232 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1234 sc1
= fold_convert (type
, sc1
);
1235 sc2
= fold_convert (type
, sc2
);
1236 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1239 /* Build a call for the comparison. */
1240 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1241 len1
, str1
, len2
, str2
);
1246 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1250 if (sym
->attr
.dummy
)
1252 tmp
= gfc_get_symbol_decl (sym
);
1253 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1254 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1258 if (!sym
->backend_decl
)
1259 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1261 tmp
= sym
->backend_decl
;
1262 if (sym
->attr
.cray_pointee
)
1263 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1264 gfc_get_symbol_decl (sym
->cp_pointer
));
1265 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1267 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1268 tmp
= build_fold_addr_expr (tmp
);
1275 /* Translate the call for an elemental subroutine call used in an operator
1276 assignment. This is a simplified version of gfc_conv_function_call. */
1279 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1286 /* Only elemental subroutines with two arguments. */
1287 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1288 gcc_assert (sym
->formal
->next
->next
== NULL
);
1290 gfc_init_block (&block
);
1292 gfc_add_block_to_block (&block
, &lse
->pre
);
1293 gfc_add_block_to_block (&block
, &rse
->pre
);
1295 /* Build the argument list for the call, including hidden string lengths. */
1296 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1297 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1298 if (lse
->string_length
!= NULL_TREE
)
1299 args
= gfc_chainon_list (args
, lse
->string_length
);
1300 if (rse
->string_length
!= NULL_TREE
)
1301 args
= gfc_chainon_list (args
, rse
->string_length
);
1303 /* Build the function call. */
1304 gfc_init_se (&se
, NULL
);
1305 gfc_conv_function_val (&se
, sym
);
1306 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1307 tmp
= build_call_list (tmp
, se
.expr
, args
);
1308 gfc_add_expr_to_block (&block
, tmp
);
1310 gfc_add_block_to_block (&block
, &lse
->post
);
1311 gfc_add_block_to_block (&block
, &rse
->post
);
1313 return gfc_finish_block (&block
);
1317 /* Initialize MAPPING. */
1320 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1322 mapping
->syms
= NULL
;
1323 mapping
->charlens
= NULL
;
1327 /* Free all memory held by MAPPING (but not MAPPING itself). */
1330 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1332 gfc_interface_sym_mapping
*sym
;
1333 gfc_interface_sym_mapping
*nextsym
;
1335 gfc_charlen
*nextcl
;
1337 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1339 nextsym
= sym
->next
;
1340 gfc_free_symbol (sym
->new->n
.sym
);
1341 gfc_free (sym
->new);
1344 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1347 gfc_free_expr (cl
->length
);
1353 /* Return a copy of gfc_charlen CL. Add the returned structure to
1354 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1356 static gfc_charlen
*
1357 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1362 new = gfc_get_charlen ();
1363 new->next
= mapping
->charlens
;
1364 new->length
= gfc_copy_expr (cl
->length
);
1366 mapping
->charlens
= new;
1371 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1372 array variable that can be used as the actual argument for dummy
1373 argument SYM. Add any initialization code to BLOCK. PACKED is as
1374 for gfc_get_nodesc_array_type and DATA points to the first element
1375 in the passed array. */
1378 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1379 gfc_packed packed
, tree data
)
1384 type
= gfc_typenode_for_spec (&sym
->ts
);
1385 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1387 var
= gfc_create_var (type
, "ifm");
1388 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1394 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1395 and offset of descriptorless array type TYPE given that it has the same
1396 size as DESC. Add any set-up code to BLOCK. */
1399 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1406 offset
= gfc_index_zero_node
;
1407 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1409 dim
= gfc_rank_cst
[n
];
1410 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1411 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1413 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1414 = gfc_conv_descriptor_lbound (desc
, dim
);
1415 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1416 = gfc_conv_descriptor_ubound (desc
, dim
);
1418 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1420 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1421 gfc_conv_descriptor_ubound (desc
, dim
),
1422 gfc_conv_descriptor_lbound (desc
, dim
));
1423 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1424 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1426 tmp
= gfc_evaluate_now (tmp
, block
);
1427 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1429 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1430 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1431 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1432 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1434 offset
= gfc_evaluate_now (offset
, block
);
1435 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1439 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1440 in SE. The caller may still use se->expr and se->string_length after
1441 calling this function. */
1444 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1445 gfc_symbol
* sym
, gfc_se
* se
)
1447 gfc_interface_sym_mapping
*sm
;
1451 gfc_symbol
*new_sym
;
1453 gfc_symtree
*new_symtree
;
1455 /* Create a new symbol to represent the actual argument. */
1456 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1457 new_sym
->ts
= sym
->ts
;
1458 new_sym
->attr
.referenced
= 1;
1459 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1460 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1461 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1462 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1464 /* Create a fake symtree for it. */
1466 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1467 new_symtree
->n
.sym
= new_sym
;
1468 gcc_assert (new_symtree
== root
);
1470 /* Create a dummy->actual mapping. */
1471 sm
= gfc_getmem (sizeof (*sm
));
1472 sm
->next
= mapping
->syms
;
1474 sm
->new = new_symtree
;
1477 /* Stabilize the argument's value. */
1478 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1480 if (sym
->ts
.type
== BT_CHARACTER
)
1482 /* Create a copy of the dummy argument's length. */
1483 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1485 /* If the length is specified as "*", record the length that
1486 the caller is passing. We should use the callee's length
1487 in all other cases. */
1488 if (!new_sym
->ts
.cl
->length
)
1490 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1491 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1495 /* Use the passed value as-is if the argument is a function. */
1496 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1499 /* If the argument is either a string or a pointer to a string,
1500 convert it to a boundless character type. */
1501 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1503 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1504 tmp
= build_pointer_type (tmp
);
1505 if (sym
->attr
.pointer
)
1506 value
= build_fold_indirect_ref (se
->expr
);
1509 value
= fold_convert (tmp
, value
);
1512 /* If the argument is a scalar, a pointer to an array or an allocatable,
1514 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1515 value
= build_fold_indirect_ref (se
->expr
);
1517 /* For character(*), use the actual argument's descriptor. */
1518 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1519 value
= build_fold_indirect_ref (se
->expr
);
1521 /* If the argument is an array descriptor, use it to determine
1522 information about the actual argument's shape. */
1523 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1524 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1526 /* Get the actual argument's descriptor. */
1527 desc
= build_fold_indirect_ref (se
->expr
);
1529 /* Create the replacement variable. */
1530 tmp
= gfc_conv_descriptor_data_get (desc
);
1531 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1534 /* Use DESC to work out the upper bounds, strides and offset. */
1535 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1538 /* Otherwise we have a packed array. */
1539 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1540 PACKED_FULL
, se
->expr
);
1542 new_sym
->backend_decl
= value
;
1546 /* Called once all dummy argument mappings have been added to MAPPING,
1547 but before the mapping is used to evaluate expressions. Pre-evaluate
1548 the length of each argument, adding any initialization code to PRE and
1549 any finalization code to POST. */
1552 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1553 stmtblock_t
* pre
, stmtblock_t
* post
)
1555 gfc_interface_sym_mapping
*sym
;
1559 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1560 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1561 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1563 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1564 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1565 gfc_init_se (&se
, NULL
);
1566 gfc_conv_expr (&se
, expr
);
1568 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1569 gfc_add_block_to_block (pre
, &se
.pre
);
1570 gfc_add_block_to_block (post
, &se
.post
);
1572 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1577 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1581 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1582 gfc_constructor
* c
)
1584 for (; c
; c
= c
->next
)
1586 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1589 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1590 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1591 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1597 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1601 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1606 for (; ref
; ref
= ref
->next
)
1610 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1612 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1613 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1614 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1616 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1623 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1624 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1630 /* EXPR is a copy of an expression that appeared in the interface
1631 associated with MAPPING. Walk it recursively looking for references to
1632 dummy arguments that MAPPING maps to actual arguments. Replace each such
1633 reference with a reference to the associated actual argument. */
1636 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1639 gfc_interface_sym_mapping
*sym
;
1640 gfc_actual_arglist
*actual
;
1641 int seen_result
= 0;
1646 /* Copying an expression does not copy its length, so do that here. */
1647 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1649 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1650 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1653 /* Apply the mapping to any references. */
1654 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1656 /* ...and to the expression's symbol, if it has one. */
1658 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1659 if (sym
->old
== expr
->symtree
->n
.sym
)
1660 expr
->symtree
= sym
->new;
1662 /* ...and to subexpressions in expr->value. */
1663 switch (expr
->expr_type
)
1666 if (expr
->symtree
->n
.sym
->attr
.result
)
1670 case EXPR_SUBSTRING
:
1674 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1675 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1679 if (expr
->value
.function
.esym
== NULL
1680 && expr
->value
.function
.isym
!= NULL
1681 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1682 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1683 && gfc_apply_interface_mapping_to_expr (mapping
,
1684 expr
->value
.function
.actual
->expr
))
1687 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1689 gfc_free (new_expr
);
1690 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1694 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1695 if (sym
->old
== expr
->value
.function
.esym
)
1696 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1698 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1699 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1703 case EXPR_STRUCTURE
:
1704 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1711 /* Evaluate interface expression EXPR using MAPPING. Store the result
1715 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1716 gfc_se
* se
, gfc_expr
* expr
)
1718 expr
= gfc_copy_expr (expr
);
1719 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1720 gfc_conv_expr (se
, expr
);
1721 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1722 gfc_free_expr (expr
);
1725 /* Returns a reference to a temporary array into which a component of
1726 an actual argument derived type array is copied and then returned
1727 after the function call.
1728 TODO Get rid of this kludge, when array descriptors are capable of
1729 handling arrays with a bigger stride in bytes than size. */
1732 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1733 int g77
, sym_intent intent
)
1749 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1751 gfc_init_se (&lse
, NULL
);
1752 gfc_init_se (&rse
, NULL
);
1754 /* Walk the argument expression. */
1755 rss
= gfc_walk_expr (expr
);
1757 gcc_assert (rss
!= gfc_ss_terminator
);
1759 /* Initialize the scalarizer. */
1760 gfc_init_loopinfo (&loop
);
1761 gfc_add_ss_to_loop (&loop
, rss
);
1763 /* Calculate the bounds of the scalarization. */
1764 gfc_conv_ss_startstride (&loop
);
1766 /* Build an ss for the temporary. */
1767 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1768 if (GFC_ARRAY_TYPE_P (base_type
)
1769 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1770 base_type
= gfc_get_element_type (base_type
);
1772 loop
.temp_ss
= gfc_get_ss ();;
1773 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1774 loop
.temp_ss
->data
.temp
.type
= base_type
;
1776 if (expr
->ts
.type
== BT_CHARACTER
)
1778 gfc_ref
*char_ref
= expr
->ref
;
1780 for (; char_ref
; char_ref
= char_ref
->next
)
1781 if (char_ref
->type
== REF_SUBSTRING
)
1785 expr
->ts
.cl
= gfc_get_charlen ();
1786 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1787 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1789 gfc_init_se (&tmp_se
, NULL
);
1790 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1791 gfc_array_index_type
);
1792 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1793 tmp_se
.expr
, gfc_index_one_node
);
1794 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1795 gfc_init_se (&tmp_se
, NULL
);
1796 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1797 gfc_array_index_type
);
1798 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1800 expr
->ts
.cl
->backend_decl
= tmp
;
1804 loop
.temp_ss
->data
.temp
.type
1805 = gfc_typenode_for_spec (&expr
->ts
);
1806 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1809 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1810 loop
.temp_ss
->next
= gfc_ss_terminator
;
1812 /* Associate the SS with the loop. */
1813 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1815 /* Setup the scalarizing loops. */
1816 gfc_conv_loop_setup (&loop
);
1818 /* Pass the temporary descriptor back to the caller. */
1819 info
= &loop
.temp_ss
->data
.info
;
1820 parmse
->expr
= info
->descriptor
;
1822 /* Setup the gfc_se structures. */
1823 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1824 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1827 lse
.ss
= loop
.temp_ss
;
1828 gfc_mark_ss_chain_used (rss
, 1);
1829 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1831 /* Start the scalarized loop body. */
1832 gfc_start_scalarized_body (&loop
, &body
);
1834 /* Translate the expression. */
1835 gfc_conv_expr (&rse
, expr
);
1837 gfc_conv_tmp_array_ref (&lse
);
1838 gfc_advance_se_ss_chain (&lse
);
1840 if (intent
!= INTENT_OUT
)
1842 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1843 gfc_add_expr_to_block (&body
, tmp
);
1844 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1845 gfc_trans_scalarizing_loops (&loop
, &body
);
1849 /* Make sure that the temporary declaration survives by merging
1850 all the loop declarations into the current context. */
1851 for (n
= 0; n
< loop
.dimen
; n
++)
1853 gfc_merge_block_scope (&body
);
1854 body
= loop
.code
[loop
.order
[n
]];
1856 gfc_merge_block_scope (&body
);
1859 /* Add the post block after the second loop, so that any
1860 freeing of allocated memory is done at the right time. */
1861 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1863 /**********Copy the temporary back again.*********/
1865 gfc_init_se (&lse
, NULL
);
1866 gfc_init_se (&rse
, NULL
);
1868 /* Walk the argument expression. */
1869 lss
= gfc_walk_expr (expr
);
1870 rse
.ss
= loop
.temp_ss
;
1873 /* Initialize the scalarizer. */
1874 gfc_init_loopinfo (&loop2
);
1875 gfc_add_ss_to_loop (&loop2
, lss
);
1877 /* Calculate the bounds of the scalarization. */
1878 gfc_conv_ss_startstride (&loop2
);
1880 /* Setup the scalarizing loops. */
1881 gfc_conv_loop_setup (&loop2
);
1883 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1884 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1886 gfc_mark_ss_chain_used (lss
, 1);
1887 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1889 /* Declare the variable to hold the temporary offset and start the
1890 scalarized loop body. */
1891 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1892 gfc_start_scalarized_body (&loop2
, &body
);
1894 /* Build the offsets for the temporary from the loop variables. The
1895 temporary array has lbounds of zero and strides of one in all
1896 dimensions, so this is very simple. The offset is only computed
1897 outside the innermost loop, so the overall transfer could be
1898 optimized further. */
1899 info
= &rse
.ss
->data
.info
;
1901 tmp_index
= gfc_index_zero_node
;
1902 for (n
= info
->dimen
- 1; n
> 0; n
--)
1905 tmp
= rse
.loop
->loopvar
[n
];
1906 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1907 tmp
, rse
.loop
->from
[n
]);
1908 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1911 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1912 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1913 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1914 tmp_str
, gfc_index_one_node
);
1916 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1920 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1921 tmp_index
, rse
.loop
->from
[0]);
1922 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1924 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1925 rse
.loop
->loopvar
[0], offset
);
1927 /* Now use the offset for the reference. */
1928 tmp
= build_fold_indirect_ref (info
->data
);
1929 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1931 if (expr
->ts
.type
== BT_CHARACTER
)
1932 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1934 gfc_conv_expr (&lse
, expr
);
1936 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1938 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1939 gfc_add_expr_to_block (&body
, tmp
);
1941 /* Generate the copying loops. */
1942 gfc_trans_scalarizing_loops (&loop2
, &body
);
1944 /* Wrap the whole thing up by adding the second loop to the post-block
1945 and following it by the post-block of the first loop. In this way,
1946 if the temporary needs freeing, it is done after use! */
1947 if (intent
!= INTENT_IN
)
1949 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1950 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1953 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1955 gfc_cleanup_loop (&loop
);
1956 gfc_cleanup_loop (&loop2
);
1958 /* Pass the string length to the argument expression. */
1959 if (expr
->ts
.type
== BT_CHARACTER
)
1960 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1962 /* We want either the address for the data or the address of the descriptor,
1963 depending on the mode of passing array arguments. */
1965 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1967 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1972 /* Is true if an array reference is followed by a component or substring
1976 is_aliased_array (gfc_expr
* e
)
1982 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1984 if (ref
->type
== REF_ARRAY
1985 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1989 && ref
->type
!= REF_ARRAY
)
1995 /* Generate the code for argument list functions. */
1998 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2000 /* Pass by value for g77 %VAL(arg), pass the address
2001 indirectly for %LOC, else by reference. Thus %REF
2002 is a "do-nothing" and %LOC is the same as an F95
2004 if (strncmp (name
, "%VAL", 4) == 0)
2005 gfc_conv_expr (se
, expr
);
2006 else if (strncmp (name
, "%LOC", 4) == 0)
2008 gfc_conv_expr_reference (se
, expr
);
2009 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2011 else if (strncmp (name
, "%REF", 4) == 0)
2012 gfc_conv_expr_reference (se
, expr
);
2014 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2018 /* Generate code for a procedure call. Note can return se->post != NULL.
2019 If se->direct_byref is set then se->expr contains the return parameter.
2020 Return nonzero, if the call has alternate specifiers. */
2023 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2024 gfc_actual_arglist
* arg
, tree append_args
)
2026 gfc_interface_mapping mapping
;
2040 gfc_formal_arglist
*formal
;
2041 int has_alternate_specifier
= 0;
2042 bool need_interface_mapping
;
2049 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2051 arglist
= NULL_TREE
;
2052 retargs
= NULL_TREE
;
2053 stringargs
= NULL_TREE
;
2059 if (!sym
->attr
.elemental
)
2061 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2062 if (se
->ss
->useflags
)
2064 gcc_assert (gfc_return_by_reference (sym
)
2065 && sym
->result
->attr
.dimension
);
2066 gcc_assert (se
->loop
!= NULL
);
2068 /* Access the previously obtained result. */
2069 gfc_conv_tmp_array_ref (se
);
2070 gfc_advance_se_ss_chain (se
);
2074 info
= &se
->ss
->data
.info
;
2079 gfc_init_block (&post
);
2080 gfc_init_interface_mapping (&mapping
);
2081 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2082 && sym
->ts
.cl
->length
2083 && sym
->ts
.cl
->length
->expr_type
2085 || sym
->attr
.dimension
);
2086 formal
= sym
->formal
;
2087 /* Evaluate the arguments. */
2088 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2091 fsym
= formal
? formal
->sym
: NULL
;
2092 parm_kind
= MISSING
;
2096 if (se
->ignore_optional
)
2098 /* Some intrinsics have already been resolved to the correct
2102 else if (arg
->label
)
2104 has_alternate_specifier
= 1;
2109 /* Pass a NULL pointer for an absent arg. */
2110 gfc_init_se (&parmse
, NULL
);
2111 parmse
.expr
= null_pointer_node
;
2112 if (arg
->missing_arg_type
== BT_CHARACTER
)
2113 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2116 else if (se
->ss
&& se
->ss
->useflags
)
2118 /* An elemental function inside a scalarized loop. */
2119 gfc_init_se (&parmse
, se
);
2120 gfc_conv_expr_reference (&parmse
, e
);
2121 parm_kind
= ELEMENTAL
;
2125 /* A scalar or transformational function. */
2126 gfc_init_se (&parmse
, NULL
);
2127 argss
= gfc_walk_expr (e
);
2129 if (argss
== gfc_ss_terminator
)
2131 if (fsym
&& fsym
->attr
.value
)
2133 gfc_conv_expr (&parmse
, e
);
2135 else if (arg
->name
&& arg
->name
[0] == '%')
2136 /* Argument list functions %VAL, %LOC and %REF are signalled
2137 through arg->name. */
2138 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2139 else if ((e
->expr_type
== EXPR_FUNCTION
)
2140 && e
->symtree
->n
.sym
->attr
.pointer
2141 && fsym
&& fsym
->attr
.target
)
2143 gfc_conv_expr (&parmse
, e
);
2144 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2148 gfc_conv_expr_reference (&parmse
, e
);
2149 if (fsym
&& fsym
->attr
.pointer
2150 && fsym
->attr
.flavor
!= FL_PROCEDURE
2151 && e
->expr_type
!= EXPR_NULL
)
2153 /* Scalar pointer dummy args require an extra level of
2154 indirection. The null pointer already contains
2155 this level of indirection. */
2156 parm_kind
= SCALAR_POINTER
;
2157 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2163 /* If the procedure requires an explicit interface, the actual
2164 argument is passed according to the corresponding formal
2165 argument. If the corresponding formal argument is a POINTER,
2166 ALLOCATABLE or assumed shape, we do not use g77's calling
2167 convention, and pass the address of the array descriptor
2168 instead. Otherwise we use g77's calling convention. */
2171 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2172 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2173 f
= f
|| !sym
->attr
.always_explicit
;
2175 if (e
->expr_type
== EXPR_VARIABLE
2176 && is_aliased_array (e
))
2177 /* The actual argument is a component reference to an
2178 array of derived types. In this case, the argument
2179 is converted to a temporary, which is passed and then
2180 written back after the procedure call. */
2181 gfc_conv_aliased_arg (&parmse
, e
, f
,
2182 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2184 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2186 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2187 allocated on entry, it must be deallocated. */
2188 if (fsym
&& fsym
->attr
.allocatable
2189 && fsym
->attr
.intent
== INTENT_OUT
)
2191 tmp
= build_fold_indirect_ref (parmse
.expr
);
2192 tmp
= gfc_trans_dealloc_allocated (tmp
);
2193 gfc_add_expr_to_block (&se
->pre
, tmp
);
2203 /* If an optional argument is itself an optional dummy
2204 argument, check its presence and substitute a null
2206 if (e
->expr_type
== EXPR_VARIABLE
2207 && e
->symtree
->n
.sym
->attr
.optional
2208 && fsym
->attr
.optional
)
2209 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2211 /* If an INTENT(OUT) dummy of derived type has a default
2212 initializer, it must be (re)initialized here. */
2213 if (fsym
->attr
.intent
== INTENT_OUT
2214 && fsym
->ts
.type
== BT_DERIVED
2217 gcc_assert (!fsym
->attr
.allocatable
);
2218 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2219 gfc_add_expr_to_block (&se
->pre
, tmp
);
2222 /* Obtain the character length of an assumed character
2223 length procedure from the typespec. */
2224 if (fsym
->ts
.type
== BT_CHARACTER
2225 && parmse
.string_length
== NULL_TREE
2226 && e
->ts
.type
== BT_PROCEDURE
2227 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2228 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2230 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2231 parmse
.string_length
2232 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2236 if (need_interface_mapping
)
2237 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2240 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2241 gfc_add_block_to_block (&post
, &parmse
.post
);
2243 /* Allocated allocatable components of derived types must be
2244 deallocated for INTENT(OUT) dummy arguments and non-variable
2245 scalars. Non-variable arrays are dealt with in trans-array.c
2246 (gfc_conv_array_parameter). */
2247 if (e
&& e
->ts
.type
== BT_DERIVED
2248 && e
->ts
.derived
->attr
.alloc_comp
2249 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2251 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2254 tmp
= build_fold_indirect_ref (parmse
.expr
);
2255 parm_rank
= e
->rank
;
2263 case (SCALAR_POINTER
):
2264 tmp
= build_fold_indirect_ref (tmp
);
2271 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2272 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2273 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2274 tmp
, build_empty_stmt ());
2276 if (e
->expr_type
!= EXPR_VARIABLE
)
2277 /* Don't deallocate non-variables until they have been used. */
2278 gfc_add_expr_to_block (&se
->post
, tmp
);
2281 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2282 gfc_add_expr_to_block (&se
->pre
, tmp
);
2286 /* Character strings are passed as two parameters, a length and a
2288 if (parmse
.string_length
!= NULL_TREE
)
2289 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2291 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2293 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2296 if (ts
.type
== BT_CHARACTER
)
2298 if (sym
->ts
.cl
->length
== NULL
)
2300 /* Assumed character length results are not allowed by 5.1.1.5 of the
2301 standard and are trapped in resolve.c; except in the case of SPREAD
2302 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2303 we take the character length of the first argument for the result.
2304 For dummies, we have to look through the formal argument list for
2305 this function and use the character length found there.*/
2306 if (!sym
->attr
.dummy
)
2307 cl
.backend_decl
= TREE_VALUE (stringargs
);
2310 formal
= sym
->ns
->proc_name
->formal
;
2311 for (; formal
; formal
= formal
->next
)
2312 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2313 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2320 /* Calculate the length of the returned string. */
2321 gfc_init_se (&parmse
, NULL
);
2322 if (need_interface_mapping
)
2323 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2325 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2326 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2327 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2329 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2330 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2331 build_int_cst (gfc_charlen_type_node
, 0));
2332 cl
.backend_decl
= tmp
;
2335 /* Set up a charlen structure for it. */
2340 len
= cl
.backend_decl
;
2343 byref
= gfc_return_by_reference (sym
);
2346 if (se
->direct_byref
)
2348 /* Sometimes, too much indirection can be applied; eg. for
2349 function_result = array_valued_recursive_function. */
2350 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2351 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2352 && GFC_DESCRIPTOR_TYPE_P
2353 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2354 se
->expr
= build_fold_indirect_ref (se
->expr
);
2356 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2358 else if (sym
->result
->attr
.dimension
)
2360 gcc_assert (se
->loop
&& info
);
2362 /* Set the type of the array. */
2363 tmp
= gfc_typenode_for_spec (&ts
);
2364 info
->dimen
= se
->loop
->dimen
;
2366 /* Evaluate the bounds of the result, if known. */
2367 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2369 /* Create a temporary to store the result. In case the function
2370 returns a pointer, the temporary will be a shallow copy and
2371 mustn't be deallocated. */
2372 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2373 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2374 false, !sym
->attr
.pointer
, callee_alloc
);
2376 /* Pass the temporary as the first argument. */
2377 tmp
= info
->descriptor
;
2378 tmp
= build_fold_addr_expr (tmp
);
2379 retargs
= gfc_chainon_list (retargs
, tmp
);
2381 else if (ts
.type
== BT_CHARACTER
)
2383 /* Pass the string length. */
2384 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2385 type
= build_pointer_type (type
);
2387 /* Return an address to a char[0:len-1]* temporary for
2388 character pointers. */
2389 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2391 /* Build char[0:len-1] * pstr. */
2392 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2393 build_int_cst (gfc_charlen_type_node
, 1));
2394 tmp
= build_range_type (gfc_array_index_type
,
2395 gfc_index_zero_node
, tmp
);
2396 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2397 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2399 /* Provide an address expression for the function arguments. */
2400 var
= build_fold_addr_expr (var
);
2403 var
= gfc_conv_string_tmp (se
, type
, len
);
2405 retargs
= gfc_chainon_list (retargs
, var
);
2409 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2411 type
= gfc_get_complex_type (ts
.kind
);
2412 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2413 retargs
= gfc_chainon_list (retargs
, var
);
2416 /* Add the string length to the argument list. */
2417 if (ts
.type
== BT_CHARACTER
)
2418 retargs
= gfc_chainon_list (retargs
, len
);
2420 gfc_free_interface_mapping (&mapping
);
2422 /* Add the return arguments. */
2423 arglist
= chainon (retargs
, arglist
);
2425 /* Add the hidden string length parameters to the arguments. */
2426 arglist
= chainon (arglist
, stringargs
);
2428 /* We may want to append extra arguments here. This is used e.g. for
2429 calls to libgfortran_matmul_??, which need extra information. */
2430 if (append_args
!= NULL_TREE
)
2431 arglist
= chainon (arglist
, append_args
);
2433 /* Generate the actual call. */
2434 gfc_conv_function_val (se
, sym
);
2436 /* If there are alternate return labels, function type should be
2437 integer. Can't modify the type in place though, since it can be shared
2438 with other functions. For dummy arguments, the typing is done to
2439 to this result, even if it has to be repeated for each call. */
2440 if (has_alternate_specifier
2441 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2443 if (!sym
->attr
.dummy
)
2445 TREE_TYPE (sym
->backend_decl
)
2446 = build_function_type (integer_type_node
,
2447 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2448 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2451 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2454 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2455 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2457 /* If we have a pointer function, but we don't want a pointer, e.g.
2460 where f is pointer valued, we have to dereference the result. */
2461 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2462 se
->expr
= build_fold_indirect_ref (se
->expr
);
2464 /* f2c calling conventions require a scalar default real function to
2465 return a double precision result. Convert this back to default
2466 real. We only care about the cases that can happen in Fortran 77.
2468 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2469 && sym
->ts
.kind
== gfc_default_real_kind
2470 && !sym
->attr
.always_explicit
)
2471 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2473 /* A pure function may still have side-effects - it may modify its
2475 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2477 if (!sym
->attr
.pure
)
2478 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2483 /* Add the function call to the pre chain. There is no expression. */
2484 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2485 se
->expr
= NULL_TREE
;
2487 if (!se
->direct_byref
)
2489 if (sym
->attr
.dimension
)
2491 if (flag_bounds_check
)
2493 /* Check the data pointer hasn't been modified. This would
2494 happen in a function returning a pointer. */
2495 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2496 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2498 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2500 se
->expr
= info
->descriptor
;
2501 /* Bundle in the string length. */
2502 se
->string_length
= len
;
2504 else if (sym
->ts
.type
== BT_CHARACTER
)
2506 /* Dereference for character pointer results. */
2507 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2508 se
->expr
= build_fold_indirect_ref (var
);
2512 se
->string_length
= len
;
2516 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2517 se
->expr
= build_fold_indirect_ref (var
);
2522 /* Follow the function call with the argument post block. */
2524 gfc_add_block_to_block (&se
->pre
, &post
);
2526 gfc_add_block_to_block (&se
->post
, &post
);
2528 return has_alternate_specifier
;
2532 /* Generate code to copy a string. */
2535 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2536 tree slength
, tree src
)
2538 tree tmp
, dlen
, slen
;
2546 stmtblock_t tempblock
;
2548 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2549 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2551 /* Deal with single character specially. */
2552 dsc
= gfc_to_single_character (dlen
, dest
);
2553 ssc
= gfc_to_single_character (slen
, src
);
2554 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2556 gfc_add_modify_expr (block
, dsc
, ssc
);
2560 /* Do nothing if the destination length is zero. */
2561 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2562 build_int_cst (size_type_node
, 0));
2564 /* The following code was previously in _gfortran_copy_string:
2566 // The two strings may overlap so we use memmove.
2568 copy_string (GFC_INTEGER_4 destlen, char * dest,
2569 GFC_INTEGER_4 srclen, const char * src)
2571 if (srclen >= destlen)
2573 // This will truncate if too long.
2574 memmove (dest, src, destlen);
2578 memmove (dest, src, srclen);
2580 memset (&dest[srclen], ' ', destlen - srclen);
2584 We're now doing it here for better optimization, but the logic
2587 /* Truncate string if source is too long. */
2588 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2589 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2590 3, dest
, src
, dlen
);
2592 /* Else copy and pad with spaces. */
2593 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2594 3, dest
, src
, slen
);
2596 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, dest
,
2597 fold_convert (sizetype
, slen
));
2598 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2600 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2601 lang_hooks
.to_target_charset (' ')),
2602 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2605 gfc_init_block (&tempblock
);
2606 gfc_add_expr_to_block (&tempblock
, tmp3
);
2607 gfc_add_expr_to_block (&tempblock
, tmp4
);
2608 tmp3
= gfc_finish_block (&tempblock
);
2610 /* The whole copy_string function is there. */
2611 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2612 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2613 gfc_add_expr_to_block (block
, tmp
);
2617 /* Translate a statement function.
2618 The value of a statement function reference is obtained by evaluating the
2619 expression using the values of the actual arguments for the values of the
2620 corresponding dummy arguments. */
2623 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2627 gfc_formal_arglist
*fargs
;
2628 gfc_actual_arglist
*args
;
2631 gfc_saved_var
*saved_vars
;
2637 sym
= expr
->symtree
->n
.sym
;
2638 args
= expr
->value
.function
.actual
;
2639 gfc_init_se (&lse
, NULL
);
2640 gfc_init_se (&rse
, NULL
);
2643 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2645 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2646 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2648 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2650 /* Each dummy shall be specified, explicitly or implicitly, to be
2652 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2655 /* Create a temporary to hold the value. */
2656 type
= gfc_typenode_for_spec (&fsym
->ts
);
2657 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2659 if (fsym
->ts
.type
== BT_CHARACTER
)
2661 /* Copy string arguments. */
2664 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2665 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2667 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2668 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2671 gfc_conv_expr (&rse
, args
->expr
);
2672 gfc_conv_string_parameter (&rse
);
2673 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2674 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2676 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2678 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2679 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2683 /* For everything else, just evaluate the expression. */
2684 gfc_conv_expr (&lse
, args
->expr
);
2686 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2687 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2688 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2694 /* Use the temporary variables in place of the real ones. */
2695 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2696 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2698 gfc_conv_expr (se
, sym
->value
);
2700 if (sym
->ts
.type
== BT_CHARACTER
)
2702 gfc_conv_const_charlen (sym
->ts
.cl
);
2704 /* Force the expression to the correct length. */
2705 if (!INTEGER_CST_P (se
->string_length
)
2706 || tree_int_cst_lt (se
->string_length
,
2707 sym
->ts
.cl
->backend_decl
))
2709 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2710 tmp
= gfc_create_var (type
, sym
->name
);
2711 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2712 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2713 se
->string_length
, se
->expr
);
2716 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2719 /* Restore the original variables. */
2720 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2721 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2722 gfc_free (saved_vars
);
2726 /* Translate a function expression. */
2729 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2733 if (expr
->value
.function
.isym
)
2735 gfc_conv_intrinsic_function (se
, expr
);
2739 /* We distinguish statement functions from general functions to improve
2740 runtime performance. */
2741 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2743 gfc_conv_statement_function (se
, expr
);
2747 /* expr.value.function.esym is the resolved (specific) function symbol for
2748 most functions. However this isn't set for dummy procedures. */
2749 sym
= expr
->value
.function
.esym
;
2751 sym
= expr
->symtree
->n
.sym
;
2752 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2757 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2759 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2760 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2762 gfc_conv_tmp_array_ref (se
);
2763 gfc_advance_se_ss_chain (se
);
2767 /* Build a static initializer. EXPR is the expression for the initial value.
2768 The other parameters describe the variable of the component being
2769 initialized. EXPR may be null. */
2772 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2773 bool array
, bool pointer
)
2777 if (!(expr
|| pointer
))
2780 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2781 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
2782 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
2783 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
))
2784 expr
= gfc_int_expr (0);
2788 /* Arrays need special handling. */
2790 return gfc_build_null_descriptor (type
);
2792 return gfc_conv_array_initializer (type
, expr
);
2795 return fold_convert (type
, null_pointer_node
);
2801 gfc_init_se (&se
, NULL
);
2802 gfc_conv_structure (&se
, expr
, 1);
2806 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2809 gfc_init_se (&se
, NULL
);
2810 gfc_conv_constant (&se
, expr
);
2817 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2829 gfc_start_block (&block
);
2831 /* Initialize the scalarizer. */
2832 gfc_init_loopinfo (&loop
);
2834 gfc_init_se (&lse
, NULL
);
2835 gfc_init_se (&rse
, NULL
);
2838 rss
= gfc_walk_expr (expr
);
2839 if (rss
== gfc_ss_terminator
)
2841 /* The rhs is scalar. Add a ss for the expression. */
2842 rss
= gfc_get_ss ();
2843 rss
->next
= gfc_ss_terminator
;
2844 rss
->type
= GFC_SS_SCALAR
;
2848 /* Create a SS for the destination. */
2849 lss
= gfc_get_ss ();
2850 lss
->type
= GFC_SS_COMPONENT
;
2852 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2853 lss
->next
= gfc_ss_terminator
;
2854 lss
->data
.info
.dimen
= cm
->as
->rank
;
2855 lss
->data
.info
.descriptor
= dest
;
2856 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2857 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2858 for (n
= 0; n
< cm
->as
->rank
; n
++)
2860 lss
->data
.info
.dim
[n
] = n
;
2861 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2862 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2864 mpz_init (lss
->shape
[n
]);
2865 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2866 cm
->as
->lower
[n
]->value
.integer
);
2867 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2870 /* Associate the SS with the loop. */
2871 gfc_add_ss_to_loop (&loop
, lss
);
2872 gfc_add_ss_to_loop (&loop
, rss
);
2874 /* Calculate the bounds of the scalarization. */
2875 gfc_conv_ss_startstride (&loop
);
2877 /* Setup the scalarizing loops. */
2878 gfc_conv_loop_setup (&loop
);
2880 /* Setup the gfc_se structures. */
2881 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2882 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2885 gfc_mark_ss_chain_used (rss
, 1);
2887 gfc_mark_ss_chain_used (lss
, 1);
2889 /* Start the scalarized loop body. */
2890 gfc_start_scalarized_body (&loop
, &body
);
2892 gfc_conv_tmp_array_ref (&lse
);
2893 if (cm
->ts
.type
== BT_CHARACTER
)
2894 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2896 gfc_conv_expr (&rse
, expr
);
2898 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2899 gfc_add_expr_to_block (&body
, tmp
);
2901 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2903 /* Generate the copying loops. */
2904 gfc_trans_scalarizing_loops (&loop
, &body
);
2906 /* Wrap the whole thing up. */
2907 gfc_add_block_to_block (&block
, &loop
.pre
);
2908 gfc_add_block_to_block (&block
, &loop
.post
);
2910 for (n
= 0; n
< cm
->as
->rank
; n
++)
2911 mpz_clear (lss
->shape
[n
]);
2912 gfc_free (lss
->shape
);
2914 gfc_cleanup_loop (&loop
);
2916 return gfc_finish_block (&block
);
2920 /* Assign a single component of a derived type constructor. */
2923 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2933 gfc_start_block (&block
);
2937 gfc_init_se (&se
, NULL
);
2938 /* Pointer component. */
2941 /* Array pointer. */
2942 if (expr
->expr_type
== EXPR_NULL
)
2943 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2946 rss
= gfc_walk_expr (expr
);
2947 se
.direct_byref
= 1;
2949 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2950 gfc_add_block_to_block (&block
, &se
.pre
);
2951 gfc_add_block_to_block (&block
, &se
.post
);
2956 /* Scalar pointers. */
2957 se
.want_pointer
= 1;
2958 gfc_conv_expr (&se
, expr
);
2959 gfc_add_block_to_block (&block
, &se
.pre
);
2960 gfc_add_modify_expr (&block
, dest
,
2961 fold_convert (TREE_TYPE (dest
), se
.expr
));
2962 gfc_add_block_to_block (&block
, &se
.post
);
2965 else if (cm
->dimension
)
2967 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2968 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2969 else if (cm
->allocatable
)
2973 gfc_init_se (&se
, NULL
);
2975 rss
= gfc_walk_expr (expr
);
2976 se
.want_pointer
= 0;
2977 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2978 gfc_add_block_to_block (&block
, &se
.pre
);
2980 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2981 gfc_add_modify_expr (&block
, dest
, tmp
);
2983 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2984 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2987 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2988 TREE_TYPE(cm
->backend_decl
),
2991 gfc_add_expr_to_block (&block
, tmp
);
2993 gfc_add_block_to_block (&block
, &se
.post
);
2994 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2996 /* Shift the lbound and ubound of temporaries to being unity, rather
2997 than zero, based. Calculate the offset for all cases. */
2998 offset
= gfc_conv_descriptor_offset (dest
);
2999 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3000 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3001 for (n
= 0; n
< expr
->rank
; n
++)
3003 if (expr
->expr_type
!= EXPR_VARIABLE
3004 && expr
->expr_type
!= EXPR_CONSTANT
)
3006 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3007 gfc_add_modify_expr (&block
, tmp
,
3008 fold_build2 (PLUS_EXPR
,
3009 gfc_array_index_type
,
3010 tmp
, gfc_index_one_node
));
3011 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3012 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3014 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3015 gfc_conv_descriptor_lbound (dest
,
3017 gfc_conv_descriptor_stride (dest
,
3019 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3020 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3021 gfc_add_modify_expr (&block
, offset
, tmp
);
3026 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3027 gfc_add_expr_to_block (&block
, tmp
);
3030 else if (expr
->ts
.type
== BT_DERIVED
)
3032 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3034 gfc_init_se (&se
, NULL
);
3035 gfc_conv_expr (&se
, expr
);
3036 gfc_add_modify_expr (&block
, dest
,
3037 fold_convert (TREE_TYPE (dest
), se
.expr
));
3041 /* Nested constructors. */
3042 tmp
= gfc_trans_structure_assign (dest
, expr
);
3043 gfc_add_expr_to_block (&block
, tmp
);
3048 /* Scalar component. */
3049 gfc_init_se (&se
, NULL
);
3050 gfc_init_se (&lse
, NULL
);
3052 gfc_conv_expr (&se
, expr
);
3053 if (cm
->ts
.type
== BT_CHARACTER
)
3054 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3056 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3057 gfc_add_expr_to_block (&block
, tmp
);
3059 return gfc_finish_block (&block
);
3062 /* Assign a derived type constructor to a variable. */
3065 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3073 gfc_start_block (&block
);
3074 cm
= expr
->ts
.derived
->components
;
3075 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3077 /* Skip absent members in default initializers. */
3081 field
= cm
->backend_decl
;
3082 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3083 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3084 gfc_add_expr_to_block (&block
, tmp
);
3086 return gfc_finish_block (&block
);
3089 /* Build an expression for a constructor. If init is nonzero then
3090 this is part of a static variable initializer. */
3093 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3100 VEC(constructor_elt
,gc
) *v
= NULL
;
3102 gcc_assert (se
->ss
== NULL
);
3103 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3104 type
= gfc_typenode_for_spec (&expr
->ts
);
3108 /* Create a temporary variable and fill it in. */
3109 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3110 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3111 gfc_add_expr_to_block (&se
->pre
, tmp
);
3115 cm
= expr
->ts
.derived
->components
;
3117 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3119 /* Skip absent members in default initializers and allocatable
3120 components. Although the latter have a default initializer
3121 of EXPR_NULL,... by default, the static nullify is not needed
3122 since this is done every time we come into scope. */
3123 if (!c
->expr
|| cm
->allocatable
)
3126 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3127 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3129 /* Append it to the constructor list. */
3130 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3132 se
->expr
= build_constructor (type
, v
);
3136 /* Translate a substring expression. */
3139 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3145 gcc_assert (ref
->type
== REF_SUBSTRING
);
3147 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3148 expr
->value
.character
.string
);
3149 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3150 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3152 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3156 /* Entry point for expression translation. Evaluates a scalar quantity.
3157 EXPR is the expression to be translated, and SE is the state structure if
3158 called from within the scalarized. */
3161 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3163 if (se
->ss
&& se
->ss
->expr
== expr
3164 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3166 /* Substitute a scalar expression evaluated outside the scalarization
3168 se
->expr
= se
->ss
->data
.scalar
.expr
;
3169 se
->string_length
= se
->ss
->string_length
;
3170 gfc_advance_se_ss_chain (se
);
3174 /* We need to convert the expressions for the iso_c_binding derived types.
3175 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3176 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3177 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3178 updated to be an integer with a kind equal to the size of a (void *). */
3179 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3180 && expr
->ts
.derived
->attr
.is_iso_c
)
3182 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3183 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3185 /* Set expr_type to EXPR_NULL, which will result in
3186 null_pointer_node being used below. */
3187 expr
->expr_type
= EXPR_NULL
;
3191 /* Update the type/kind of the expression to be what the new
3192 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3193 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3194 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3195 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3199 switch (expr
->expr_type
)
3202 gfc_conv_expr_op (se
, expr
);
3206 gfc_conv_function_expr (se
, expr
);
3210 gfc_conv_constant (se
, expr
);
3214 gfc_conv_variable (se
, expr
);
3218 se
->expr
= null_pointer_node
;
3221 case EXPR_SUBSTRING
:
3222 gfc_conv_substring_expr (se
, expr
);
3225 case EXPR_STRUCTURE
:
3226 gfc_conv_structure (se
, expr
, 0);
3230 gfc_conv_array_constructor_expr (se
, expr
);
3239 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3240 of an assignment. */
3242 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3244 gfc_conv_expr (se
, expr
);
3245 /* All numeric lvalues should have empty post chains. If not we need to
3246 figure out a way of rewriting an lvalue so that it has no post chain. */
3247 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3250 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3251 numeric expressions. Used for scalar values where inserting cleanup code
3254 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3258 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3259 gfc_conv_expr (se
, expr
);
3262 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3263 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3265 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3269 /* Helper to translate and expression and convert it to a particular type. */
3271 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3273 gfc_conv_expr_val (se
, expr
);
3274 se
->expr
= convert (type
, se
->expr
);
3278 /* Converts an expression so that it can be passed by reference. Scalar
3282 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3286 if (se
->ss
&& se
->ss
->expr
== expr
3287 && se
->ss
->type
== GFC_SS_REFERENCE
)
3289 se
->expr
= se
->ss
->data
.scalar
.expr
;
3290 se
->string_length
= se
->ss
->string_length
;
3291 gfc_advance_se_ss_chain (se
);
3295 if (expr
->ts
.type
== BT_CHARACTER
)
3297 gfc_conv_expr (se
, expr
);
3298 gfc_conv_string_parameter (se
);
3302 if (expr
->expr_type
== EXPR_VARIABLE
)
3304 se
->want_pointer
= 1;
3305 gfc_conv_expr (se
, expr
);
3308 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3309 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3310 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3316 gfc_conv_expr (se
, expr
);
3318 /* Create a temporary var to hold the value. */
3319 if (TREE_CONSTANT (se
->expr
))
3321 tree tmp
= se
->expr
;
3322 STRIP_TYPE_NOPS (tmp
);
3323 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3324 DECL_INITIAL (var
) = tmp
;
3325 TREE_STATIC (var
) = 1;
3330 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3331 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3333 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3335 /* Take the address of that value. */
3336 se
->expr
= build_fold_addr_expr (var
);
3341 gfc_trans_pointer_assign (gfc_code
* code
)
3343 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3347 /* Generate code for a pointer assignment. */
3350 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3360 gfc_start_block (&block
);
3362 gfc_init_se (&lse
, NULL
);
3364 lss
= gfc_walk_expr (expr1
);
3365 rss
= gfc_walk_expr (expr2
);
3366 if (lss
== gfc_ss_terminator
)
3368 /* Scalar pointers. */
3369 lse
.want_pointer
= 1;
3370 gfc_conv_expr (&lse
, expr1
);
3371 gcc_assert (rss
== gfc_ss_terminator
);
3372 gfc_init_se (&rse
, NULL
);
3373 rse
.want_pointer
= 1;
3374 gfc_conv_expr (&rse
, expr2
);
3375 gfc_add_block_to_block (&block
, &lse
.pre
);
3376 gfc_add_block_to_block (&block
, &rse
.pre
);
3377 gfc_add_modify_expr (&block
, lse
.expr
,
3378 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3379 gfc_add_block_to_block (&block
, &rse
.post
);
3380 gfc_add_block_to_block (&block
, &lse
.post
);
3384 /* Array pointer. */
3385 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3386 switch (expr2
->expr_type
)
3389 /* Just set the data pointer to null. */
3390 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3394 /* Assign directly to the pointer's descriptor. */
3395 lse
.direct_byref
= 1;
3396 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3400 /* Assign to a temporary descriptor and then copy that
3401 temporary to the pointer. */
3403 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3406 lse
.direct_byref
= 1;
3407 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3408 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3411 gfc_add_block_to_block (&block
, &lse
.pre
);
3412 gfc_add_block_to_block (&block
, &lse
.post
);
3414 return gfc_finish_block (&block
);
3418 /* Makes sure se is suitable for passing as a function string parameter. */
3419 /* TODO: Need to check all callers fo this function. It may be abused. */
3422 gfc_conv_string_parameter (gfc_se
* se
)
3426 if (TREE_CODE (se
->expr
) == STRING_CST
)
3428 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3432 type
= TREE_TYPE (se
->expr
);
3433 if (TYPE_STRING_FLAG (type
))
3435 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3436 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3439 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3440 gcc_assert (se
->string_length
3441 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3445 /* Generate code for assignment of scalar variables. Includes character
3446 strings and derived types with allocatable components. */
3449 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3450 bool l_is_temp
, bool r_is_var
)
3456 gfc_init_block (&block
);
3458 if (ts
.type
== BT_CHARACTER
)
3460 gcc_assert (lse
->string_length
!= NULL_TREE
3461 && rse
->string_length
!= NULL_TREE
);
3463 gfc_conv_string_parameter (lse
);
3464 gfc_conv_string_parameter (rse
);
3466 gfc_add_block_to_block (&block
, &lse
->pre
);
3467 gfc_add_block_to_block (&block
, &rse
->pre
);
3469 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3470 rse
->string_length
, rse
->expr
);
3472 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3476 /* Are the rhs and the lhs the same? */
3479 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3480 build_fold_addr_expr (lse
->expr
),
3481 build_fold_addr_expr (rse
->expr
));
3482 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3485 /* Deallocate the lhs allocated components as long as it is not
3486 the same as the rhs. */
3489 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3491 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3492 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3495 gfc_add_block_to_block (&block
, &lse
->pre
);
3496 gfc_add_block_to_block (&block
, &rse
->pre
);
3498 gfc_add_modify_expr (&block
, lse
->expr
,
3499 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3501 /* Do a deep copy if the rhs is a variable, if it is not the
3505 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3506 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3507 gfc_add_expr_to_block (&block
, tmp
);
3512 gfc_add_block_to_block (&block
, &lse
->pre
);
3513 gfc_add_block_to_block (&block
, &rse
->pre
);
3515 gfc_add_modify_expr (&block
, lse
->expr
,
3516 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3519 gfc_add_block_to_block (&block
, &lse
->post
);
3520 gfc_add_block_to_block (&block
, &rse
->post
);
3522 return gfc_finish_block (&block
);
3526 /* Try to translate array(:) = func (...), where func is a transformational
3527 array function, without using a temporary. Returns NULL is this isn't the
3531 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3536 bool seen_array_ref
;
3538 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3539 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3542 /* Elemental functions don't need a temporary anyway. */
3543 if (expr2
->value
.function
.esym
!= NULL
3544 && expr2
->value
.function
.esym
->attr
.elemental
)
3547 /* Fail if EXPR1 can't be expressed as a descriptor. */
3548 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3551 /* Functions returning pointers need temporaries. */
3552 if (expr2
->symtree
->n
.sym
->attr
.pointer
3553 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3556 /* Character array functions need temporaries unless the
3557 character lengths are the same. */
3558 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3560 if (expr1
->ts
.cl
->length
== NULL
3561 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3564 if (expr2
->ts
.cl
->length
== NULL
3565 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3568 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3569 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3573 /* Check that no LHS component references appear during an array
3574 reference. This is needed because we do not have the means to
3575 span any arbitrary stride with an array descriptor. This check
3576 is not needed for the rhs because the function result has to be
3578 seen_array_ref
= false;
3579 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3581 if (ref
->type
== REF_ARRAY
)
3582 seen_array_ref
= true;
3583 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3587 /* Check for a dependency. */
3588 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3589 expr2
->value
.function
.esym
,
3590 expr2
->value
.function
.actual
))
3593 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3595 gcc_assert (expr2
->value
.function
.isym
3596 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3597 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3599 ss
= gfc_walk_expr (expr1
);
3600 gcc_assert (ss
!= gfc_ss_terminator
);
3601 gfc_init_se (&se
, NULL
);
3602 gfc_start_block (&se
.pre
);
3603 se
.want_pointer
= 1;
3605 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3607 se
.direct_byref
= 1;
3608 se
.ss
= gfc_walk_expr (expr2
);
3609 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3610 gfc_conv_function_expr (&se
, expr2
);
3611 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3613 return gfc_finish_block (&se
.pre
);
3616 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3619 is_zero_initializer_p (gfc_expr
* expr
)
3621 if (expr
->expr_type
!= EXPR_CONSTANT
)
3624 /* We ignore constants with prescribed memory representations for now. */
3625 if (expr
->representation
.string
)
3628 switch (expr
->ts
.type
)
3631 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3634 return mpfr_zero_p (expr
->value
.real
)
3635 && MPFR_SIGN (expr
->value
.real
) >= 0;
3638 return expr
->value
.logical
== 0;
3641 return mpfr_zero_p (expr
->value
.complex.r
)
3642 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3643 && mpfr_zero_p (expr
->value
.complex.i
)
3644 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3652 /* Try to efficiently translate array(:) = 0. Return NULL if this
3656 gfc_trans_zero_assign (gfc_expr
* expr
)
3658 tree dest
, len
, type
;
3662 sym
= expr
->symtree
->n
.sym
;
3663 dest
= gfc_get_symbol_decl (sym
);
3665 type
= TREE_TYPE (dest
);
3666 if (POINTER_TYPE_P (type
))
3667 type
= TREE_TYPE (type
);
3668 if (!GFC_ARRAY_TYPE_P (type
))
3671 /* Determine the length of the array. */
3672 len
= GFC_TYPE_ARRAY_SIZE (type
);
3673 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3676 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3677 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3678 fold_convert (gfc_array_index_type
, tmp
));
3680 /* Convert arguments to the correct types. */
3681 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3682 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3684 dest
= fold_convert (pvoid_type_node
, dest
);
3685 len
= fold_convert (size_type_node
, len
);
3687 /* Construct call to __builtin_memset. */
3688 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3689 3, dest
, integer_zero_node
, len
);
3690 return fold_convert (void_type_node
, tmp
);
3694 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3695 that constructs the call to __builtin_memcpy. */
3698 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3702 /* Convert arguments to the correct types. */
3703 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3704 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3706 dst
= fold_convert (pvoid_type_node
, dst
);
3708 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3709 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3711 src
= fold_convert (pvoid_type_node
, src
);
3713 len
= fold_convert (size_type_node
, len
);
3715 /* Construct call to __builtin_memcpy. */
3716 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3717 return fold_convert (void_type_node
, tmp
);
3721 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3722 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3723 source/rhs, both are gfc_full_array_ref_p which have been checked for
3727 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3729 tree dst
, dlen
, dtype
;
3730 tree src
, slen
, stype
;
3733 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3734 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3736 dtype
= TREE_TYPE (dst
);
3737 if (POINTER_TYPE_P (dtype
))
3738 dtype
= TREE_TYPE (dtype
);
3739 stype
= TREE_TYPE (src
);
3740 if (POINTER_TYPE_P (stype
))
3741 stype
= TREE_TYPE (stype
);
3743 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3746 /* Determine the lengths of the arrays. */
3747 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3748 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3750 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3751 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3752 fold_convert (gfc_array_index_type
, tmp
));
3754 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3755 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3757 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3758 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3759 fold_convert (gfc_array_index_type
, tmp
));
3761 /* Sanity check that they are the same. This should always be
3762 the case, as we should already have checked for conformance. */
3763 if (!tree_int_cst_equal (slen
, dlen
))
3766 return gfc_build_memcpy_call (dst
, src
, dlen
);
3770 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3771 this can't be done. EXPR1 is the destination/lhs for which
3772 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3775 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3777 unsigned HOST_WIDE_INT nelem
;
3783 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3787 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3788 dtype
= TREE_TYPE (dst
);
3789 if (POINTER_TYPE_P (dtype
))
3790 dtype
= TREE_TYPE (dtype
);
3791 if (!GFC_ARRAY_TYPE_P (dtype
))
3794 /* Determine the lengths of the array. */
3795 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3796 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3799 /* Confirm that the constructor is the same size. */
3800 if (compare_tree_int (len
, nelem
) != 0)
3803 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3804 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3805 fold_convert (gfc_array_index_type
, tmp
));
3807 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3808 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3810 stype
= TREE_TYPE (src
);
3811 if (POINTER_TYPE_P (stype
))
3812 stype
= TREE_TYPE (stype
);
3814 return gfc_build_memcpy_call (dst
, src
, len
);
3818 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3819 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3822 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3827 gfc_ss
*lss_section
;
3835 /* Assignment of the form lhs = rhs. */
3836 gfc_start_block (&block
);
3838 gfc_init_se (&lse
, NULL
);
3839 gfc_init_se (&rse
, NULL
);
3842 lss
= gfc_walk_expr (expr1
);
3844 if (lss
!= gfc_ss_terminator
)
3846 /* The assignment needs scalarization. */
3849 /* Find a non-scalar SS from the lhs. */
3850 while (lss_section
!= gfc_ss_terminator
3851 && lss_section
->type
!= GFC_SS_SECTION
)
3852 lss_section
= lss_section
->next
;
3854 gcc_assert (lss_section
!= gfc_ss_terminator
);
3856 /* Initialize the scalarizer. */
3857 gfc_init_loopinfo (&loop
);
3860 rss
= gfc_walk_expr (expr2
);
3861 if (rss
== gfc_ss_terminator
)
3863 /* The rhs is scalar. Add a ss for the expression. */
3864 rss
= gfc_get_ss ();
3865 rss
->next
= gfc_ss_terminator
;
3866 rss
->type
= GFC_SS_SCALAR
;
3869 /* Associate the SS with the loop. */
3870 gfc_add_ss_to_loop (&loop
, lss
);
3871 gfc_add_ss_to_loop (&loop
, rss
);
3873 /* Calculate the bounds of the scalarization. */
3874 gfc_conv_ss_startstride (&loop
);
3875 /* Resolve any data dependencies in the statement. */
3876 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3877 /* Setup the scalarizing loops. */
3878 gfc_conv_loop_setup (&loop
);
3880 /* Setup the gfc_se structures. */
3881 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3882 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3885 gfc_mark_ss_chain_used (rss
, 1);
3886 if (loop
.temp_ss
== NULL
)
3889 gfc_mark_ss_chain_used (lss
, 1);
3893 lse
.ss
= loop
.temp_ss
;
3894 gfc_mark_ss_chain_used (lss
, 3);
3895 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3898 /* Start the scalarized loop body. */
3899 gfc_start_scalarized_body (&loop
, &body
);
3902 gfc_init_block (&body
);
3904 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3906 /* Translate the expression. */
3907 gfc_conv_expr (&rse
, expr2
);
3911 gfc_conv_tmp_array_ref (&lse
);
3912 gfc_advance_se_ss_chain (&lse
);
3915 gfc_conv_expr (&lse
, expr1
);
3917 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3918 l_is_temp
|| init_flag
,
3919 expr2
->expr_type
== EXPR_VARIABLE
);
3920 gfc_add_expr_to_block (&body
, tmp
);
3922 if (lss
== gfc_ss_terminator
)
3924 /* Use the scalar assignment as is. */
3925 gfc_add_block_to_block (&block
, &body
);
3929 gcc_assert (lse
.ss
== gfc_ss_terminator
3930 && rse
.ss
== gfc_ss_terminator
);
3934 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3936 /* We need to copy the temporary to the actual lhs. */
3937 gfc_init_se (&lse
, NULL
);
3938 gfc_init_se (&rse
, NULL
);
3939 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3940 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3942 rse
.ss
= loop
.temp_ss
;
3945 gfc_conv_tmp_array_ref (&rse
);
3946 gfc_advance_se_ss_chain (&rse
);
3947 gfc_conv_expr (&lse
, expr1
);
3949 gcc_assert (lse
.ss
== gfc_ss_terminator
3950 && rse
.ss
== gfc_ss_terminator
);
3952 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3954 gfc_add_expr_to_block (&body
, tmp
);
3957 /* Generate the copying loops. */
3958 gfc_trans_scalarizing_loops (&loop
, &body
);
3960 /* Wrap the whole thing up. */
3961 gfc_add_block_to_block (&block
, &loop
.pre
);
3962 gfc_add_block_to_block (&block
, &loop
.post
);
3964 gfc_cleanup_loop (&loop
);
3967 return gfc_finish_block (&block
);
3971 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3974 copyable_array_p (gfc_expr
* expr
)
3976 /* First check it's an array. */
3977 if (expr
->rank
< 1 || !expr
->ref
)
3980 /* Next check that it's of a simple enough type. */
3981 switch (expr
->ts
.type
)
3993 return !expr
->ts
.derived
->attr
.alloc_comp
;
4002 /* Translate an assignment. */
4005 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4009 /* Special case a single function returning an array. */
4010 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4012 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4017 /* Special case assigning an array to zero. */
4018 if (expr1
->expr_type
== EXPR_VARIABLE
4021 && expr1
->ref
->next
== NULL
4022 && gfc_full_array_ref_p (expr1
->ref
)
4023 && is_zero_initializer_p (expr2
))
4025 tmp
= gfc_trans_zero_assign (expr1
);
4030 /* Special case copying one array to another. */
4031 if (expr1
->expr_type
== EXPR_VARIABLE
4032 && copyable_array_p (expr1
)
4033 && gfc_full_array_ref_p (expr1
->ref
)
4034 && expr2
->expr_type
== EXPR_VARIABLE
4035 && copyable_array_p (expr2
)
4036 && gfc_full_array_ref_p (expr2
->ref
)
4037 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4038 && !gfc_check_dependency (expr1
, expr2
, 0))
4040 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4045 /* Special case initializing an array from a constant array constructor. */
4046 if (expr1
->expr_type
== EXPR_VARIABLE
4047 && copyable_array_p (expr1
)
4048 && gfc_full_array_ref_p (expr1
->ref
)
4049 && expr2
->expr_type
== EXPR_ARRAY
4050 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4052 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4057 /* Fallback to the scalarizer to generate explicit loops. */
4058 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4062 gfc_trans_init_assign (gfc_code
* code
)
4064 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4068 gfc_trans_assign (gfc_code
* code
)
4070 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);