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 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
46 static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
55 dest
->loop
= src
->loop
;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
68 memset (se
, 0, sizeof (gfc_se
));
69 gfc_init_block (&se
->pre
);
70 gfc_init_block (&se
->post
);
75 gfc_copy_se_loopvars (se
, parent
);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se
* se
)
88 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se
* se
)
112 if (CONSTANT_CLASS_P (se
->expr
))
115 /* We need a temporary for this result. */
116 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
117 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol
* sym
)
130 gcc_assert (sym
->attr
.dummy
);
132 decl
= gfc_get_symbol_decl (sym
);
133 if (TREE_CODE (decl
) != PARM_DECL
)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
139 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 return build2 (NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
154 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
);
162 if (ts
.type
== BT_CHARACTER
)
164 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
165 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
166 se
->string_length
, tmp
);
167 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
168 se
->string_length
= tmp
;
174 /* Get the character length of an expression, looking through gfc_refs
178 gfc_get_expr_charlen (gfc_expr
*e
)
183 gcc_assert (e
->expr_type
== EXPR_VARIABLE
184 && e
->ts
.type
== BT_CHARACTER
);
186 length
= NULL
; /* To silence compiler warning. */
188 if (is_subref_array (e
) && e
->ts
.cl
->length
)
191 gfc_init_se (&tmpse
, NULL
);
192 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
193 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
197 /* First candidate: if the variable is of type CHARACTER, the
198 expression's length could be the length of the character
200 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
201 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
203 /* Look through the reference chain for component references. */
204 for (r
= e
->ref
; r
; r
= r
->next
)
209 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
210 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
218 /* We should never got substring references here. These will be
219 broken down by the scalarizer. */
225 gcc_assert (length
!= NULL
);
231 /* Generate code to initialize a string length variable. Returns the
235 gfc_conv_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
239 gfc_init_se (&se
, NULL
);
240 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
241 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
242 build_int_cst (gfc_charlen_type_node
, 0));
243 gfc_add_block_to_block (pblock
, &se
.pre
);
245 if (cl
->backend_decl
)
246 gfc_add_modify_expr (pblock
, cl
->backend_decl
, se
.expr
);
248 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
253 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
254 const char *name
, locus
*where
)
264 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
265 type
= build_pointer_type (type
);
268 gfc_init_se (&start
, se
);
269 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
270 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
272 if (integer_onep (start
.expr
))
273 gfc_conv_string_parameter (se
);
276 /* Avoid multiple evaluation of substring start. */
277 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
278 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
280 /* Change the start of the string. */
281 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
284 tmp
= build_fold_indirect_ref (se
->expr
);
285 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
286 se
->expr
= gfc_build_addr_expr (type
, tmp
);
289 /* Length = end + 1 - start. */
290 gfc_init_se (&end
, se
);
291 if (ref
->u
.ss
.end
== NULL
)
292 end
.expr
= se
->string_length
;
295 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
296 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
298 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
299 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
301 if (flag_bounds_check
)
303 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
304 start
.expr
, end
.expr
);
306 /* Check lower bound. */
307 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
308 build_int_cst (gfc_charlen_type_node
, 1));
309 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
312 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
313 "is less than one", name
);
315 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
317 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
318 fold_convert (long_integer_type_node
,
322 /* Check upper bound. */
323 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
325 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
328 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
329 "exceeds string length (%%ld)", name
);
331 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
332 "exceeds string length (%%ld)");
333 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
334 fold_convert (long_integer_type_node
, end
.expr
),
335 fold_convert (long_integer_type_node
,
340 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
341 build_int_cst (gfc_charlen_type_node
, 1),
343 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
344 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
345 build_int_cst (gfc_charlen_type_node
, 0));
346 se
->string_length
= tmp
;
350 /* Convert a derived type component reference. */
353 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
360 c
= ref
->u
.c
.component
;
362 gcc_assert (c
->backend_decl
);
364 field
= c
->backend_decl
;
365 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
367 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
371 if (c
->ts
.type
== BT_CHARACTER
)
373 tmp
= c
->ts
.cl
->backend_decl
;
374 /* Components must always be constant length. */
375 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
376 se
->string_length
= tmp
;
379 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
380 se
->expr
= build_fold_indirect_ref (se
->expr
);
384 /* Return the contents of a variable. Also handles reference/pointer
385 variables (all Fortran pointer references are implicit). */
388 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
395 bool alternate_entry
;
398 sym
= expr
->symtree
->n
.sym
;
401 /* Check that something hasn't gone horribly wrong. */
402 gcc_assert (se
->ss
!= gfc_ss_terminator
);
403 gcc_assert (se
->ss
->expr
== expr
);
405 /* A scalarized term. We already know the descriptor. */
406 se
->expr
= se
->ss
->data
.info
.descriptor
;
407 se
->string_length
= se
->ss
->string_length
;
408 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
409 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
414 tree se_expr
= NULL_TREE
;
416 se
->expr
= gfc_get_symbol_decl (sym
);
418 /* Deal with references to a parent results or entries by storing
419 the current_function_decl and moving to the parent_decl. */
420 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
421 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
422 && sym
->result
== sym
;
423 entry_master
= sym
->attr
.result
424 && sym
->ns
->proc_name
->attr
.entry_master
425 && !gfc_return_by_reference (sym
->ns
->proc_name
);
426 parent_decl
= DECL_CONTEXT (current_function_decl
);
428 if ((se
->expr
== parent_decl
&& return_value
)
429 || (sym
->ns
&& sym
->ns
->proc_name
431 && sym
->ns
->proc_name
->backend_decl
== parent_decl
432 && (alternate_entry
|| entry_master
)))
437 /* Special case for assigning the return value of a function.
438 Self recursive functions must have an explicit return value. */
439 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
440 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
442 /* Similarly for alternate entry points. */
443 else if (alternate_entry
444 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
447 gfc_entry_list
*el
= NULL
;
449 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
452 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
457 else if (entry_master
458 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
460 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
465 /* Procedure actual arguments. */
466 else if (sym
->attr
.flavor
== FL_PROCEDURE
467 && se
->expr
!= current_function_decl
)
469 gcc_assert (se
->want_pointer
);
470 if (!sym
->attr
.dummy
)
472 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
473 se
->expr
= build_fold_addr_expr (se
->expr
);
479 /* Dereference the expression, where needed. Since characters
480 are entirely different from other types, they are treated
482 if (sym
->ts
.type
== BT_CHARACTER
)
484 /* Dereference character pointer dummy arguments
486 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
488 || sym
->attr
.function
489 || sym
->attr
.result
))
490 se
->expr
= build_fold_indirect_ref (se
->expr
);
493 else if (!sym
->attr
.value
)
495 /* Dereference non-character scalar dummy arguments. */
496 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
497 se
->expr
= build_fold_indirect_ref (se
->expr
);
499 /* Dereference scalar hidden result. */
500 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
501 && (sym
->attr
.function
|| sym
->attr
.result
)
502 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
503 se
->expr
= build_fold_indirect_ref (se
->expr
);
505 /* Dereference non-character pointer variables.
506 These must be dummies, results, or scalars. */
507 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
509 || sym
->attr
.function
511 || !sym
->attr
.dimension
))
512 se
->expr
= build_fold_indirect_ref (se
->expr
);
518 /* For character variables, also get the length. */
519 if (sym
->ts
.type
== BT_CHARACTER
)
521 /* If the character length of an entry isn't set, get the length from
522 the master function instead. */
523 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
524 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
526 se
->string_length
= sym
->ts
.cl
->backend_decl
;
527 gcc_assert (se
->string_length
);
535 /* Return the descriptor if that's what we want and this is an array
536 section reference. */
537 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
539 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
540 /* Return the descriptor for array pointers and allocations. */
542 && ref
->next
== NULL
&& (se
->descriptor_only
))
545 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
546 /* Return a pointer to an element. */
550 gfc_conv_component_ref (se
, ref
);
554 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
555 expr
->symtree
->name
, &expr
->where
);
564 /* Pointer assignment, allocation or pass by reference. Arrays are handled
566 if (se
->want_pointer
)
568 if (expr
->ts
.type
== BT_CHARACTER
)
569 gfc_conv_string_parameter (se
);
571 se
->expr
= build_fold_addr_expr (se
->expr
);
576 /* Unary ops are easy... Or they would be if ! was a valid op. */
579 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
584 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
585 /* Initialize the operand. */
586 gfc_init_se (&operand
, se
);
587 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
588 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
590 type
= gfc_typenode_for_spec (&expr
->ts
);
592 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
593 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
594 All other unary operators have an equivalent GIMPLE unary operator. */
595 if (code
== TRUTH_NOT_EXPR
)
596 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
597 build_int_cst (type
, 0));
599 se
->expr
= build1 (code
, type
, operand
.expr
);
603 /* Expand power operator to optimal multiplications when a value is raised
604 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
605 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
606 Programming", 3rd Edition, 1998. */
608 /* This code is mostly duplicated from expand_powi in the backend.
609 We establish the "optimal power tree" lookup table with the defined size.
610 The items in the table are the exponents used to calculate the index
611 exponents. Any integer n less than the value can get an "addition chain",
612 with the first node being one. */
613 #define POWI_TABLE_SIZE 256
615 /* The table is from builtins.c. */
616 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
618 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
619 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
620 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
621 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
622 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
623 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
624 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
625 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
626 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
627 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
628 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
629 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
630 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
631 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
632 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
633 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
634 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
635 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
636 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
637 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
638 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
639 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
640 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
641 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
642 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
643 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
644 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
645 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
646 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
647 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
648 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
649 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
652 /* If n is larger than lookup table's max index, we use the "window
654 #define POWI_WINDOW_SIZE 3
656 /* Recursive function to expand the power operator. The temporary
657 values are put in tmpvar. The function returns tmpvar[1] ** n. */
659 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
666 if (n
< POWI_TABLE_SIZE
)
671 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
672 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
676 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
677 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
678 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
682 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
686 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
687 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
689 if (n
< POWI_TABLE_SIZE
)
696 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
697 return 1. Else return 0 and a call to runtime library functions
698 will have to be built. */
700 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
705 tree vartmp
[POWI_TABLE_SIZE
];
707 unsigned HOST_WIDE_INT n
;
710 /* If exponent is too large, we won't expand it anyway, so don't bother
711 with large integer values. */
712 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
715 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
716 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
717 of the asymmetric range of the integer type. */
718 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
720 type
= TREE_TYPE (lhs
);
721 sgn
= tree_int_cst_sgn (rhs
);
723 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
724 || optimize_size
) && (m
> 2 || m
< -1))
730 se
->expr
= gfc_build_const (type
, integer_one_node
);
734 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
735 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
737 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
738 build_int_cst (TREE_TYPE (lhs
), -1));
739 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
740 build_int_cst (TREE_TYPE (lhs
), 1));
743 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
746 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
747 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
748 build_int_cst (type
, 0));
752 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
753 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
754 build_int_cst (type
, 0));
755 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
759 memset (vartmp
, 0, sizeof (vartmp
));
763 tmp
= gfc_build_const (type
, integer_one_node
);
764 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
767 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
773 /* Power op (**). Constant integer exponent has special handling. */
776 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
778 tree gfc_int4_type_node
;
785 gfc_init_se (&lse
, se
);
786 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
787 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
788 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
790 gfc_init_se (&rse
, se
);
791 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
792 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
794 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
795 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
796 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
799 gfc_int4_type_node
= gfc_get_int_type (4);
801 kind
= expr
->value
.op
.op1
->ts
.kind
;
802 switch (expr
->value
.op
.op2
->ts
.type
)
805 ikind
= expr
->value
.op
.op2
->ts
.kind
;
810 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
832 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
833 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
858 switch (expr
->value
.op
.op1
->ts
.type
)
861 if (kind
== 3) /* Case 16 was not handled properly above. */
863 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
867 /* Use builtins for real ** int4. */
873 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
877 fndecl
= built_in_decls
[BUILT_IN_POWI
];
882 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
890 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
894 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
906 fndecl
= built_in_decls
[BUILT_IN_POWF
];
909 fndecl
= built_in_decls
[BUILT_IN_POW
];
913 fndecl
= built_in_decls
[BUILT_IN_POWL
];
924 fndecl
= gfor_fndecl_math_cpowf
;
927 fndecl
= gfor_fndecl_math_cpow
;
930 fndecl
= gfor_fndecl_math_cpowl10
;
933 fndecl
= gfor_fndecl_math_cpowl16
;
945 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
949 /* Generate code to allocate a string temporary. */
952 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
957 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
959 if (gfc_can_put_var_on_stack (len
))
961 /* Create a temporary variable to hold the result. */
962 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
963 build_int_cst (gfc_charlen_type_node
, 1));
964 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
965 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
966 var
= gfc_create_var (tmp
, "str");
967 var
= gfc_build_addr_expr (type
, var
);
971 /* Allocate a temporary to hold the result. */
972 var
= gfc_create_var (type
, "pstr");
973 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
974 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
976 /* Free the temporary afterwards. */
977 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
978 gfc_add_expr_to_block (&se
->post
, tmp
);
985 /* Handle a string concatenation operation. A temporary will be allocated to
989 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
998 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
999 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1001 gfc_init_se (&lse
, se
);
1002 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1003 gfc_conv_string_parameter (&lse
);
1004 gfc_init_se (&rse
, se
);
1005 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1006 gfc_conv_string_parameter (&rse
);
1008 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1009 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1011 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1012 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1013 if (len
== NULL_TREE
)
1015 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1016 lse
.string_length
, rse
.string_length
);
1019 type
= build_pointer_type (type
);
1021 var
= gfc_conv_string_tmp (se
, type
, len
);
1023 /* Do the actual concatenation. */
1024 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1026 lse
.string_length
, lse
.expr
,
1027 rse
.string_length
, rse
.expr
);
1028 gfc_add_expr_to_block (&se
->pre
, tmp
);
1030 /* Add the cleanup for the operands. */
1031 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1032 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1035 se
->string_length
= len
;
1038 /* Translates an op expression. Common (binary) cases are handled by this
1039 function, others are passed on. Recursion is used in either case.
1040 We use the fact that (op1.ts == op2.ts) (except for the power
1042 Operators need no special handling for scalarized expressions as long as
1043 they call gfc_conv_simple_val to get their operands.
1044 Character strings get special handling. */
1047 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1049 enum tree_code code
;
1058 switch (expr
->value
.op
.operator)
1060 case INTRINSIC_UPLUS
:
1061 case INTRINSIC_PARENTHESES
:
1062 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1065 case INTRINSIC_UMINUS
:
1066 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1070 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1073 case INTRINSIC_PLUS
:
1077 case INTRINSIC_MINUS
:
1081 case INTRINSIC_TIMES
:
1085 case INTRINSIC_DIVIDE
:
1086 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1087 an integer, we must round towards zero, so we use a
1089 if (expr
->ts
.type
== BT_INTEGER
)
1090 code
= TRUNC_DIV_EXPR
;
1095 case INTRINSIC_POWER
:
1096 gfc_conv_power_op (se
, expr
);
1099 case INTRINSIC_CONCAT
:
1100 gfc_conv_concat_op (se
, expr
);
1104 code
= TRUTH_ANDIF_EXPR
;
1109 code
= TRUTH_ORIF_EXPR
;
1113 /* EQV and NEQV only work on logicals, but since we represent them
1114 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1116 case INTRINSIC_EQ_OS
:
1124 case INTRINSIC_NE_OS
:
1125 case INTRINSIC_NEQV
:
1132 case INTRINSIC_GT_OS
:
1139 case INTRINSIC_GE_OS
:
1146 case INTRINSIC_LT_OS
:
1153 case INTRINSIC_LE_OS
:
1159 case INTRINSIC_USER
:
1160 case INTRINSIC_ASSIGN
:
1161 /* These should be converted into function calls by the frontend. */
1165 fatal_error ("Unknown intrinsic op");
1169 /* The only exception to this is **, which is handled separately anyway. */
1170 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1172 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1176 gfc_init_se (&lse
, se
);
1177 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1178 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1181 gfc_init_se (&rse
, se
);
1182 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1183 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1187 gfc_conv_string_parameter (&lse
);
1188 gfc_conv_string_parameter (&rse
);
1190 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1191 rse
.string_length
, rse
.expr
);
1192 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1193 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1196 type
= gfc_typenode_for_spec (&expr
->ts
);
1200 /* The result of logical ops is always boolean_type_node. */
1201 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1202 se
->expr
= convert (type
, tmp
);
1205 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1207 /* Add the post blocks. */
1208 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1209 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1212 /* If a string's length is one, we convert it to a single character. */
1215 gfc_to_single_character (tree len
, tree str
)
1217 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1219 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1220 && TREE_INT_CST_HIGH (len
) == 0)
1222 str
= fold_convert (pchar_type_node
, str
);
1223 return build_fold_indirect_ref (str
);
1231 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1234 if (sym
->backend_decl
)
1236 /* This becomes the nominal_type in
1237 function.c:assign_parm_find_data_types. */
1238 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1239 /* This becomes the passed_type in
1240 function.c:assign_parm_find_data_types. C promotes char to
1241 integer for argument passing. */
1242 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1244 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1249 /* If we have a constant character expression, make it into an
1251 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1255 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1256 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1258 /* The expr needs to be compatible with a C int. If the
1259 conversion fails, then the 2 causes an ICE. */
1260 ts
.type
= BT_INTEGER
;
1261 ts
.kind
= gfc_c_int_kind
;
1262 gfc_convert_type (*expr
, &ts
, 2);
1265 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1267 if ((*expr
)->ref
== NULL
)
1269 se
->expr
= gfc_to_single_character
1270 (build_int_cst (integer_type_node
, 1),
1271 gfc_build_addr_expr (pchar_type_node
,
1273 ((*expr
)->symtree
->n
.sym
)));
1277 gfc_conv_variable (se
, *expr
);
1278 se
->expr
= gfc_to_single_character
1279 (build_int_cst (integer_type_node
, 1),
1280 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1287 /* Compare two strings. If they are all single characters, the result is the
1288 subtraction of them. Otherwise, we build a library call. */
1291 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1297 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1298 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1300 sc1
= gfc_to_single_character (len1
, str1
);
1301 sc2
= gfc_to_single_character (len2
, str2
);
1303 /* Deal with single character specially. */
1304 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1306 sc1
= fold_convert (integer_type_node
, sc1
);
1307 sc2
= fold_convert (integer_type_node
, sc2
);
1308 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1311 /* Build a call for the comparison. */
1312 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1313 len1
, str1
, len2
, str2
);
1318 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1322 if (sym
->attr
.dummy
)
1324 tmp
= gfc_get_symbol_decl (sym
);
1325 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1326 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1330 if (!sym
->backend_decl
)
1331 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1333 tmp
= sym
->backend_decl
;
1334 if (sym
->attr
.cray_pointee
)
1335 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1336 gfc_get_symbol_decl (sym
->cp_pointer
));
1337 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1339 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1340 tmp
= build_fold_addr_expr (tmp
);
1347 /* Translate the call for an elemental subroutine call used in an operator
1348 assignment. This is a simplified version of gfc_conv_function_call. */
1351 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1358 /* Only elemental subroutines with two arguments. */
1359 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1360 gcc_assert (sym
->formal
->next
->next
== NULL
);
1362 gfc_init_block (&block
);
1364 gfc_add_block_to_block (&block
, &lse
->pre
);
1365 gfc_add_block_to_block (&block
, &rse
->pre
);
1367 /* Build the argument list for the call, including hidden string lengths. */
1368 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1369 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1370 if (lse
->string_length
!= NULL_TREE
)
1371 args
= gfc_chainon_list (args
, lse
->string_length
);
1372 if (rse
->string_length
!= NULL_TREE
)
1373 args
= gfc_chainon_list (args
, rse
->string_length
);
1375 /* Build the function call. */
1376 gfc_init_se (&se
, NULL
);
1377 gfc_conv_function_val (&se
, sym
);
1378 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1379 tmp
= build_call_list (tmp
, se
.expr
, args
);
1380 gfc_add_expr_to_block (&block
, tmp
);
1382 gfc_add_block_to_block (&block
, &lse
->post
);
1383 gfc_add_block_to_block (&block
, &rse
->post
);
1385 return gfc_finish_block (&block
);
1389 /* Initialize MAPPING. */
1392 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1394 mapping
->syms
= NULL
;
1395 mapping
->charlens
= NULL
;
1399 /* Free all memory held by MAPPING (but not MAPPING itself). */
1402 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1404 gfc_interface_sym_mapping
*sym
;
1405 gfc_interface_sym_mapping
*nextsym
;
1407 gfc_charlen
*nextcl
;
1409 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1411 nextsym
= sym
->next
;
1412 gfc_free_symbol (sym
->new->n
.sym
);
1413 gfc_free (sym
->new);
1416 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1419 gfc_free_expr (cl
->length
);
1425 /* Return a copy of gfc_charlen CL. Add the returned structure to
1426 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1428 static gfc_charlen
*
1429 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1434 new = gfc_get_charlen ();
1435 new->next
= mapping
->charlens
;
1436 new->length
= gfc_copy_expr (cl
->length
);
1438 mapping
->charlens
= new;
1443 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1444 array variable that can be used as the actual argument for dummy
1445 argument SYM. Add any initialization code to BLOCK. PACKED is as
1446 for gfc_get_nodesc_array_type and DATA points to the first element
1447 in the passed array. */
1450 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1451 gfc_packed packed
, tree data
)
1456 type
= gfc_typenode_for_spec (&sym
->ts
);
1457 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1459 var
= gfc_create_var (type
, "ifm");
1460 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1466 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1467 and offset of descriptorless array type TYPE given that it has the same
1468 size as DESC. Add any set-up code to BLOCK. */
1471 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1478 offset
= gfc_index_zero_node
;
1479 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1481 dim
= gfc_rank_cst
[n
];
1482 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1483 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1485 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1486 = gfc_conv_descriptor_lbound (desc
, dim
);
1487 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1488 = gfc_conv_descriptor_ubound (desc
, dim
);
1490 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1492 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1493 gfc_conv_descriptor_ubound (desc
, dim
),
1494 gfc_conv_descriptor_lbound (desc
, dim
));
1495 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1496 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1498 tmp
= gfc_evaluate_now (tmp
, block
);
1499 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1501 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1502 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1503 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1504 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1506 offset
= gfc_evaluate_now (offset
, block
);
1507 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1511 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1512 in SE. The caller may still use se->expr and se->string_length after
1513 calling this function. */
1516 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1517 gfc_symbol
* sym
, gfc_se
* se
)
1519 gfc_interface_sym_mapping
*sm
;
1523 gfc_symbol
*new_sym
;
1525 gfc_symtree
*new_symtree
;
1527 /* Create a new symbol to represent the actual argument. */
1528 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1529 new_sym
->ts
= sym
->ts
;
1530 new_sym
->attr
.referenced
= 1;
1531 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1532 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1533 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1534 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1536 /* Create a fake symtree for it. */
1538 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1539 new_symtree
->n
.sym
= new_sym
;
1540 gcc_assert (new_symtree
== root
);
1542 /* Create a dummy->actual mapping. */
1543 sm
= gfc_getmem (sizeof (*sm
));
1544 sm
->next
= mapping
->syms
;
1546 sm
->new = new_symtree
;
1549 /* Stabilize the argument's value. */
1550 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1552 if (sym
->ts
.type
== BT_CHARACTER
)
1554 /* Create a copy of the dummy argument's length. */
1555 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1557 /* If the length is specified as "*", record the length that
1558 the caller is passing. We should use the callee's length
1559 in all other cases. */
1560 if (!new_sym
->ts
.cl
->length
)
1562 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1563 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1567 /* Use the passed value as-is if the argument is a function. */
1568 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1571 /* If the argument is either a string or a pointer to a string,
1572 convert it to a boundless character type. */
1573 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1575 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1576 tmp
= build_pointer_type (tmp
);
1577 if (sym
->attr
.pointer
)
1578 value
= build_fold_indirect_ref (se
->expr
);
1581 value
= fold_convert (tmp
, value
);
1584 /* If the argument is a scalar, a pointer to an array or an allocatable,
1586 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1587 value
= build_fold_indirect_ref (se
->expr
);
1589 /* For character(*), use the actual argument's descriptor. */
1590 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1591 value
= build_fold_indirect_ref (se
->expr
);
1593 /* If the argument is an array descriptor, use it to determine
1594 information about the actual argument's shape. */
1595 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1596 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1598 /* Get the actual argument's descriptor. */
1599 desc
= build_fold_indirect_ref (se
->expr
);
1601 /* Create the replacement variable. */
1602 tmp
= gfc_conv_descriptor_data_get (desc
);
1603 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1606 /* Use DESC to work out the upper bounds, strides and offset. */
1607 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1610 /* Otherwise we have a packed array. */
1611 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1612 PACKED_FULL
, se
->expr
);
1614 new_sym
->backend_decl
= value
;
1618 /* Called once all dummy argument mappings have been added to MAPPING,
1619 but before the mapping is used to evaluate expressions. Pre-evaluate
1620 the length of each argument, adding any initialization code to PRE and
1621 any finalization code to POST. */
1624 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1625 stmtblock_t
* pre
, stmtblock_t
* post
)
1627 gfc_interface_sym_mapping
*sym
;
1631 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1632 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1633 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1635 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1636 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1637 gfc_init_se (&se
, NULL
);
1638 gfc_conv_expr (&se
, expr
);
1640 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1641 gfc_add_block_to_block (pre
, &se
.pre
);
1642 gfc_add_block_to_block (post
, &se
.post
);
1644 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1649 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1653 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1654 gfc_constructor
* c
)
1656 for (; c
; c
= c
->next
)
1658 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1661 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1662 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1663 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1669 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1673 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1678 for (; ref
; ref
= ref
->next
)
1682 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1684 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1685 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1686 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1688 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1695 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1696 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1702 /* EXPR is a copy of an expression that appeared in the interface
1703 associated with MAPPING. Walk it recursively looking for references to
1704 dummy arguments that MAPPING maps to actual arguments. Replace each such
1705 reference with a reference to the associated actual argument. */
1708 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1711 gfc_interface_sym_mapping
*sym
;
1712 gfc_actual_arglist
*actual
;
1713 int seen_result
= 0;
1718 /* Copying an expression does not copy its length, so do that here. */
1719 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1721 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1722 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1725 /* Apply the mapping to any references. */
1726 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1728 /* ...and to the expression's symbol, if it has one. */
1730 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1731 if (sym
->old
== expr
->symtree
->n
.sym
)
1732 expr
->symtree
= sym
->new;
1734 /* ...and to subexpressions in expr->value. */
1735 switch (expr
->expr_type
)
1738 if (expr
->symtree
->n
.sym
->attr
.result
)
1742 case EXPR_SUBSTRING
:
1746 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1747 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1751 if (expr
->value
.function
.esym
== NULL
1752 && expr
->value
.function
.isym
!= NULL
1753 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1754 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1755 && gfc_apply_interface_mapping_to_expr (mapping
,
1756 expr
->value
.function
.actual
->expr
))
1759 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1761 gfc_free (new_expr
);
1762 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1766 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1767 if (sym
->old
== expr
->value
.function
.esym
)
1768 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1770 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1771 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1775 case EXPR_STRUCTURE
:
1776 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1783 /* Evaluate interface expression EXPR using MAPPING. Store the result
1787 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1788 gfc_se
* se
, gfc_expr
* expr
)
1790 expr
= gfc_copy_expr (expr
);
1791 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1792 gfc_conv_expr (se
, expr
);
1793 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1794 gfc_free_expr (expr
);
1798 /* Returns a reference to a temporary array into which a component of
1799 an actual argument derived type array is copied and then returned
1800 after the function call. */
1802 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1803 int g77
, sym_intent intent
)
1819 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1821 gfc_init_se (&lse
, NULL
);
1822 gfc_init_se (&rse
, NULL
);
1824 /* Walk the argument expression. */
1825 rss
= gfc_walk_expr (expr
);
1827 gcc_assert (rss
!= gfc_ss_terminator
);
1829 /* Initialize the scalarizer. */
1830 gfc_init_loopinfo (&loop
);
1831 gfc_add_ss_to_loop (&loop
, rss
);
1833 /* Calculate the bounds of the scalarization. */
1834 gfc_conv_ss_startstride (&loop
);
1836 /* Build an ss for the temporary. */
1837 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
1838 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
1840 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1841 if (GFC_ARRAY_TYPE_P (base_type
)
1842 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1843 base_type
= gfc_get_element_type (base_type
);
1845 loop
.temp_ss
= gfc_get_ss ();;
1846 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1847 loop
.temp_ss
->data
.temp
.type
= base_type
;
1849 if (expr
->ts
.type
== BT_CHARACTER
)
1850 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1852 loop
.temp_ss
->string_length
= NULL
;
1854 parmse
->string_length
= loop
.temp_ss
->string_length
;
1855 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1856 loop
.temp_ss
->next
= gfc_ss_terminator
;
1858 /* Associate the SS with the loop. */
1859 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1861 /* Setup the scalarizing loops. */
1862 gfc_conv_loop_setup (&loop
);
1864 /* Pass the temporary descriptor back to the caller. */
1865 info
= &loop
.temp_ss
->data
.info
;
1866 parmse
->expr
= info
->descriptor
;
1868 /* Setup the gfc_se structures. */
1869 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1870 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1873 lse
.ss
= loop
.temp_ss
;
1874 gfc_mark_ss_chain_used (rss
, 1);
1875 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1877 /* Start the scalarized loop body. */
1878 gfc_start_scalarized_body (&loop
, &body
);
1880 /* Translate the expression. */
1881 gfc_conv_expr (&rse
, expr
);
1883 gfc_conv_tmp_array_ref (&lse
);
1884 gfc_advance_se_ss_chain (&lse
);
1886 if (intent
!= INTENT_OUT
)
1888 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1889 gfc_add_expr_to_block (&body
, tmp
);
1890 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1891 gfc_trans_scalarizing_loops (&loop
, &body
);
1895 /* Make sure that the temporary declaration survives by merging
1896 all the loop declarations into the current context. */
1897 for (n
= 0; n
< loop
.dimen
; n
++)
1899 gfc_merge_block_scope (&body
);
1900 body
= loop
.code
[loop
.order
[n
]];
1902 gfc_merge_block_scope (&body
);
1905 /* Add the post block after the second loop, so that any
1906 freeing of allocated memory is done at the right time. */
1907 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1909 /**********Copy the temporary back again.*********/
1911 gfc_init_se (&lse
, NULL
);
1912 gfc_init_se (&rse
, NULL
);
1914 /* Walk the argument expression. */
1915 lss
= gfc_walk_expr (expr
);
1916 rse
.ss
= loop
.temp_ss
;
1919 /* Initialize the scalarizer. */
1920 gfc_init_loopinfo (&loop2
);
1921 gfc_add_ss_to_loop (&loop2
, lss
);
1923 /* Calculate the bounds of the scalarization. */
1924 gfc_conv_ss_startstride (&loop2
);
1926 /* Setup the scalarizing loops. */
1927 gfc_conv_loop_setup (&loop2
);
1929 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1930 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1932 gfc_mark_ss_chain_used (lss
, 1);
1933 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1935 /* Declare the variable to hold the temporary offset and start the
1936 scalarized loop body. */
1937 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1938 gfc_start_scalarized_body (&loop2
, &body
);
1940 /* Build the offsets for the temporary from the loop variables. The
1941 temporary array has lbounds of zero and strides of one in all
1942 dimensions, so this is very simple. The offset is only computed
1943 outside the innermost loop, so the overall transfer could be
1944 optimized further. */
1945 info
= &rse
.ss
->data
.info
;
1947 tmp_index
= gfc_index_zero_node
;
1948 for (n
= info
->dimen
- 1; n
> 0; n
--)
1951 tmp
= rse
.loop
->loopvar
[n
];
1952 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1953 tmp
, rse
.loop
->from
[n
]);
1954 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1957 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1958 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1959 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1960 tmp_str
, gfc_index_one_node
);
1962 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1966 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1967 tmp_index
, rse
.loop
->from
[0]);
1968 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1970 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1971 rse
.loop
->loopvar
[0], offset
);
1973 /* Now use the offset for the reference. */
1974 tmp
= build_fold_indirect_ref (info
->data
);
1975 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
1977 if (expr
->ts
.type
== BT_CHARACTER
)
1978 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1980 gfc_conv_expr (&lse
, expr
);
1982 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1984 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1985 gfc_add_expr_to_block (&body
, tmp
);
1987 /* Generate the copying loops. */
1988 gfc_trans_scalarizing_loops (&loop2
, &body
);
1990 /* Wrap the whole thing up by adding the second loop to the post-block
1991 and following it by the post-block of the first loop. In this way,
1992 if the temporary needs freeing, it is done after use! */
1993 if (intent
!= INTENT_IN
)
1995 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1996 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1999 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2001 gfc_cleanup_loop (&loop
);
2002 gfc_cleanup_loop (&loop2
);
2004 /* Pass the string length to the argument expression. */
2005 if (expr
->ts
.type
== BT_CHARACTER
)
2006 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2008 /* We want either the address for the data or the address of the descriptor,
2009 depending on the mode of passing array arguments. */
2011 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2013 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2019 /* Generate the code for argument list functions. */
2022 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2024 /* Pass by value for g77 %VAL(arg), pass the address
2025 indirectly for %LOC, else by reference. Thus %REF
2026 is a "do-nothing" and %LOC is the same as an F95
2028 if (strncmp (name
, "%VAL", 4) == 0)
2029 gfc_conv_expr (se
, expr
);
2030 else if (strncmp (name
, "%LOC", 4) == 0)
2032 gfc_conv_expr_reference (se
, expr
);
2033 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2035 else if (strncmp (name
, "%REF", 4) == 0)
2036 gfc_conv_expr_reference (se
, expr
);
2038 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2042 /* Generate code for a procedure call. Note can return se->post != NULL.
2043 If se->direct_byref is set then se->expr contains the return parameter.
2044 Return nonzero, if the call has alternate specifiers. */
2047 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2048 gfc_actual_arglist
* arg
, tree append_args
)
2050 gfc_interface_mapping mapping
;
2064 gfc_formal_arglist
*formal
;
2065 int has_alternate_specifier
= 0;
2066 bool need_interface_mapping
;
2073 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2075 arglist
= NULL_TREE
;
2076 retargs
= NULL_TREE
;
2077 stringargs
= NULL_TREE
;
2081 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2083 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2085 if (arg
->expr
->rank
== 0)
2086 gfc_conv_expr_reference (se
, arg
->expr
);
2090 /* This is really the actual arg because no formal arglist is
2091 created for C_LOC. */
2092 fsym
= arg
->expr
->symtree
->n
.sym
;
2094 /* We should want it to do g77 calling convention. */
2096 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2097 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2098 f
= f
|| !sym
->attr
.always_explicit
;
2100 argss
= gfc_walk_expr (arg
->expr
);
2101 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2106 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2108 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2109 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2110 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2111 gfc_conv_expr_reference (se
, arg
->expr
);
2115 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2120 /* Build the addr_expr for the first argument. The argument is
2121 already an *address* so we don't need to set want_pointer in
2123 gfc_init_se (&arg1se
, NULL
);
2124 gfc_conv_expr (&arg1se
, arg
->expr
);
2125 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2126 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2128 /* See if we were given two arguments. */
2129 if (arg
->next
== NULL
)
2130 /* Only given one arg so generate a null and do a
2131 not-equal comparison against the first arg. */
2132 se
->expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2133 fold_convert (TREE_TYPE (arg1se
.expr
),
2134 null_pointer_node
));
2140 /* Given two arguments so build the arg2se from second arg. */
2141 gfc_init_se (&arg2se
, NULL
);
2142 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2143 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2144 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2146 /* Generate test to compare that the two args are equal. */
2147 eq_expr
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
,
2149 /* Generate test to ensure that the first arg is not null. */
2150 not_null_expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2153 /* Finally, the generated test must check that both arg1 is not
2154 NULL and that it is equal to the second arg. */
2155 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2156 not_null_expr
, eq_expr
);
2165 if (!sym
->attr
.elemental
)
2167 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2168 if (se
->ss
->useflags
)
2170 gcc_assert (gfc_return_by_reference (sym
)
2171 && sym
->result
->attr
.dimension
);
2172 gcc_assert (se
->loop
!= NULL
);
2174 /* Access the previously obtained result. */
2175 gfc_conv_tmp_array_ref (se
);
2176 gfc_advance_se_ss_chain (se
);
2180 info
= &se
->ss
->data
.info
;
2185 gfc_init_block (&post
);
2186 gfc_init_interface_mapping (&mapping
);
2187 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2188 && sym
->ts
.cl
->length
2189 && sym
->ts
.cl
->length
->expr_type
2191 || sym
->attr
.dimension
);
2192 formal
= sym
->formal
;
2193 /* Evaluate the arguments. */
2194 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2197 fsym
= formal
? formal
->sym
: NULL
;
2198 parm_kind
= MISSING
;
2202 if (se
->ignore_optional
)
2204 /* Some intrinsics have already been resolved to the correct
2208 else if (arg
->label
)
2210 has_alternate_specifier
= 1;
2215 /* Pass a NULL pointer for an absent arg. */
2216 gfc_init_se (&parmse
, NULL
);
2217 parmse
.expr
= null_pointer_node
;
2218 if (arg
->missing_arg_type
== BT_CHARACTER
)
2219 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2222 else if (se
->ss
&& se
->ss
->useflags
)
2224 /* An elemental function inside a scalarized loop. */
2225 gfc_init_se (&parmse
, se
);
2226 gfc_conv_expr_reference (&parmse
, e
);
2227 parm_kind
= ELEMENTAL
;
2231 /* A scalar or transformational function. */
2232 gfc_init_se (&parmse
, NULL
);
2233 argss
= gfc_walk_expr (e
);
2235 if (argss
== gfc_ss_terminator
)
2237 if (fsym
&& fsym
->attr
.value
)
2239 if (fsym
->ts
.type
== BT_CHARACTER
2240 && fsym
->ts
.is_c_interop
2241 && fsym
->ns
->proc_name
!= NULL
2242 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2245 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2246 if (parmse
.expr
== NULL
)
2247 gfc_conv_expr (&parmse
, e
);
2250 gfc_conv_expr (&parmse
, e
);
2252 else if (arg
->name
&& arg
->name
[0] == '%')
2253 /* Argument list functions %VAL, %LOC and %REF are signalled
2254 through arg->name. */
2255 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2256 else if ((e
->expr_type
== EXPR_FUNCTION
)
2257 && e
->symtree
->n
.sym
->attr
.pointer
2258 && fsym
&& fsym
->attr
.target
)
2260 gfc_conv_expr (&parmse
, e
);
2261 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2265 gfc_conv_expr_reference (&parmse
, e
);
2266 if (fsym
&& fsym
->attr
.pointer
2267 && fsym
->attr
.flavor
!= FL_PROCEDURE
2268 && e
->expr_type
!= EXPR_NULL
)
2270 /* Scalar pointer dummy args require an extra level of
2271 indirection. The null pointer already contains
2272 this level of indirection. */
2273 parm_kind
= SCALAR_POINTER
;
2274 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2280 /* If the procedure requires an explicit interface, the actual
2281 argument is passed according to the corresponding formal
2282 argument. If the corresponding formal argument is a POINTER,
2283 ALLOCATABLE or assumed shape, we do not use g77's calling
2284 convention, and pass the address of the array descriptor
2285 instead. Otherwise we use g77's calling convention. */
2288 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2289 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2290 f
= f
|| !sym
->attr
.always_explicit
;
2292 if (e
->expr_type
== EXPR_VARIABLE
2293 && is_subref_array (e
))
2294 /* The actual argument is a component reference to an
2295 array of derived types. In this case, the argument
2296 is converted to a temporary, which is passed and then
2297 written back after the procedure call. */
2298 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2299 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2301 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2303 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2304 allocated on entry, it must be deallocated. */
2305 if (fsym
&& fsym
->attr
.allocatable
2306 && fsym
->attr
.intent
== INTENT_OUT
)
2308 tmp
= build_fold_indirect_ref (parmse
.expr
);
2309 tmp
= gfc_trans_dealloc_allocated (tmp
);
2310 gfc_add_expr_to_block (&se
->pre
, tmp
);
2316 /* The case with fsym->attr.optional is that of a user subroutine
2317 with an interface indicating an optional argument. When we call
2318 an intrinsic subroutine, however, fsym is NULL, but we might still
2319 have an optional argument, so we proceed to the substitution
2321 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2323 /* If an optional argument is itself an optional dummy argument,
2324 check its presence and substitute a null if absent. */
2325 if (e
->expr_type
== EXPR_VARIABLE
2326 && e
->symtree
->n
.sym
->attr
.optional
)
2327 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
);
2332 /* Obtain the character length of an assumed character length
2333 length procedure from the typespec. */
2334 if (fsym
->ts
.type
== BT_CHARACTER
2335 && parmse
.string_length
== NULL_TREE
2336 && e
->ts
.type
== BT_PROCEDURE
2337 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2338 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2340 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2341 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2345 if (fsym
&& need_interface_mapping
)
2346 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2348 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2349 gfc_add_block_to_block (&post
, &parmse
.post
);
2351 /* Allocated allocatable components of derived types must be
2352 deallocated for INTENT(OUT) dummy arguments and non-variable
2353 scalars. Non-variable arrays are dealt with in trans-array.c
2354 (gfc_conv_array_parameter). */
2355 if (e
&& e
->ts
.type
== BT_DERIVED
2356 && e
->ts
.derived
->attr
.alloc_comp
2357 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2359 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2362 tmp
= build_fold_indirect_ref (parmse
.expr
);
2363 parm_rank
= e
->rank
;
2371 case (SCALAR_POINTER
):
2372 tmp
= build_fold_indirect_ref (tmp
);
2379 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2380 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2381 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2382 tmp
, build_empty_stmt ());
2384 if (e
->expr_type
!= EXPR_VARIABLE
)
2385 /* Don't deallocate non-variables until they have been used. */
2386 gfc_add_expr_to_block (&se
->post
, tmp
);
2389 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2390 gfc_add_expr_to_block (&se
->pre
, tmp
);
2394 /* Character strings are passed as two parameters, a length and a
2395 pointer - except for Bind(c) which only passes the pointer. */
2396 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2397 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2399 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2401 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2404 if (ts
.type
== BT_CHARACTER
)
2406 if (sym
->ts
.cl
->length
== NULL
)
2408 /* Assumed character length results are not allowed by 5.1.1.5 of the
2409 standard and are trapped in resolve.c; except in the case of SPREAD
2410 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2411 we take the character length of the first argument for the result.
2412 For dummies, we have to look through the formal argument list for
2413 this function and use the character length found there.*/
2414 if (!sym
->attr
.dummy
)
2415 cl
.backend_decl
= TREE_VALUE (stringargs
);
2418 formal
= sym
->ns
->proc_name
->formal
;
2419 for (; formal
; formal
= formal
->next
)
2420 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2421 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2428 /* Calculate the length of the returned string. */
2429 gfc_init_se (&parmse
, NULL
);
2430 if (need_interface_mapping
)
2431 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2433 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2434 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2435 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2437 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2438 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2439 build_int_cst (gfc_charlen_type_node
, 0));
2440 cl
.backend_decl
= tmp
;
2443 /* Set up a charlen structure for it. */
2448 len
= cl
.backend_decl
;
2451 byref
= gfc_return_by_reference (sym
);
2454 if (se
->direct_byref
)
2456 /* Sometimes, too much indirection can be applied; eg. for
2457 function_result = array_valued_recursive_function. */
2458 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2459 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2460 && GFC_DESCRIPTOR_TYPE_P
2461 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2462 se
->expr
= build_fold_indirect_ref (se
->expr
);
2464 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2466 else if (sym
->result
->attr
.dimension
)
2468 gcc_assert (se
->loop
&& info
);
2470 /* Set the type of the array. */
2471 tmp
= gfc_typenode_for_spec (&ts
);
2472 info
->dimen
= se
->loop
->dimen
;
2474 /* Evaluate the bounds of the result, if known. */
2475 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2477 /* Create a temporary to store the result. In case the function
2478 returns a pointer, the temporary will be a shallow copy and
2479 mustn't be deallocated. */
2480 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2481 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2482 false, !sym
->attr
.pointer
, callee_alloc
);
2484 /* Pass the temporary as the first argument. */
2485 tmp
= info
->descriptor
;
2486 tmp
= build_fold_addr_expr (tmp
);
2487 retargs
= gfc_chainon_list (retargs
, tmp
);
2489 else if (ts
.type
== BT_CHARACTER
)
2491 /* Pass the string length. */
2492 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2493 type
= build_pointer_type (type
);
2495 /* Return an address to a char[0:len-1]* temporary for
2496 character pointers. */
2497 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2499 /* Build char[0:len-1] * pstr. */
2500 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2501 build_int_cst (gfc_charlen_type_node
, 1));
2502 tmp
= build_range_type (gfc_array_index_type
,
2503 gfc_index_zero_node
, tmp
);
2504 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2505 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2507 /* Provide an address expression for the function arguments. */
2508 var
= build_fold_addr_expr (var
);
2511 var
= gfc_conv_string_tmp (se
, type
, len
);
2513 retargs
= gfc_chainon_list (retargs
, var
);
2517 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2519 type
= gfc_get_complex_type (ts
.kind
);
2520 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2521 retargs
= gfc_chainon_list (retargs
, var
);
2524 /* Add the string length to the argument list. */
2525 if (ts
.type
== BT_CHARACTER
)
2526 retargs
= gfc_chainon_list (retargs
, len
);
2528 gfc_free_interface_mapping (&mapping
);
2530 /* Add the return arguments. */
2531 arglist
= chainon (retargs
, arglist
);
2533 /* Add the hidden string length parameters to the arguments. */
2534 arglist
= chainon (arglist
, stringargs
);
2536 /* We may want to append extra arguments here. This is used e.g. for
2537 calls to libgfortran_matmul_??, which need extra information. */
2538 if (append_args
!= NULL_TREE
)
2539 arglist
= chainon (arglist
, append_args
);
2541 /* Generate the actual call. */
2542 gfc_conv_function_val (se
, sym
);
2544 /* If there are alternate return labels, function type should be
2545 integer. Can't modify the type in place though, since it can be shared
2546 with other functions. For dummy arguments, the typing is done to
2547 to this result, even if it has to be repeated for each call. */
2548 if (has_alternate_specifier
2549 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2551 if (!sym
->attr
.dummy
)
2553 TREE_TYPE (sym
->backend_decl
)
2554 = build_function_type (integer_type_node
,
2555 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2556 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2559 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2562 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2563 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2565 /* If we have a pointer function, but we don't want a pointer, e.g.
2568 where f is pointer valued, we have to dereference the result. */
2569 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2570 se
->expr
= build_fold_indirect_ref (se
->expr
);
2572 /* f2c calling conventions require a scalar default real function to
2573 return a double precision result. Convert this back to default
2574 real. We only care about the cases that can happen in Fortran 77.
2576 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2577 && sym
->ts
.kind
== gfc_default_real_kind
2578 && !sym
->attr
.always_explicit
)
2579 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2581 /* A pure function may still have side-effects - it may modify its
2583 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2585 if (!sym
->attr
.pure
)
2586 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2591 /* Add the function call to the pre chain. There is no expression. */
2592 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2593 se
->expr
= NULL_TREE
;
2595 if (!se
->direct_byref
)
2597 if (sym
->attr
.dimension
)
2599 if (flag_bounds_check
)
2601 /* Check the data pointer hasn't been modified. This would
2602 happen in a function returning a pointer. */
2603 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2604 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2606 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2608 se
->expr
= info
->descriptor
;
2609 /* Bundle in the string length. */
2610 se
->string_length
= len
;
2612 else if (sym
->ts
.type
== BT_CHARACTER
)
2614 /* Dereference for character pointer results. */
2615 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2616 se
->expr
= build_fold_indirect_ref (var
);
2620 se
->string_length
= len
;
2624 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2625 se
->expr
= build_fold_indirect_ref (var
);
2630 /* Follow the function call with the argument post block. */
2632 gfc_add_block_to_block (&se
->pre
, &post
);
2634 gfc_add_block_to_block (&se
->post
, &post
);
2636 return has_alternate_specifier
;
2640 /* Generate code to copy a string. */
2643 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2644 tree slength
, tree src
)
2646 tree tmp
, dlen
, slen
;
2654 stmtblock_t tempblock
;
2656 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2657 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2659 /* Deal with single character specially. */
2660 dsc
= gfc_to_single_character (dlen
, dest
);
2661 ssc
= gfc_to_single_character (slen
, src
);
2662 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2664 gfc_add_modify_expr (block
, dsc
, ssc
);
2668 /* Do nothing if the destination length is zero. */
2669 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2670 build_int_cst (size_type_node
, 0));
2672 /* The following code was previously in _gfortran_copy_string:
2674 // The two strings may overlap so we use memmove.
2676 copy_string (GFC_INTEGER_4 destlen, char * dest,
2677 GFC_INTEGER_4 srclen, const char * src)
2679 if (srclen >= destlen)
2681 // This will truncate if too long.
2682 memmove (dest, src, destlen);
2686 memmove (dest, src, srclen);
2688 memset (&dest[srclen], ' ', destlen - srclen);
2692 We're now doing it here for better optimization, but the logic
2695 /* Truncate string if source is too long. */
2696 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2697 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2698 3, dest
, src
, dlen
);
2700 /* Else copy and pad with spaces. */
2701 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2702 3, dest
, src
, slen
);
2704 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
2705 fold_convert (sizetype
, slen
));
2706 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2708 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2709 lang_hooks
.to_target_charset (' ')),
2710 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2713 gfc_init_block (&tempblock
);
2714 gfc_add_expr_to_block (&tempblock
, tmp3
);
2715 gfc_add_expr_to_block (&tempblock
, tmp4
);
2716 tmp3
= gfc_finish_block (&tempblock
);
2718 /* The whole copy_string function is there. */
2719 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2720 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2721 gfc_add_expr_to_block (block
, tmp
);
2725 /* Translate a statement function.
2726 The value of a statement function reference is obtained by evaluating the
2727 expression using the values of the actual arguments for the values of the
2728 corresponding dummy arguments. */
2731 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2735 gfc_formal_arglist
*fargs
;
2736 gfc_actual_arglist
*args
;
2739 gfc_saved_var
*saved_vars
;
2745 sym
= expr
->symtree
->n
.sym
;
2746 args
= expr
->value
.function
.actual
;
2747 gfc_init_se (&lse
, NULL
);
2748 gfc_init_se (&rse
, NULL
);
2751 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2753 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2754 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2756 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2758 /* Each dummy shall be specified, explicitly or implicitly, to be
2760 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2763 /* Create a temporary to hold the value. */
2764 type
= gfc_typenode_for_spec (&fsym
->ts
);
2765 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2767 if (fsym
->ts
.type
== BT_CHARACTER
)
2769 /* Copy string arguments. */
2772 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2773 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2775 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2776 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2779 gfc_conv_expr (&rse
, args
->expr
);
2780 gfc_conv_string_parameter (&rse
);
2781 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2782 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2784 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2786 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2787 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2791 /* For everything else, just evaluate the expression. */
2792 gfc_conv_expr (&lse
, args
->expr
);
2794 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2795 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2796 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2802 /* Use the temporary variables in place of the real ones. */
2803 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2804 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2806 gfc_conv_expr (se
, sym
->value
);
2808 if (sym
->ts
.type
== BT_CHARACTER
)
2810 gfc_conv_const_charlen (sym
->ts
.cl
);
2812 /* Force the expression to the correct length. */
2813 if (!INTEGER_CST_P (se
->string_length
)
2814 || tree_int_cst_lt (se
->string_length
,
2815 sym
->ts
.cl
->backend_decl
))
2817 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2818 tmp
= gfc_create_var (type
, sym
->name
);
2819 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2820 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2821 se
->string_length
, se
->expr
);
2824 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2827 /* Restore the original variables. */
2828 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2829 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2830 gfc_free (saved_vars
);
2834 /* Translate a function expression. */
2837 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2841 if (expr
->value
.function
.isym
)
2843 gfc_conv_intrinsic_function (se
, expr
);
2847 /* We distinguish statement functions from general functions to improve
2848 runtime performance. */
2849 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2851 gfc_conv_statement_function (se
, expr
);
2855 /* expr.value.function.esym is the resolved (specific) function symbol for
2856 most functions. However this isn't set for dummy procedures. */
2857 sym
= expr
->value
.function
.esym
;
2859 sym
= expr
->symtree
->n
.sym
;
2860 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2865 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2867 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2868 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2870 gfc_conv_tmp_array_ref (se
);
2871 gfc_advance_se_ss_chain (se
);
2875 /* Build a static initializer. EXPR is the expression for the initial value.
2876 The other parameters describe the variable of the component being
2877 initialized. EXPR may be null. */
2880 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2881 bool array
, bool pointer
)
2885 if (!(expr
|| pointer
))
2888 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
2889 (these are the only two iso_c_binding derived types that can be
2890 used as initialization expressions). If so, we need to modify
2891 the 'expr' to be that for a (void *). */
2892 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2893 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
2895 gfc_symbol
*derived
= expr
->ts
.derived
;
2897 expr
= gfc_int_expr (0);
2899 /* The derived symbol has already been converted to a (void *). Use
2901 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
2902 expr
->ts
.kind
= derived
->ts
.kind
;
2907 /* Arrays need special handling. */
2909 return gfc_build_null_descriptor (type
);
2911 return gfc_conv_array_initializer (type
, expr
);
2914 return fold_convert (type
, null_pointer_node
);
2920 gfc_init_se (&se
, NULL
);
2921 gfc_conv_structure (&se
, expr
, 1);
2925 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2928 gfc_init_se (&se
, NULL
);
2929 gfc_conv_constant (&se
, expr
);
2936 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2948 gfc_start_block (&block
);
2950 /* Initialize the scalarizer. */
2951 gfc_init_loopinfo (&loop
);
2953 gfc_init_se (&lse
, NULL
);
2954 gfc_init_se (&rse
, NULL
);
2957 rss
= gfc_walk_expr (expr
);
2958 if (rss
== gfc_ss_terminator
)
2960 /* The rhs is scalar. Add a ss for the expression. */
2961 rss
= gfc_get_ss ();
2962 rss
->next
= gfc_ss_terminator
;
2963 rss
->type
= GFC_SS_SCALAR
;
2967 /* Create a SS for the destination. */
2968 lss
= gfc_get_ss ();
2969 lss
->type
= GFC_SS_COMPONENT
;
2971 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2972 lss
->next
= gfc_ss_terminator
;
2973 lss
->data
.info
.dimen
= cm
->as
->rank
;
2974 lss
->data
.info
.descriptor
= dest
;
2975 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2976 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2977 for (n
= 0; n
< cm
->as
->rank
; n
++)
2979 lss
->data
.info
.dim
[n
] = n
;
2980 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2981 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2983 mpz_init (lss
->shape
[n
]);
2984 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2985 cm
->as
->lower
[n
]->value
.integer
);
2986 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2989 /* Associate the SS with the loop. */
2990 gfc_add_ss_to_loop (&loop
, lss
);
2991 gfc_add_ss_to_loop (&loop
, rss
);
2993 /* Calculate the bounds of the scalarization. */
2994 gfc_conv_ss_startstride (&loop
);
2996 /* Setup the scalarizing loops. */
2997 gfc_conv_loop_setup (&loop
);
2999 /* Setup the gfc_se structures. */
3000 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3001 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3004 gfc_mark_ss_chain_used (rss
, 1);
3006 gfc_mark_ss_chain_used (lss
, 1);
3008 /* Start the scalarized loop body. */
3009 gfc_start_scalarized_body (&loop
, &body
);
3011 gfc_conv_tmp_array_ref (&lse
);
3012 if (cm
->ts
.type
== BT_CHARACTER
)
3013 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3015 gfc_conv_expr (&rse
, expr
);
3017 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3018 gfc_add_expr_to_block (&body
, tmp
);
3020 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3022 /* Generate the copying loops. */
3023 gfc_trans_scalarizing_loops (&loop
, &body
);
3025 /* Wrap the whole thing up. */
3026 gfc_add_block_to_block (&block
, &loop
.pre
);
3027 gfc_add_block_to_block (&block
, &loop
.post
);
3029 for (n
= 0; n
< cm
->as
->rank
; n
++)
3030 mpz_clear (lss
->shape
[n
]);
3031 gfc_free (lss
->shape
);
3033 gfc_cleanup_loop (&loop
);
3035 return gfc_finish_block (&block
);
3039 /* Assign a single component of a derived type constructor. */
3042 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3052 gfc_start_block (&block
);
3056 gfc_init_se (&se
, NULL
);
3057 /* Pointer component. */
3060 /* Array pointer. */
3061 if (expr
->expr_type
== EXPR_NULL
)
3062 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3065 rss
= gfc_walk_expr (expr
);
3066 se
.direct_byref
= 1;
3068 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3069 gfc_add_block_to_block (&block
, &se
.pre
);
3070 gfc_add_block_to_block (&block
, &se
.post
);
3075 /* Scalar pointers. */
3076 se
.want_pointer
= 1;
3077 gfc_conv_expr (&se
, expr
);
3078 gfc_add_block_to_block (&block
, &se
.pre
);
3079 gfc_add_modify_expr (&block
, dest
,
3080 fold_convert (TREE_TYPE (dest
), se
.expr
));
3081 gfc_add_block_to_block (&block
, &se
.post
);
3084 else if (cm
->dimension
)
3086 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3087 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3088 else if (cm
->allocatable
)
3092 gfc_init_se (&se
, NULL
);
3094 rss
= gfc_walk_expr (expr
);
3095 se
.want_pointer
= 0;
3096 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3097 gfc_add_block_to_block (&block
, &se
.pre
);
3099 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3100 gfc_add_modify_expr (&block
, dest
, tmp
);
3102 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3103 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3106 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3107 TREE_TYPE(cm
->backend_decl
),
3110 gfc_add_expr_to_block (&block
, tmp
);
3112 gfc_add_block_to_block (&block
, &se
.post
);
3113 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3115 /* Shift the lbound and ubound of temporaries to being unity, rather
3116 than zero, based. Calculate the offset for all cases. */
3117 offset
= gfc_conv_descriptor_offset (dest
);
3118 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3119 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3120 for (n
= 0; n
< expr
->rank
; n
++)
3122 if (expr
->expr_type
!= EXPR_VARIABLE
3123 && expr
->expr_type
!= EXPR_CONSTANT
)
3126 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3127 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3128 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3129 gfc_add_modify_expr (&block
, tmp
,
3130 fold_build2 (PLUS_EXPR
,
3131 gfc_array_index_type
,
3132 span
, gfc_index_one_node
));
3133 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3134 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3136 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3137 gfc_conv_descriptor_lbound (dest
,
3139 gfc_conv_descriptor_stride (dest
,
3141 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3142 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3143 gfc_add_modify_expr (&block
, offset
, tmp
);
3148 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3149 gfc_add_expr_to_block (&block
, tmp
);
3152 else if (expr
->ts
.type
== BT_DERIVED
)
3154 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3156 gfc_init_se (&se
, NULL
);
3157 gfc_conv_expr (&se
, expr
);
3158 gfc_add_modify_expr (&block
, dest
,
3159 fold_convert (TREE_TYPE (dest
), se
.expr
));
3163 /* Nested constructors. */
3164 tmp
= gfc_trans_structure_assign (dest
, expr
);
3165 gfc_add_expr_to_block (&block
, tmp
);
3170 /* Scalar component. */
3171 gfc_init_se (&se
, NULL
);
3172 gfc_init_se (&lse
, NULL
);
3174 gfc_conv_expr (&se
, expr
);
3175 if (cm
->ts
.type
== BT_CHARACTER
)
3176 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3178 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3179 gfc_add_expr_to_block (&block
, tmp
);
3181 return gfc_finish_block (&block
);
3184 /* Assign a derived type constructor to a variable. */
3187 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3195 gfc_start_block (&block
);
3196 cm
= expr
->ts
.derived
->components
;
3197 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3199 /* Skip absent members in default initializers. */
3203 /* Update the type/kind of the expression if it represents either
3204 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3205 be the first place reached for initializing output variables that
3206 have components of type C_PTR/C_FUNPTR that are initialized. */
3207 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3208 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3210 c
->expr
->expr_type
= EXPR_NULL
;
3211 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3212 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3213 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3216 field
= cm
->backend_decl
;
3217 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3218 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3219 gfc_add_expr_to_block (&block
, tmp
);
3221 return gfc_finish_block (&block
);
3224 /* Build an expression for a constructor. If init is nonzero then
3225 this is part of a static variable initializer. */
3228 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3235 VEC(constructor_elt
,gc
) *v
= NULL
;
3237 gcc_assert (se
->ss
== NULL
);
3238 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3239 type
= gfc_typenode_for_spec (&expr
->ts
);
3243 /* Create a temporary variable and fill it in. */
3244 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3245 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3246 gfc_add_expr_to_block (&se
->pre
, tmp
);
3250 cm
= expr
->ts
.derived
->components
;
3252 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3254 /* Skip absent members in default initializers and allocatable
3255 components. Although the latter have a default initializer
3256 of EXPR_NULL,... by default, the static nullify is not needed
3257 since this is done every time we come into scope. */
3258 if (!c
->expr
|| cm
->allocatable
)
3261 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3262 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3264 /* Append it to the constructor list. */
3265 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3267 se
->expr
= build_constructor (type
, v
);
3271 /* Translate a substring expression. */
3274 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3280 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3282 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3283 expr
->value
.character
.string
);
3284 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3285 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3288 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3292 /* Entry point for expression translation. Evaluates a scalar quantity.
3293 EXPR is the expression to be translated, and SE is the state structure if
3294 called from within the scalarized. */
3297 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3299 if (se
->ss
&& se
->ss
->expr
== expr
3300 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3302 /* Substitute a scalar expression evaluated outside the scalarization
3304 se
->expr
= se
->ss
->data
.scalar
.expr
;
3305 se
->string_length
= se
->ss
->string_length
;
3306 gfc_advance_se_ss_chain (se
);
3310 /* We need to convert the expressions for the iso_c_binding derived types.
3311 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3312 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3313 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3314 updated to be an integer with a kind equal to the size of a (void *). */
3315 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3316 && expr
->ts
.derived
->attr
.is_iso_c
)
3318 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3319 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3321 /* Set expr_type to EXPR_NULL, which will result in
3322 null_pointer_node being used below. */
3323 expr
->expr_type
= EXPR_NULL
;
3327 /* Update the type/kind of the expression to be what the new
3328 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3329 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3330 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3331 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3335 switch (expr
->expr_type
)
3338 gfc_conv_expr_op (se
, expr
);
3342 gfc_conv_function_expr (se
, expr
);
3346 gfc_conv_constant (se
, expr
);
3350 gfc_conv_variable (se
, expr
);
3354 se
->expr
= null_pointer_node
;
3357 case EXPR_SUBSTRING
:
3358 gfc_conv_substring_expr (se
, expr
);
3361 case EXPR_STRUCTURE
:
3362 gfc_conv_structure (se
, expr
, 0);
3366 gfc_conv_array_constructor_expr (se
, expr
);
3375 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3376 of an assignment. */
3378 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3380 gfc_conv_expr (se
, expr
);
3381 /* All numeric lvalues should have empty post chains. If not we need to
3382 figure out a way of rewriting an lvalue so that it has no post chain. */
3383 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3386 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3387 numeric expressions. Used for scalar values where inserting cleanup code
3390 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3394 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3395 gfc_conv_expr (se
, expr
);
3398 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3399 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3401 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3405 /* Helper to translate an expression and convert it to a particular type. */
3407 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3409 gfc_conv_expr_val (se
, expr
);
3410 se
->expr
= convert (type
, se
->expr
);
3414 /* Converts an expression so that it can be passed by reference. Scalar
3418 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3422 if (se
->ss
&& se
->ss
->expr
== expr
3423 && se
->ss
->type
== GFC_SS_REFERENCE
)
3425 se
->expr
= se
->ss
->data
.scalar
.expr
;
3426 se
->string_length
= se
->ss
->string_length
;
3427 gfc_advance_se_ss_chain (se
);
3431 if (expr
->ts
.type
== BT_CHARACTER
)
3433 gfc_conv_expr (se
, expr
);
3434 gfc_conv_string_parameter (se
);
3438 if (expr
->expr_type
== EXPR_VARIABLE
)
3440 se
->want_pointer
= 1;
3441 gfc_conv_expr (se
, expr
);
3444 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3445 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3446 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3452 if (expr
->expr_type
== EXPR_FUNCTION
3453 && expr
->symtree
->n
.sym
->attr
.pointer
3454 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3456 se
->want_pointer
= 1;
3457 gfc_conv_expr (se
, expr
);
3458 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3459 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3465 gfc_conv_expr (se
, expr
);
3467 /* Create a temporary var to hold the value. */
3468 if (TREE_CONSTANT (se
->expr
))
3470 tree tmp
= se
->expr
;
3471 STRIP_TYPE_NOPS (tmp
);
3472 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3473 DECL_INITIAL (var
) = tmp
;
3474 TREE_STATIC (var
) = 1;
3479 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3480 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3482 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3484 /* Take the address of that value. */
3485 se
->expr
= build_fold_addr_expr (var
);
3490 gfc_trans_pointer_assign (gfc_code
* code
)
3492 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3496 /* Generate code for a pointer assignment. */
3499 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3511 gfc_start_block (&block
);
3513 gfc_init_se (&lse
, NULL
);
3515 lss
= gfc_walk_expr (expr1
);
3516 rss
= gfc_walk_expr (expr2
);
3517 if (lss
== gfc_ss_terminator
)
3519 /* Scalar pointers. */
3520 lse
.want_pointer
= 1;
3521 gfc_conv_expr (&lse
, expr1
);
3522 gcc_assert (rss
== gfc_ss_terminator
);
3523 gfc_init_se (&rse
, NULL
);
3524 rse
.want_pointer
= 1;
3525 gfc_conv_expr (&rse
, expr2
);
3526 gfc_add_block_to_block (&block
, &lse
.pre
);
3527 gfc_add_block_to_block (&block
, &rse
.pre
);
3528 gfc_add_modify_expr (&block
, lse
.expr
,
3529 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3530 gfc_add_block_to_block (&block
, &rse
.post
);
3531 gfc_add_block_to_block (&block
, &lse
.post
);
3535 /* Array pointer. */
3536 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3537 switch (expr2
->expr_type
)
3540 /* Just set the data pointer to null. */
3541 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3545 /* Assign directly to the pointer's descriptor. */
3546 lse
.direct_byref
= 1;
3547 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3549 /* If this is a subreference array pointer assignment, use the rhs
3550 descriptor element size for the lhs span. */
3551 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3553 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3554 gfc_init_se (&rse
, NULL
);
3555 rse
.descriptor_only
= 1;
3556 gfc_conv_expr (&rse
, expr2
);
3557 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3558 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3559 if (!INTEGER_CST_P (tmp
))
3560 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3561 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3567 /* Assign to a temporary descriptor and then copy that
3568 temporary to the pointer. */
3570 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3573 lse
.direct_byref
= 1;
3574 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3575 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3578 gfc_add_block_to_block (&block
, &lse
.pre
);
3579 gfc_add_block_to_block (&block
, &lse
.post
);
3581 return gfc_finish_block (&block
);
3585 /* Makes sure se is suitable for passing as a function string parameter. */
3586 /* TODO: Need to check all callers fo this function. It may be abused. */
3589 gfc_conv_string_parameter (gfc_se
* se
)
3593 if (TREE_CODE (se
->expr
) == STRING_CST
)
3595 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3599 type
= TREE_TYPE (se
->expr
);
3600 if (TYPE_STRING_FLAG (type
))
3602 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3603 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3606 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3608 type
= build_pointer_type (type
);
3609 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3613 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3614 gcc_assert (se
->string_length
3615 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3619 /* Generate code for assignment of scalar variables. Includes character
3620 strings and derived types with allocatable components. */
3623 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3624 bool l_is_temp
, bool r_is_var
)
3630 gfc_init_block (&block
);
3632 if (ts
.type
== BT_CHARACTER
)
3634 gcc_assert (lse
->string_length
!= NULL_TREE
3635 && rse
->string_length
!= NULL_TREE
);
3637 gfc_conv_string_parameter (lse
);
3638 gfc_conv_string_parameter (rse
);
3640 gfc_add_block_to_block (&block
, &lse
->pre
);
3641 gfc_add_block_to_block (&block
, &rse
->pre
);
3643 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3644 rse
->string_length
, rse
->expr
);
3646 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3650 /* Are the rhs and the lhs the same? */
3653 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3654 build_fold_addr_expr (lse
->expr
),
3655 build_fold_addr_expr (rse
->expr
));
3656 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3659 /* Deallocate the lhs allocated components as long as it is not
3660 the same as the rhs. This must be done following the assignment
3661 to prevent deallocating data that could be used in the rhs
3665 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3666 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3668 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3669 gfc_add_expr_to_block (&lse
->post
, tmp
);
3672 gfc_add_block_to_block (&block
, &rse
->pre
);
3673 gfc_add_block_to_block (&block
, &lse
->pre
);
3675 gfc_add_modify_expr (&block
, lse
->expr
,
3676 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3678 /* Do a deep copy if the rhs is a variable, if it is not the
3682 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3683 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3684 gfc_add_expr_to_block (&block
, tmp
);
3689 gfc_add_block_to_block (&block
, &lse
->pre
);
3690 gfc_add_block_to_block (&block
, &rse
->pre
);
3692 gfc_add_modify_expr (&block
, lse
->expr
,
3693 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3696 gfc_add_block_to_block (&block
, &lse
->post
);
3697 gfc_add_block_to_block (&block
, &rse
->post
);
3699 return gfc_finish_block (&block
);
3703 /* Try to translate array(:) = func (...), where func is a transformational
3704 array function, without using a temporary. Returns NULL is this isn't the
3708 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3713 bool seen_array_ref
;
3715 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3716 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3719 /* Elemental functions don't need a temporary anyway. */
3720 if (expr2
->value
.function
.esym
!= NULL
3721 && expr2
->value
.function
.esym
->attr
.elemental
)
3724 /* Fail if EXPR1 can't be expressed as a descriptor. */
3725 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3728 /* Functions returning pointers need temporaries. */
3729 if (expr2
->symtree
->n
.sym
->attr
.pointer
3730 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3733 /* Character array functions need temporaries unless the
3734 character lengths are the same. */
3735 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3737 if (expr1
->ts
.cl
->length
== NULL
3738 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3741 if (expr2
->ts
.cl
->length
== NULL
3742 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3745 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3746 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3750 /* Check that no LHS component references appear during an array
3751 reference. This is needed because we do not have the means to
3752 span any arbitrary stride with an array descriptor. This check
3753 is not needed for the rhs because the function result has to be
3755 seen_array_ref
= false;
3756 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3758 if (ref
->type
== REF_ARRAY
)
3759 seen_array_ref
= true;
3760 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3764 /* Check for a dependency. */
3765 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3766 expr2
->value
.function
.esym
,
3767 expr2
->value
.function
.actual
))
3770 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3772 gcc_assert (expr2
->value
.function
.isym
3773 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3774 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3776 ss
= gfc_walk_expr (expr1
);
3777 gcc_assert (ss
!= gfc_ss_terminator
);
3778 gfc_init_se (&se
, NULL
);
3779 gfc_start_block (&se
.pre
);
3780 se
.want_pointer
= 1;
3782 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3784 se
.direct_byref
= 1;
3785 se
.ss
= gfc_walk_expr (expr2
);
3786 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3787 gfc_conv_function_expr (&se
, expr2
);
3788 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3790 return gfc_finish_block (&se
.pre
);
3793 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3796 is_zero_initializer_p (gfc_expr
* expr
)
3798 if (expr
->expr_type
!= EXPR_CONSTANT
)
3801 /* We ignore constants with prescribed memory representations for now. */
3802 if (expr
->representation
.string
)
3805 switch (expr
->ts
.type
)
3808 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3811 return mpfr_zero_p (expr
->value
.real
)
3812 && MPFR_SIGN (expr
->value
.real
) >= 0;
3815 return expr
->value
.logical
== 0;
3818 return mpfr_zero_p (expr
->value
.complex.r
)
3819 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3820 && mpfr_zero_p (expr
->value
.complex.i
)
3821 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3829 /* Try to efficiently translate array(:) = 0. Return NULL if this
3833 gfc_trans_zero_assign (gfc_expr
* expr
)
3835 tree dest
, len
, type
;
3839 sym
= expr
->symtree
->n
.sym
;
3840 dest
= gfc_get_symbol_decl (sym
);
3842 type
= TREE_TYPE (dest
);
3843 if (POINTER_TYPE_P (type
))
3844 type
= TREE_TYPE (type
);
3845 if (!GFC_ARRAY_TYPE_P (type
))
3848 /* Determine the length of the array. */
3849 len
= GFC_TYPE_ARRAY_SIZE (type
);
3850 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3853 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3854 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3855 fold_convert (gfc_array_index_type
, tmp
));
3857 /* Convert arguments to the correct types. */
3858 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3859 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3861 dest
= fold_convert (pvoid_type_node
, dest
);
3862 len
= fold_convert (size_type_node
, len
);
3864 /* Construct call to __builtin_memset. */
3865 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3866 3, dest
, integer_zero_node
, len
);
3867 return fold_convert (void_type_node
, tmp
);
3871 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3872 that constructs the call to __builtin_memcpy. */
3875 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3879 /* Convert arguments to the correct types. */
3880 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3881 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3883 dst
= fold_convert (pvoid_type_node
, dst
);
3885 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3886 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3888 src
= fold_convert (pvoid_type_node
, src
);
3890 len
= fold_convert (size_type_node
, len
);
3892 /* Construct call to __builtin_memcpy. */
3893 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3894 return fold_convert (void_type_node
, tmp
);
3898 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3899 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3900 source/rhs, both are gfc_full_array_ref_p which have been checked for
3904 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3906 tree dst
, dlen
, dtype
;
3907 tree src
, slen
, stype
;
3910 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3911 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3913 dtype
= TREE_TYPE (dst
);
3914 if (POINTER_TYPE_P (dtype
))
3915 dtype
= TREE_TYPE (dtype
);
3916 stype
= TREE_TYPE (src
);
3917 if (POINTER_TYPE_P (stype
))
3918 stype
= TREE_TYPE (stype
);
3920 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3923 /* Determine the lengths of the arrays. */
3924 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3925 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3927 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3928 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3929 fold_convert (gfc_array_index_type
, tmp
));
3931 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3932 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3934 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3935 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3936 fold_convert (gfc_array_index_type
, tmp
));
3938 /* Sanity check that they are the same. This should always be
3939 the case, as we should already have checked for conformance. */
3940 if (!tree_int_cst_equal (slen
, dlen
))
3943 return gfc_build_memcpy_call (dst
, src
, dlen
);
3947 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3948 this can't be done. EXPR1 is the destination/lhs for which
3949 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3952 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3954 unsigned HOST_WIDE_INT nelem
;
3960 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3964 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3965 dtype
= TREE_TYPE (dst
);
3966 if (POINTER_TYPE_P (dtype
))
3967 dtype
= TREE_TYPE (dtype
);
3968 if (!GFC_ARRAY_TYPE_P (dtype
))
3971 /* Determine the lengths of the array. */
3972 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3973 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3976 /* Confirm that the constructor is the same size. */
3977 if (compare_tree_int (len
, nelem
) != 0)
3980 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3981 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3982 fold_convert (gfc_array_index_type
, tmp
));
3984 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3985 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3987 stype
= TREE_TYPE (src
);
3988 if (POINTER_TYPE_P (stype
))
3989 stype
= TREE_TYPE (stype
);
3991 return gfc_build_memcpy_call (dst
, src
, len
);
3995 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3996 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3999 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4004 gfc_ss
*lss_section
;
4012 /* Assignment of the form lhs = rhs. */
4013 gfc_start_block (&block
);
4015 gfc_init_se (&lse
, NULL
);
4016 gfc_init_se (&rse
, NULL
);
4019 lss
= gfc_walk_expr (expr1
);
4021 if (lss
!= gfc_ss_terminator
)
4023 /* The assignment needs scalarization. */
4026 /* Find a non-scalar SS from the lhs. */
4027 while (lss_section
!= gfc_ss_terminator
4028 && lss_section
->type
!= GFC_SS_SECTION
)
4029 lss_section
= lss_section
->next
;
4031 gcc_assert (lss_section
!= gfc_ss_terminator
);
4033 /* Initialize the scalarizer. */
4034 gfc_init_loopinfo (&loop
);
4037 rss
= gfc_walk_expr (expr2
);
4038 if (rss
== gfc_ss_terminator
)
4040 /* The rhs is scalar. Add a ss for the expression. */
4041 rss
= gfc_get_ss ();
4042 rss
->next
= gfc_ss_terminator
;
4043 rss
->type
= GFC_SS_SCALAR
;
4046 /* Associate the SS with the loop. */
4047 gfc_add_ss_to_loop (&loop
, lss
);
4048 gfc_add_ss_to_loop (&loop
, rss
);
4050 /* Calculate the bounds of the scalarization. */
4051 gfc_conv_ss_startstride (&loop
);
4052 /* Resolve any data dependencies in the statement. */
4053 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4054 /* Setup the scalarizing loops. */
4055 gfc_conv_loop_setup (&loop
);
4057 /* Setup the gfc_se structures. */
4058 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4059 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4062 gfc_mark_ss_chain_used (rss
, 1);
4063 if (loop
.temp_ss
== NULL
)
4066 gfc_mark_ss_chain_used (lss
, 1);
4070 lse
.ss
= loop
.temp_ss
;
4071 gfc_mark_ss_chain_used (lss
, 3);
4072 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4075 /* Start the scalarized loop body. */
4076 gfc_start_scalarized_body (&loop
, &body
);
4079 gfc_init_block (&body
);
4081 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4083 /* Translate the expression. */
4084 gfc_conv_expr (&rse
, expr2
);
4088 gfc_conv_tmp_array_ref (&lse
);
4089 gfc_advance_se_ss_chain (&lse
);
4092 gfc_conv_expr (&lse
, expr1
);
4094 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4095 l_is_temp
|| init_flag
,
4096 expr2
->expr_type
== EXPR_VARIABLE
);
4097 gfc_add_expr_to_block (&body
, tmp
);
4099 if (lss
== gfc_ss_terminator
)
4101 /* Use the scalar assignment as is. */
4102 gfc_add_block_to_block (&block
, &body
);
4106 gcc_assert (lse
.ss
== gfc_ss_terminator
4107 && rse
.ss
== gfc_ss_terminator
);
4111 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4113 /* We need to copy the temporary to the actual lhs. */
4114 gfc_init_se (&lse
, NULL
);
4115 gfc_init_se (&rse
, NULL
);
4116 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4117 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4119 rse
.ss
= loop
.temp_ss
;
4122 gfc_conv_tmp_array_ref (&rse
);
4123 gfc_advance_se_ss_chain (&rse
);
4124 gfc_conv_expr (&lse
, expr1
);
4126 gcc_assert (lse
.ss
== gfc_ss_terminator
4127 && rse
.ss
== gfc_ss_terminator
);
4129 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4131 gfc_add_expr_to_block (&body
, tmp
);
4134 /* Generate the copying loops. */
4135 gfc_trans_scalarizing_loops (&loop
, &body
);
4137 /* Wrap the whole thing up. */
4138 gfc_add_block_to_block (&block
, &loop
.pre
);
4139 gfc_add_block_to_block (&block
, &loop
.post
);
4141 gfc_cleanup_loop (&loop
);
4144 return gfc_finish_block (&block
);
4148 /* Check whether EXPR is a copyable array. */
4151 copyable_array_p (gfc_expr
* expr
)
4153 if (expr
->expr_type
!= EXPR_VARIABLE
)
4156 /* First check it's an array. */
4157 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4160 if (!gfc_full_array_ref_p (expr
->ref
))
4163 /* Next check that it's of a simple enough type. */
4164 switch (expr
->ts
.type
)
4176 return !expr
->ts
.derived
->attr
.alloc_comp
;
4185 /* Translate an assignment. */
4188 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4192 /* Special case a single function returning an array. */
4193 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4195 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4200 /* Special case assigning an array to zero. */
4201 if (copyable_array_p (expr1
)
4202 && is_zero_initializer_p (expr2
))
4204 tmp
= gfc_trans_zero_assign (expr1
);
4209 /* Special case copying one array to another. */
4210 if (copyable_array_p (expr1
)
4211 && copyable_array_p (expr2
)
4212 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4213 && !gfc_check_dependency (expr1
, expr2
, 0))
4215 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4220 /* Special case initializing an array from a constant array constructor. */
4221 if (copyable_array_p (expr1
)
4222 && expr2
->expr_type
== EXPR_ARRAY
4223 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4225 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4230 /* Fallback to the scalarizer to generate explicit loops. */
4231 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4235 gfc_trans_init_assign (gfc_code
* code
)
4237 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4241 gfc_trans_assign (gfc_code
* code
)
4243 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);