1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
34 #include "tree-gimple.h"
35 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
156 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
157 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
159 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
161 if (ts
.type
== BT_CHARACTER
)
163 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
164 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
165 se
->string_length
, tmp
);
166 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
167 se
->string_length
= tmp
;
173 /* Get the character length of an expression, looking through gfc_refs
177 gfc_get_expr_charlen (gfc_expr
*e
)
182 gcc_assert (e
->expr_type
== EXPR_VARIABLE
183 && e
->ts
.type
== BT_CHARACTER
);
185 length
= NULL
; /* To silence compiler warning. */
187 /* First candidate: if the variable is of type CHARACTER, the
188 expression's length could be the length of the character
190 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
191 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
193 /* Look through the reference chain for component references. */
194 for (r
= e
->ref
; r
; r
= r
->next
)
199 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
200 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
208 /* We should never got substring references here. These will be
209 broken down by the scalarizer. */
214 gcc_assert (length
!= NULL
);
220 /* Generate code to initialize a string length variable. Returns the
224 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
229 gfc_init_se (&se
, NULL
);
230 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
231 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
232 build_int_cst (gfc_charlen_type_node
, 0));
233 gfc_add_block_to_block (pblock
, &se
.pre
);
235 tmp
= cl
->backend_decl
;
236 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
241 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
242 const char *name
, locus
*where
)
252 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
253 type
= build_pointer_type (type
);
256 gfc_init_se (&start
, se
);
257 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
258 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
260 if (integer_onep (start
.expr
))
261 gfc_conv_string_parameter (se
);
264 /* Avoid multiple evaluation of substring start. */
265 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
266 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
268 /* Change the start of the string. */
269 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
272 tmp
= build_fold_indirect_ref (se
->expr
);
273 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
274 se
->expr
= gfc_build_addr_expr (type
, tmp
);
277 /* Length = end + 1 - start. */
278 gfc_init_se (&end
, se
);
279 if (ref
->u
.ss
.end
== NULL
)
280 end
.expr
= se
->string_length
;
283 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
284 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
286 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
287 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
289 if (flag_bounds_check
)
291 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
292 start
.expr
, end
.expr
);
294 /* Check lower bound. */
295 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
296 build_int_cst (gfc_charlen_type_node
, 1));
297 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
300 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
301 "is less than one", name
);
303 asprintf (&msg
, "Substring out of bounds: lower bound "
305 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
308 /* Check upper bound. */
309 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
311 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
314 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
315 "exceeds string length", name
);
317 asprintf (&msg
, "Substring out of bounds: upper bound "
318 "exceeds string length");
319 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
323 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
324 build_int_cst (gfc_charlen_type_node
, 1),
326 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
327 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
328 build_int_cst (gfc_charlen_type_node
, 0));
329 se
->string_length
= tmp
;
333 /* Convert a derived type component reference. */
336 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
343 c
= ref
->u
.c
.component
;
345 gcc_assert (c
->backend_decl
);
347 field
= c
->backend_decl
;
348 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
350 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
354 if (c
->ts
.type
== BT_CHARACTER
)
356 tmp
= c
->ts
.cl
->backend_decl
;
357 /* Components must always be constant length. */
358 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
359 se
->string_length
= tmp
;
362 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
363 se
->expr
= build_fold_indirect_ref (se
->expr
);
367 /* Return the contents of a variable. Also handles reference/pointer
368 variables (all Fortran pointer references are implicit). */
371 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
378 bool alternate_entry
;
381 sym
= expr
->symtree
->n
.sym
;
384 /* Check that something hasn't gone horribly wrong. */
385 gcc_assert (se
->ss
!= gfc_ss_terminator
);
386 gcc_assert (se
->ss
->expr
== expr
);
388 /* A scalarized term. We already know the descriptor. */
389 se
->expr
= se
->ss
->data
.info
.descriptor
;
390 se
->string_length
= se
->ss
->string_length
;
391 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
392 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
397 tree se_expr
= NULL_TREE
;
399 se
->expr
= gfc_get_symbol_decl (sym
);
401 /* Deal with references to a parent results or entries by storing
402 the current_function_decl and moving to the parent_decl. */
403 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
404 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
405 && sym
->result
== sym
;
406 entry_master
= sym
->attr
.result
407 && sym
->ns
->proc_name
->attr
.entry_master
408 && !gfc_return_by_reference (sym
->ns
->proc_name
);
409 parent_decl
= DECL_CONTEXT (current_function_decl
);
411 if ((se
->expr
== parent_decl
&& return_value
)
412 || (sym
->ns
&& sym
->ns
->proc_name
414 && sym
->ns
->proc_name
->backend_decl
== parent_decl
415 && (alternate_entry
|| entry_master
)))
420 /* Special case for assigning the return value of a function.
421 Self recursive functions must have an explicit return value. */
422 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
423 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
425 /* Similarly for alternate entry points. */
426 else if (alternate_entry
427 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
430 gfc_entry_list
*el
= NULL
;
432 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
435 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
440 else if (entry_master
441 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
443 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
448 /* Procedure actual arguments. */
449 else if (sym
->attr
.flavor
== FL_PROCEDURE
450 && se
->expr
!= current_function_decl
)
452 gcc_assert (se
->want_pointer
);
453 if (!sym
->attr
.dummy
)
455 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
456 se
->expr
= build_fold_addr_expr (se
->expr
);
462 /* Dereference the expression, where needed. Since characters
463 are entirely different from other types, they are treated
465 if (sym
->ts
.type
== BT_CHARACTER
)
467 /* Dereference character pointer dummy arguments
469 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
471 || sym
->attr
.function
472 || sym
->attr
.result
))
473 se
->expr
= build_fold_indirect_ref (se
->expr
);
475 /* A character with VALUE attribute needs an address
478 se
->expr
= build_fold_addr_expr (se
->expr
);
481 else if (!sym
->attr
.value
)
483 /* Dereference non-character scalar dummy arguments. */
484 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
485 se
->expr
= build_fold_indirect_ref (se
->expr
);
487 /* Dereference scalar hidden result. */
488 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
489 && (sym
->attr
.function
|| sym
->attr
.result
)
490 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
491 se
->expr
= build_fold_indirect_ref (se
->expr
);
493 /* Dereference non-character pointer variables.
494 These must be dummies, results, or scalars. */
495 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
497 || sym
->attr
.function
499 || !sym
->attr
.dimension
))
500 se
->expr
= build_fold_indirect_ref (se
->expr
);
506 /* For character variables, also get the length. */
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 /* If the character length of an entry isn't set, get the length from
510 the master function instead. */
511 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
512 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
514 se
->string_length
= sym
->ts
.cl
->backend_decl
;
515 gcc_assert (se
->string_length
);
523 /* Return the descriptor if that's what we want and this is an array
524 section reference. */
525 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
527 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
528 /* Return the descriptor for array pointers and allocations. */
530 && ref
->next
== NULL
&& (se
->descriptor_only
))
533 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
534 /* Return a pointer to an element. */
538 gfc_conv_component_ref (se
, ref
);
542 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
543 expr
->symtree
->name
, &expr
->where
);
552 /* Pointer assignment, allocation or pass by reference. Arrays are handled
554 if (se
->want_pointer
)
556 if (expr
->ts
.type
== BT_CHARACTER
)
557 gfc_conv_string_parameter (se
);
559 se
->expr
= build_fold_addr_expr (se
->expr
);
564 /* Unary ops are easy... Or they would be if ! was a valid op. */
567 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
572 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
573 /* Initialize the operand. */
574 gfc_init_se (&operand
, se
);
575 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
576 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
578 type
= gfc_typenode_for_spec (&expr
->ts
);
580 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
581 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
582 All other unary operators have an equivalent GIMPLE unary operator. */
583 if (code
== TRUTH_NOT_EXPR
)
584 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
585 build_int_cst (type
, 0));
587 se
->expr
= build1 (code
, type
, operand
.expr
);
591 /* Expand power operator to optimal multiplications when a value is raised
592 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
593 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
594 Programming", 3rd Edition, 1998. */
596 /* This code is mostly duplicated from expand_powi in the backend.
597 We establish the "optimal power tree" lookup table with the defined size.
598 The items in the table are the exponents used to calculate the index
599 exponents. Any integer n less than the value can get an "addition chain",
600 with the first node being one. */
601 #define POWI_TABLE_SIZE 256
603 /* The table is from builtins.c. */
604 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
606 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
607 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
608 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
609 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
610 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
611 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
612 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
613 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
614 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
615 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
616 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
617 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
618 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
619 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
620 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
621 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
622 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
623 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
624 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
625 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
626 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
627 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
628 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
629 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
630 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
631 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
632 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
633 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
634 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
635 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
636 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
637 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
640 /* If n is larger than lookup table's max index, we use the "window
642 #define POWI_WINDOW_SIZE 3
644 /* Recursive function to expand the power operator. The temporary
645 values are put in tmpvar. The function returns tmpvar[1] ** n. */
647 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
654 if (n
< POWI_TABLE_SIZE
)
659 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
660 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
664 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
665 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
666 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
670 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
674 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
675 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
677 if (n
< POWI_TABLE_SIZE
)
684 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
685 return 1. Else return 0 and a call to runtime library functions
686 will have to be built. */
688 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
693 tree vartmp
[POWI_TABLE_SIZE
];
695 unsigned HOST_WIDE_INT n
;
698 /* If exponent is too large, we won't expand it anyway, so don't bother
699 with large integer values. */
700 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
703 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
704 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
705 of the asymmetric range of the integer type. */
706 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
708 type
= TREE_TYPE (lhs
);
709 sgn
= tree_int_cst_sgn (rhs
);
711 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
712 || optimize_size
) && (m
> 2 || m
< -1))
718 se
->expr
= gfc_build_const (type
, integer_one_node
);
722 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
723 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
725 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
726 build_int_cst (TREE_TYPE (lhs
), -1));
727 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
728 build_int_cst (TREE_TYPE (lhs
), 1));
731 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
734 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
735 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
736 build_int_cst (type
, 0));
740 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
741 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
742 build_int_cst (type
, 0));
743 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
747 memset (vartmp
, 0, sizeof (vartmp
));
751 tmp
= gfc_build_const (type
, integer_one_node
);
752 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
755 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
761 /* Power op (**). Constant integer exponent has special handling. */
764 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
766 tree gfc_int4_type_node
;
773 gfc_init_se (&lse
, se
);
774 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
775 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
776 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
778 gfc_init_se (&rse
, se
);
779 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
780 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
782 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
783 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
784 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
787 gfc_int4_type_node
= gfc_get_int_type (4);
789 kind
= expr
->value
.op
.op1
->ts
.kind
;
790 switch (expr
->value
.op
.op2
->ts
.type
)
793 ikind
= expr
->value
.op
.op2
->ts
.kind
;
798 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
820 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
821 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
846 switch (expr
->value
.op
.op1
->ts
.type
)
849 if (kind
== 3) /* Case 16 was not handled properly above. */
851 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
855 /* Use builtins for real ** int4. */
861 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
865 fndecl
= built_in_decls
[BUILT_IN_POWI
];
870 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
878 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
882 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
894 fndecl
= built_in_decls
[BUILT_IN_POWF
];
897 fndecl
= built_in_decls
[BUILT_IN_POW
];
901 fndecl
= built_in_decls
[BUILT_IN_POWL
];
912 fndecl
= gfor_fndecl_math_cpowf
;
915 fndecl
= gfor_fndecl_math_cpow
;
918 fndecl
= gfor_fndecl_math_cpowl10
;
921 fndecl
= gfor_fndecl_math_cpowl16
;
933 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
937 /* Generate code to allocate a string temporary. */
940 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
945 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
947 if (gfc_can_put_var_on_stack (len
))
949 /* Create a temporary variable to hold the result. */
950 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
951 build_int_cst (gfc_charlen_type_node
, 1));
952 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
953 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
954 var
= gfc_create_var (tmp
, "str");
955 var
= gfc_build_addr_expr (type
, var
);
959 /* Allocate a temporary to hold the result. */
960 var
= gfc_create_var (type
, "pstr");
961 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
962 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
964 /* Free the temporary afterwards. */
965 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
966 gfc_add_expr_to_block (&se
->post
, tmp
);
973 /* Handle a string concatenation operation. A temporary will be allocated to
977 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
986 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
987 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
989 gfc_init_se (&lse
, se
);
990 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
991 gfc_conv_string_parameter (&lse
);
992 gfc_init_se (&rse
, se
);
993 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
994 gfc_conv_string_parameter (&rse
);
996 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
997 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
999 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1000 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1001 if (len
== NULL_TREE
)
1003 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1004 lse
.string_length
, rse
.string_length
);
1007 type
= build_pointer_type (type
);
1009 var
= gfc_conv_string_tmp (se
, type
, len
);
1011 /* Do the actual concatenation. */
1012 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1014 lse
.string_length
, lse
.expr
,
1015 rse
.string_length
, rse
.expr
);
1016 gfc_add_expr_to_block (&se
->pre
, tmp
);
1018 /* Add the cleanup for the operands. */
1019 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1020 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1023 se
->string_length
= len
;
1026 /* Translates an op expression. Common (binary) cases are handled by this
1027 function, others are passed on. Recursion is used in either case.
1028 We use the fact that (op1.ts == op2.ts) (except for the power
1030 Operators need no special handling for scalarized expressions as long as
1031 they call gfc_conv_simple_val to get their operands.
1032 Character strings get special handling. */
1035 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1037 enum tree_code code
;
1047 switch (expr
->value
.op
.operator)
1049 case INTRINSIC_UPLUS
:
1050 case INTRINSIC_PARENTHESES
:
1051 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1054 case INTRINSIC_UMINUS
:
1055 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1059 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1062 case INTRINSIC_PLUS
:
1066 case INTRINSIC_MINUS
:
1070 case INTRINSIC_TIMES
:
1074 case INTRINSIC_DIVIDE
:
1075 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1076 an integer, we must round towards zero, so we use a
1078 if (expr
->ts
.type
== BT_INTEGER
)
1079 code
= TRUNC_DIV_EXPR
;
1084 case INTRINSIC_POWER
:
1085 gfc_conv_power_op (se
, expr
);
1088 case INTRINSIC_CONCAT
:
1089 gfc_conv_concat_op (se
, expr
);
1093 code
= TRUTH_ANDIF_EXPR
;
1098 code
= TRUTH_ORIF_EXPR
;
1102 /* EQV and NEQV only work on logicals, but since we represent them
1103 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1105 case INTRINSIC_EQ_OS
:
1113 case INTRINSIC_NE_OS
:
1114 case INTRINSIC_NEQV
:
1121 case INTRINSIC_GT_OS
:
1128 case INTRINSIC_GE_OS
:
1135 case INTRINSIC_LT_OS
:
1142 case INTRINSIC_LE_OS
:
1148 case INTRINSIC_USER
:
1149 case INTRINSIC_ASSIGN
:
1150 /* These should be converted into function calls by the frontend. */
1154 fatal_error ("Unknown intrinsic op");
1158 /* The only exception to this is **, which is handled separately anyway. */
1159 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1161 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1165 gfc_init_se (&lse
, se
);
1166 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1167 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1170 gfc_init_se (&rse
, se
);
1171 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1172 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1176 gfc_conv_string_parameter (&lse
);
1177 gfc_conv_string_parameter (&rse
);
1179 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1180 rse
.string_length
, rse
.expr
);
1181 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1182 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1185 type
= gfc_typenode_for_spec (&expr
->ts
);
1189 /* The result of logical ops is always boolean_type_node. */
1190 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1191 se
->expr
= convert (type
, tmp
);
1194 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1196 /* Add the post blocks. */
1197 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1198 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1201 /* If a string's length is one, we convert it to a single character. */
1204 gfc_to_single_character (tree len
, tree str
)
1206 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1208 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1209 && TREE_INT_CST_HIGH (len
) == 0)
1211 str
= fold_convert (pchar_type_node
, str
);
1212 return build_fold_indirect_ref (str
);
1218 /* Compare two strings. If they are all single characters, the result is the
1219 subtraction of them. Otherwise, we build a library call. */
1222 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1229 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1230 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1232 type
= gfc_get_int_type (gfc_default_integer_kind
);
1234 sc1
= gfc_to_single_character (len1
, str1
);
1235 sc2
= gfc_to_single_character (len2
, str2
);
1237 /* Deal with single character specially. */
1238 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1240 sc1
= fold_convert (type
, sc1
);
1241 sc2
= fold_convert (type
, sc2
);
1242 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1245 /* Build a call for the comparison. */
1246 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1247 len1
, str1
, len2
, str2
);
1252 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1256 if (sym
->attr
.dummy
)
1258 tmp
= gfc_get_symbol_decl (sym
);
1259 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1260 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1264 if (!sym
->backend_decl
)
1265 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1267 tmp
= sym
->backend_decl
;
1268 if (sym
->attr
.cray_pointee
)
1269 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1270 gfc_get_symbol_decl (sym
->cp_pointer
));
1271 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1273 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1274 tmp
= build_fold_addr_expr (tmp
);
1281 /* Translate the call for an elemental subroutine call used in an operator
1282 assignment. This is a simplified version of gfc_conv_function_call. */
1285 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1292 /* Only elemental subroutines with two arguments. */
1293 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1294 gcc_assert (sym
->formal
->next
->next
== NULL
);
1296 gfc_init_block (&block
);
1298 gfc_add_block_to_block (&block
, &lse
->pre
);
1299 gfc_add_block_to_block (&block
, &rse
->pre
);
1301 /* Build the argument list for the call, including hidden string lengths. */
1302 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1303 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1304 if (lse
->string_length
!= NULL_TREE
)
1305 args
= gfc_chainon_list (args
, lse
->string_length
);
1306 if (rse
->string_length
!= NULL_TREE
)
1307 args
= gfc_chainon_list (args
, rse
->string_length
);
1309 /* Build the function call. */
1310 gfc_init_se (&se
, NULL
);
1311 gfc_conv_function_val (&se
, sym
);
1312 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1313 tmp
= build_call_list (tmp
, se
.expr
, args
);
1314 gfc_add_expr_to_block (&block
, tmp
);
1316 gfc_add_block_to_block (&block
, &lse
->post
);
1317 gfc_add_block_to_block (&block
, &rse
->post
);
1319 return gfc_finish_block (&block
);
1323 /* Initialize MAPPING. */
1326 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1328 mapping
->syms
= NULL
;
1329 mapping
->charlens
= NULL
;
1333 /* Free all memory held by MAPPING (but not MAPPING itself). */
1336 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1338 gfc_interface_sym_mapping
*sym
;
1339 gfc_interface_sym_mapping
*nextsym
;
1341 gfc_charlen
*nextcl
;
1343 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1345 nextsym
= sym
->next
;
1346 gfc_free_symbol (sym
->new->n
.sym
);
1347 gfc_free (sym
->new);
1350 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1353 gfc_free_expr (cl
->length
);
1359 /* Return a copy of gfc_charlen CL. Add the returned structure to
1360 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1362 static gfc_charlen
*
1363 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1368 new = gfc_get_charlen ();
1369 new->next
= mapping
->charlens
;
1370 new->length
= gfc_copy_expr (cl
->length
);
1372 mapping
->charlens
= new;
1377 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1378 array variable that can be used as the actual argument for dummy
1379 argument SYM. Add any initialization code to BLOCK. PACKED is as
1380 for gfc_get_nodesc_array_type and DATA points to the first element
1381 in the passed array. */
1384 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1385 gfc_packed packed
, tree data
)
1390 type
= gfc_typenode_for_spec (&sym
->ts
);
1391 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1393 var
= gfc_create_var (type
, "ifm");
1394 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1400 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1401 and offset of descriptorless array type TYPE given that it has the same
1402 size as DESC. Add any set-up code to BLOCK. */
1405 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1412 offset
= gfc_index_zero_node
;
1413 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1415 dim
= gfc_rank_cst
[n
];
1416 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1417 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1419 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1420 = gfc_conv_descriptor_lbound (desc
, dim
);
1421 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1422 = gfc_conv_descriptor_ubound (desc
, dim
);
1424 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1426 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1427 gfc_conv_descriptor_ubound (desc
, dim
),
1428 gfc_conv_descriptor_lbound (desc
, dim
));
1429 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1430 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1432 tmp
= gfc_evaluate_now (tmp
, block
);
1433 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1435 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1436 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1437 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1438 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1440 offset
= gfc_evaluate_now (offset
, block
);
1441 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1445 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1446 in SE. The caller may still use se->expr and se->string_length after
1447 calling this function. */
1450 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1451 gfc_symbol
* sym
, gfc_se
* se
)
1453 gfc_interface_sym_mapping
*sm
;
1457 gfc_symbol
*new_sym
;
1459 gfc_symtree
*new_symtree
;
1461 /* Create a new symbol to represent the actual argument. */
1462 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1463 new_sym
->ts
= sym
->ts
;
1464 new_sym
->attr
.referenced
= 1;
1465 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1466 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1467 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1468 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1470 /* Create a fake symtree for it. */
1472 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1473 new_symtree
->n
.sym
= new_sym
;
1474 gcc_assert (new_symtree
== root
);
1476 /* Create a dummy->actual mapping. */
1477 sm
= gfc_getmem (sizeof (*sm
));
1478 sm
->next
= mapping
->syms
;
1480 sm
->new = new_symtree
;
1483 /* Stabilize the argument's value. */
1484 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1486 if (sym
->ts
.type
== BT_CHARACTER
)
1488 /* Create a copy of the dummy argument's length. */
1489 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1491 /* If the length is specified as "*", record the length that
1492 the caller is passing. We should use the callee's length
1493 in all other cases. */
1494 if (!new_sym
->ts
.cl
->length
)
1496 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1497 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1501 /* Use the passed value as-is if the argument is a function. */
1502 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1505 /* If the argument is either a string or a pointer to a string,
1506 convert it to a boundless character type. */
1507 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1509 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1510 tmp
= build_pointer_type (tmp
);
1511 if (sym
->attr
.pointer
)
1512 value
= build_fold_indirect_ref (se
->expr
);
1515 value
= fold_convert (tmp
, value
);
1518 /* If the argument is a scalar, a pointer to an array or an allocatable,
1520 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1521 value
= build_fold_indirect_ref (se
->expr
);
1523 /* For character(*), use the actual argument's descriptor. */
1524 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1525 value
= build_fold_indirect_ref (se
->expr
);
1527 /* If the argument is an array descriptor, use it to determine
1528 information about the actual argument's shape. */
1529 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1530 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1532 /* Get the actual argument's descriptor. */
1533 desc
= build_fold_indirect_ref (se
->expr
);
1535 /* Create the replacement variable. */
1536 tmp
= gfc_conv_descriptor_data_get (desc
);
1537 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1540 /* Use DESC to work out the upper bounds, strides and offset. */
1541 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1544 /* Otherwise we have a packed array. */
1545 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1546 PACKED_FULL
, se
->expr
);
1548 new_sym
->backend_decl
= value
;
1552 /* Called once all dummy argument mappings have been added to MAPPING,
1553 but before the mapping is used to evaluate expressions. Pre-evaluate
1554 the length of each argument, adding any initialization code to PRE and
1555 any finalization code to POST. */
1558 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1559 stmtblock_t
* pre
, stmtblock_t
* post
)
1561 gfc_interface_sym_mapping
*sym
;
1565 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1566 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1567 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1569 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1570 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1571 gfc_init_se (&se
, NULL
);
1572 gfc_conv_expr (&se
, expr
);
1574 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1575 gfc_add_block_to_block (pre
, &se
.pre
);
1576 gfc_add_block_to_block (post
, &se
.post
);
1578 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1583 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1587 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1588 gfc_constructor
* c
)
1590 for (; c
; c
= c
->next
)
1592 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1595 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1596 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1597 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1603 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1607 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1612 for (; ref
; ref
= ref
->next
)
1616 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1618 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1619 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1620 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1622 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1629 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1630 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1636 /* EXPR is a copy of an expression that appeared in the interface
1637 associated with MAPPING. Walk it recursively looking for references to
1638 dummy arguments that MAPPING maps to actual arguments. Replace each such
1639 reference with a reference to the associated actual argument. */
1642 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1645 gfc_interface_sym_mapping
*sym
;
1646 gfc_actual_arglist
*actual
;
1647 int seen_result
= 0;
1652 /* Copying an expression does not copy its length, so do that here. */
1653 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1655 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1656 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1659 /* Apply the mapping to any references. */
1660 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1662 /* ...and to the expression's symbol, if it has one. */
1664 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1665 if (sym
->old
== expr
->symtree
->n
.sym
)
1666 expr
->symtree
= sym
->new;
1668 /* ...and to subexpressions in expr->value. */
1669 switch (expr
->expr_type
)
1672 if (expr
->symtree
->n
.sym
->attr
.result
)
1676 case EXPR_SUBSTRING
:
1680 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1681 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1685 if (expr
->value
.function
.esym
== NULL
1686 && expr
->value
.function
.isym
!= NULL
1687 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1688 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1689 && gfc_apply_interface_mapping_to_expr (mapping
,
1690 expr
->value
.function
.actual
->expr
))
1693 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1695 gfc_free (new_expr
);
1696 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1700 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1701 if (sym
->old
== expr
->value
.function
.esym
)
1702 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1704 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1705 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1709 case EXPR_STRUCTURE
:
1710 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1717 /* Evaluate interface expression EXPR using MAPPING. Store the result
1721 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1722 gfc_se
* se
, gfc_expr
* expr
)
1724 expr
= gfc_copy_expr (expr
);
1725 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1726 gfc_conv_expr (se
, expr
);
1727 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1728 gfc_free_expr (expr
);
1731 /* Returns a reference to a temporary array into which a component of
1732 an actual argument derived type array is copied and then returned
1733 after the function call.
1734 TODO Get rid of this kludge, when array descriptors are capable of
1735 handling arrays with a bigger stride in bytes than size. */
1738 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1739 int g77
, sym_intent intent
)
1755 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1757 gfc_init_se (&lse
, NULL
);
1758 gfc_init_se (&rse
, NULL
);
1760 /* Walk the argument expression. */
1761 rss
= gfc_walk_expr (expr
);
1763 gcc_assert (rss
!= gfc_ss_terminator
);
1765 /* Initialize the scalarizer. */
1766 gfc_init_loopinfo (&loop
);
1767 gfc_add_ss_to_loop (&loop
, rss
);
1769 /* Calculate the bounds of the scalarization. */
1770 gfc_conv_ss_startstride (&loop
);
1772 /* Build an ss for the temporary. */
1773 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1774 if (GFC_ARRAY_TYPE_P (base_type
)
1775 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1776 base_type
= gfc_get_element_type (base_type
);
1778 loop
.temp_ss
= gfc_get_ss ();;
1779 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1780 loop
.temp_ss
->data
.temp
.type
= base_type
;
1782 if (expr
->ts
.type
== BT_CHARACTER
)
1784 gfc_ref
*char_ref
= expr
->ref
;
1786 for (; char_ref
; char_ref
= char_ref
->next
)
1787 if (char_ref
->type
== REF_SUBSTRING
)
1791 expr
->ts
.cl
= gfc_get_charlen ();
1792 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1793 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1795 gfc_init_se (&tmp_se
, NULL
);
1796 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1797 gfc_array_index_type
);
1798 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1799 tmp_se
.expr
, gfc_index_one_node
);
1800 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1801 gfc_init_se (&tmp_se
, NULL
);
1802 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1803 gfc_array_index_type
);
1804 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1806 expr
->ts
.cl
->backend_decl
= tmp
;
1810 loop
.temp_ss
->data
.temp
.type
1811 = gfc_typenode_for_spec (&expr
->ts
);
1812 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1815 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1816 loop
.temp_ss
->next
= gfc_ss_terminator
;
1818 /* Associate the SS with the loop. */
1819 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1821 /* Setup the scalarizing loops. */
1822 gfc_conv_loop_setup (&loop
);
1824 /* Pass the temporary descriptor back to the caller. */
1825 info
= &loop
.temp_ss
->data
.info
;
1826 parmse
->expr
= info
->descriptor
;
1828 /* Setup the gfc_se structures. */
1829 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1830 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1833 lse
.ss
= loop
.temp_ss
;
1834 gfc_mark_ss_chain_used (rss
, 1);
1835 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1837 /* Start the scalarized loop body. */
1838 gfc_start_scalarized_body (&loop
, &body
);
1840 /* Translate the expression. */
1841 gfc_conv_expr (&rse
, expr
);
1843 gfc_conv_tmp_array_ref (&lse
);
1844 gfc_advance_se_ss_chain (&lse
);
1846 if (intent
!= INTENT_OUT
)
1848 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1849 gfc_add_expr_to_block (&body
, tmp
);
1850 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1851 gfc_trans_scalarizing_loops (&loop
, &body
);
1855 /* Make sure that the temporary declaration survives by merging
1856 all the loop declarations into the current context. */
1857 for (n
= 0; n
< loop
.dimen
; n
++)
1859 gfc_merge_block_scope (&body
);
1860 body
= loop
.code
[loop
.order
[n
]];
1862 gfc_merge_block_scope (&body
);
1865 /* Add the post block after the second loop, so that any
1866 freeing of allocated memory is done at the right time. */
1867 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1869 /**********Copy the temporary back again.*********/
1871 gfc_init_se (&lse
, NULL
);
1872 gfc_init_se (&rse
, NULL
);
1874 /* Walk the argument expression. */
1875 lss
= gfc_walk_expr (expr
);
1876 rse
.ss
= loop
.temp_ss
;
1879 /* Initialize the scalarizer. */
1880 gfc_init_loopinfo (&loop2
);
1881 gfc_add_ss_to_loop (&loop2
, lss
);
1883 /* Calculate the bounds of the scalarization. */
1884 gfc_conv_ss_startstride (&loop2
);
1886 /* Setup the scalarizing loops. */
1887 gfc_conv_loop_setup (&loop2
);
1889 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1890 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1892 gfc_mark_ss_chain_used (lss
, 1);
1893 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1895 /* Declare the variable to hold the temporary offset and start the
1896 scalarized loop body. */
1897 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1898 gfc_start_scalarized_body (&loop2
, &body
);
1900 /* Build the offsets for the temporary from the loop variables. The
1901 temporary array has lbounds of zero and strides of one in all
1902 dimensions, so this is very simple. The offset is only computed
1903 outside the innermost loop, so the overall transfer could be
1904 optimized further. */
1905 info
= &rse
.ss
->data
.info
;
1907 tmp_index
= gfc_index_zero_node
;
1908 for (n
= info
->dimen
- 1; n
> 0; n
--)
1911 tmp
= rse
.loop
->loopvar
[n
];
1912 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1913 tmp
, rse
.loop
->from
[n
]);
1914 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1917 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1918 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1919 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1920 tmp_str
, gfc_index_one_node
);
1922 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1926 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1927 tmp_index
, rse
.loop
->from
[0]);
1928 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1930 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1931 rse
.loop
->loopvar
[0], offset
);
1933 /* Now use the offset for the reference. */
1934 tmp
= build_fold_indirect_ref (info
->data
);
1935 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1937 if (expr
->ts
.type
== BT_CHARACTER
)
1938 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1940 gfc_conv_expr (&lse
, expr
);
1942 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1944 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1945 gfc_add_expr_to_block (&body
, tmp
);
1947 /* Generate the copying loops. */
1948 gfc_trans_scalarizing_loops (&loop2
, &body
);
1950 /* Wrap the whole thing up by adding the second loop to the post-block
1951 and following it by the post-block of the first loop. In this way,
1952 if the temporary needs freeing, it is done after use! */
1953 if (intent
!= INTENT_IN
)
1955 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1956 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1959 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1961 gfc_cleanup_loop (&loop
);
1962 gfc_cleanup_loop (&loop2
);
1964 /* Pass the string length to the argument expression. */
1965 if (expr
->ts
.type
== BT_CHARACTER
)
1966 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1968 /* We want either the address for the data or the address of the descriptor,
1969 depending on the mode of passing array arguments. */
1971 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1973 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1978 /* Is true if an array reference is followed by a component or substring
1982 is_aliased_array (gfc_expr
* e
)
1988 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1990 if (ref
->type
== REF_ARRAY
1991 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1995 && ref
->type
!= REF_ARRAY
)
2001 /* Generate the code for argument list functions. */
2004 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2006 /* Pass by value for g77 %VAL(arg), pass the address
2007 indirectly for %LOC, else by reference. Thus %REF
2008 is a "do-nothing" and %LOC is the same as an F95
2010 if (strncmp (name
, "%VAL", 4) == 0)
2011 gfc_conv_expr (se
, expr
);
2012 else if (strncmp (name
, "%LOC", 4) == 0)
2014 gfc_conv_expr_reference (se
, expr
);
2015 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2017 else if (strncmp (name
, "%REF", 4) == 0)
2018 gfc_conv_expr_reference (se
, expr
);
2020 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2024 /* Generate code for a procedure call. Note can return se->post != NULL.
2025 If se->direct_byref is set then se->expr contains the return parameter.
2026 Return nonzero, if the call has alternate specifiers. */
2029 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2030 gfc_actual_arglist
* arg
, tree append_args
)
2032 gfc_interface_mapping mapping
;
2046 gfc_formal_arglist
*formal
;
2047 int has_alternate_specifier
= 0;
2048 bool need_interface_mapping
;
2055 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2057 arglist
= NULL_TREE
;
2058 retargs
= NULL_TREE
;
2059 stringargs
= NULL_TREE
;
2063 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2065 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2067 if (arg
->expr
->rank
== 0)
2068 gfc_conv_expr_reference (se
, arg
->expr
);
2072 /* This is really the actual arg because no formal arglist is
2073 created for C_LOC. */
2074 fsym
= arg
->expr
->symtree
->n
.sym
;
2076 /* We should want it to do g77 calling convention. */
2078 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2079 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2080 f
= f
|| !sym
->attr
.always_explicit
;
2082 argss
= gfc_walk_expr (arg
->expr
);
2083 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2088 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2090 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2091 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2092 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2093 gfc_conv_expr_reference (se
, arg
->expr
);
2101 if (!sym
->attr
.elemental
)
2103 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2104 if (se
->ss
->useflags
)
2106 gcc_assert (gfc_return_by_reference (sym
)
2107 && sym
->result
->attr
.dimension
);
2108 gcc_assert (se
->loop
!= NULL
);
2110 /* Access the previously obtained result. */
2111 gfc_conv_tmp_array_ref (se
);
2112 gfc_advance_se_ss_chain (se
);
2116 info
= &se
->ss
->data
.info
;
2121 gfc_init_block (&post
);
2122 gfc_init_interface_mapping (&mapping
);
2123 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2124 && sym
->ts
.cl
->length
2125 && sym
->ts
.cl
->length
->expr_type
2127 || sym
->attr
.dimension
);
2128 formal
= sym
->formal
;
2129 /* Evaluate the arguments. */
2130 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2133 fsym
= formal
? formal
->sym
: NULL
;
2134 parm_kind
= MISSING
;
2138 if (se
->ignore_optional
)
2140 /* Some intrinsics have already been resolved to the correct
2144 else if (arg
->label
)
2146 has_alternate_specifier
= 1;
2151 /* Pass a NULL pointer for an absent arg. */
2152 gfc_init_se (&parmse
, NULL
);
2153 parmse
.expr
= null_pointer_node
;
2154 if (arg
->missing_arg_type
== BT_CHARACTER
)
2155 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2158 else if (se
->ss
&& se
->ss
->useflags
)
2160 /* An elemental function inside a scalarized loop. */
2161 gfc_init_se (&parmse
, se
);
2162 gfc_conv_expr_reference (&parmse
, e
);
2163 parm_kind
= ELEMENTAL
;
2167 /* A scalar or transformational function. */
2168 gfc_init_se (&parmse
, NULL
);
2169 argss
= gfc_walk_expr (e
);
2171 if (argss
== gfc_ss_terminator
)
2173 if (fsym
&& fsym
->attr
.value
)
2175 gfc_conv_expr (&parmse
, e
);
2177 else if (arg
->name
&& arg
->name
[0] == '%')
2178 /* Argument list functions %VAL, %LOC and %REF are signalled
2179 through arg->name. */
2180 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2181 else if ((e
->expr_type
== EXPR_FUNCTION
)
2182 && e
->symtree
->n
.sym
->attr
.pointer
2183 && fsym
&& fsym
->attr
.target
)
2185 gfc_conv_expr (&parmse
, e
);
2186 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2190 gfc_conv_expr_reference (&parmse
, e
);
2191 if (fsym
&& fsym
->attr
.pointer
2192 && fsym
->attr
.flavor
!= FL_PROCEDURE
2193 && e
->expr_type
!= EXPR_NULL
)
2195 /* Scalar pointer dummy args require an extra level of
2196 indirection. The null pointer already contains
2197 this level of indirection. */
2198 parm_kind
= SCALAR_POINTER
;
2199 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2205 /* If the procedure requires an explicit interface, the actual
2206 argument is passed according to the corresponding formal
2207 argument. If the corresponding formal argument is a POINTER,
2208 ALLOCATABLE or assumed shape, we do not use g77's calling
2209 convention, and pass the address of the array descriptor
2210 instead. Otherwise we use g77's calling convention. */
2213 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2214 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2215 f
= f
|| !sym
->attr
.always_explicit
;
2217 if (e
->expr_type
== EXPR_VARIABLE
2218 && is_aliased_array (e
))
2219 /* The actual argument is a component reference to an
2220 array of derived types. In this case, the argument
2221 is converted to a temporary, which is passed and then
2222 written back after the procedure call. */
2223 gfc_conv_aliased_arg (&parmse
, e
, f
,
2224 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2226 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2228 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2229 allocated on entry, it must be deallocated. */
2230 if (fsym
&& fsym
->attr
.allocatable
2231 && fsym
->attr
.intent
== INTENT_OUT
)
2233 tmp
= build_fold_indirect_ref (parmse
.expr
);
2234 tmp
= gfc_trans_dealloc_allocated (tmp
);
2235 gfc_add_expr_to_block (&se
->pre
, tmp
);
2245 /* If an optional argument is itself an optional dummy
2246 argument, check its presence and substitute a null
2248 if (e
->expr_type
== EXPR_VARIABLE
2249 && e
->symtree
->n
.sym
->attr
.optional
2250 && fsym
->attr
.optional
)
2251 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2253 /* If an INTENT(OUT) dummy of derived type has a default
2254 initializer, it must be (re)initialized here. */
2255 if (fsym
->attr
.intent
== INTENT_OUT
2256 && fsym
->ts
.type
== BT_DERIVED
2259 gcc_assert (!fsym
->attr
.allocatable
);
2260 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2261 gfc_add_expr_to_block (&se
->pre
, tmp
);
2264 /* Obtain the character length of an assumed character
2265 length procedure from the typespec. */
2266 if (fsym
->ts
.type
== BT_CHARACTER
2267 && parmse
.string_length
== NULL_TREE
2268 && e
->ts
.type
== BT_PROCEDURE
2269 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2270 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2272 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2273 parmse
.string_length
2274 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2278 if (need_interface_mapping
)
2279 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2282 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2283 gfc_add_block_to_block (&post
, &parmse
.post
);
2285 /* Allocated allocatable components of derived types must be
2286 deallocated for INTENT(OUT) dummy arguments and non-variable
2287 scalars. Non-variable arrays are dealt with in trans-array.c
2288 (gfc_conv_array_parameter). */
2289 if (e
&& e
->ts
.type
== BT_DERIVED
2290 && e
->ts
.derived
->attr
.alloc_comp
2291 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2293 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2296 tmp
= build_fold_indirect_ref (parmse
.expr
);
2297 parm_rank
= e
->rank
;
2305 case (SCALAR_POINTER
):
2306 tmp
= build_fold_indirect_ref (tmp
);
2313 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2314 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2315 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2316 tmp
, build_empty_stmt ());
2318 if (e
->expr_type
!= EXPR_VARIABLE
)
2319 /* Don't deallocate non-variables until they have been used. */
2320 gfc_add_expr_to_block (&se
->post
, tmp
);
2323 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2324 gfc_add_expr_to_block (&se
->pre
, tmp
);
2328 /* Character strings are passed as two parameters, a length and a
2330 if (parmse
.string_length
!= NULL_TREE
)
2331 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2333 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2335 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2338 if (ts
.type
== BT_CHARACTER
)
2340 if (sym
->ts
.cl
->length
== NULL
)
2342 /* Assumed character length results are not allowed by 5.1.1.5 of the
2343 standard and are trapped in resolve.c; except in the case of SPREAD
2344 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2345 we take the character length of the first argument for the result.
2346 For dummies, we have to look through the formal argument list for
2347 this function and use the character length found there.*/
2348 if (!sym
->attr
.dummy
)
2349 cl
.backend_decl
= TREE_VALUE (stringargs
);
2352 formal
= sym
->ns
->proc_name
->formal
;
2353 for (; formal
; formal
= formal
->next
)
2354 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2355 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2362 /* Calculate the length of the returned string. */
2363 gfc_init_se (&parmse
, NULL
);
2364 if (need_interface_mapping
)
2365 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2367 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2368 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2369 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2371 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2372 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2373 build_int_cst (gfc_charlen_type_node
, 0));
2374 cl
.backend_decl
= tmp
;
2377 /* Set up a charlen structure for it. */
2382 len
= cl
.backend_decl
;
2385 byref
= gfc_return_by_reference (sym
);
2388 if (se
->direct_byref
)
2390 /* Sometimes, too much indirection can be applied; eg. for
2391 function_result = array_valued_recursive_function. */
2392 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2393 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2394 && GFC_DESCRIPTOR_TYPE_P
2395 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2396 se
->expr
= build_fold_indirect_ref (se
->expr
);
2398 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2400 else if (sym
->result
->attr
.dimension
)
2402 gcc_assert (se
->loop
&& info
);
2404 /* Set the type of the array. */
2405 tmp
= gfc_typenode_for_spec (&ts
);
2406 info
->dimen
= se
->loop
->dimen
;
2408 /* Evaluate the bounds of the result, if known. */
2409 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2411 /* Create a temporary to store the result. In case the function
2412 returns a pointer, the temporary will be a shallow copy and
2413 mustn't be deallocated. */
2414 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2415 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2416 false, !sym
->attr
.pointer
, callee_alloc
);
2418 /* Pass the temporary as the first argument. */
2419 tmp
= info
->descriptor
;
2420 tmp
= build_fold_addr_expr (tmp
);
2421 retargs
= gfc_chainon_list (retargs
, tmp
);
2423 else if (ts
.type
== BT_CHARACTER
)
2425 /* Pass the string length. */
2426 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2427 type
= build_pointer_type (type
);
2429 /* Return an address to a char[0:len-1]* temporary for
2430 character pointers. */
2431 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2433 /* Build char[0:len-1] * pstr. */
2434 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2435 build_int_cst (gfc_charlen_type_node
, 1));
2436 tmp
= build_range_type (gfc_array_index_type
,
2437 gfc_index_zero_node
, tmp
);
2438 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2439 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2441 /* Provide an address expression for the function arguments. */
2442 var
= build_fold_addr_expr (var
);
2445 var
= gfc_conv_string_tmp (se
, type
, len
);
2447 retargs
= gfc_chainon_list (retargs
, var
);
2451 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2453 type
= gfc_get_complex_type (ts
.kind
);
2454 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2455 retargs
= gfc_chainon_list (retargs
, var
);
2458 /* Add the string length to the argument list. */
2459 if (ts
.type
== BT_CHARACTER
)
2460 retargs
= gfc_chainon_list (retargs
, len
);
2462 gfc_free_interface_mapping (&mapping
);
2464 /* Add the return arguments. */
2465 arglist
= chainon (retargs
, arglist
);
2467 /* Add the hidden string length parameters to the arguments. */
2468 arglist
= chainon (arglist
, stringargs
);
2470 /* We may want to append extra arguments here. This is used e.g. for
2471 calls to libgfortran_matmul_??, which need extra information. */
2472 if (append_args
!= NULL_TREE
)
2473 arglist
= chainon (arglist
, append_args
);
2475 /* Generate the actual call. */
2476 gfc_conv_function_val (se
, sym
);
2478 /* If there are alternate return labels, function type should be
2479 integer. Can't modify the type in place though, since it can be shared
2480 with other functions. For dummy arguments, the typing is done to
2481 to this result, even if it has to be repeated for each call. */
2482 if (has_alternate_specifier
2483 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2485 if (!sym
->attr
.dummy
)
2487 TREE_TYPE (sym
->backend_decl
)
2488 = build_function_type (integer_type_node
,
2489 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2490 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2493 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2496 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2497 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2499 /* If we have a pointer function, but we don't want a pointer, e.g.
2502 where f is pointer valued, we have to dereference the result. */
2503 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2504 se
->expr
= build_fold_indirect_ref (se
->expr
);
2506 /* f2c calling conventions require a scalar default real function to
2507 return a double precision result. Convert this back to default
2508 real. We only care about the cases that can happen in Fortran 77.
2510 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2511 && sym
->ts
.kind
== gfc_default_real_kind
2512 && !sym
->attr
.always_explicit
)
2513 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2515 /* A pure function may still have side-effects - it may modify its
2517 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2519 if (!sym
->attr
.pure
)
2520 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2525 /* Add the function call to the pre chain. There is no expression. */
2526 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2527 se
->expr
= NULL_TREE
;
2529 if (!se
->direct_byref
)
2531 if (sym
->attr
.dimension
)
2533 if (flag_bounds_check
)
2535 /* Check the data pointer hasn't been modified. This would
2536 happen in a function returning a pointer. */
2537 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2538 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2540 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2542 se
->expr
= info
->descriptor
;
2543 /* Bundle in the string length. */
2544 se
->string_length
= len
;
2546 else if (sym
->ts
.type
== BT_CHARACTER
)
2548 /* Dereference for character pointer results. */
2549 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2550 se
->expr
= build_fold_indirect_ref (var
);
2554 se
->string_length
= len
;
2558 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2559 se
->expr
= build_fold_indirect_ref (var
);
2564 /* Follow the function call with the argument post block. */
2566 gfc_add_block_to_block (&se
->pre
, &post
);
2568 gfc_add_block_to_block (&se
->post
, &post
);
2570 return has_alternate_specifier
;
2574 /* Generate code to copy a string. */
2577 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2578 tree slength
, tree src
)
2580 tree tmp
, dlen
, slen
;
2588 stmtblock_t tempblock
;
2590 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2591 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2593 /* Deal with single character specially. */
2594 dsc
= gfc_to_single_character (dlen
, dest
);
2595 ssc
= gfc_to_single_character (slen
, src
);
2596 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2598 gfc_add_modify_expr (block
, dsc
, ssc
);
2602 /* Do nothing if the destination length is zero. */
2603 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2604 build_int_cst (size_type_node
, 0));
2606 /* The following code was previously in _gfortran_copy_string:
2608 // The two strings may overlap so we use memmove.
2610 copy_string (GFC_INTEGER_4 destlen, char * dest,
2611 GFC_INTEGER_4 srclen, const char * src)
2613 if (srclen >= destlen)
2615 // This will truncate if too long.
2616 memmove (dest, src, destlen);
2620 memmove (dest, src, srclen);
2622 memset (&dest[srclen], ' ', destlen - srclen);
2626 We're now doing it here for better optimization, but the logic
2629 /* Truncate string if source is too long. */
2630 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2631 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2632 3, dest
, src
, dlen
);
2634 /* Else copy and pad with spaces. */
2635 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2636 3, dest
, src
, slen
);
2638 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, dest
,
2639 fold_convert (sizetype
, slen
));
2640 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2642 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2643 lang_hooks
.to_target_charset (' ')),
2644 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2647 gfc_init_block (&tempblock
);
2648 gfc_add_expr_to_block (&tempblock
, tmp3
);
2649 gfc_add_expr_to_block (&tempblock
, tmp4
);
2650 tmp3
= gfc_finish_block (&tempblock
);
2652 /* The whole copy_string function is there. */
2653 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2654 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2655 gfc_add_expr_to_block (block
, tmp
);
2659 /* Translate a statement function.
2660 The value of a statement function reference is obtained by evaluating the
2661 expression using the values of the actual arguments for the values of the
2662 corresponding dummy arguments. */
2665 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2669 gfc_formal_arglist
*fargs
;
2670 gfc_actual_arglist
*args
;
2673 gfc_saved_var
*saved_vars
;
2679 sym
= expr
->symtree
->n
.sym
;
2680 args
= expr
->value
.function
.actual
;
2681 gfc_init_se (&lse
, NULL
);
2682 gfc_init_se (&rse
, NULL
);
2685 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2687 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2688 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2690 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2692 /* Each dummy shall be specified, explicitly or implicitly, to be
2694 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2697 /* Create a temporary to hold the value. */
2698 type
= gfc_typenode_for_spec (&fsym
->ts
);
2699 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2701 if (fsym
->ts
.type
== BT_CHARACTER
)
2703 /* Copy string arguments. */
2706 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2707 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2709 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2710 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2713 gfc_conv_expr (&rse
, args
->expr
);
2714 gfc_conv_string_parameter (&rse
);
2715 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2716 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2718 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2720 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2721 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2725 /* For everything else, just evaluate the expression. */
2726 gfc_conv_expr (&lse
, args
->expr
);
2728 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2729 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2730 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2736 /* Use the temporary variables in place of the real ones. */
2737 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2738 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2740 gfc_conv_expr (se
, sym
->value
);
2742 if (sym
->ts
.type
== BT_CHARACTER
)
2744 gfc_conv_const_charlen (sym
->ts
.cl
);
2746 /* Force the expression to the correct length. */
2747 if (!INTEGER_CST_P (se
->string_length
)
2748 || tree_int_cst_lt (se
->string_length
,
2749 sym
->ts
.cl
->backend_decl
))
2751 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2752 tmp
= gfc_create_var (type
, sym
->name
);
2753 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2754 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2755 se
->string_length
, se
->expr
);
2758 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2761 /* Restore the original variables. */
2762 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2763 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2764 gfc_free (saved_vars
);
2768 /* Translate a function expression. */
2771 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2775 if (expr
->value
.function
.isym
)
2777 gfc_conv_intrinsic_function (se
, expr
);
2781 /* We distinguish statement functions from general functions to improve
2782 runtime performance. */
2783 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2785 gfc_conv_statement_function (se
, expr
);
2789 /* expr.value.function.esym is the resolved (specific) function symbol for
2790 most functions. However this isn't set for dummy procedures. */
2791 sym
= expr
->value
.function
.esym
;
2793 sym
= expr
->symtree
->n
.sym
;
2794 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2799 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2801 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2802 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2804 gfc_conv_tmp_array_ref (se
);
2805 gfc_advance_se_ss_chain (se
);
2809 /* Build a static initializer. EXPR is the expression for the initial value.
2810 The other parameters describe the variable of the component being
2811 initialized. EXPR may be null. */
2814 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2815 bool array
, bool pointer
)
2819 if (!(expr
|| pointer
))
2822 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2823 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
2824 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
2825 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
))
2826 expr
= gfc_int_expr (0);
2830 /* Arrays need special handling. */
2832 return gfc_build_null_descriptor (type
);
2834 return gfc_conv_array_initializer (type
, expr
);
2837 return fold_convert (type
, null_pointer_node
);
2843 gfc_init_se (&se
, NULL
);
2844 gfc_conv_structure (&se
, expr
, 1);
2848 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2851 gfc_init_se (&se
, NULL
);
2852 gfc_conv_constant (&se
, expr
);
2859 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2871 gfc_start_block (&block
);
2873 /* Initialize the scalarizer. */
2874 gfc_init_loopinfo (&loop
);
2876 gfc_init_se (&lse
, NULL
);
2877 gfc_init_se (&rse
, NULL
);
2880 rss
= gfc_walk_expr (expr
);
2881 if (rss
== gfc_ss_terminator
)
2883 /* The rhs is scalar. Add a ss for the expression. */
2884 rss
= gfc_get_ss ();
2885 rss
->next
= gfc_ss_terminator
;
2886 rss
->type
= GFC_SS_SCALAR
;
2890 /* Create a SS for the destination. */
2891 lss
= gfc_get_ss ();
2892 lss
->type
= GFC_SS_COMPONENT
;
2894 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2895 lss
->next
= gfc_ss_terminator
;
2896 lss
->data
.info
.dimen
= cm
->as
->rank
;
2897 lss
->data
.info
.descriptor
= dest
;
2898 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2899 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2900 for (n
= 0; n
< cm
->as
->rank
; n
++)
2902 lss
->data
.info
.dim
[n
] = n
;
2903 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2904 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2906 mpz_init (lss
->shape
[n
]);
2907 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2908 cm
->as
->lower
[n
]->value
.integer
);
2909 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2912 /* Associate the SS with the loop. */
2913 gfc_add_ss_to_loop (&loop
, lss
);
2914 gfc_add_ss_to_loop (&loop
, rss
);
2916 /* Calculate the bounds of the scalarization. */
2917 gfc_conv_ss_startstride (&loop
);
2919 /* Setup the scalarizing loops. */
2920 gfc_conv_loop_setup (&loop
);
2922 /* Setup the gfc_se structures. */
2923 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2924 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2927 gfc_mark_ss_chain_used (rss
, 1);
2929 gfc_mark_ss_chain_used (lss
, 1);
2931 /* Start the scalarized loop body. */
2932 gfc_start_scalarized_body (&loop
, &body
);
2934 gfc_conv_tmp_array_ref (&lse
);
2935 if (cm
->ts
.type
== BT_CHARACTER
)
2936 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2938 gfc_conv_expr (&rse
, expr
);
2940 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2941 gfc_add_expr_to_block (&body
, tmp
);
2943 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2945 /* Generate the copying loops. */
2946 gfc_trans_scalarizing_loops (&loop
, &body
);
2948 /* Wrap the whole thing up. */
2949 gfc_add_block_to_block (&block
, &loop
.pre
);
2950 gfc_add_block_to_block (&block
, &loop
.post
);
2952 for (n
= 0; n
< cm
->as
->rank
; n
++)
2953 mpz_clear (lss
->shape
[n
]);
2954 gfc_free (lss
->shape
);
2956 gfc_cleanup_loop (&loop
);
2958 return gfc_finish_block (&block
);
2962 /* Assign a single component of a derived type constructor. */
2965 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2975 gfc_start_block (&block
);
2979 gfc_init_se (&se
, NULL
);
2980 /* Pointer component. */
2983 /* Array pointer. */
2984 if (expr
->expr_type
== EXPR_NULL
)
2985 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2988 rss
= gfc_walk_expr (expr
);
2989 se
.direct_byref
= 1;
2991 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2992 gfc_add_block_to_block (&block
, &se
.pre
);
2993 gfc_add_block_to_block (&block
, &se
.post
);
2998 /* Scalar pointers. */
2999 se
.want_pointer
= 1;
3000 gfc_conv_expr (&se
, expr
);
3001 gfc_add_block_to_block (&block
, &se
.pre
);
3002 gfc_add_modify_expr (&block
, dest
,
3003 fold_convert (TREE_TYPE (dest
), se
.expr
));
3004 gfc_add_block_to_block (&block
, &se
.post
);
3007 else if (cm
->dimension
)
3009 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3010 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3011 else if (cm
->allocatable
)
3015 gfc_init_se (&se
, NULL
);
3017 rss
= gfc_walk_expr (expr
);
3018 se
.want_pointer
= 0;
3019 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3020 gfc_add_block_to_block (&block
, &se
.pre
);
3022 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3023 gfc_add_modify_expr (&block
, dest
, tmp
);
3025 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3026 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3029 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3030 TREE_TYPE(cm
->backend_decl
),
3033 gfc_add_expr_to_block (&block
, tmp
);
3035 gfc_add_block_to_block (&block
, &se
.post
);
3036 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3038 /* Shift the lbound and ubound of temporaries to being unity, rather
3039 than zero, based. Calculate the offset for all cases. */
3040 offset
= gfc_conv_descriptor_offset (dest
);
3041 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3042 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3043 for (n
= 0; n
< expr
->rank
; n
++)
3045 if (expr
->expr_type
!= EXPR_VARIABLE
3046 && expr
->expr_type
!= EXPR_CONSTANT
)
3049 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3050 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3051 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3052 gfc_add_modify_expr (&block
, tmp
,
3053 fold_build2 (PLUS_EXPR
,
3054 gfc_array_index_type
,
3055 span
, gfc_index_one_node
));
3056 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3057 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3059 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3060 gfc_conv_descriptor_lbound (dest
,
3062 gfc_conv_descriptor_stride (dest
,
3064 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3065 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3066 gfc_add_modify_expr (&block
, offset
, tmp
);
3071 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3072 gfc_add_expr_to_block (&block
, tmp
);
3075 else if (expr
->ts
.type
== BT_DERIVED
)
3077 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3079 gfc_init_se (&se
, NULL
);
3080 gfc_conv_expr (&se
, expr
);
3081 gfc_add_modify_expr (&block
, dest
,
3082 fold_convert (TREE_TYPE (dest
), se
.expr
));
3086 /* Nested constructors. */
3087 tmp
= gfc_trans_structure_assign (dest
, expr
);
3088 gfc_add_expr_to_block (&block
, tmp
);
3093 /* Scalar component. */
3094 gfc_init_se (&se
, NULL
);
3095 gfc_init_se (&lse
, NULL
);
3097 gfc_conv_expr (&se
, expr
);
3098 if (cm
->ts
.type
== BT_CHARACTER
)
3099 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3101 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3102 gfc_add_expr_to_block (&block
, tmp
);
3104 return gfc_finish_block (&block
);
3107 /* Assign a derived type constructor to a variable. */
3110 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3118 gfc_start_block (&block
);
3119 cm
= expr
->ts
.derived
->components
;
3120 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3122 /* Skip absent members in default initializers. */
3126 field
= cm
->backend_decl
;
3127 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3128 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3129 gfc_add_expr_to_block (&block
, tmp
);
3131 return gfc_finish_block (&block
);
3134 /* Build an expression for a constructor. If init is nonzero then
3135 this is part of a static variable initializer. */
3138 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3145 VEC(constructor_elt
,gc
) *v
= NULL
;
3147 gcc_assert (se
->ss
== NULL
);
3148 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3149 type
= gfc_typenode_for_spec (&expr
->ts
);
3153 /* Create a temporary variable and fill it in. */
3154 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3155 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3156 gfc_add_expr_to_block (&se
->pre
, tmp
);
3160 cm
= expr
->ts
.derived
->components
;
3162 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3164 /* Skip absent members in default initializers and allocatable
3165 components. Although the latter have a default initializer
3166 of EXPR_NULL,... by default, the static nullify is not needed
3167 since this is done every time we come into scope. */
3168 if (!c
->expr
|| cm
->allocatable
)
3171 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3172 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3174 /* Append it to the constructor list. */
3175 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3177 se
->expr
= build_constructor (type
, v
);
3181 /* Translate a substring expression. */
3184 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3190 gcc_assert (ref
->type
== REF_SUBSTRING
);
3192 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3193 expr
->value
.character
.string
);
3194 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3195 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3197 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3201 /* Entry point for expression translation. Evaluates a scalar quantity.
3202 EXPR is the expression to be translated, and SE is the state structure if
3203 called from within the scalarized. */
3206 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3208 if (se
->ss
&& se
->ss
->expr
== expr
3209 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3211 /* Substitute a scalar expression evaluated outside the scalarization
3213 se
->expr
= se
->ss
->data
.scalar
.expr
;
3214 se
->string_length
= se
->ss
->string_length
;
3215 gfc_advance_se_ss_chain (se
);
3219 /* We need to convert the expressions for the iso_c_binding derived types.
3220 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3221 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3222 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3223 updated to be an integer with a kind equal to the size of a (void *). */
3224 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3225 && expr
->ts
.derived
->attr
.is_iso_c
)
3227 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3228 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3230 /* Set expr_type to EXPR_NULL, which will result in
3231 null_pointer_node being used below. */
3232 expr
->expr_type
= EXPR_NULL
;
3236 /* Update the type/kind of the expression to be what the new
3237 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3238 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3239 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3240 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3244 switch (expr
->expr_type
)
3247 gfc_conv_expr_op (se
, expr
);
3251 gfc_conv_function_expr (se
, expr
);
3255 gfc_conv_constant (se
, expr
);
3259 gfc_conv_variable (se
, expr
);
3263 se
->expr
= null_pointer_node
;
3266 case EXPR_SUBSTRING
:
3267 gfc_conv_substring_expr (se
, expr
);
3270 case EXPR_STRUCTURE
:
3271 gfc_conv_structure (se
, expr
, 0);
3275 gfc_conv_array_constructor_expr (se
, expr
);
3284 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3285 of an assignment. */
3287 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3289 gfc_conv_expr (se
, expr
);
3290 /* All numeric lvalues should have empty post chains. If not we need to
3291 figure out a way of rewriting an lvalue so that it has no post chain. */
3292 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3295 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3296 numeric expressions. Used for scalar values where inserting cleanup code
3299 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3303 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3304 gfc_conv_expr (se
, expr
);
3307 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3308 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3310 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3314 /* Helper to translate and expression and convert it to a particular type. */
3316 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3318 gfc_conv_expr_val (se
, expr
);
3319 se
->expr
= convert (type
, se
->expr
);
3323 /* Converts an expression so that it can be passed by reference. Scalar
3327 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3331 if (se
->ss
&& se
->ss
->expr
== expr
3332 && se
->ss
->type
== GFC_SS_REFERENCE
)
3334 se
->expr
= se
->ss
->data
.scalar
.expr
;
3335 se
->string_length
= se
->ss
->string_length
;
3336 gfc_advance_se_ss_chain (se
);
3340 if (expr
->ts
.type
== BT_CHARACTER
)
3342 gfc_conv_expr (se
, expr
);
3343 gfc_conv_string_parameter (se
);
3347 if (expr
->expr_type
== EXPR_VARIABLE
)
3349 se
->want_pointer
= 1;
3350 gfc_conv_expr (se
, expr
);
3353 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3354 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3355 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3361 gfc_conv_expr (se
, expr
);
3363 /* Create a temporary var to hold the value. */
3364 if (TREE_CONSTANT (se
->expr
))
3366 tree tmp
= se
->expr
;
3367 STRIP_TYPE_NOPS (tmp
);
3368 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3369 DECL_INITIAL (var
) = tmp
;
3370 TREE_STATIC (var
) = 1;
3375 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3376 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3378 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3380 /* Take the address of that value. */
3381 se
->expr
= build_fold_addr_expr (var
);
3386 gfc_trans_pointer_assign (gfc_code
* code
)
3388 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3392 /* Generate code for a pointer assignment. */
3395 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3405 gfc_start_block (&block
);
3407 gfc_init_se (&lse
, NULL
);
3409 lss
= gfc_walk_expr (expr1
);
3410 rss
= gfc_walk_expr (expr2
);
3411 if (lss
== gfc_ss_terminator
)
3413 /* Scalar pointers. */
3414 lse
.want_pointer
= 1;
3415 gfc_conv_expr (&lse
, expr1
);
3416 gcc_assert (rss
== gfc_ss_terminator
);
3417 gfc_init_se (&rse
, NULL
);
3418 rse
.want_pointer
= 1;
3419 gfc_conv_expr (&rse
, expr2
);
3420 gfc_add_block_to_block (&block
, &lse
.pre
);
3421 gfc_add_block_to_block (&block
, &rse
.pre
);
3422 gfc_add_modify_expr (&block
, lse
.expr
,
3423 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3424 gfc_add_block_to_block (&block
, &rse
.post
);
3425 gfc_add_block_to_block (&block
, &lse
.post
);
3429 /* Array pointer. */
3430 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3431 switch (expr2
->expr_type
)
3434 /* Just set the data pointer to null. */
3435 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3439 /* Assign directly to the pointer's descriptor. */
3440 lse
.direct_byref
= 1;
3441 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3445 /* Assign to a temporary descriptor and then copy that
3446 temporary to the pointer. */
3448 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3451 lse
.direct_byref
= 1;
3452 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3453 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3456 gfc_add_block_to_block (&block
, &lse
.pre
);
3457 gfc_add_block_to_block (&block
, &lse
.post
);
3459 return gfc_finish_block (&block
);
3463 /* Makes sure se is suitable for passing as a function string parameter. */
3464 /* TODO: Need to check all callers fo this function. It may be abused. */
3467 gfc_conv_string_parameter (gfc_se
* se
)
3471 if (TREE_CODE (se
->expr
) == STRING_CST
)
3473 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3477 type
= TREE_TYPE (se
->expr
);
3478 if (TYPE_STRING_FLAG (type
))
3480 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3481 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3484 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3485 gcc_assert (se
->string_length
3486 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3490 /* Generate code for assignment of scalar variables. Includes character
3491 strings and derived types with allocatable components. */
3494 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3495 bool l_is_temp
, bool r_is_var
)
3501 gfc_init_block (&block
);
3503 if (ts
.type
== BT_CHARACTER
)
3505 gcc_assert (lse
->string_length
!= NULL_TREE
3506 && rse
->string_length
!= NULL_TREE
);
3508 gfc_conv_string_parameter (lse
);
3509 gfc_conv_string_parameter (rse
);
3511 gfc_add_block_to_block (&block
, &lse
->pre
);
3512 gfc_add_block_to_block (&block
, &rse
->pre
);
3514 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3515 rse
->string_length
, rse
->expr
);
3517 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3521 /* Are the rhs and the lhs the same? */
3524 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3525 build_fold_addr_expr (lse
->expr
),
3526 build_fold_addr_expr (rse
->expr
));
3527 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3530 /* Deallocate the lhs allocated components as long as it is not
3531 the same as the rhs. */
3534 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3536 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3537 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3542 gfc_add_block_to_block (&block
, &lse
->pre
);
3543 gfc_add_block_to_block (&block
, &rse
->pre
);
3547 gfc_add_block_to_block (&block
, &rse
->pre
);
3548 gfc_add_block_to_block (&block
, &lse
->pre
);
3551 gfc_add_modify_expr (&block
, lse
->expr
,
3552 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3554 /* Do a deep copy if the rhs is a variable, if it is not the
3558 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3559 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3560 gfc_add_expr_to_block (&block
, tmp
);
3565 gfc_add_block_to_block (&block
, &lse
->pre
);
3566 gfc_add_block_to_block (&block
, &rse
->pre
);
3568 gfc_add_modify_expr (&block
, lse
->expr
,
3569 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3572 gfc_add_block_to_block (&block
, &lse
->post
);
3573 gfc_add_block_to_block (&block
, &rse
->post
);
3575 return gfc_finish_block (&block
);
3579 /* Try to translate array(:) = func (...), where func is a transformational
3580 array function, without using a temporary. Returns NULL is this isn't the
3584 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3589 bool seen_array_ref
;
3591 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3592 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3595 /* Elemental functions don't need a temporary anyway. */
3596 if (expr2
->value
.function
.esym
!= NULL
3597 && expr2
->value
.function
.esym
->attr
.elemental
)
3600 /* Fail if EXPR1 can't be expressed as a descriptor. */
3601 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3604 /* Functions returning pointers need temporaries. */
3605 if (expr2
->symtree
->n
.sym
->attr
.pointer
3606 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3609 /* Character array functions need temporaries unless the
3610 character lengths are the same. */
3611 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3613 if (expr1
->ts
.cl
->length
== NULL
3614 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3617 if (expr2
->ts
.cl
->length
== NULL
3618 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3621 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3622 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3626 /* Check that no LHS component references appear during an array
3627 reference. This is needed because we do not have the means to
3628 span any arbitrary stride with an array descriptor. This check
3629 is not needed for the rhs because the function result has to be
3631 seen_array_ref
= false;
3632 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3634 if (ref
->type
== REF_ARRAY
)
3635 seen_array_ref
= true;
3636 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3640 /* Check for a dependency. */
3641 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3642 expr2
->value
.function
.esym
,
3643 expr2
->value
.function
.actual
))
3646 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3648 gcc_assert (expr2
->value
.function
.isym
3649 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3650 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3652 ss
= gfc_walk_expr (expr1
);
3653 gcc_assert (ss
!= gfc_ss_terminator
);
3654 gfc_init_se (&se
, NULL
);
3655 gfc_start_block (&se
.pre
);
3656 se
.want_pointer
= 1;
3658 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3660 se
.direct_byref
= 1;
3661 se
.ss
= gfc_walk_expr (expr2
);
3662 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3663 gfc_conv_function_expr (&se
, expr2
);
3664 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3666 return gfc_finish_block (&se
.pre
);
3669 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3672 is_zero_initializer_p (gfc_expr
* expr
)
3674 if (expr
->expr_type
!= EXPR_CONSTANT
)
3677 /* We ignore constants with prescribed memory representations for now. */
3678 if (expr
->representation
.string
)
3681 switch (expr
->ts
.type
)
3684 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3687 return mpfr_zero_p (expr
->value
.real
)
3688 && MPFR_SIGN (expr
->value
.real
) >= 0;
3691 return expr
->value
.logical
== 0;
3694 return mpfr_zero_p (expr
->value
.complex.r
)
3695 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3696 && mpfr_zero_p (expr
->value
.complex.i
)
3697 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3705 /* Try to efficiently translate array(:) = 0. Return NULL if this
3709 gfc_trans_zero_assign (gfc_expr
* expr
)
3711 tree dest
, len
, type
;
3715 sym
= expr
->symtree
->n
.sym
;
3716 dest
= gfc_get_symbol_decl (sym
);
3718 type
= TREE_TYPE (dest
);
3719 if (POINTER_TYPE_P (type
))
3720 type
= TREE_TYPE (type
);
3721 if (!GFC_ARRAY_TYPE_P (type
))
3724 /* Determine the length of the array. */
3725 len
= GFC_TYPE_ARRAY_SIZE (type
);
3726 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3729 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3730 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3731 fold_convert (gfc_array_index_type
, tmp
));
3733 /* Convert arguments to the correct types. */
3734 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3735 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3737 dest
= fold_convert (pvoid_type_node
, dest
);
3738 len
= fold_convert (size_type_node
, len
);
3740 /* Construct call to __builtin_memset. */
3741 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3742 3, dest
, integer_zero_node
, len
);
3743 return fold_convert (void_type_node
, tmp
);
3747 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3748 that constructs the call to __builtin_memcpy. */
3751 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3755 /* Convert arguments to the correct types. */
3756 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3757 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3759 dst
= fold_convert (pvoid_type_node
, dst
);
3761 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3762 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3764 src
= fold_convert (pvoid_type_node
, src
);
3766 len
= fold_convert (size_type_node
, len
);
3768 /* Construct call to __builtin_memcpy. */
3769 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3770 return fold_convert (void_type_node
, tmp
);
3774 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3775 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3776 source/rhs, both are gfc_full_array_ref_p which have been checked for
3780 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3782 tree dst
, dlen
, dtype
;
3783 tree src
, slen
, stype
;
3786 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3787 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3789 dtype
= TREE_TYPE (dst
);
3790 if (POINTER_TYPE_P (dtype
))
3791 dtype
= TREE_TYPE (dtype
);
3792 stype
= TREE_TYPE (src
);
3793 if (POINTER_TYPE_P (stype
))
3794 stype
= TREE_TYPE (stype
);
3796 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3799 /* Determine the lengths of the arrays. */
3800 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3801 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3803 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3804 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3805 fold_convert (gfc_array_index_type
, tmp
));
3807 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3808 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3810 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3811 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3812 fold_convert (gfc_array_index_type
, tmp
));
3814 /* Sanity check that they are the same. This should always be
3815 the case, as we should already have checked for conformance. */
3816 if (!tree_int_cst_equal (slen
, dlen
))
3819 return gfc_build_memcpy_call (dst
, src
, dlen
);
3823 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3824 this can't be done. EXPR1 is the destination/lhs for which
3825 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3828 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3830 unsigned HOST_WIDE_INT nelem
;
3836 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3840 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3841 dtype
= TREE_TYPE (dst
);
3842 if (POINTER_TYPE_P (dtype
))
3843 dtype
= TREE_TYPE (dtype
);
3844 if (!GFC_ARRAY_TYPE_P (dtype
))
3847 /* Determine the lengths of the array. */
3848 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3849 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3852 /* Confirm that the constructor is the same size. */
3853 if (compare_tree_int (len
, nelem
) != 0)
3856 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3857 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3858 fold_convert (gfc_array_index_type
, tmp
));
3860 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3861 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3863 stype
= TREE_TYPE (src
);
3864 if (POINTER_TYPE_P (stype
))
3865 stype
= TREE_TYPE (stype
);
3867 return gfc_build_memcpy_call (dst
, src
, len
);
3871 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3872 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3875 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3880 gfc_ss
*lss_section
;
3888 /* Assignment of the form lhs = rhs. */
3889 gfc_start_block (&block
);
3891 gfc_init_se (&lse
, NULL
);
3892 gfc_init_se (&rse
, NULL
);
3895 lss
= gfc_walk_expr (expr1
);
3897 if (lss
!= gfc_ss_terminator
)
3899 /* The assignment needs scalarization. */
3902 /* Find a non-scalar SS from the lhs. */
3903 while (lss_section
!= gfc_ss_terminator
3904 && lss_section
->type
!= GFC_SS_SECTION
)
3905 lss_section
= lss_section
->next
;
3907 gcc_assert (lss_section
!= gfc_ss_terminator
);
3909 /* Initialize the scalarizer. */
3910 gfc_init_loopinfo (&loop
);
3913 rss
= gfc_walk_expr (expr2
);
3914 if (rss
== gfc_ss_terminator
)
3916 /* The rhs is scalar. Add a ss for the expression. */
3917 rss
= gfc_get_ss ();
3918 rss
->next
= gfc_ss_terminator
;
3919 rss
->type
= GFC_SS_SCALAR
;
3922 /* Associate the SS with the loop. */
3923 gfc_add_ss_to_loop (&loop
, lss
);
3924 gfc_add_ss_to_loop (&loop
, rss
);
3926 /* Calculate the bounds of the scalarization. */
3927 gfc_conv_ss_startstride (&loop
);
3928 /* Resolve any data dependencies in the statement. */
3929 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3930 /* Setup the scalarizing loops. */
3931 gfc_conv_loop_setup (&loop
);
3933 /* Setup the gfc_se structures. */
3934 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3935 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3938 gfc_mark_ss_chain_used (rss
, 1);
3939 if (loop
.temp_ss
== NULL
)
3942 gfc_mark_ss_chain_used (lss
, 1);
3946 lse
.ss
= loop
.temp_ss
;
3947 gfc_mark_ss_chain_used (lss
, 3);
3948 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3951 /* Start the scalarized loop body. */
3952 gfc_start_scalarized_body (&loop
, &body
);
3955 gfc_init_block (&body
);
3957 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3959 /* Translate the expression. */
3960 gfc_conv_expr (&rse
, expr2
);
3964 gfc_conv_tmp_array_ref (&lse
);
3965 gfc_advance_se_ss_chain (&lse
);
3968 gfc_conv_expr (&lse
, expr1
);
3970 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3971 l_is_temp
|| init_flag
,
3972 expr2
->expr_type
== EXPR_VARIABLE
);
3973 gfc_add_expr_to_block (&body
, tmp
);
3975 if (lss
== gfc_ss_terminator
)
3977 /* Use the scalar assignment as is. */
3978 gfc_add_block_to_block (&block
, &body
);
3982 gcc_assert (lse
.ss
== gfc_ss_terminator
3983 && rse
.ss
== gfc_ss_terminator
);
3987 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3989 /* We need to copy the temporary to the actual lhs. */
3990 gfc_init_se (&lse
, NULL
);
3991 gfc_init_se (&rse
, NULL
);
3992 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3993 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3995 rse
.ss
= loop
.temp_ss
;
3998 gfc_conv_tmp_array_ref (&rse
);
3999 gfc_advance_se_ss_chain (&rse
);
4000 gfc_conv_expr (&lse
, expr1
);
4002 gcc_assert (lse
.ss
== gfc_ss_terminator
4003 && rse
.ss
== gfc_ss_terminator
);
4005 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4007 gfc_add_expr_to_block (&body
, tmp
);
4010 /* Generate the copying loops. */
4011 gfc_trans_scalarizing_loops (&loop
, &body
);
4013 /* Wrap the whole thing up. */
4014 gfc_add_block_to_block (&block
, &loop
.pre
);
4015 gfc_add_block_to_block (&block
, &loop
.post
);
4017 gfc_cleanup_loop (&loop
);
4020 return gfc_finish_block (&block
);
4024 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
4027 copyable_array_p (gfc_expr
* expr
)
4029 /* First check it's an array. */
4030 if (expr
->rank
< 1 || !expr
->ref
)
4033 /* Next check that it's of a simple enough type. */
4034 switch (expr
->ts
.type
)
4046 return !expr
->ts
.derived
->attr
.alloc_comp
;
4055 /* Translate an assignment. */
4058 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4062 /* Special case a single function returning an array. */
4063 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4065 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4070 /* Special case assigning an array to zero. */
4071 if (expr1
->expr_type
== EXPR_VARIABLE
4074 && expr1
->ref
->next
== NULL
4075 && gfc_full_array_ref_p (expr1
->ref
)
4076 && is_zero_initializer_p (expr2
))
4078 tmp
= gfc_trans_zero_assign (expr1
);
4083 /* Special case copying one array to another. */
4084 if (expr1
->expr_type
== EXPR_VARIABLE
4085 && copyable_array_p (expr1
)
4086 && gfc_full_array_ref_p (expr1
->ref
)
4087 && expr2
->expr_type
== EXPR_VARIABLE
4088 && copyable_array_p (expr2
)
4089 && gfc_full_array_ref_p (expr2
->ref
)
4090 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4091 && !gfc_check_dependency (expr1
, expr2
, 0))
4093 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4098 /* Special case initializing an array from a constant array constructor. */
4099 if (expr1
->expr_type
== EXPR_VARIABLE
4100 && copyable_array_p (expr1
)
4101 && gfc_full_array_ref_p (expr1
->ref
)
4102 && expr2
->expr_type
== EXPR_ARRAY
4103 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4105 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4110 /* Fallback to the scalarizer to generate explicit loops. */
4111 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4115 gfc_trans_init_assign (gfc_code
* code
)
4117 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4121 gfc_trans_assign (gfc_code
* code
)
4123 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);