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
);
476 else if (!sym
->attr
.value
)
478 /* Dereference non-character scalar dummy arguments. */
479 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
480 se
->expr
= build_fold_indirect_ref (se
->expr
);
482 /* Dereference scalar hidden result. */
483 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
484 && (sym
->attr
.function
|| sym
->attr
.result
)
485 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
486 se
->expr
= build_fold_indirect_ref (se
->expr
);
488 /* Dereference non-character pointer variables.
489 These must be dummies, results, or scalars. */
490 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
492 || sym
->attr
.function
494 || !sym
->attr
.dimension
))
495 se
->expr
= build_fold_indirect_ref (se
->expr
);
501 /* For character variables, also get the length. */
502 if (sym
->ts
.type
== BT_CHARACTER
)
504 /* If the character length of an entry isn't set, get the length from
505 the master function instead. */
506 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
507 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
509 se
->string_length
= sym
->ts
.cl
->backend_decl
;
510 gcc_assert (se
->string_length
);
518 /* Return the descriptor if that's what we want and this is an array
519 section reference. */
520 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
522 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
523 /* Return the descriptor for array pointers and allocations. */
525 && ref
->next
== NULL
&& (se
->descriptor_only
))
528 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
529 /* Return a pointer to an element. */
533 gfc_conv_component_ref (se
, ref
);
537 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
538 expr
->symtree
->name
, &expr
->where
);
547 /* Pointer assignment, allocation or pass by reference. Arrays are handled
549 if (se
->want_pointer
)
551 if (expr
->ts
.type
== BT_CHARACTER
)
552 gfc_conv_string_parameter (se
);
554 se
->expr
= build_fold_addr_expr (se
->expr
);
559 /* Unary ops are easy... Or they would be if ! was a valid op. */
562 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
567 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
568 /* Initialize the operand. */
569 gfc_init_se (&operand
, se
);
570 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
571 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
573 type
= gfc_typenode_for_spec (&expr
->ts
);
575 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
576 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
577 All other unary operators have an equivalent GIMPLE unary operator. */
578 if (code
== TRUTH_NOT_EXPR
)
579 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
580 build_int_cst (type
, 0));
582 se
->expr
= build1 (code
, type
, operand
.expr
);
586 /* Expand power operator to optimal multiplications when a value is raised
587 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
588 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
589 Programming", 3rd Edition, 1998. */
591 /* This code is mostly duplicated from expand_powi in the backend.
592 We establish the "optimal power tree" lookup table with the defined size.
593 The items in the table are the exponents used to calculate the index
594 exponents. Any integer n less than the value can get an "addition chain",
595 with the first node being one. */
596 #define POWI_TABLE_SIZE 256
598 /* The table is from builtins.c. */
599 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
601 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
602 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
603 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
604 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
605 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
606 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
607 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
608 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
609 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
610 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
611 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
612 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
613 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
614 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
615 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
616 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
617 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
618 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
619 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
620 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
621 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
622 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
623 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
624 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
625 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
626 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
627 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
628 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
629 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
630 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
631 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
632 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
635 /* If n is larger than lookup table's max index, we use the "window
637 #define POWI_WINDOW_SIZE 3
639 /* Recursive function to expand the power operator. The temporary
640 values are put in tmpvar. The function returns tmpvar[1] ** n. */
642 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
649 if (n
< POWI_TABLE_SIZE
)
654 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
655 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
659 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
660 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
661 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
665 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
669 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
670 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
672 if (n
< POWI_TABLE_SIZE
)
679 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
680 return 1. Else return 0 and a call to runtime library functions
681 will have to be built. */
683 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
688 tree vartmp
[POWI_TABLE_SIZE
];
690 unsigned HOST_WIDE_INT n
;
693 /* If exponent is too large, we won't expand it anyway, so don't bother
694 with large integer values. */
695 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
698 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
699 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
700 of the asymmetric range of the integer type. */
701 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
703 type
= TREE_TYPE (lhs
);
704 sgn
= tree_int_cst_sgn (rhs
);
706 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
707 || optimize_size
) && (m
> 2 || m
< -1))
713 se
->expr
= gfc_build_const (type
, integer_one_node
);
717 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
718 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
720 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
721 build_int_cst (TREE_TYPE (lhs
), -1));
722 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
723 build_int_cst (TREE_TYPE (lhs
), 1));
726 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
729 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
730 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
731 build_int_cst (type
, 0));
735 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
736 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
737 build_int_cst (type
, 0));
738 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
742 memset (vartmp
, 0, sizeof (vartmp
));
746 tmp
= gfc_build_const (type
, integer_one_node
);
747 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
750 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
756 /* Power op (**). Constant integer exponent has special handling. */
759 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
761 tree gfc_int4_type_node
;
768 gfc_init_se (&lse
, se
);
769 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
770 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
771 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
773 gfc_init_se (&rse
, se
);
774 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
775 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
777 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
778 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
779 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
782 gfc_int4_type_node
= gfc_get_int_type (4);
784 kind
= expr
->value
.op
.op1
->ts
.kind
;
785 switch (expr
->value
.op
.op2
->ts
.type
)
788 ikind
= expr
->value
.op
.op2
->ts
.kind
;
793 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
815 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
816 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
841 switch (expr
->value
.op
.op1
->ts
.type
)
844 if (kind
== 3) /* Case 16 was not handled properly above. */
846 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
850 /* Use builtins for real ** int4. */
856 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
860 fndecl
= built_in_decls
[BUILT_IN_POWI
];
865 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
873 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
877 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
889 fndecl
= built_in_decls
[BUILT_IN_POWF
];
892 fndecl
= built_in_decls
[BUILT_IN_POW
];
896 fndecl
= built_in_decls
[BUILT_IN_POWL
];
907 fndecl
= gfor_fndecl_math_cpowf
;
910 fndecl
= gfor_fndecl_math_cpow
;
913 fndecl
= gfor_fndecl_math_cpowl10
;
916 fndecl
= gfor_fndecl_math_cpowl16
;
928 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
932 /* Generate code to allocate a string temporary. */
935 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
940 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
942 if (gfc_can_put_var_on_stack (len
))
944 /* Create a temporary variable to hold the result. */
945 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
946 build_int_cst (gfc_charlen_type_node
, 1));
947 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
948 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
949 var
= gfc_create_var (tmp
, "str");
950 var
= gfc_build_addr_expr (type
, var
);
954 /* Allocate a temporary to hold the result. */
955 var
= gfc_create_var (type
, "pstr");
956 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
957 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
959 /* Free the temporary afterwards. */
960 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
961 gfc_add_expr_to_block (&se
->post
, tmp
);
968 /* Handle a string concatenation operation. A temporary will be allocated to
972 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
981 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
982 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
984 gfc_init_se (&lse
, se
);
985 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
986 gfc_conv_string_parameter (&lse
);
987 gfc_init_se (&rse
, se
);
988 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
989 gfc_conv_string_parameter (&rse
);
991 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
992 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
994 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
995 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
996 if (len
== NULL_TREE
)
998 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
999 lse
.string_length
, rse
.string_length
);
1002 type
= build_pointer_type (type
);
1004 var
= gfc_conv_string_tmp (se
, type
, len
);
1006 /* Do the actual concatenation. */
1007 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1009 lse
.string_length
, lse
.expr
,
1010 rse
.string_length
, rse
.expr
);
1011 gfc_add_expr_to_block (&se
->pre
, tmp
);
1013 /* Add the cleanup for the operands. */
1014 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1015 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1018 se
->string_length
= len
;
1021 /* Translates an op expression. Common (binary) cases are handled by this
1022 function, others are passed on. Recursion is used in either case.
1023 We use the fact that (op1.ts == op2.ts) (except for the power
1025 Operators need no special handling for scalarized expressions as long as
1026 they call gfc_conv_simple_val to get their operands.
1027 Character strings get special handling. */
1030 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1032 enum tree_code code
;
1042 switch (expr
->value
.op
.operator)
1044 case INTRINSIC_UPLUS
:
1045 case INTRINSIC_PARENTHESES
:
1046 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1049 case INTRINSIC_UMINUS
:
1050 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1054 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1057 case INTRINSIC_PLUS
:
1061 case INTRINSIC_MINUS
:
1065 case INTRINSIC_TIMES
:
1069 case INTRINSIC_DIVIDE
:
1070 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1071 an integer, we must round towards zero, so we use a
1073 if (expr
->ts
.type
== BT_INTEGER
)
1074 code
= TRUNC_DIV_EXPR
;
1079 case INTRINSIC_POWER
:
1080 gfc_conv_power_op (se
, expr
);
1083 case INTRINSIC_CONCAT
:
1084 gfc_conv_concat_op (se
, expr
);
1088 code
= TRUTH_ANDIF_EXPR
;
1093 code
= TRUTH_ORIF_EXPR
;
1097 /* EQV and NEQV only work on logicals, but since we represent them
1098 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1100 case INTRINSIC_EQ_OS
:
1108 case INTRINSIC_NE_OS
:
1109 case INTRINSIC_NEQV
:
1116 case INTRINSIC_GT_OS
:
1123 case INTRINSIC_GE_OS
:
1130 case INTRINSIC_LT_OS
:
1137 case INTRINSIC_LE_OS
:
1143 case INTRINSIC_USER
:
1144 case INTRINSIC_ASSIGN
:
1145 /* These should be converted into function calls by the frontend. */
1149 fatal_error ("Unknown intrinsic op");
1153 /* The only exception to this is **, which is handled separately anyway. */
1154 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1156 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1160 gfc_init_se (&lse
, se
);
1161 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1162 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1165 gfc_init_se (&rse
, se
);
1166 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1167 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1171 gfc_conv_string_parameter (&lse
);
1172 gfc_conv_string_parameter (&rse
);
1174 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1175 rse
.string_length
, rse
.expr
);
1176 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1177 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1180 type
= gfc_typenode_for_spec (&expr
->ts
);
1184 /* The result of logical ops is always boolean_type_node. */
1185 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1186 se
->expr
= convert (type
, tmp
);
1189 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1191 /* Add the post blocks. */
1192 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1193 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1196 /* If a string's length is one, we convert it to a single character. */
1199 gfc_to_single_character (tree len
, tree str
)
1201 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1203 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1204 && TREE_INT_CST_HIGH (len
) == 0)
1206 str
= fold_convert (pchar_type_node
, str
);
1207 return build_fold_indirect_ref (str
);
1213 /* Compare two strings. If they are all single characters, the result is the
1214 subtraction of them. Otherwise, we build a library call. */
1217 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1224 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1225 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1227 type
= gfc_get_int_type (gfc_default_integer_kind
);
1229 sc1
= gfc_to_single_character (len1
, str1
);
1230 sc2
= gfc_to_single_character (len2
, str2
);
1232 /* Deal with single character specially. */
1233 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1235 sc1
= fold_convert (type
, sc1
);
1236 sc2
= fold_convert (type
, sc2
);
1237 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1240 /* Build a call for the comparison. */
1241 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1242 len1
, str1
, len2
, str2
);
1247 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1251 if (sym
->attr
.dummy
)
1253 tmp
= gfc_get_symbol_decl (sym
);
1254 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1255 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1259 if (!sym
->backend_decl
)
1260 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1262 tmp
= sym
->backend_decl
;
1263 if (sym
->attr
.cray_pointee
)
1264 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1265 gfc_get_symbol_decl (sym
->cp_pointer
));
1266 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1268 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1269 tmp
= build_fold_addr_expr (tmp
);
1276 /* Translate the call for an elemental subroutine call used in an operator
1277 assignment. This is a simplified version of gfc_conv_function_call. */
1280 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1287 /* Only elemental subroutines with two arguments. */
1288 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1289 gcc_assert (sym
->formal
->next
->next
== NULL
);
1291 gfc_init_block (&block
);
1293 gfc_add_block_to_block (&block
, &lse
->pre
);
1294 gfc_add_block_to_block (&block
, &rse
->pre
);
1296 /* Build the argument list for the call, including hidden string lengths. */
1297 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1298 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1299 if (lse
->string_length
!= NULL_TREE
)
1300 args
= gfc_chainon_list (args
, lse
->string_length
);
1301 if (rse
->string_length
!= NULL_TREE
)
1302 args
= gfc_chainon_list (args
, rse
->string_length
);
1304 /* Build the function call. */
1305 gfc_init_se (&se
, NULL
);
1306 gfc_conv_function_val (&se
, sym
);
1307 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1308 tmp
= build_call_list (tmp
, se
.expr
, args
);
1309 gfc_add_expr_to_block (&block
, tmp
);
1311 gfc_add_block_to_block (&block
, &lse
->post
);
1312 gfc_add_block_to_block (&block
, &rse
->post
);
1314 return gfc_finish_block (&block
);
1318 /* Initialize MAPPING. */
1321 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1323 mapping
->syms
= NULL
;
1324 mapping
->charlens
= NULL
;
1328 /* Free all memory held by MAPPING (but not MAPPING itself). */
1331 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1333 gfc_interface_sym_mapping
*sym
;
1334 gfc_interface_sym_mapping
*nextsym
;
1336 gfc_charlen
*nextcl
;
1338 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1340 nextsym
= sym
->next
;
1341 gfc_free_symbol (sym
->new->n
.sym
);
1342 gfc_free (sym
->new);
1345 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1348 gfc_free_expr (cl
->length
);
1354 /* Return a copy of gfc_charlen CL. Add the returned structure to
1355 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1357 static gfc_charlen
*
1358 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1363 new = gfc_get_charlen ();
1364 new->next
= mapping
->charlens
;
1365 new->length
= gfc_copy_expr (cl
->length
);
1367 mapping
->charlens
= new;
1372 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1373 array variable that can be used as the actual argument for dummy
1374 argument SYM. Add any initialization code to BLOCK. PACKED is as
1375 for gfc_get_nodesc_array_type and DATA points to the first element
1376 in the passed array. */
1379 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1380 gfc_packed packed
, tree data
)
1385 type
= gfc_typenode_for_spec (&sym
->ts
);
1386 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1388 var
= gfc_create_var (type
, "ifm");
1389 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1395 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1396 and offset of descriptorless array type TYPE given that it has the same
1397 size as DESC. Add any set-up code to BLOCK. */
1400 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1407 offset
= gfc_index_zero_node
;
1408 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1410 dim
= gfc_rank_cst
[n
];
1411 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1412 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1414 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1415 = gfc_conv_descriptor_lbound (desc
, dim
);
1416 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1417 = gfc_conv_descriptor_ubound (desc
, dim
);
1419 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1421 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1422 gfc_conv_descriptor_ubound (desc
, dim
),
1423 gfc_conv_descriptor_lbound (desc
, dim
));
1424 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1425 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1427 tmp
= gfc_evaluate_now (tmp
, block
);
1428 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1430 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1431 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1432 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1433 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1435 offset
= gfc_evaluate_now (offset
, block
);
1436 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1440 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1441 in SE. The caller may still use se->expr and se->string_length after
1442 calling this function. */
1445 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1446 gfc_symbol
* sym
, gfc_se
* se
)
1448 gfc_interface_sym_mapping
*sm
;
1452 gfc_symbol
*new_sym
;
1454 gfc_symtree
*new_symtree
;
1456 /* Create a new symbol to represent the actual argument. */
1457 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1458 new_sym
->ts
= sym
->ts
;
1459 new_sym
->attr
.referenced
= 1;
1460 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1461 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1462 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1463 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1465 /* Create a fake symtree for it. */
1467 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1468 new_symtree
->n
.sym
= new_sym
;
1469 gcc_assert (new_symtree
== root
);
1471 /* Create a dummy->actual mapping. */
1472 sm
= gfc_getmem (sizeof (*sm
));
1473 sm
->next
= mapping
->syms
;
1475 sm
->new = new_symtree
;
1478 /* Stabilize the argument's value. */
1479 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1481 if (sym
->ts
.type
== BT_CHARACTER
)
1483 /* Create a copy of the dummy argument's length. */
1484 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1486 /* If the length is specified as "*", record the length that
1487 the caller is passing. We should use the callee's length
1488 in all other cases. */
1489 if (!new_sym
->ts
.cl
->length
)
1491 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1492 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1496 /* Use the passed value as-is if the argument is a function. */
1497 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1500 /* If the argument is either a string or a pointer to a string,
1501 convert it to a boundless character type. */
1502 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1504 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1505 tmp
= build_pointer_type (tmp
);
1506 if (sym
->attr
.pointer
)
1507 value
= build_fold_indirect_ref (se
->expr
);
1510 value
= fold_convert (tmp
, value
);
1513 /* If the argument is a scalar, a pointer to an array or an allocatable,
1515 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1516 value
= build_fold_indirect_ref (se
->expr
);
1518 /* For character(*), use the actual argument's descriptor. */
1519 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1520 value
= build_fold_indirect_ref (se
->expr
);
1522 /* If the argument is an array descriptor, use it to determine
1523 information about the actual argument's shape. */
1524 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1525 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1527 /* Get the actual argument's descriptor. */
1528 desc
= build_fold_indirect_ref (se
->expr
);
1530 /* Create the replacement variable. */
1531 tmp
= gfc_conv_descriptor_data_get (desc
);
1532 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1535 /* Use DESC to work out the upper bounds, strides and offset. */
1536 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1539 /* Otherwise we have a packed array. */
1540 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1541 PACKED_FULL
, se
->expr
);
1543 new_sym
->backend_decl
= value
;
1547 /* Called once all dummy argument mappings have been added to MAPPING,
1548 but before the mapping is used to evaluate expressions. Pre-evaluate
1549 the length of each argument, adding any initialization code to PRE and
1550 any finalization code to POST. */
1553 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1554 stmtblock_t
* pre
, stmtblock_t
* post
)
1556 gfc_interface_sym_mapping
*sym
;
1560 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1561 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1562 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1564 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1565 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1566 gfc_init_se (&se
, NULL
);
1567 gfc_conv_expr (&se
, expr
);
1569 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1570 gfc_add_block_to_block (pre
, &se
.pre
);
1571 gfc_add_block_to_block (post
, &se
.post
);
1573 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1578 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1582 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1583 gfc_constructor
* c
)
1585 for (; c
; c
= c
->next
)
1587 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1590 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1591 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1592 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1598 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1602 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1607 for (; ref
; ref
= ref
->next
)
1611 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1613 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1614 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1615 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1617 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1624 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1625 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1631 /* EXPR is a copy of an expression that appeared in the interface
1632 associated with MAPPING. Walk it recursively looking for references to
1633 dummy arguments that MAPPING maps to actual arguments. Replace each such
1634 reference with a reference to the associated actual argument. */
1637 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1640 gfc_interface_sym_mapping
*sym
;
1641 gfc_actual_arglist
*actual
;
1642 int seen_result
= 0;
1647 /* Copying an expression does not copy its length, so do that here. */
1648 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1650 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1651 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1654 /* Apply the mapping to any references. */
1655 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1657 /* ...and to the expression's symbol, if it has one. */
1659 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1660 if (sym
->old
== expr
->symtree
->n
.sym
)
1661 expr
->symtree
= sym
->new;
1663 /* ...and to subexpressions in expr->value. */
1664 switch (expr
->expr_type
)
1667 if (expr
->symtree
->n
.sym
->attr
.result
)
1671 case EXPR_SUBSTRING
:
1675 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1676 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1680 if (expr
->value
.function
.esym
== NULL
1681 && expr
->value
.function
.isym
!= NULL
1682 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1683 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1684 && gfc_apply_interface_mapping_to_expr (mapping
,
1685 expr
->value
.function
.actual
->expr
))
1688 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1690 gfc_free (new_expr
);
1691 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1695 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1696 if (sym
->old
== expr
->value
.function
.esym
)
1697 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1699 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1700 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1704 case EXPR_STRUCTURE
:
1705 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1712 /* Evaluate interface expression EXPR using MAPPING. Store the result
1716 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1717 gfc_se
* se
, gfc_expr
* expr
)
1719 expr
= gfc_copy_expr (expr
);
1720 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1721 gfc_conv_expr (se
, expr
);
1722 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1723 gfc_free_expr (expr
);
1726 /* Returns a reference to a temporary array into which a component of
1727 an actual argument derived type array is copied and then returned
1728 after the function call.
1729 TODO Get rid of this kludge, when array descriptors are capable of
1730 handling arrays with a bigger stride in bytes than size. */
1733 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1734 int g77
, sym_intent intent
)
1750 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1752 gfc_init_se (&lse
, NULL
);
1753 gfc_init_se (&rse
, NULL
);
1755 /* Walk the argument expression. */
1756 rss
= gfc_walk_expr (expr
);
1758 gcc_assert (rss
!= gfc_ss_terminator
);
1760 /* Initialize the scalarizer. */
1761 gfc_init_loopinfo (&loop
);
1762 gfc_add_ss_to_loop (&loop
, rss
);
1764 /* Calculate the bounds of the scalarization. */
1765 gfc_conv_ss_startstride (&loop
);
1767 /* Build an ss for the temporary. */
1768 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1769 if (GFC_ARRAY_TYPE_P (base_type
)
1770 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1771 base_type
= gfc_get_element_type (base_type
);
1773 loop
.temp_ss
= gfc_get_ss ();;
1774 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1775 loop
.temp_ss
->data
.temp
.type
= base_type
;
1777 if (expr
->ts
.type
== BT_CHARACTER
)
1779 gfc_ref
*char_ref
= expr
->ref
;
1781 for (; char_ref
; char_ref
= char_ref
->next
)
1782 if (char_ref
->type
== REF_SUBSTRING
)
1786 expr
->ts
.cl
= gfc_get_charlen ();
1787 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1788 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1790 gfc_init_se (&tmp_se
, NULL
);
1791 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1792 gfc_array_index_type
);
1793 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1794 tmp_se
.expr
, gfc_index_one_node
);
1795 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1796 gfc_init_se (&tmp_se
, NULL
);
1797 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1798 gfc_array_index_type
);
1799 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1801 expr
->ts
.cl
->backend_decl
= tmp
;
1805 loop
.temp_ss
->data
.temp
.type
1806 = gfc_typenode_for_spec (&expr
->ts
);
1807 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1810 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1811 loop
.temp_ss
->next
= gfc_ss_terminator
;
1813 /* Associate the SS with the loop. */
1814 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1816 /* Setup the scalarizing loops. */
1817 gfc_conv_loop_setup (&loop
);
1819 /* Pass the temporary descriptor back to the caller. */
1820 info
= &loop
.temp_ss
->data
.info
;
1821 parmse
->expr
= info
->descriptor
;
1823 /* Setup the gfc_se structures. */
1824 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1825 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1828 lse
.ss
= loop
.temp_ss
;
1829 gfc_mark_ss_chain_used (rss
, 1);
1830 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1832 /* Start the scalarized loop body. */
1833 gfc_start_scalarized_body (&loop
, &body
);
1835 /* Translate the expression. */
1836 gfc_conv_expr (&rse
, expr
);
1838 gfc_conv_tmp_array_ref (&lse
);
1839 gfc_advance_se_ss_chain (&lse
);
1841 if (intent
!= INTENT_OUT
)
1843 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1844 gfc_add_expr_to_block (&body
, tmp
);
1845 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1846 gfc_trans_scalarizing_loops (&loop
, &body
);
1850 /* Make sure that the temporary declaration survives by merging
1851 all the loop declarations into the current context. */
1852 for (n
= 0; n
< loop
.dimen
; n
++)
1854 gfc_merge_block_scope (&body
);
1855 body
= loop
.code
[loop
.order
[n
]];
1857 gfc_merge_block_scope (&body
);
1860 /* Add the post block after the second loop, so that any
1861 freeing of allocated memory is done at the right time. */
1862 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1864 /**********Copy the temporary back again.*********/
1866 gfc_init_se (&lse
, NULL
);
1867 gfc_init_se (&rse
, NULL
);
1869 /* Walk the argument expression. */
1870 lss
= gfc_walk_expr (expr
);
1871 rse
.ss
= loop
.temp_ss
;
1874 /* Initialize the scalarizer. */
1875 gfc_init_loopinfo (&loop2
);
1876 gfc_add_ss_to_loop (&loop2
, lss
);
1878 /* Calculate the bounds of the scalarization. */
1879 gfc_conv_ss_startstride (&loop2
);
1881 /* Setup the scalarizing loops. */
1882 gfc_conv_loop_setup (&loop2
);
1884 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1885 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1887 gfc_mark_ss_chain_used (lss
, 1);
1888 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1890 /* Declare the variable to hold the temporary offset and start the
1891 scalarized loop body. */
1892 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1893 gfc_start_scalarized_body (&loop2
, &body
);
1895 /* Build the offsets for the temporary from the loop variables. The
1896 temporary array has lbounds of zero and strides of one in all
1897 dimensions, so this is very simple. The offset is only computed
1898 outside the innermost loop, so the overall transfer could be
1899 optimized further. */
1900 info
= &rse
.ss
->data
.info
;
1902 tmp_index
= gfc_index_zero_node
;
1903 for (n
= info
->dimen
- 1; n
> 0; n
--)
1906 tmp
= rse
.loop
->loopvar
[n
];
1907 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1908 tmp
, rse
.loop
->from
[n
]);
1909 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1912 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1913 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1914 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1915 tmp_str
, gfc_index_one_node
);
1917 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1921 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1922 tmp_index
, rse
.loop
->from
[0]);
1923 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1925 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1926 rse
.loop
->loopvar
[0], offset
);
1928 /* Now use the offset for the reference. */
1929 tmp
= build_fold_indirect_ref (info
->data
);
1930 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1932 if (expr
->ts
.type
== BT_CHARACTER
)
1933 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1935 gfc_conv_expr (&lse
, expr
);
1937 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1939 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1940 gfc_add_expr_to_block (&body
, tmp
);
1942 /* Generate the copying loops. */
1943 gfc_trans_scalarizing_loops (&loop2
, &body
);
1945 /* Wrap the whole thing up by adding the second loop to the post-block
1946 and following it by the post-block of the first loop. In this way,
1947 if the temporary needs freeing, it is done after use! */
1948 if (intent
!= INTENT_IN
)
1950 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1951 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1954 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1956 gfc_cleanup_loop (&loop
);
1957 gfc_cleanup_loop (&loop2
);
1959 /* Pass the string length to the argument expression. */
1960 if (expr
->ts
.type
== BT_CHARACTER
)
1961 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1963 /* We want either the address for the data or the address of the descriptor,
1964 depending on the mode of passing array arguments. */
1966 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1968 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1973 /* Is true if an array reference is followed by a component or substring
1977 is_aliased_array (gfc_expr
* e
)
1983 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1985 if (ref
->type
== REF_ARRAY
1986 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1990 && ref
->type
!= REF_ARRAY
)
1996 /* Generate the code for argument list functions. */
1999 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2001 /* Pass by value for g77 %VAL(arg), pass the address
2002 indirectly for %LOC, else by reference. Thus %REF
2003 is a "do-nothing" and %LOC is the same as an F95
2005 if (strncmp (name
, "%VAL", 4) == 0)
2006 gfc_conv_expr (se
, expr
);
2007 else if (strncmp (name
, "%LOC", 4) == 0)
2009 gfc_conv_expr_reference (se
, expr
);
2010 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2012 else if (strncmp (name
, "%REF", 4) == 0)
2013 gfc_conv_expr_reference (se
, expr
);
2015 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2019 /* Generate code for a procedure call. Note can return se->post != NULL.
2020 If se->direct_byref is set then se->expr contains the return parameter.
2021 Return nonzero, if the call has alternate specifiers. */
2024 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2025 gfc_actual_arglist
* arg
, tree append_args
)
2027 gfc_interface_mapping mapping
;
2041 gfc_formal_arglist
*formal
;
2042 int has_alternate_specifier
= 0;
2043 bool need_interface_mapping
;
2050 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2052 arglist
= NULL_TREE
;
2053 retargs
= NULL_TREE
;
2054 stringargs
= NULL_TREE
;
2058 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2060 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2062 if (arg
->expr
->rank
== 0)
2063 gfc_conv_expr_reference (se
, arg
->expr
);
2067 /* This is really the actual arg because no formal arglist is
2068 created for C_LOC. */
2069 fsym
= arg
->expr
->symtree
->n
.sym
;
2071 /* We should want it to do g77 calling convention. */
2073 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2074 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2075 f
= f
|| !sym
->attr
.always_explicit
;
2077 argss
= gfc_walk_expr (arg
->expr
);
2078 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2083 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2085 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2086 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2087 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2088 gfc_conv_expr_reference (se
, arg
->expr
);
2096 if (!sym
->attr
.elemental
)
2098 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2099 if (se
->ss
->useflags
)
2101 gcc_assert (gfc_return_by_reference (sym
)
2102 && sym
->result
->attr
.dimension
);
2103 gcc_assert (se
->loop
!= NULL
);
2105 /* Access the previously obtained result. */
2106 gfc_conv_tmp_array_ref (se
);
2107 gfc_advance_se_ss_chain (se
);
2111 info
= &se
->ss
->data
.info
;
2116 gfc_init_block (&post
);
2117 gfc_init_interface_mapping (&mapping
);
2118 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2119 && sym
->ts
.cl
->length
2120 && sym
->ts
.cl
->length
->expr_type
2122 || sym
->attr
.dimension
);
2123 formal
= sym
->formal
;
2124 /* Evaluate the arguments. */
2125 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2128 fsym
= formal
? formal
->sym
: NULL
;
2129 parm_kind
= MISSING
;
2133 if (se
->ignore_optional
)
2135 /* Some intrinsics have already been resolved to the correct
2139 else if (arg
->label
)
2141 has_alternate_specifier
= 1;
2146 /* Pass a NULL pointer for an absent arg. */
2147 gfc_init_se (&parmse
, NULL
);
2148 parmse
.expr
= null_pointer_node
;
2149 if (arg
->missing_arg_type
== BT_CHARACTER
)
2150 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2153 else if (se
->ss
&& se
->ss
->useflags
)
2155 /* An elemental function inside a scalarized loop. */
2156 gfc_init_se (&parmse
, se
);
2157 gfc_conv_expr_reference (&parmse
, e
);
2158 parm_kind
= ELEMENTAL
;
2162 /* A scalar or transformational function. */
2163 gfc_init_se (&parmse
, NULL
);
2164 argss
= gfc_walk_expr (e
);
2166 if (argss
== gfc_ss_terminator
)
2168 if (fsym
&& fsym
->attr
.value
)
2170 gfc_conv_expr (&parmse
, e
);
2172 else if (arg
->name
&& arg
->name
[0] == '%')
2173 /* Argument list functions %VAL, %LOC and %REF are signalled
2174 through arg->name. */
2175 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2176 else if ((e
->expr_type
== EXPR_FUNCTION
)
2177 && e
->symtree
->n
.sym
->attr
.pointer
2178 && fsym
&& fsym
->attr
.target
)
2180 gfc_conv_expr (&parmse
, e
);
2181 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2185 gfc_conv_expr_reference (&parmse
, e
);
2186 if (fsym
&& fsym
->attr
.pointer
2187 && fsym
->attr
.flavor
!= FL_PROCEDURE
2188 && e
->expr_type
!= EXPR_NULL
)
2190 /* Scalar pointer dummy args require an extra level of
2191 indirection. The null pointer already contains
2192 this level of indirection. */
2193 parm_kind
= SCALAR_POINTER
;
2194 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2200 /* If the procedure requires an explicit interface, the actual
2201 argument is passed according to the corresponding formal
2202 argument. If the corresponding formal argument is a POINTER,
2203 ALLOCATABLE or assumed shape, we do not use g77's calling
2204 convention, and pass the address of the array descriptor
2205 instead. Otherwise we use g77's calling convention. */
2208 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2209 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2210 f
= f
|| !sym
->attr
.always_explicit
;
2212 if (e
->expr_type
== EXPR_VARIABLE
2213 && is_aliased_array (e
))
2214 /* The actual argument is a component reference to an
2215 array of derived types. In this case, the argument
2216 is converted to a temporary, which is passed and then
2217 written back after the procedure call. */
2218 gfc_conv_aliased_arg (&parmse
, e
, f
,
2219 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2221 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2223 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2224 allocated on entry, it must be deallocated. */
2225 if (fsym
&& fsym
->attr
.allocatable
2226 && fsym
->attr
.intent
== INTENT_OUT
)
2228 tmp
= build_fold_indirect_ref (parmse
.expr
);
2229 tmp
= gfc_trans_dealloc_allocated (tmp
);
2230 gfc_add_expr_to_block (&se
->pre
, tmp
);
2240 /* If an optional argument is itself an optional dummy
2241 argument, check its presence and substitute a null
2243 if (e
->expr_type
== EXPR_VARIABLE
2244 && e
->symtree
->n
.sym
->attr
.optional
2245 && fsym
->attr
.optional
)
2246 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2248 /* Obtain the character length of an assumed character
2249 length procedure from the typespec. */
2250 if (fsym
->ts
.type
== BT_CHARACTER
2251 && parmse
.string_length
== NULL_TREE
2252 && e
->ts
.type
== BT_PROCEDURE
2253 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2254 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2256 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2257 parmse
.string_length
2258 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2262 if (need_interface_mapping
)
2263 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2266 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2267 gfc_add_block_to_block (&post
, &parmse
.post
);
2269 /* Allocated allocatable components of derived types must be
2270 deallocated for INTENT(OUT) dummy arguments and non-variable
2271 scalars. Non-variable arrays are dealt with in trans-array.c
2272 (gfc_conv_array_parameter). */
2273 if (e
&& e
->ts
.type
== BT_DERIVED
2274 && e
->ts
.derived
->attr
.alloc_comp
2275 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2277 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2280 tmp
= build_fold_indirect_ref (parmse
.expr
);
2281 parm_rank
= e
->rank
;
2289 case (SCALAR_POINTER
):
2290 tmp
= build_fold_indirect_ref (tmp
);
2297 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2298 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2299 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2300 tmp
, build_empty_stmt ());
2302 if (e
->expr_type
!= EXPR_VARIABLE
)
2303 /* Don't deallocate non-variables until they have been used. */
2304 gfc_add_expr_to_block (&se
->post
, tmp
);
2307 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2308 gfc_add_expr_to_block (&se
->pre
, tmp
);
2312 /* Character strings are passed as two parameters, a length and a
2314 if (parmse
.string_length
!= NULL_TREE
)
2315 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2317 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2319 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2322 if (ts
.type
== BT_CHARACTER
)
2324 if (sym
->ts
.cl
->length
== NULL
)
2326 /* Assumed character length results are not allowed by 5.1.1.5 of the
2327 standard and are trapped in resolve.c; except in the case of SPREAD
2328 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2329 we take the character length of the first argument for the result.
2330 For dummies, we have to look through the formal argument list for
2331 this function and use the character length found there.*/
2332 if (!sym
->attr
.dummy
)
2333 cl
.backend_decl
= TREE_VALUE (stringargs
);
2336 formal
= sym
->ns
->proc_name
->formal
;
2337 for (; formal
; formal
= formal
->next
)
2338 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2339 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2346 /* Calculate the length of the returned string. */
2347 gfc_init_se (&parmse
, NULL
);
2348 if (need_interface_mapping
)
2349 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2351 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2352 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2353 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2355 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2356 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2357 build_int_cst (gfc_charlen_type_node
, 0));
2358 cl
.backend_decl
= tmp
;
2361 /* Set up a charlen structure for it. */
2366 len
= cl
.backend_decl
;
2369 byref
= gfc_return_by_reference (sym
);
2372 if (se
->direct_byref
)
2374 /* Sometimes, too much indirection can be applied; eg. for
2375 function_result = array_valued_recursive_function. */
2376 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2377 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2378 && GFC_DESCRIPTOR_TYPE_P
2379 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2380 se
->expr
= build_fold_indirect_ref (se
->expr
);
2382 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2384 else if (sym
->result
->attr
.dimension
)
2386 gcc_assert (se
->loop
&& info
);
2388 /* Set the type of the array. */
2389 tmp
= gfc_typenode_for_spec (&ts
);
2390 info
->dimen
= se
->loop
->dimen
;
2392 /* Evaluate the bounds of the result, if known. */
2393 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2395 /* Create a temporary to store the result. In case the function
2396 returns a pointer, the temporary will be a shallow copy and
2397 mustn't be deallocated. */
2398 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2399 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2400 false, !sym
->attr
.pointer
, callee_alloc
);
2402 /* Pass the temporary as the first argument. */
2403 tmp
= info
->descriptor
;
2404 tmp
= build_fold_addr_expr (tmp
);
2405 retargs
= gfc_chainon_list (retargs
, tmp
);
2407 else if (ts
.type
== BT_CHARACTER
)
2409 /* Pass the string length. */
2410 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2411 type
= build_pointer_type (type
);
2413 /* Return an address to a char[0:len-1]* temporary for
2414 character pointers. */
2415 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2417 /* Build char[0:len-1] * pstr. */
2418 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2419 build_int_cst (gfc_charlen_type_node
, 1));
2420 tmp
= build_range_type (gfc_array_index_type
,
2421 gfc_index_zero_node
, tmp
);
2422 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2423 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2425 /* Provide an address expression for the function arguments. */
2426 var
= build_fold_addr_expr (var
);
2429 var
= gfc_conv_string_tmp (se
, type
, len
);
2431 retargs
= gfc_chainon_list (retargs
, var
);
2435 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2437 type
= gfc_get_complex_type (ts
.kind
);
2438 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2439 retargs
= gfc_chainon_list (retargs
, var
);
2442 /* Add the string length to the argument list. */
2443 if (ts
.type
== BT_CHARACTER
)
2444 retargs
= gfc_chainon_list (retargs
, len
);
2446 gfc_free_interface_mapping (&mapping
);
2448 /* Add the return arguments. */
2449 arglist
= chainon (retargs
, arglist
);
2451 /* Add the hidden string length parameters to the arguments. */
2452 arglist
= chainon (arglist
, stringargs
);
2454 /* We may want to append extra arguments here. This is used e.g. for
2455 calls to libgfortran_matmul_??, which need extra information. */
2456 if (append_args
!= NULL_TREE
)
2457 arglist
= chainon (arglist
, append_args
);
2459 /* Generate the actual call. */
2460 gfc_conv_function_val (se
, sym
);
2462 /* If there are alternate return labels, function type should be
2463 integer. Can't modify the type in place though, since it can be shared
2464 with other functions. For dummy arguments, the typing is done to
2465 to this result, even if it has to be repeated for each call. */
2466 if (has_alternate_specifier
2467 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2469 if (!sym
->attr
.dummy
)
2471 TREE_TYPE (sym
->backend_decl
)
2472 = build_function_type (integer_type_node
,
2473 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2474 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2477 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2480 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2481 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2483 /* If we have a pointer function, but we don't want a pointer, e.g.
2486 where f is pointer valued, we have to dereference the result. */
2487 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2488 se
->expr
= build_fold_indirect_ref (se
->expr
);
2490 /* f2c calling conventions require a scalar default real function to
2491 return a double precision result. Convert this back to default
2492 real. We only care about the cases that can happen in Fortran 77.
2494 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2495 && sym
->ts
.kind
== gfc_default_real_kind
2496 && !sym
->attr
.always_explicit
)
2497 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2499 /* A pure function may still have side-effects - it may modify its
2501 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2503 if (!sym
->attr
.pure
)
2504 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2509 /* Add the function call to the pre chain. There is no expression. */
2510 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2511 se
->expr
= NULL_TREE
;
2513 if (!se
->direct_byref
)
2515 if (sym
->attr
.dimension
)
2517 if (flag_bounds_check
)
2519 /* Check the data pointer hasn't been modified. This would
2520 happen in a function returning a pointer. */
2521 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2522 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2524 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2526 se
->expr
= info
->descriptor
;
2527 /* Bundle in the string length. */
2528 se
->string_length
= len
;
2530 else if (sym
->ts
.type
== BT_CHARACTER
)
2532 /* Dereference for character pointer results. */
2533 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2534 se
->expr
= build_fold_indirect_ref (var
);
2538 se
->string_length
= len
;
2542 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2543 se
->expr
= build_fold_indirect_ref (var
);
2548 /* Follow the function call with the argument post block. */
2550 gfc_add_block_to_block (&se
->pre
, &post
);
2552 gfc_add_block_to_block (&se
->post
, &post
);
2554 return has_alternate_specifier
;
2558 /* Generate code to copy a string. */
2561 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2562 tree slength
, tree src
)
2564 tree tmp
, dlen
, slen
;
2572 stmtblock_t tempblock
;
2574 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2575 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2577 /* Deal with single character specially. */
2578 dsc
= gfc_to_single_character (dlen
, dest
);
2579 ssc
= gfc_to_single_character (slen
, src
);
2580 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2582 gfc_add_modify_expr (block
, dsc
, ssc
);
2586 /* Do nothing if the destination length is zero. */
2587 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2588 build_int_cst (size_type_node
, 0));
2590 /* The following code was previously in _gfortran_copy_string:
2592 // The two strings may overlap so we use memmove.
2594 copy_string (GFC_INTEGER_4 destlen, char * dest,
2595 GFC_INTEGER_4 srclen, const char * src)
2597 if (srclen >= destlen)
2599 // This will truncate if too long.
2600 memmove (dest, src, destlen);
2604 memmove (dest, src, srclen);
2606 memset (&dest[srclen], ' ', destlen - srclen);
2610 We're now doing it here for better optimization, but the logic
2613 /* Truncate string if source is too long. */
2614 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2615 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2616 3, dest
, src
, dlen
);
2618 /* Else copy and pad with spaces. */
2619 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2620 3, dest
, src
, slen
);
2622 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, dest
,
2623 fold_convert (sizetype
, slen
));
2624 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2626 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2627 lang_hooks
.to_target_charset (' ')),
2628 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2631 gfc_init_block (&tempblock
);
2632 gfc_add_expr_to_block (&tempblock
, tmp3
);
2633 gfc_add_expr_to_block (&tempblock
, tmp4
);
2634 tmp3
= gfc_finish_block (&tempblock
);
2636 /* The whole copy_string function is there. */
2637 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2638 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2639 gfc_add_expr_to_block (block
, tmp
);
2643 /* Translate a statement function.
2644 The value of a statement function reference is obtained by evaluating the
2645 expression using the values of the actual arguments for the values of the
2646 corresponding dummy arguments. */
2649 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2653 gfc_formal_arglist
*fargs
;
2654 gfc_actual_arglist
*args
;
2657 gfc_saved_var
*saved_vars
;
2663 sym
= expr
->symtree
->n
.sym
;
2664 args
= expr
->value
.function
.actual
;
2665 gfc_init_se (&lse
, NULL
);
2666 gfc_init_se (&rse
, NULL
);
2669 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2671 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2672 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2674 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2676 /* Each dummy shall be specified, explicitly or implicitly, to be
2678 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2681 /* Create a temporary to hold the value. */
2682 type
= gfc_typenode_for_spec (&fsym
->ts
);
2683 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2685 if (fsym
->ts
.type
== BT_CHARACTER
)
2687 /* Copy string arguments. */
2690 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2691 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2693 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2694 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2697 gfc_conv_expr (&rse
, args
->expr
);
2698 gfc_conv_string_parameter (&rse
);
2699 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2700 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2702 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2704 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2705 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2709 /* For everything else, just evaluate the expression. */
2710 gfc_conv_expr (&lse
, args
->expr
);
2712 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2713 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2714 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2720 /* Use the temporary variables in place of the real ones. */
2721 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2722 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2724 gfc_conv_expr (se
, sym
->value
);
2726 if (sym
->ts
.type
== BT_CHARACTER
)
2728 gfc_conv_const_charlen (sym
->ts
.cl
);
2730 /* Force the expression to the correct length. */
2731 if (!INTEGER_CST_P (se
->string_length
)
2732 || tree_int_cst_lt (se
->string_length
,
2733 sym
->ts
.cl
->backend_decl
))
2735 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2736 tmp
= gfc_create_var (type
, sym
->name
);
2737 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2738 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2739 se
->string_length
, se
->expr
);
2742 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2745 /* Restore the original variables. */
2746 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2747 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2748 gfc_free (saved_vars
);
2752 /* Translate a function expression. */
2755 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2759 if (expr
->value
.function
.isym
)
2761 gfc_conv_intrinsic_function (se
, expr
);
2765 /* We distinguish statement functions from general functions to improve
2766 runtime performance. */
2767 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2769 gfc_conv_statement_function (se
, expr
);
2773 /* expr.value.function.esym is the resolved (specific) function symbol for
2774 most functions. However this isn't set for dummy procedures. */
2775 sym
= expr
->value
.function
.esym
;
2777 sym
= expr
->symtree
->n
.sym
;
2778 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2783 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2785 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2786 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2788 gfc_conv_tmp_array_ref (se
);
2789 gfc_advance_se_ss_chain (se
);
2793 /* Build a static initializer. EXPR is the expression for the initial value.
2794 The other parameters describe the variable of the component being
2795 initialized. EXPR may be null. */
2798 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2799 bool array
, bool pointer
)
2803 if (!(expr
|| pointer
))
2806 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2807 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
2808 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
2809 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
))
2810 expr
= gfc_int_expr (0);
2814 /* Arrays need special handling. */
2816 return gfc_build_null_descriptor (type
);
2818 return gfc_conv_array_initializer (type
, expr
);
2821 return fold_convert (type
, null_pointer_node
);
2827 gfc_init_se (&se
, NULL
);
2828 gfc_conv_structure (&se
, expr
, 1);
2832 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2835 gfc_init_se (&se
, NULL
);
2836 gfc_conv_constant (&se
, expr
);
2843 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2855 gfc_start_block (&block
);
2857 /* Initialize the scalarizer. */
2858 gfc_init_loopinfo (&loop
);
2860 gfc_init_se (&lse
, NULL
);
2861 gfc_init_se (&rse
, NULL
);
2864 rss
= gfc_walk_expr (expr
);
2865 if (rss
== gfc_ss_terminator
)
2867 /* The rhs is scalar. Add a ss for the expression. */
2868 rss
= gfc_get_ss ();
2869 rss
->next
= gfc_ss_terminator
;
2870 rss
->type
= GFC_SS_SCALAR
;
2874 /* Create a SS for the destination. */
2875 lss
= gfc_get_ss ();
2876 lss
->type
= GFC_SS_COMPONENT
;
2878 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2879 lss
->next
= gfc_ss_terminator
;
2880 lss
->data
.info
.dimen
= cm
->as
->rank
;
2881 lss
->data
.info
.descriptor
= dest
;
2882 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2883 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2884 for (n
= 0; n
< cm
->as
->rank
; n
++)
2886 lss
->data
.info
.dim
[n
] = n
;
2887 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2888 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2890 mpz_init (lss
->shape
[n
]);
2891 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2892 cm
->as
->lower
[n
]->value
.integer
);
2893 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2896 /* Associate the SS with the loop. */
2897 gfc_add_ss_to_loop (&loop
, lss
);
2898 gfc_add_ss_to_loop (&loop
, rss
);
2900 /* Calculate the bounds of the scalarization. */
2901 gfc_conv_ss_startstride (&loop
);
2903 /* Setup the scalarizing loops. */
2904 gfc_conv_loop_setup (&loop
);
2906 /* Setup the gfc_se structures. */
2907 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2908 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2911 gfc_mark_ss_chain_used (rss
, 1);
2913 gfc_mark_ss_chain_used (lss
, 1);
2915 /* Start the scalarized loop body. */
2916 gfc_start_scalarized_body (&loop
, &body
);
2918 gfc_conv_tmp_array_ref (&lse
);
2919 if (cm
->ts
.type
== BT_CHARACTER
)
2920 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2922 gfc_conv_expr (&rse
, expr
);
2924 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2925 gfc_add_expr_to_block (&body
, tmp
);
2927 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2929 /* Generate the copying loops. */
2930 gfc_trans_scalarizing_loops (&loop
, &body
);
2932 /* Wrap the whole thing up. */
2933 gfc_add_block_to_block (&block
, &loop
.pre
);
2934 gfc_add_block_to_block (&block
, &loop
.post
);
2936 for (n
= 0; n
< cm
->as
->rank
; n
++)
2937 mpz_clear (lss
->shape
[n
]);
2938 gfc_free (lss
->shape
);
2940 gfc_cleanup_loop (&loop
);
2942 return gfc_finish_block (&block
);
2946 /* Assign a single component of a derived type constructor. */
2949 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2959 gfc_start_block (&block
);
2963 gfc_init_se (&se
, NULL
);
2964 /* Pointer component. */
2967 /* Array pointer. */
2968 if (expr
->expr_type
== EXPR_NULL
)
2969 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2972 rss
= gfc_walk_expr (expr
);
2973 se
.direct_byref
= 1;
2975 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2976 gfc_add_block_to_block (&block
, &se
.pre
);
2977 gfc_add_block_to_block (&block
, &se
.post
);
2982 /* Scalar pointers. */
2983 se
.want_pointer
= 1;
2984 gfc_conv_expr (&se
, expr
);
2985 gfc_add_block_to_block (&block
, &se
.pre
);
2986 gfc_add_modify_expr (&block
, dest
,
2987 fold_convert (TREE_TYPE (dest
), se
.expr
));
2988 gfc_add_block_to_block (&block
, &se
.post
);
2991 else if (cm
->dimension
)
2993 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2994 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2995 else if (cm
->allocatable
)
2999 gfc_init_se (&se
, NULL
);
3001 rss
= gfc_walk_expr (expr
);
3002 se
.want_pointer
= 0;
3003 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3004 gfc_add_block_to_block (&block
, &se
.pre
);
3006 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3007 gfc_add_modify_expr (&block
, dest
, tmp
);
3009 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3010 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3013 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3014 TREE_TYPE(cm
->backend_decl
),
3017 gfc_add_expr_to_block (&block
, tmp
);
3019 gfc_add_block_to_block (&block
, &se
.post
);
3020 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3022 /* Shift the lbound and ubound of temporaries to being unity, rather
3023 than zero, based. Calculate the offset for all cases. */
3024 offset
= gfc_conv_descriptor_offset (dest
);
3025 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3026 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3027 for (n
= 0; n
< expr
->rank
; n
++)
3029 if (expr
->expr_type
!= EXPR_VARIABLE
3030 && expr
->expr_type
!= EXPR_CONSTANT
)
3033 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3034 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3035 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3036 gfc_add_modify_expr (&block
, tmp
,
3037 fold_build2 (PLUS_EXPR
,
3038 gfc_array_index_type
,
3039 span
, gfc_index_one_node
));
3040 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3041 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3043 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3044 gfc_conv_descriptor_lbound (dest
,
3046 gfc_conv_descriptor_stride (dest
,
3048 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3049 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3050 gfc_add_modify_expr (&block
, offset
, tmp
);
3055 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3056 gfc_add_expr_to_block (&block
, tmp
);
3059 else if (expr
->ts
.type
== BT_DERIVED
)
3061 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3063 gfc_init_se (&se
, NULL
);
3064 gfc_conv_expr (&se
, expr
);
3065 gfc_add_modify_expr (&block
, dest
,
3066 fold_convert (TREE_TYPE (dest
), se
.expr
));
3070 /* Nested constructors. */
3071 tmp
= gfc_trans_structure_assign (dest
, expr
);
3072 gfc_add_expr_to_block (&block
, tmp
);
3077 /* Scalar component. */
3078 gfc_init_se (&se
, NULL
);
3079 gfc_init_se (&lse
, NULL
);
3081 gfc_conv_expr (&se
, expr
);
3082 if (cm
->ts
.type
== BT_CHARACTER
)
3083 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3085 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3086 gfc_add_expr_to_block (&block
, tmp
);
3088 return gfc_finish_block (&block
);
3091 /* Assign a derived type constructor to a variable. */
3094 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3102 gfc_start_block (&block
);
3103 cm
= expr
->ts
.derived
->components
;
3104 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3106 /* Skip absent members in default initializers. */
3110 field
= cm
->backend_decl
;
3111 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3112 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3113 gfc_add_expr_to_block (&block
, tmp
);
3115 return gfc_finish_block (&block
);
3118 /* Build an expression for a constructor. If init is nonzero then
3119 this is part of a static variable initializer. */
3122 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3129 VEC(constructor_elt
,gc
) *v
= NULL
;
3131 gcc_assert (se
->ss
== NULL
);
3132 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3133 type
= gfc_typenode_for_spec (&expr
->ts
);
3137 /* Create a temporary variable and fill it in. */
3138 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3139 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3140 gfc_add_expr_to_block (&se
->pre
, tmp
);
3144 cm
= expr
->ts
.derived
->components
;
3146 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3148 /* Skip absent members in default initializers and allocatable
3149 components. Although the latter have a default initializer
3150 of EXPR_NULL,... by default, the static nullify is not needed
3151 since this is done every time we come into scope. */
3152 if (!c
->expr
|| cm
->allocatable
)
3155 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3156 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3158 /* Append it to the constructor list. */
3159 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3161 se
->expr
= build_constructor (type
, v
);
3165 /* Translate a substring expression. */
3168 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3174 gcc_assert (ref
->type
== REF_SUBSTRING
);
3176 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3177 expr
->value
.character
.string
);
3178 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3179 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3181 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3185 /* Entry point for expression translation. Evaluates a scalar quantity.
3186 EXPR is the expression to be translated, and SE is the state structure if
3187 called from within the scalarized. */
3190 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3192 if (se
->ss
&& se
->ss
->expr
== expr
3193 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3195 /* Substitute a scalar expression evaluated outside the scalarization
3197 se
->expr
= se
->ss
->data
.scalar
.expr
;
3198 se
->string_length
= se
->ss
->string_length
;
3199 gfc_advance_se_ss_chain (se
);
3203 /* We need to convert the expressions for the iso_c_binding derived types.
3204 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3205 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3206 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3207 updated to be an integer with a kind equal to the size of a (void *). */
3208 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3209 && expr
->ts
.derived
->attr
.is_iso_c
)
3211 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3212 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3214 /* Set expr_type to EXPR_NULL, which will result in
3215 null_pointer_node being used below. */
3216 expr
->expr_type
= EXPR_NULL
;
3220 /* Update the type/kind of the expression to be what the new
3221 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3222 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3223 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3224 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3228 switch (expr
->expr_type
)
3231 gfc_conv_expr_op (se
, expr
);
3235 gfc_conv_function_expr (se
, expr
);
3239 gfc_conv_constant (se
, expr
);
3243 gfc_conv_variable (se
, expr
);
3247 se
->expr
= null_pointer_node
;
3250 case EXPR_SUBSTRING
:
3251 gfc_conv_substring_expr (se
, expr
);
3254 case EXPR_STRUCTURE
:
3255 gfc_conv_structure (se
, expr
, 0);
3259 gfc_conv_array_constructor_expr (se
, expr
);
3268 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3269 of an assignment. */
3271 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3273 gfc_conv_expr (se
, expr
);
3274 /* All numeric lvalues should have empty post chains. If not we need to
3275 figure out a way of rewriting an lvalue so that it has no post chain. */
3276 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3279 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3280 numeric expressions. Used for scalar values where inserting cleanup code
3283 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3287 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3288 gfc_conv_expr (se
, expr
);
3291 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3292 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3294 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3298 /* Helper to translate and expression and convert it to a particular type. */
3300 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3302 gfc_conv_expr_val (se
, expr
);
3303 se
->expr
= convert (type
, se
->expr
);
3307 /* Converts an expression so that it can be passed by reference. Scalar
3311 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3315 if (se
->ss
&& se
->ss
->expr
== expr
3316 && se
->ss
->type
== GFC_SS_REFERENCE
)
3318 se
->expr
= se
->ss
->data
.scalar
.expr
;
3319 se
->string_length
= se
->ss
->string_length
;
3320 gfc_advance_se_ss_chain (se
);
3324 if (expr
->ts
.type
== BT_CHARACTER
)
3326 gfc_conv_expr (se
, expr
);
3327 gfc_conv_string_parameter (se
);
3331 if (expr
->expr_type
== EXPR_VARIABLE
)
3333 se
->want_pointer
= 1;
3334 gfc_conv_expr (se
, expr
);
3337 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3338 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3339 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3345 gfc_conv_expr (se
, expr
);
3347 /* Create a temporary var to hold the value. */
3348 if (TREE_CONSTANT (se
->expr
))
3350 tree tmp
= se
->expr
;
3351 STRIP_TYPE_NOPS (tmp
);
3352 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3353 DECL_INITIAL (var
) = tmp
;
3354 TREE_STATIC (var
) = 1;
3359 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3360 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3362 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3364 /* Take the address of that value. */
3365 se
->expr
= build_fold_addr_expr (var
);
3370 gfc_trans_pointer_assign (gfc_code
* code
)
3372 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3376 /* Generate code for a pointer assignment. */
3379 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3389 gfc_start_block (&block
);
3391 gfc_init_se (&lse
, NULL
);
3393 lss
= gfc_walk_expr (expr1
);
3394 rss
= gfc_walk_expr (expr2
);
3395 if (lss
== gfc_ss_terminator
)
3397 /* Scalar pointers. */
3398 lse
.want_pointer
= 1;
3399 gfc_conv_expr (&lse
, expr1
);
3400 gcc_assert (rss
== gfc_ss_terminator
);
3401 gfc_init_se (&rse
, NULL
);
3402 rse
.want_pointer
= 1;
3403 gfc_conv_expr (&rse
, expr2
);
3404 gfc_add_block_to_block (&block
, &lse
.pre
);
3405 gfc_add_block_to_block (&block
, &rse
.pre
);
3406 gfc_add_modify_expr (&block
, lse
.expr
,
3407 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3408 gfc_add_block_to_block (&block
, &rse
.post
);
3409 gfc_add_block_to_block (&block
, &lse
.post
);
3413 /* Array pointer. */
3414 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3415 switch (expr2
->expr_type
)
3418 /* Just set the data pointer to null. */
3419 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3423 /* Assign directly to the pointer's descriptor. */
3424 lse
.direct_byref
= 1;
3425 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3429 /* Assign to a temporary descriptor and then copy that
3430 temporary to the pointer. */
3432 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3435 lse
.direct_byref
= 1;
3436 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3437 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3440 gfc_add_block_to_block (&block
, &lse
.pre
);
3441 gfc_add_block_to_block (&block
, &lse
.post
);
3443 return gfc_finish_block (&block
);
3447 /* Makes sure se is suitable for passing as a function string parameter. */
3448 /* TODO: Need to check all callers fo this function. It may be abused. */
3451 gfc_conv_string_parameter (gfc_se
* se
)
3455 if (TREE_CODE (se
->expr
) == STRING_CST
)
3457 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3461 type
= TREE_TYPE (se
->expr
);
3462 if (TYPE_STRING_FLAG (type
))
3464 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3465 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3468 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3469 gcc_assert (se
->string_length
3470 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3474 /* Generate code for assignment of scalar variables. Includes character
3475 strings and derived types with allocatable components. */
3478 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3479 bool l_is_temp
, bool r_is_var
)
3485 gfc_init_block (&block
);
3487 if (ts
.type
== BT_CHARACTER
)
3489 gcc_assert (lse
->string_length
!= NULL_TREE
3490 && rse
->string_length
!= NULL_TREE
);
3492 gfc_conv_string_parameter (lse
);
3493 gfc_conv_string_parameter (rse
);
3495 gfc_add_block_to_block (&block
, &lse
->pre
);
3496 gfc_add_block_to_block (&block
, &rse
->pre
);
3498 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3499 rse
->string_length
, rse
->expr
);
3501 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3505 /* Are the rhs and the lhs the same? */
3508 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3509 build_fold_addr_expr (lse
->expr
),
3510 build_fold_addr_expr (rse
->expr
));
3511 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3514 /* Deallocate the lhs allocated components as long as it is not
3515 the same as the rhs. */
3518 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3520 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3521 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3526 gfc_add_block_to_block (&block
, &lse
->pre
);
3527 gfc_add_block_to_block (&block
, &rse
->pre
);
3531 gfc_add_block_to_block (&block
, &rse
->pre
);
3532 gfc_add_block_to_block (&block
, &lse
->pre
);
3535 gfc_add_modify_expr (&block
, lse
->expr
,
3536 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3538 /* Do a deep copy if the rhs is a variable, if it is not the
3542 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3543 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3544 gfc_add_expr_to_block (&block
, tmp
);
3549 gfc_add_block_to_block (&block
, &lse
->pre
);
3550 gfc_add_block_to_block (&block
, &rse
->pre
);
3552 gfc_add_modify_expr (&block
, lse
->expr
,
3553 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3556 gfc_add_block_to_block (&block
, &lse
->post
);
3557 gfc_add_block_to_block (&block
, &rse
->post
);
3559 return gfc_finish_block (&block
);
3563 /* Try to translate array(:) = func (...), where func is a transformational
3564 array function, without using a temporary. Returns NULL is this isn't the
3568 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3573 bool seen_array_ref
;
3575 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3576 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3579 /* Elemental functions don't need a temporary anyway. */
3580 if (expr2
->value
.function
.esym
!= NULL
3581 && expr2
->value
.function
.esym
->attr
.elemental
)
3584 /* Fail if EXPR1 can't be expressed as a descriptor. */
3585 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3588 /* Functions returning pointers need temporaries. */
3589 if (expr2
->symtree
->n
.sym
->attr
.pointer
3590 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3593 /* Character array functions need temporaries unless the
3594 character lengths are the same. */
3595 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3597 if (expr1
->ts
.cl
->length
== NULL
3598 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3601 if (expr2
->ts
.cl
->length
== NULL
3602 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3605 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3606 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3610 /* Check that no LHS component references appear during an array
3611 reference. This is needed because we do not have the means to
3612 span any arbitrary stride with an array descriptor. This check
3613 is not needed for the rhs because the function result has to be
3615 seen_array_ref
= false;
3616 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3618 if (ref
->type
== REF_ARRAY
)
3619 seen_array_ref
= true;
3620 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3624 /* Check for a dependency. */
3625 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3626 expr2
->value
.function
.esym
,
3627 expr2
->value
.function
.actual
))
3630 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3632 gcc_assert (expr2
->value
.function
.isym
3633 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3634 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3636 ss
= gfc_walk_expr (expr1
);
3637 gcc_assert (ss
!= gfc_ss_terminator
);
3638 gfc_init_se (&se
, NULL
);
3639 gfc_start_block (&se
.pre
);
3640 se
.want_pointer
= 1;
3642 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3644 se
.direct_byref
= 1;
3645 se
.ss
= gfc_walk_expr (expr2
);
3646 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3647 gfc_conv_function_expr (&se
, expr2
);
3648 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3650 return gfc_finish_block (&se
.pre
);
3653 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3656 is_zero_initializer_p (gfc_expr
* expr
)
3658 if (expr
->expr_type
!= EXPR_CONSTANT
)
3661 /* We ignore constants with prescribed memory representations for now. */
3662 if (expr
->representation
.string
)
3665 switch (expr
->ts
.type
)
3668 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3671 return mpfr_zero_p (expr
->value
.real
)
3672 && MPFR_SIGN (expr
->value
.real
) >= 0;
3675 return expr
->value
.logical
== 0;
3678 return mpfr_zero_p (expr
->value
.complex.r
)
3679 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3680 && mpfr_zero_p (expr
->value
.complex.i
)
3681 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3689 /* Try to efficiently translate array(:) = 0. Return NULL if this
3693 gfc_trans_zero_assign (gfc_expr
* expr
)
3695 tree dest
, len
, type
;
3699 sym
= expr
->symtree
->n
.sym
;
3700 dest
= gfc_get_symbol_decl (sym
);
3702 type
= TREE_TYPE (dest
);
3703 if (POINTER_TYPE_P (type
))
3704 type
= TREE_TYPE (type
);
3705 if (!GFC_ARRAY_TYPE_P (type
))
3708 /* Determine the length of the array. */
3709 len
= GFC_TYPE_ARRAY_SIZE (type
);
3710 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3713 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3714 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3715 fold_convert (gfc_array_index_type
, tmp
));
3717 /* Convert arguments to the correct types. */
3718 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3719 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3721 dest
= fold_convert (pvoid_type_node
, dest
);
3722 len
= fold_convert (size_type_node
, len
);
3724 /* Construct call to __builtin_memset. */
3725 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3726 3, dest
, integer_zero_node
, len
);
3727 return fold_convert (void_type_node
, tmp
);
3731 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3732 that constructs the call to __builtin_memcpy. */
3735 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3739 /* Convert arguments to the correct types. */
3740 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3741 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3743 dst
= fold_convert (pvoid_type_node
, dst
);
3745 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3746 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3748 src
= fold_convert (pvoid_type_node
, src
);
3750 len
= fold_convert (size_type_node
, len
);
3752 /* Construct call to __builtin_memcpy. */
3753 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3754 return fold_convert (void_type_node
, tmp
);
3758 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3759 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3760 source/rhs, both are gfc_full_array_ref_p which have been checked for
3764 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3766 tree dst
, dlen
, dtype
;
3767 tree src
, slen
, stype
;
3770 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3771 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3773 dtype
= TREE_TYPE (dst
);
3774 if (POINTER_TYPE_P (dtype
))
3775 dtype
= TREE_TYPE (dtype
);
3776 stype
= TREE_TYPE (src
);
3777 if (POINTER_TYPE_P (stype
))
3778 stype
= TREE_TYPE (stype
);
3780 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3783 /* Determine the lengths of the arrays. */
3784 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3785 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3787 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3788 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3789 fold_convert (gfc_array_index_type
, tmp
));
3791 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3792 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3794 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3795 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3796 fold_convert (gfc_array_index_type
, tmp
));
3798 /* Sanity check that they are the same. This should always be
3799 the case, as we should already have checked for conformance. */
3800 if (!tree_int_cst_equal (slen
, dlen
))
3803 return gfc_build_memcpy_call (dst
, src
, dlen
);
3807 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3808 this can't be done. EXPR1 is the destination/lhs for which
3809 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3812 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3814 unsigned HOST_WIDE_INT nelem
;
3820 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3824 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3825 dtype
= TREE_TYPE (dst
);
3826 if (POINTER_TYPE_P (dtype
))
3827 dtype
= TREE_TYPE (dtype
);
3828 if (!GFC_ARRAY_TYPE_P (dtype
))
3831 /* Determine the lengths of the array. */
3832 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3833 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3836 /* Confirm that the constructor is the same size. */
3837 if (compare_tree_int (len
, nelem
) != 0)
3840 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3841 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3842 fold_convert (gfc_array_index_type
, tmp
));
3844 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3845 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3847 stype
= TREE_TYPE (src
);
3848 if (POINTER_TYPE_P (stype
))
3849 stype
= TREE_TYPE (stype
);
3851 return gfc_build_memcpy_call (dst
, src
, len
);
3855 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3856 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3859 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3864 gfc_ss
*lss_section
;
3872 /* Assignment of the form lhs = rhs. */
3873 gfc_start_block (&block
);
3875 gfc_init_se (&lse
, NULL
);
3876 gfc_init_se (&rse
, NULL
);
3879 lss
= gfc_walk_expr (expr1
);
3881 if (lss
!= gfc_ss_terminator
)
3883 /* The assignment needs scalarization. */
3886 /* Find a non-scalar SS from the lhs. */
3887 while (lss_section
!= gfc_ss_terminator
3888 && lss_section
->type
!= GFC_SS_SECTION
)
3889 lss_section
= lss_section
->next
;
3891 gcc_assert (lss_section
!= gfc_ss_terminator
);
3893 /* Initialize the scalarizer. */
3894 gfc_init_loopinfo (&loop
);
3897 rss
= gfc_walk_expr (expr2
);
3898 if (rss
== gfc_ss_terminator
)
3900 /* The rhs is scalar. Add a ss for the expression. */
3901 rss
= gfc_get_ss ();
3902 rss
->next
= gfc_ss_terminator
;
3903 rss
->type
= GFC_SS_SCALAR
;
3906 /* Associate the SS with the loop. */
3907 gfc_add_ss_to_loop (&loop
, lss
);
3908 gfc_add_ss_to_loop (&loop
, rss
);
3910 /* Calculate the bounds of the scalarization. */
3911 gfc_conv_ss_startstride (&loop
);
3912 /* Resolve any data dependencies in the statement. */
3913 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3914 /* Setup the scalarizing loops. */
3915 gfc_conv_loop_setup (&loop
);
3917 /* Setup the gfc_se structures. */
3918 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3919 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3922 gfc_mark_ss_chain_used (rss
, 1);
3923 if (loop
.temp_ss
== NULL
)
3926 gfc_mark_ss_chain_used (lss
, 1);
3930 lse
.ss
= loop
.temp_ss
;
3931 gfc_mark_ss_chain_used (lss
, 3);
3932 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3935 /* Start the scalarized loop body. */
3936 gfc_start_scalarized_body (&loop
, &body
);
3939 gfc_init_block (&body
);
3941 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3943 /* Translate the expression. */
3944 gfc_conv_expr (&rse
, expr2
);
3948 gfc_conv_tmp_array_ref (&lse
);
3949 gfc_advance_se_ss_chain (&lse
);
3952 gfc_conv_expr (&lse
, expr1
);
3954 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3955 l_is_temp
|| init_flag
,
3956 expr2
->expr_type
== EXPR_VARIABLE
);
3957 gfc_add_expr_to_block (&body
, tmp
);
3959 if (lss
== gfc_ss_terminator
)
3961 /* Use the scalar assignment as is. */
3962 gfc_add_block_to_block (&block
, &body
);
3966 gcc_assert (lse
.ss
== gfc_ss_terminator
3967 && rse
.ss
== gfc_ss_terminator
);
3971 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3973 /* We need to copy the temporary to the actual lhs. */
3974 gfc_init_se (&lse
, NULL
);
3975 gfc_init_se (&rse
, NULL
);
3976 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3977 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3979 rse
.ss
= loop
.temp_ss
;
3982 gfc_conv_tmp_array_ref (&rse
);
3983 gfc_advance_se_ss_chain (&rse
);
3984 gfc_conv_expr (&lse
, expr1
);
3986 gcc_assert (lse
.ss
== gfc_ss_terminator
3987 && rse
.ss
== gfc_ss_terminator
);
3989 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3991 gfc_add_expr_to_block (&body
, tmp
);
3994 /* Generate the copying loops. */
3995 gfc_trans_scalarizing_loops (&loop
, &body
);
3997 /* Wrap the whole thing up. */
3998 gfc_add_block_to_block (&block
, &loop
.pre
);
3999 gfc_add_block_to_block (&block
, &loop
.post
);
4001 gfc_cleanup_loop (&loop
);
4004 return gfc_finish_block (&block
);
4008 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
4011 copyable_array_p (gfc_expr
* expr
)
4013 /* First check it's an array. */
4014 if (expr
->rank
< 1 || !expr
->ref
)
4017 /* Next check that it's of a simple enough type. */
4018 switch (expr
->ts
.type
)
4030 return !expr
->ts
.derived
->attr
.alloc_comp
;
4039 /* Translate an assignment. */
4042 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4046 /* Special case a single function returning an array. */
4047 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4049 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4054 /* Special case assigning an array to zero. */
4055 if (expr1
->expr_type
== EXPR_VARIABLE
4058 && expr1
->ref
->next
== NULL
4059 && gfc_full_array_ref_p (expr1
->ref
)
4060 && is_zero_initializer_p (expr2
))
4062 tmp
= gfc_trans_zero_assign (expr1
);
4067 /* Special case copying one array to another. */
4068 if (expr1
->expr_type
== EXPR_VARIABLE
4069 && copyable_array_p (expr1
)
4070 && gfc_full_array_ref_p (expr1
->ref
)
4071 && expr2
->expr_type
== EXPR_VARIABLE
4072 && copyable_array_p (expr2
)
4073 && gfc_full_array_ref_p (expr2
->ref
)
4074 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4075 && !gfc_check_dependency (expr1
, expr2
, 0))
4077 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4082 /* Special case initializing an array from a constant array constructor. */
4083 if (expr1
->expr_type
== EXPR_VARIABLE
4084 && copyable_array_p (expr1
)
4085 && gfc_full_array_ref_p (expr1
->ref
)
4086 && expr2
->expr_type
== EXPR_ARRAY
4087 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4089 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4094 /* Fallback to the scalarizer to generate explicit loops. */
4095 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4099 gfc_trans_init_assign (gfc_code
* code
)
4101 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4105 gfc_trans_assign (gfc_code
* code
)
4107 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);