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
, int kind
)
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
));
158 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
162 tmp
= gfc_get_int_type (kind
);
163 tmp
= fold_convert (tmp
, se
->expr
);
164 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
169 if (ts
.type
== BT_CHARACTER
)
171 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
172 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
173 se
->string_length
, tmp
);
174 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
175 se
->string_length
= tmp
;
181 /* Get the character length of an expression, looking through gfc_refs
185 gfc_get_expr_charlen (gfc_expr
*e
)
190 gcc_assert (e
->expr_type
== EXPR_VARIABLE
191 && e
->ts
.type
== BT_CHARACTER
);
193 length
= NULL
; /* To silence compiler warning. */
195 if (is_subref_array (e
) && e
->ts
.cl
->length
)
198 gfc_init_se (&tmpse
, NULL
);
199 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
200 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
204 /* First candidate: if the variable is of type CHARACTER, the
205 expression's length could be the length of the character
207 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
208 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
210 /* Look through the reference chain for component references. */
211 for (r
= e
->ref
; r
; r
= r
->next
)
216 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
217 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
225 /* We should never got substring references here. These will be
226 broken down by the scalarizer. */
232 gcc_assert (length
!= NULL
);
238 /* Generate code to initialize a string length variable. Returns the
242 gfc_conv_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
246 gfc_init_se (&se
, NULL
);
247 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
248 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
249 build_int_cst (gfc_charlen_type_node
, 0));
250 gfc_add_block_to_block (pblock
, &se
.pre
);
252 if (cl
->backend_decl
)
253 gfc_add_modify_expr (pblock
, cl
->backend_decl
, se
.expr
);
255 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
260 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
261 const char *name
, locus
*where
)
271 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
272 type
= build_pointer_type (type
);
275 gfc_init_se (&start
, se
);
276 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
277 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
279 if (integer_onep (start
.expr
))
280 gfc_conv_string_parameter (se
);
283 /* Avoid multiple evaluation of substring start. */
284 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
285 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
287 /* Change the start of the string. */
288 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
291 tmp
= build_fold_indirect_ref (se
->expr
);
292 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
293 se
->expr
= gfc_build_addr_expr (type
, tmp
);
296 /* Length = end + 1 - start. */
297 gfc_init_se (&end
, se
);
298 if (ref
->u
.ss
.end
== NULL
)
299 end
.expr
= se
->string_length
;
302 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
303 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
305 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
306 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
308 if (flag_bounds_check
)
310 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
311 start
.expr
, end
.expr
);
313 /* Check lower bound. */
314 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
315 build_int_cst (gfc_charlen_type_node
, 1));
316 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
319 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
320 "is less than one", name
);
322 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
324 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
325 fold_convert (long_integer_type_node
,
329 /* Check upper bound. */
330 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
332 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
335 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
336 "exceeds string length (%%ld)", name
);
338 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
339 "exceeds string length (%%ld)");
340 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
341 fold_convert (long_integer_type_node
, end
.expr
),
342 fold_convert (long_integer_type_node
,
347 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
348 build_int_cst (gfc_charlen_type_node
, 1),
350 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
351 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
352 build_int_cst (gfc_charlen_type_node
, 0));
353 se
->string_length
= tmp
;
357 /* Convert a derived type component reference. */
360 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
367 c
= ref
->u
.c
.component
;
369 gcc_assert (c
->backend_decl
);
371 field
= c
->backend_decl
;
372 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
374 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
378 if (c
->ts
.type
== BT_CHARACTER
)
380 tmp
= c
->ts
.cl
->backend_decl
;
381 /* Components must always be constant length. */
382 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
383 se
->string_length
= tmp
;
386 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
387 se
->expr
= build_fold_indirect_ref (se
->expr
);
391 /* Return the contents of a variable. Also handles reference/pointer
392 variables (all Fortran pointer references are implicit). */
395 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
402 bool alternate_entry
;
405 sym
= expr
->symtree
->n
.sym
;
408 /* Check that something hasn't gone horribly wrong. */
409 gcc_assert (se
->ss
!= gfc_ss_terminator
);
410 gcc_assert (se
->ss
->expr
== expr
);
412 /* A scalarized term. We already know the descriptor. */
413 se
->expr
= se
->ss
->data
.info
.descriptor
;
414 se
->string_length
= se
->ss
->string_length
;
415 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
416 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
421 tree se_expr
= NULL_TREE
;
423 se
->expr
= gfc_get_symbol_decl (sym
);
425 /* Deal with references to a parent results or entries by storing
426 the current_function_decl and moving to the parent_decl. */
427 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
428 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
429 && sym
->result
== sym
;
430 entry_master
= sym
->attr
.result
431 && sym
->ns
->proc_name
->attr
.entry_master
432 && !gfc_return_by_reference (sym
->ns
->proc_name
);
433 parent_decl
= DECL_CONTEXT (current_function_decl
);
435 if ((se
->expr
== parent_decl
&& return_value
)
436 || (sym
->ns
&& sym
->ns
->proc_name
438 && sym
->ns
->proc_name
->backend_decl
== parent_decl
439 && (alternate_entry
|| entry_master
)))
444 /* Special case for assigning the return value of a function.
445 Self recursive functions must have an explicit return value. */
446 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
447 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
449 /* Similarly for alternate entry points. */
450 else if (alternate_entry
451 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
454 gfc_entry_list
*el
= NULL
;
456 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
459 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
464 else if (entry_master
465 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
467 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
472 /* Procedure actual arguments. */
473 else if (sym
->attr
.flavor
== FL_PROCEDURE
474 && se
->expr
!= current_function_decl
)
476 gcc_assert (se
->want_pointer
);
477 if (!sym
->attr
.dummy
)
479 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
480 se
->expr
= build_fold_addr_expr (se
->expr
);
486 /* Dereference the expression, where needed. Since characters
487 are entirely different from other types, they are treated
489 if (sym
->ts
.type
== BT_CHARACTER
)
491 /* Dereference character pointer dummy arguments
493 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
495 || sym
->attr
.function
496 || sym
->attr
.result
))
497 se
->expr
= build_fold_indirect_ref (se
->expr
);
500 else if (!sym
->attr
.value
)
502 /* Dereference non-character scalar dummy arguments. */
503 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
504 se
->expr
= build_fold_indirect_ref (se
->expr
);
506 /* Dereference scalar hidden result. */
507 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
508 && (sym
->attr
.function
|| sym
->attr
.result
)
509 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
510 se
->expr
= build_fold_indirect_ref (se
->expr
);
512 /* Dereference non-character pointer variables.
513 These must be dummies, results, or scalars. */
514 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
516 || sym
->attr
.function
518 || !sym
->attr
.dimension
))
519 se
->expr
= build_fold_indirect_ref (se
->expr
);
525 /* For character variables, also get the length. */
526 if (sym
->ts
.type
== BT_CHARACTER
)
528 /* If the character length of an entry isn't set, get the length from
529 the master function instead. */
530 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
531 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
533 se
->string_length
= sym
->ts
.cl
->backend_decl
;
534 gcc_assert (se
->string_length
);
542 /* Return the descriptor if that's what we want and this is an array
543 section reference. */
544 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
546 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
547 /* Return the descriptor for array pointers and allocations. */
549 && ref
->next
== NULL
&& (se
->descriptor_only
))
552 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
553 /* Return a pointer to an element. */
557 gfc_conv_component_ref (se
, ref
);
561 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
562 expr
->symtree
->name
, &expr
->where
);
571 /* Pointer assignment, allocation or pass by reference. Arrays are handled
573 if (se
->want_pointer
)
575 if (expr
->ts
.type
== BT_CHARACTER
)
576 gfc_conv_string_parameter (se
);
578 se
->expr
= build_fold_addr_expr (se
->expr
);
583 /* Unary ops are easy... Or they would be if ! was a valid op. */
586 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
591 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
592 /* Initialize the operand. */
593 gfc_init_se (&operand
, se
);
594 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
595 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
597 type
= gfc_typenode_for_spec (&expr
->ts
);
599 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
600 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
601 All other unary operators have an equivalent GIMPLE unary operator. */
602 if (code
== TRUTH_NOT_EXPR
)
603 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
604 build_int_cst (type
, 0));
606 se
->expr
= build1 (code
, type
, operand
.expr
);
610 /* Expand power operator to optimal multiplications when a value is raised
611 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
612 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
613 Programming", 3rd Edition, 1998. */
615 /* This code is mostly duplicated from expand_powi in the backend.
616 We establish the "optimal power tree" lookup table with the defined size.
617 The items in the table are the exponents used to calculate the index
618 exponents. Any integer n less than the value can get an "addition chain",
619 with the first node being one. */
620 #define POWI_TABLE_SIZE 256
622 /* The table is from builtins.c. */
623 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
625 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
626 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
627 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
628 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
629 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
630 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
631 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
632 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
633 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
634 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
635 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
636 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
637 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
638 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
639 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
640 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
641 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
642 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
643 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
644 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
645 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
646 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
647 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
648 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
649 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
650 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
651 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
652 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
653 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
654 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
655 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
656 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
659 /* If n is larger than lookup table's max index, we use the "window
661 #define POWI_WINDOW_SIZE 3
663 /* Recursive function to expand the power operator. The temporary
664 values are put in tmpvar. The function returns tmpvar[1] ** n. */
666 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
673 if (n
< POWI_TABLE_SIZE
)
678 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
679 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
683 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
684 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
685 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
689 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
693 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
694 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
696 if (n
< POWI_TABLE_SIZE
)
703 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
704 return 1. Else return 0 and a call to runtime library functions
705 will have to be built. */
707 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
712 tree vartmp
[POWI_TABLE_SIZE
];
714 unsigned HOST_WIDE_INT n
;
717 /* If exponent is too large, we won't expand it anyway, so don't bother
718 with large integer values. */
719 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
722 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
723 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
724 of the asymmetric range of the integer type. */
725 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
727 type
= TREE_TYPE (lhs
);
728 sgn
= tree_int_cst_sgn (rhs
);
730 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
731 || optimize_size
) && (m
> 2 || m
< -1))
737 se
->expr
= gfc_build_const (type
, integer_one_node
);
741 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
742 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
744 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
745 build_int_cst (TREE_TYPE (lhs
), -1));
746 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
747 build_int_cst (TREE_TYPE (lhs
), 1));
750 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
753 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
754 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
755 build_int_cst (type
, 0));
759 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
760 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
761 build_int_cst (type
, 0));
762 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
766 memset (vartmp
, 0, sizeof (vartmp
));
770 tmp
= gfc_build_const (type
, integer_one_node
);
771 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
774 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
780 /* Power op (**). Constant integer exponent has special handling. */
783 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
785 tree gfc_int4_type_node
;
792 gfc_init_se (&lse
, se
);
793 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
794 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
795 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
797 gfc_init_se (&rse
, se
);
798 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
799 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
801 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
802 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
803 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
806 gfc_int4_type_node
= gfc_get_int_type (4);
808 kind
= expr
->value
.op
.op1
->ts
.kind
;
809 switch (expr
->value
.op
.op2
->ts
.type
)
812 ikind
= expr
->value
.op
.op2
->ts
.kind
;
817 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
839 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
840 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
865 switch (expr
->value
.op
.op1
->ts
.type
)
868 if (kind
== 3) /* Case 16 was not handled properly above. */
870 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
874 /* Use builtins for real ** int4. */
880 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
884 fndecl
= built_in_decls
[BUILT_IN_POWI
];
889 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
897 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
901 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
913 fndecl
= built_in_decls
[BUILT_IN_POWF
];
916 fndecl
= built_in_decls
[BUILT_IN_POW
];
920 fndecl
= built_in_decls
[BUILT_IN_POWL
];
931 fndecl
= gfor_fndecl_math_cpowf
;
934 fndecl
= gfor_fndecl_math_cpow
;
937 fndecl
= gfor_fndecl_math_cpowl10
;
940 fndecl
= gfor_fndecl_math_cpowl16
;
952 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
956 /* Generate code to allocate a string temporary. */
959 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
964 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
966 if (gfc_can_put_var_on_stack (len
))
968 /* Create a temporary variable to hold the result. */
969 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
970 build_int_cst (gfc_charlen_type_node
, 1));
971 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
972 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
973 var
= gfc_create_var (tmp
, "str");
974 var
= gfc_build_addr_expr (type
, var
);
978 /* Allocate a temporary to hold the result. */
979 var
= gfc_create_var (type
, "pstr");
980 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
981 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
983 /* Free the temporary afterwards. */
984 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
985 gfc_add_expr_to_block (&se
->post
, tmp
);
992 /* Handle a string concatenation operation. A temporary will be allocated to
996 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1005 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1006 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1008 gfc_init_se (&lse
, se
);
1009 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1010 gfc_conv_string_parameter (&lse
);
1011 gfc_init_se (&rse
, se
);
1012 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1013 gfc_conv_string_parameter (&rse
);
1015 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1016 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1018 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1019 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1020 if (len
== NULL_TREE
)
1022 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1023 lse
.string_length
, rse
.string_length
);
1026 type
= build_pointer_type (type
);
1028 var
= gfc_conv_string_tmp (se
, type
, len
);
1030 /* Do the actual concatenation. */
1031 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1033 lse
.string_length
, lse
.expr
,
1034 rse
.string_length
, rse
.expr
);
1035 gfc_add_expr_to_block (&se
->pre
, tmp
);
1037 /* Add the cleanup for the operands. */
1038 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1039 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1042 se
->string_length
= len
;
1045 /* Translates an op expression. Common (binary) cases are handled by this
1046 function, others are passed on. Recursion is used in either case.
1047 We use the fact that (op1.ts == op2.ts) (except for the power
1049 Operators need no special handling for scalarized expressions as long as
1050 they call gfc_conv_simple_val to get their operands.
1051 Character strings get special handling. */
1054 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1056 enum tree_code code
;
1065 switch (expr
->value
.op
.operator)
1067 case INTRINSIC_UPLUS
:
1068 case INTRINSIC_PARENTHESES
:
1069 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1072 case INTRINSIC_UMINUS
:
1073 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1077 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1080 case INTRINSIC_PLUS
:
1084 case INTRINSIC_MINUS
:
1088 case INTRINSIC_TIMES
:
1092 case INTRINSIC_DIVIDE
:
1093 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1094 an integer, we must round towards zero, so we use a
1096 if (expr
->ts
.type
== BT_INTEGER
)
1097 code
= TRUNC_DIV_EXPR
;
1102 case INTRINSIC_POWER
:
1103 gfc_conv_power_op (se
, expr
);
1106 case INTRINSIC_CONCAT
:
1107 gfc_conv_concat_op (se
, expr
);
1111 code
= TRUTH_ANDIF_EXPR
;
1116 code
= TRUTH_ORIF_EXPR
;
1120 /* EQV and NEQV only work on logicals, but since we represent them
1121 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1123 case INTRINSIC_EQ_OS
:
1131 case INTRINSIC_NE_OS
:
1132 case INTRINSIC_NEQV
:
1139 case INTRINSIC_GT_OS
:
1146 case INTRINSIC_GE_OS
:
1153 case INTRINSIC_LT_OS
:
1160 case INTRINSIC_LE_OS
:
1166 case INTRINSIC_USER
:
1167 case INTRINSIC_ASSIGN
:
1168 /* These should be converted into function calls by the frontend. */
1172 fatal_error ("Unknown intrinsic op");
1176 /* The only exception to this is **, which is handled separately anyway. */
1177 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1179 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1183 gfc_init_se (&lse
, se
);
1184 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1185 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1188 gfc_init_se (&rse
, se
);
1189 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1190 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1194 gfc_conv_string_parameter (&lse
);
1195 gfc_conv_string_parameter (&rse
);
1197 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1198 rse
.string_length
, rse
.expr
);
1199 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1200 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1203 type
= gfc_typenode_for_spec (&expr
->ts
);
1207 /* The result of logical ops is always boolean_type_node. */
1208 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1209 se
->expr
= convert (type
, tmp
);
1212 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1214 /* Add the post blocks. */
1215 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1216 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1219 /* If a string's length is one, we convert it to a single character. */
1222 gfc_to_single_character (tree len
, tree str
)
1224 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1226 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1227 && TREE_INT_CST_HIGH (len
) == 0)
1229 str
= fold_convert (pchar_type_node
, str
);
1230 return build_fold_indirect_ref (str
);
1238 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1241 if (sym
->backend_decl
)
1243 /* This becomes the nominal_type in
1244 function.c:assign_parm_find_data_types. */
1245 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1246 /* This becomes the passed_type in
1247 function.c:assign_parm_find_data_types. C promotes char to
1248 integer for argument passing. */
1249 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1251 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1256 /* If we have a constant character expression, make it into an
1258 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1262 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1263 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1265 /* The expr needs to be compatible with a C int. If the
1266 conversion fails, then the 2 causes an ICE. */
1267 ts
.type
= BT_INTEGER
;
1268 ts
.kind
= gfc_c_int_kind
;
1269 gfc_convert_type (*expr
, &ts
, 2);
1272 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1274 if ((*expr
)->ref
== NULL
)
1276 se
->expr
= gfc_to_single_character
1277 (build_int_cst (integer_type_node
, 1),
1278 gfc_build_addr_expr (pchar_type_node
,
1280 ((*expr
)->symtree
->n
.sym
)));
1284 gfc_conv_variable (se
, *expr
);
1285 se
->expr
= gfc_to_single_character
1286 (build_int_cst (integer_type_node
, 1),
1287 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1294 /* Compare two strings. If they are all single characters, the result is the
1295 subtraction of them. Otherwise, we build a library call. */
1298 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1304 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1305 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1307 sc1
= gfc_to_single_character (len1
, str1
);
1308 sc2
= gfc_to_single_character (len2
, str2
);
1310 /* Deal with single character specially. */
1311 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1313 sc1
= fold_convert (integer_type_node
, sc1
);
1314 sc2
= fold_convert (integer_type_node
, sc2
);
1315 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1318 /* Build a call for the comparison. */
1319 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1320 len1
, str1
, len2
, str2
);
1325 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1329 if (sym
->attr
.dummy
)
1331 tmp
= gfc_get_symbol_decl (sym
);
1332 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1333 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1337 if (!sym
->backend_decl
)
1338 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1340 tmp
= sym
->backend_decl
;
1341 if (sym
->attr
.cray_pointee
)
1342 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1343 gfc_get_symbol_decl (sym
->cp_pointer
));
1344 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1346 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1347 tmp
= build_fold_addr_expr (tmp
);
1354 /* Translate the call for an elemental subroutine call used in an operator
1355 assignment. This is a simplified version of gfc_conv_function_call. */
1358 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1365 /* Only elemental subroutines with two arguments. */
1366 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1367 gcc_assert (sym
->formal
->next
->next
== NULL
);
1369 gfc_init_block (&block
);
1371 gfc_add_block_to_block (&block
, &lse
->pre
);
1372 gfc_add_block_to_block (&block
, &rse
->pre
);
1374 /* Build the argument list for the call, including hidden string lengths. */
1375 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1376 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1377 if (lse
->string_length
!= NULL_TREE
)
1378 args
= gfc_chainon_list (args
, lse
->string_length
);
1379 if (rse
->string_length
!= NULL_TREE
)
1380 args
= gfc_chainon_list (args
, rse
->string_length
);
1382 /* Build the function call. */
1383 gfc_init_se (&se
, NULL
);
1384 gfc_conv_function_val (&se
, sym
);
1385 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1386 tmp
= build_call_list (tmp
, se
.expr
, args
);
1387 gfc_add_expr_to_block (&block
, tmp
);
1389 gfc_add_block_to_block (&block
, &lse
->post
);
1390 gfc_add_block_to_block (&block
, &rse
->post
);
1392 return gfc_finish_block (&block
);
1396 /* Initialize MAPPING. */
1399 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1401 mapping
->syms
= NULL
;
1402 mapping
->charlens
= NULL
;
1406 /* Free all memory held by MAPPING (but not MAPPING itself). */
1409 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1411 gfc_interface_sym_mapping
*sym
;
1412 gfc_interface_sym_mapping
*nextsym
;
1414 gfc_charlen
*nextcl
;
1416 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1418 nextsym
= sym
->next
;
1419 gfc_free_symbol (sym
->new->n
.sym
);
1420 gfc_free (sym
->new);
1423 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1426 gfc_free_expr (cl
->length
);
1432 /* Return a copy of gfc_charlen CL. Add the returned structure to
1433 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1435 static gfc_charlen
*
1436 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1441 new = gfc_get_charlen ();
1442 new->next
= mapping
->charlens
;
1443 new->length
= gfc_copy_expr (cl
->length
);
1445 mapping
->charlens
= new;
1450 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1451 array variable that can be used as the actual argument for dummy
1452 argument SYM. Add any initialization code to BLOCK. PACKED is as
1453 for gfc_get_nodesc_array_type and DATA points to the first element
1454 in the passed array. */
1457 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1458 gfc_packed packed
, tree data
)
1463 type
= gfc_typenode_for_spec (&sym
->ts
);
1464 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1466 var
= gfc_create_var (type
, "ifm");
1467 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1473 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1474 and offset of descriptorless array type TYPE given that it has the same
1475 size as DESC. Add any set-up code to BLOCK. */
1478 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1485 offset
= gfc_index_zero_node
;
1486 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1488 dim
= gfc_rank_cst
[n
];
1489 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1490 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1492 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1493 = gfc_conv_descriptor_lbound (desc
, dim
);
1494 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1495 = gfc_conv_descriptor_ubound (desc
, dim
);
1497 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1499 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1500 gfc_conv_descriptor_ubound (desc
, dim
),
1501 gfc_conv_descriptor_lbound (desc
, dim
));
1502 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1503 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1505 tmp
= gfc_evaluate_now (tmp
, block
);
1506 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1508 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1509 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1510 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1511 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1513 offset
= gfc_evaluate_now (offset
, block
);
1514 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1518 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1519 in SE. The caller may still use se->expr and se->string_length after
1520 calling this function. */
1523 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1524 gfc_symbol
* sym
, gfc_se
* se
)
1526 gfc_interface_sym_mapping
*sm
;
1530 gfc_symbol
*new_sym
;
1532 gfc_symtree
*new_symtree
;
1534 /* Create a new symbol to represent the actual argument. */
1535 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1536 new_sym
->ts
= sym
->ts
;
1537 new_sym
->attr
.referenced
= 1;
1538 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1539 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1540 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1541 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1543 /* Create a fake symtree for it. */
1545 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1546 new_symtree
->n
.sym
= new_sym
;
1547 gcc_assert (new_symtree
== root
);
1549 /* Create a dummy->actual mapping. */
1550 sm
= gfc_getmem (sizeof (*sm
));
1551 sm
->next
= mapping
->syms
;
1553 sm
->new = new_symtree
;
1556 /* Stabilize the argument's value. */
1557 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1559 if (sym
->ts
.type
== BT_CHARACTER
)
1561 /* Create a copy of the dummy argument's length. */
1562 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1564 /* If the length is specified as "*", record the length that
1565 the caller is passing. We should use the callee's length
1566 in all other cases. */
1567 if (!new_sym
->ts
.cl
->length
)
1569 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1570 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1574 /* Use the passed value as-is if the argument is a function. */
1575 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1578 /* If the argument is either a string or a pointer to a string,
1579 convert it to a boundless character type. */
1580 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1582 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1583 tmp
= build_pointer_type (tmp
);
1584 if (sym
->attr
.pointer
)
1585 value
= build_fold_indirect_ref (se
->expr
);
1588 value
= fold_convert (tmp
, value
);
1591 /* If the argument is a scalar, a pointer to an array or an allocatable,
1593 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1594 value
= build_fold_indirect_ref (se
->expr
);
1596 /* For character(*), use the actual argument's descriptor. */
1597 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1598 value
= build_fold_indirect_ref (se
->expr
);
1600 /* If the argument is an array descriptor, use it to determine
1601 information about the actual argument's shape. */
1602 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1603 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1605 /* Get the actual argument's descriptor. */
1606 desc
= build_fold_indirect_ref (se
->expr
);
1608 /* Create the replacement variable. */
1609 tmp
= gfc_conv_descriptor_data_get (desc
);
1610 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1613 /* Use DESC to work out the upper bounds, strides and offset. */
1614 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1617 /* Otherwise we have a packed array. */
1618 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1619 PACKED_FULL
, se
->expr
);
1621 new_sym
->backend_decl
= value
;
1625 /* Called once all dummy argument mappings have been added to MAPPING,
1626 but before the mapping is used to evaluate expressions. Pre-evaluate
1627 the length of each argument, adding any initialization code to PRE and
1628 any finalization code to POST. */
1631 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1632 stmtblock_t
* pre
, stmtblock_t
* post
)
1634 gfc_interface_sym_mapping
*sym
;
1638 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1639 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1640 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1642 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1643 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1644 gfc_init_se (&se
, NULL
);
1645 gfc_conv_expr (&se
, expr
);
1647 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1648 gfc_add_block_to_block (pre
, &se
.pre
);
1649 gfc_add_block_to_block (post
, &se
.post
);
1651 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1656 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1660 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1661 gfc_constructor
* c
)
1663 for (; c
; c
= c
->next
)
1665 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1668 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1669 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1670 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1676 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1680 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1685 for (; ref
; ref
= ref
->next
)
1689 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1691 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1692 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1693 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1695 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1702 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1703 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1709 /* EXPR is a copy of an expression that appeared in the interface
1710 associated with MAPPING. Walk it recursively looking for references to
1711 dummy arguments that MAPPING maps to actual arguments. Replace each such
1712 reference with a reference to the associated actual argument. */
1715 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1718 gfc_interface_sym_mapping
*sym
;
1719 gfc_actual_arglist
*actual
;
1720 int seen_result
= 0;
1725 /* Copying an expression does not copy its length, so do that here. */
1726 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1728 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1729 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1732 /* Apply the mapping to any references. */
1733 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1735 /* ...and to the expression's symbol, if it has one. */
1737 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1738 if (sym
->old
== expr
->symtree
->n
.sym
)
1739 expr
->symtree
= sym
->new;
1741 /* ...and to subexpressions in expr->value. */
1742 switch (expr
->expr_type
)
1745 if (expr
->symtree
->n
.sym
->attr
.result
)
1749 case EXPR_SUBSTRING
:
1753 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1754 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1758 if (expr
->value
.function
.esym
== NULL
1759 && expr
->value
.function
.isym
!= NULL
1760 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1761 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1762 && gfc_apply_interface_mapping_to_expr (mapping
,
1763 expr
->value
.function
.actual
->expr
))
1766 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1768 gfc_free (new_expr
);
1769 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1773 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1774 if (sym
->old
== expr
->value
.function
.esym
)
1775 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1777 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1778 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1782 case EXPR_STRUCTURE
:
1783 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1790 /* Evaluate interface expression EXPR using MAPPING. Store the result
1794 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1795 gfc_se
* se
, gfc_expr
* expr
)
1797 expr
= gfc_copy_expr (expr
);
1798 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1799 gfc_conv_expr (se
, expr
);
1800 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1801 gfc_free_expr (expr
);
1805 /* Returns a reference to a temporary array into which a component of
1806 an actual argument derived type array is copied and then returned
1807 after the function call. */
1809 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1810 int g77
, sym_intent intent
)
1826 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1828 gfc_init_se (&lse
, NULL
);
1829 gfc_init_se (&rse
, NULL
);
1831 /* Walk the argument expression. */
1832 rss
= gfc_walk_expr (expr
);
1834 gcc_assert (rss
!= gfc_ss_terminator
);
1836 /* Initialize the scalarizer. */
1837 gfc_init_loopinfo (&loop
);
1838 gfc_add_ss_to_loop (&loop
, rss
);
1840 /* Calculate the bounds of the scalarization. */
1841 gfc_conv_ss_startstride (&loop
);
1843 /* Build an ss for the temporary. */
1844 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
1845 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
1847 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1848 if (GFC_ARRAY_TYPE_P (base_type
)
1849 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1850 base_type
= gfc_get_element_type (base_type
);
1852 loop
.temp_ss
= gfc_get_ss ();;
1853 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1854 loop
.temp_ss
->data
.temp
.type
= base_type
;
1856 if (expr
->ts
.type
== BT_CHARACTER
)
1857 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1859 loop
.temp_ss
->string_length
= NULL
;
1861 parmse
->string_length
= loop
.temp_ss
->string_length
;
1862 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1863 loop
.temp_ss
->next
= gfc_ss_terminator
;
1865 /* Associate the SS with the loop. */
1866 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1868 /* Setup the scalarizing loops. */
1869 gfc_conv_loop_setup (&loop
);
1871 /* Pass the temporary descriptor back to the caller. */
1872 info
= &loop
.temp_ss
->data
.info
;
1873 parmse
->expr
= info
->descriptor
;
1875 /* Setup the gfc_se structures. */
1876 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1877 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1880 lse
.ss
= loop
.temp_ss
;
1881 gfc_mark_ss_chain_used (rss
, 1);
1882 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1884 /* Start the scalarized loop body. */
1885 gfc_start_scalarized_body (&loop
, &body
);
1887 /* Translate the expression. */
1888 gfc_conv_expr (&rse
, expr
);
1890 gfc_conv_tmp_array_ref (&lse
);
1891 gfc_advance_se_ss_chain (&lse
);
1893 if (intent
!= INTENT_OUT
)
1895 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1896 gfc_add_expr_to_block (&body
, tmp
);
1897 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1898 gfc_trans_scalarizing_loops (&loop
, &body
);
1902 /* Make sure that the temporary declaration survives by merging
1903 all the loop declarations into the current context. */
1904 for (n
= 0; n
< loop
.dimen
; n
++)
1906 gfc_merge_block_scope (&body
);
1907 body
= loop
.code
[loop
.order
[n
]];
1909 gfc_merge_block_scope (&body
);
1912 /* Add the post block after the second loop, so that any
1913 freeing of allocated memory is done at the right time. */
1914 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1916 /**********Copy the temporary back again.*********/
1918 gfc_init_se (&lse
, NULL
);
1919 gfc_init_se (&rse
, NULL
);
1921 /* Walk the argument expression. */
1922 lss
= gfc_walk_expr (expr
);
1923 rse
.ss
= loop
.temp_ss
;
1926 /* Initialize the scalarizer. */
1927 gfc_init_loopinfo (&loop2
);
1928 gfc_add_ss_to_loop (&loop2
, lss
);
1930 /* Calculate the bounds of the scalarization. */
1931 gfc_conv_ss_startstride (&loop2
);
1933 /* Setup the scalarizing loops. */
1934 gfc_conv_loop_setup (&loop2
);
1936 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1937 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1939 gfc_mark_ss_chain_used (lss
, 1);
1940 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1942 /* Declare the variable to hold the temporary offset and start the
1943 scalarized loop body. */
1944 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1945 gfc_start_scalarized_body (&loop2
, &body
);
1947 /* Build the offsets for the temporary from the loop variables. The
1948 temporary array has lbounds of zero and strides of one in all
1949 dimensions, so this is very simple. The offset is only computed
1950 outside the innermost loop, so the overall transfer could be
1951 optimized further. */
1952 info
= &rse
.ss
->data
.info
;
1954 tmp_index
= gfc_index_zero_node
;
1955 for (n
= info
->dimen
- 1; n
> 0; n
--)
1958 tmp
= rse
.loop
->loopvar
[n
];
1959 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1960 tmp
, rse
.loop
->from
[n
]);
1961 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1964 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1965 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1966 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1967 tmp_str
, gfc_index_one_node
);
1969 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1973 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1974 tmp_index
, rse
.loop
->from
[0]);
1975 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1977 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1978 rse
.loop
->loopvar
[0], offset
);
1980 /* Now use the offset for the reference. */
1981 tmp
= build_fold_indirect_ref (info
->data
);
1982 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
1984 if (expr
->ts
.type
== BT_CHARACTER
)
1985 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1987 gfc_conv_expr (&lse
, expr
);
1989 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1991 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1992 gfc_add_expr_to_block (&body
, tmp
);
1994 /* Generate the copying loops. */
1995 gfc_trans_scalarizing_loops (&loop2
, &body
);
1997 /* Wrap the whole thing up by adding the second loop to the post-block
1998 and following it by the post-block of the first loop. In this way,
1999 if the temporary needs freeing, it is done after use! */
2000 if (intent
!= INTENT_IN
)
2002 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2003 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2006 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2008 gfc_cleanup_loop (&loop
);
2009 gfc_cleanup_loop (&loop2
);
2011 /* Pass the string length to the argument expression. */
2012 if (expr
->ts
.type
== BT_CHARACTER
)
2013 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2015 /* We want either the address for the data or the address of the descriptor,
2016 depending on the mode of passing array arguments. */
2018 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2020 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2026 /* Generate the code for argument list functions. */
2029 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2031 /* Pass by value for g77 %VAL(arg), pass the address
2032 indirectly for %LOC, else by reference. Thus %REF
2033 is a "do-nothing" and %LOC is the same as an F95
2035 if (strncmp (name
, "%VAL", 4) == 0)
2036 gfc_conv_expr (se
, expr
);
2037 else if (strncmp (name
, "%LOC", 4) == 0)
2039 gfc_conv_expr_reference (se
, expr
);
2040 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2042 else if (strncmp (name
, "%REF", 4) == 0)
2043 gfc_conv_expr_reference (se
, expr
);
2045 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2049 /* Generate code for a procedure call. Note can return se->post != NULL.
2050 If se->direct_byref is set then se->expr contains the return parameter.
2051 Return nonzero, if the call has alternate specifiers. */
2054 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2055 gfc_actual_arglist
* arg
, tree append_args
)
2057 gfc_interface_mapping mapping
;
2071 gfc_formal_arglist
*formal
;
2072 int has_alternate_specifier
= 0;
2073 bool need_interface_mapping
;
2080 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2082 arglist
= NULL_TREE
;
2083 retargs
= NULL_TREE
;
2084 stringargs
= NULL_TREE
;
2088 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2090 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2092 if (arg
->expr
->rank
== 0)
2093 gfc_conv_expr_reference (se
, arg
->expr
);
2097 /* This is really the actual arg because no formal arglist is
2098 created for C_LOC. */
2099 fsym
= arg
->expr
->symtree
->n
.sym
;
2101 /* We should want it to do g77 calling convention. */
2103 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2104 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2105 f
= f
|| !sym
->attr
.always_explicit
;
2107 argss
= gfc_walk_expr (arg
->expr
);
2108 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2113 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2115 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2116 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2117 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2118 gfc_conv_expr_reference (se
, arg
->expr
);
2122 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2127 /* Build the addr_expr for the first argument. The argument is
2128 already an *address* so we don't need to set want_pointer in
2130 gfc_init_se (&arg1se
, NULL
);
2131 gfc_conv_expr (&arg1se
, arg
->expr
);
2132 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2133 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2135 /* See if we were given two arguments. */
2136 if (arg
->next
== NULL
)
2137 /* Only given one arg so generate a null and do a
2138 not-equal comparison against the first arg. */
2139 se
->expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2140 fold_convert (TREE_TYPE (arg1se
.expr
),
2141 null_pointer_node
));
2147 /* Given two arguments so build the arg2se from second arg. */
2148 gfc_init_se (&arg2se
, NULL
);
2149 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2150 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2151 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2153 /* Generate test to compare that the two args are equal. */
2154 eq_expr
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
,
2156 /* Generate test to ensure that the first arg is not null. */
2157 not_null_expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2160 /* Finally, the generated test must check that both arg1 is not
2161 NULL and that it is equal to the second arg. */
2162 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2163 not_null_expr
, eq_expr
);
2172 if (!sym
->attr
.elemental
)
2174 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2175 if (se
->ss
->useflags
)
2177 gcc_assert (gfc_return_by_reference (sym
)
2178 && sym
->result
->attr
.dimension
);
2179 gcc_assert (se
->loop
!= NULL
);
2181 /* Access the previously obtained result. */
2182 gfc_conv_tmp_array_ref (se
);
2183 gfc_advance_se_ss_chain (se
);
2187 info
= &se
->ss
->data
.info
;
2192 gfc_init_block (&post
);
2193 gfc_init_interface_mapping (&mapping
);
2194 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2195 && sym
->ts
.cl
->length
2196 && sym
->ts
.cl
->length
->expr_type
2198 || sym
->attr
.dimension
);
2199 formal
= sym
->formal
;
2200 /* Evaluate the arguments. */
2201 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2204 fsym
= formal
? formal
->sym
: NULL
;
2205 parm_kind
= MISSING
;
2209 if (se
->ignore_optional
)
2211 /* Some intrinsics have already been resolved to the correct
2215 else if (arg
->label
)
2217 has_alternate_specifier
= 1;
2222 /* Pass a NULL pointer for an absent arg. */
2223 gfc_init_se (&parmse
, NULL
);
2224 parmse
.expr
= null_pointer_node
;
2225 if (arg
->missing_arg_type
== BT_CHARACTER
)
2226 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2229 else if (se
->ss
&& se
->ss
->useflags
)
2231 /* An elemental function inside a scalarized loop. */
2232 gfc_init_se (&parmse
, se
);
2233 gfc_conv_expr_reference (&parmse
, e
);
2234 parm_kind
= ELEMENTAL
;
2238 /* A scalar or transformational function. */
2239 gfc_init_se (&parmse
, NULL
);
2240 argss
= gfc_walk_expr (e
);
2242 if (argss
== gfc_ss_terminator
)
2244 if (fsym
&& fsym
->attr
.value
)
2246 if (fsym
->ts
.type
== BT_CHARACTER
2247 && fsym
->ts
.is_c_interop
2248 && fsym
->ns
->proc_name
!= NULL
2249 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2252 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2253 if (parmse
.expr
== NULL
)
2254 gfc_conv_expr (&parmse
, e
);
2257 gfc_conv_expr (&parmse
, e
);
2259 else if (arg
->name
&& arg
->name
[0] == '%')
2260 /* Argument list functions %VAL, %LOC and %REF are signalled
2261 through arg->name. */
2262 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2263 else if ((e
->expr_type
== EXPR_FUNCTION
)
2264 && e
->symtree
->n
.sym
->attr
.pointer
2265 && fsym
&& fsym
->attr
.target
)
2267 gfc_conv_expr (&parmse
, e
);
2268 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2272 gfc_conv_expr_reference (&parmse
, e
);
2273 if (fsym
&& fsym
->attr
.pointer
2274 && fsym
->attr
.flavor
!= FL_PROCEDURE
2275 && e
->expr_type
!= EXPR_NULL
)
2277 /* Scalar pointer dummy args require an extra level of
2278 indirection. The null pointer already contains
2279 this level of indirection. */
2280 parm_kind
= SCALAR_POINTER
;
2281 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2287 /* If the procedure requires an explicit interface, the actual
2288 argument is passed according to the corresponding formal
2289 argument. If the corresponding formal argument is a POINTER,
2290 ALLOCATABLE or assumed shape, we do not use g77's calling
2291 convention, and pass the address of the array descriptor
2292 instead. Otherwise we use g77's calling convention. */
2295 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2296 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2297 f
= f
|| !sym
->attr
.always_explicit
;
2299 if (e
->expr_type
== EXPR_VARIABLE
2300 && is_subref_array (e
))
2301 /* The actual argument is a component reference to an
2302 array of derived types. In this case, the argument
2303 is converted to a temporary, which is passed and then
2304 written back after the procedure call. */
2305 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2306 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2308 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2310 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2311 allocated on entry, it must be deallocated. */
2312 if (fsym
&& fsym
->attr
.allocatable
2313 && fsym
->attr
.intent
== INTENT_OUT
)
2315 tmp
= build_fold_indirect_ref (parmse
.expr
);
2316 tmp
= gfc_trans_dealloc_allocated (tmp
);
2317 gfc_add_expr_to_block (&se
->pre
, tmp
);
2323 /* The case with fsym->attr.optional is that of a user subroutine
2324 with an interface indicating an optional argument. When we call
2325 an intrinsic subroutine, however, fsym is NULL, but we might still
2326 have an optional argument, so we proceed to the substitution
2328 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2330 /* If an optional argument is itself an optional dummy argument,
2331 check its presence and substitute a null if absent. */
2332 if (e
->expr_type
== EXPR_VARIABLE
2333 && e
->symtree
->n
.sym
->attr
.optional
)
2334 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2335 e
->representation
.length
);
2340 /* Obtain the character length of an assumed character length
2341 length procedure from the typespec. */
2342 if (fsym
->ts
.type
== BT_CHARACTER
2343 && parmse
.string_length
== NULL_TREE
2344 && e
->ts
.type
== BT_PROCEDURE
2345 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2346 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2348 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2349 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2353 if (fsym
&& need_interface_mapping
)
2354 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2356 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2357 gfc_add_block_to_block (&post
, &parmse
.post
);
2359 /* Allocated allocatable components of derived types must be
2360 deallocated for INTENT(OUT) dummy arguments and non-variable
2361 scalars. Non-variable arrays are dealt with in trans-array.c
2362 (gfc_conv_array_parameter). */
2363 if (e
&& e
->ts
.type
== BT_DERIVED
2364 && e
->ts
.derived
->attr
.alloc_comp
2365 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2367 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2370 tmp
= build_fold_indirect_ref (parmse
.expr
);
2371 parm_rank
= e
->rank
;
2379 case (SCALAR_POINTER
):
2380 tmp
= build_fold_indirect_ref (tmp
);
2387 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2388 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2389 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2390 tmp
, build_empty_stmt ());
2392 if (e
->expr_type
!= EXPR_VARIABLE
)
2393 /* Don't deallocate non-variables until they have been used. */
2394 gfc_add_expr_to_block (&se
->post
, tmp
);
2397 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2398 gfc_add_expr_to_block (&se
->pre
, tmp
);
2402 /* Character strings are passed as two parameters, a length and a
2403 pointer - except for Bind(c) which only passes the pointer. */
2404 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2405 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2407 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2409 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2412 if (ts
.type
== BT_CHARACTER
)
2414 if (sym
->ts
.cl
->length
== NULL
)
2416 /* Assumed character length results are not allowed by 5.1.1.5 of the
2417 standard and are trapped in resolve.c; except in the case of SPREAD
2418 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2419 we take the character length of the first argument for the result.
2420 For dummies, we have to look through the formal argument list for
2421 this function and use the character length found there.*/
2422 if (!sym
->attr
.dummy
)
2423 cl
.backend_decl
= TREE_VALUE (stringargs
);
2426 formal
= sym
->ns
->proc_name
->formal
;
2427 for (; formal
; formal
= formal
->next
)
2428 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2429 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2436 /* Calculate the length of the returned string. */
2437 gfc_init_se (&parmse
, NULL
);
2438 if (need_interface_mapping
)
2439 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2441 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2442 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2443 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2445 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2446 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2447 build_int_cst (gfc_charlen_type_node
, 0));
2448 cl
.backend_decl
= tmp
;
2451 /* Set up a charlen structure for it. */
2456 len
= cl
.backend_decl
;
2459 byref
= gfc_return_by_reference (sym
);
2462 if (se
->direct_byref
)
2464 /* Sometimes, too much indirection can be applied; eg. for
2465 function_result = array_valued_recursive_function. */
2466 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2467 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2468 && GFC_DESCRIPTOR_TYPE_P
2469 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2470 se
->expr
= build_fold_indirect_ref (se
->expr
);
2472 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2474 else if (sym
->result
->attr
.dimension
)
2476 gcc_assert (se
->loop
&& info
);
2478 /* Set the type of the array. */
2479 tmp
= gfc_typenode_for_spec (&ts
);
2480 info
->dimen
= se
->loop
->dimen
;
2482 /* Evaluate the bounds of the result, if known. */
2483 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2485 /* Create a temporary to store the result. In case the function
2486 returns a pointer, the temporary will be a shallow copy and
2487 mustn't be deallocated. */
2488 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2489 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2490 false, !sym
->attr
.pointer
, callee_alloc
);
2492 /* Pass the temporary as the first argument. */
2493 tmp
= info
->descriptor
;
2494 tmp
= build_fold_addr_expr (tmp
);
2495 retargs
= gfc_chainon_list (retargs
, tmp
);
2497 else if (ts
.type
== BT_CHARACTER
)
2499 /* Pass the string length. */
2500 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2501 type
= build_pointer_type (type
);
2503 /* Return an address to a char[0:len-1]* temporary for
2504 character pointers. */
2505 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2507 /* Build char[0:len-1] * pstr. */
2508 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2509 build_int_cst (gfc_charlen_type_node
, 1));
2510 tmp
= build_range_type (gfc_array_index_type
,
2511 gfc_index_zero_node
, tmp
);
2512 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2513 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2515 /* Provide an address expression for the function arguments. */
2516 var
= build_fold_addr_expr (var
);
2519 var
= gfc_conv_string_tmp (se
, type
, len
);
2521 retargs
= gfc_chainon_list (retargs
, var
);
2525 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2527 type
= gfc_get_complex_type (ts
.kind
);
2528 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2529 retargs
= gfc_chainon_list (retargs
, var
);
2532 /* Add the string length to the argument list. */
2533 if (ts
.type
== BT_CHARACTER
)
2534 retargs
= gfc_chainon_list (retargs
, len
);
2536 gfc_free_interface_mapping (&mapping
);
2538 /* Add the return arguments. */
2539 arglist
= chainon (retargs
, arglist
);
2541 /* Add the hidden string length parameters to the arguments. */
2542 arglist
= chainon (arglist
, stringargs
);
2544 /* We may want to append extra arguments here. This is used e.g. for
2545 calls to libgfortran_matmul_??, which need extra information. */
2546 if (append_args
!= NULL_TREE
)
2547 arglist
= chainon (arglist
, append_args
);
2549 /* Generate the actual call. */
2550 gfc_conv_function_val (se
, sym
);
2552 /* If there are alternate return labels, function type should be
2553 integer. Can't modify the type in place though, since it can be shared
2554 with other functions. For dummy arguments, the typing is done to
2555 to this result, even if it has to be repeated for each call. */
2556 if (has_alternate_specifier
2557 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2559 if (!sym
->attr
.dummy
)
2561 TREE_TYPE (sym
->backend_decl
)
2562 = build_function_type (integer_type_node
,
2563 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2564 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2567 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2570 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2571 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2573 /* If we have a pointer function, but we don't want a pointer, e.g.
2576 where f is pointer valued, we have to dereference the result. */
2577 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2578 se
->expr
= build_fold_indirect_ref (se
->expr
);
2580 /* f2c calling conventions require a scalar default real function to
2581 return a double precision result. Convert this back to default
2582 real. We only care about the cases that can happen in Fortran 77.
2584 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2585 && sym
->ts
.kind
== gfc_default_real_kind
2586 && !sym
->attr
.always_explicit
)
2587 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2589 /* Bind(C) character variables may have only length 1. */
2590 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
2592 gcc_assert (sym
->ts
.cl
->length
2593 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
2594 && mpz_cmp_si (sym
->ts
.cl
->length
->value
.integer
, 1) == 0);
2595 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2598 /* A pure function may still have side-effects - it may modify its
2600 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2602 if (!sym
->attr
.pure
)
2603 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2608 /* Add the function call to the pre chain. There is no expression. */
2609 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2610 se
->expr
= NULL_TREE
;
2612 if (!se
->direct_byref
)
2614 if (sym
->attr
.dimension
)
2616 if (flag_bounds_check
)
2618 /* Check the data pointer hasn't been modified. This would
2619 happen in a function returning a pointer. */
2620 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2621 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2623 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2625 se
->expr
= info
->descriptor
;
2626 /* Bundle in the string length. */
2627 se
->string_length
= len
;
2629 else if (sym
->ts
.type
== BT_CHARACTER
)
2631 /* Dereference for character pointer results. */
2632 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2633 se
->expr
= build_fold_indirect_ref (var
);
2637 se
->string_length
= len
;
2641 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2642 se
->expr
= build_fold_indirect_ref (var
);
2647 /* Follow the function call with the argument post block. */
2649 gfc_add_block_to_block (&se
->pre
, &post
);
2651 gfc_add_block_to_block (&se
->post
, &post
);
2653 return has_alternate_specifier
;
2657 /* Generate code to copy a string. */
2660 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2661 tree slength
, tree src
)
2663 tree tmp
, dlen
, slen
;
2671 stmtblock_t tempblock
;
2673 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2674 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2676 /* Deal with single character specially. */
2677 dsc
= gfc_to_single_character (dlen
, dest
);
2678 ssc
= gfc_to_single_character (slen
, src
);
2679 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2681 gfc_add_modify_expr (block
, dsc
, ssc
);
2685 /* Do nothing if the destination length is zero. */
2686 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2687 build_int_cst (size_type_node
, 0));
2689 /* The following code was previously in _gfortran_copy_string:
2691 // The two strings may overlap so we use memmove.
2693 copy_string (GFC_INTEGER_4 destlen, char * dest,
2694 GFC_INTEGER_4 srclen, const char * src)
2696 if (srclen >= destlen)
2698 // This will truncate if too long.
2699 memmove (dest, src, destlen);
2703 memmove (dest, src, srclen);
2705 memset (&dest[srclen], ' ', destlen - srclen);
2709 We're now doing it here for better optimization, but the logic
2712 /* Truncate string if source is too long. */
2713 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2714 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2715 3, dest
, src
, dlen
);
2717 /* Else copy and pad with spaces. */
2718 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2719 3, dest
, src
, slen
);
2721 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
2722 fold_convert (sizetype
, slen
));
2723 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2725 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2726 lang_hooks
.to_target_charset (' ')),
2727 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2730 gfc_init_block (&tempblock
);
2731 gfc_add_expr_to_block (&tempblock
, tmp3
);
2732 gfc_add_expr_to_block (&tempblock
, tmp4
);
2733 tmp3
= gfc_finish_block (&tempblock
);
2735 /* The whole copy_string function is there. */
2736 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2737 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2738 gfc_add_expr_to_block (block
, tmp
);
2742 /* Translate a statement function.
2743 The value of a statement function reference is obtained by evaluating the
2744 expression using the values of the actual arguments for the values of the
2745 corresponding dummy arguments. */
2748 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2752 gfc_formal_arglist
*fargs
;
2753 gfc_actual_arglist
*args
;
2756 gfc_saved_var
*saved_vars
;
2762 sym
= expr
->symtree
->n
.sym
;
2763 args
= expr
->value
.function
.actual
;
2764 gfc_init_se (&lse
, NULL
);
2765 gfc_init_se (&rse
, NULL
);
2768 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2770 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2771 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2773 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2775 /* Each dummy shall be specified, explicitly or implicitly, to be
2777 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2780 /* Create a temporary to hold the value. */
2781 type
= gfc_typenode_for_spec (&fsym
->ts
);
2782 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2784 if (fsym
->ts
.type
== BT_CHARACTER
)
2786 /* Copy string arguments. */
2789 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2790 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2792 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2793 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2796 gfc_conv_expr (&rse
, args
->expr
);
2797 gfc_conv_string_parameter (&rse
);
2798 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2799 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2801 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2803 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2804 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2808 /* For everything else, just evaluate the expression. */
2809 gfc_conv_expr (&lse
, args
->expr
);
2811 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2812 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2813 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2819 /* Use the temporary variables in place of the real ones. */
2820 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2821 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2823 gfc_conv_expr (se
, sym
->value
);
2825 if (sym
->ts
.type
== BT_CHARACTER
)
2827 gfc_conv_const_charlen (sym
->ts
.cl
);
2829 /* Force the expression to the correct length. */
2830 if (!INTEGER_CST_P (se
->string_length
)
2831 || tree_int_cst_lt (se
->string_length
,
2832 sym
->ts
.cl
->backend_decl
))
2834 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2835 tmp
= gfc_create_var (type
, sym
->name
);
2836 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2837 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2838 se
->string_length
, se
->expr
);
2841 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2844 /* Restore the original variables. */
2845 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2846 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2847 gfc_free (saved_vars
);
2851 /* Translate a function expression. */
2854 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2858 if (expr
->value
.function
.isym
)
2860 gfc_conv_intrinsic_function (se
, expr
);
2864 /* We distinguish statement functions from general functions to improve
2865 runtime performance. */
2866 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2868 gfc_conv_statement_function (se
, expr
);
2872 /* expr.value.function.esym is the resolved (specific) function symbol for
2873 most functions. However this isn't set for dummy procedures. */
2874 sym
= expr
->value
.function
.esym
;
2876 sym
= expr
->symtree
->n
.sym
;
2877 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2882 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2884 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2885 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2887 gfc_conv_tmp_array_ref (se
);
2888 gfc_advance_se_ss_chain (se
);
2892 /* Build a static initializer. EXPR is the expression for the initial value.
2893 The other parameters describe the variable of the component being
2894 initialized. EXPR may be null. */
2897 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2898 bool array
, bool pointer
)
2902 if (!(expr
|| pointer
))
2905 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
2906 (these are the only two iso_c_binding derived types that can be
2907 used as initialization expressions). If so, we need to modify
2908 the 'expr' to be that for a (void *). */
2909 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2910 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
2912 gfc_symbol
*derived
= expr
->ts
.derived
;
2914 expr
= gfc_int_expr (0);
2916 /* The derived symbol has already been converted to a (void *). Use
2918 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
2919 expr
->ts
.kind
= derived
->ts
.kind
;
2924 /* Arrays need special handling. */
2926 return gfc_build_null_descriptor (type
);
2928 return gfc_conv_array_initializer (type
, expr
);
2931 return fold_convert (type
, null_pointer_node
);
2937 gfc_init_se (&se
, NULL
);
2938 gfc_conv_structure (&se
, expr
, 1);
2942 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2945 gfc_init_se (&se
, NULL
);
2946 gfc_conv_constant (&se
, expr
);
2953 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2965 gfc_start_block (&block
);
2967 /* Initialize the scalarizer. */
2968 gfc_init_loopinfo (&loop
);
2970 gfc_init_se (&lse
, NULL
);
2971 gfc_init_se (&rse
, NULL
);
2974 rss
= gfc_walk_expr (expr
);
2975 if (rss
== gfc_ss_terminator
)
2977 /* The rhs is scalar. Add a ss for the expression. */
2978 rss
= gfc_get_ss ();
2979 rss
->next
= gfc_ss_terminator
;
2980 rss
->type
= GFC_SS_SCALAR
;
2984 /* Create a SS for the destination. */
2985 lss
= gfc_get_ss ();
2986 lss
->type
= GFC_SS_COMPONENT
;
2988 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2989 lss
->next
= gfc_ss_terminator
;
2990 lss
->data
.info
.dimen
= cm
->as
->rank
;
2991 lss
->data
.info
.descriptor
= dest
;
2992 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2993 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2994 for (n
= 0; n
< cm
->as
->rank
; n
++)
2996 lss
->data
.info
.dim
[n
] = n
;
2997 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2998 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3000 mpz_init (lss
->shape
[n
]);
3001 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3002 cm
->as
->lower
[n
]->value
.integer
);
3003 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3006 /* Associate the SS with the loop. */
3007 gfc_add_ss_to_loop (&loop
, lss
);
3008 gfc_add_ss_to_loop (&loop
, rss
);
3010 /* Calculate the bounds of the scalarization. */
3011 gfc_conv_ss_startstride (&loop
);
3013 /* Setup the scalarizing loops. */
3014 gfc_conv_loop_setup (&loop
);
3016 /* Setup the gfc_se structures. */
3017 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3018 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3021 gfc_mark_ss_chain_used (rss
, 1);
3023 gfc_mark_ss_chain_used (lss
, 1);
3025 /* Start the scalarized loop body. */
3026 gfc_start_scalarized_body (&loop
, &body
);
3028 gfc_conv_tmp_array_ref (&lse
);
3029 if (cm
->ts
.type
== BT_CHARACTER
)
3030 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3032 gfc_conv_expr (&rse
, expr
);
3034 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3035 gfc_add_expr_to_block (&body
, tmp
);
3037 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3039 /* Generate the copying loops. */
3040 gfc_trans_scalarizing_loops (&loop
, &body
);
3042 /* Wrap the whole thing up. */
3043 gfc_add_block_to_block (&block
, &loop
.pre
);
3044 gfc_add_block_to_block (&block
, &loop
.post
);
3046 for (n
= 0; n
< cm
->as
->rank
; n
++)
3047 mpz_clear (lss
->shape
[n
]);
3048 gfc_free (lss
->shape
);
3050 gfc_cleanup_loop (&loop
);
3052 return gfc_finish_block (&block
);
3056 /* Assign a single component of a derived type constructor. */
3059 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3069 gfc_start_block (&block
);
3073 gfc_init_se (&se
, NULL
);
3074 /* Pointer component. */
3077 /* Array pointer. */
3078 if (expr
->expr_type
== EXPR_NULL
)
3079 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3082 rss
= gfc_walk_expr (expr
);
3083 se
.direct_byref
= 1;
3085 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3086 gfc_add_block_to_block (&block
, &se
.pre
);
3087 gfc_add_block_to_block (&block
, &se
.post
);
3092 /* Scalar pointers. */
3093 se
.want_pointer
= 1;
3094 gfc_conv_expr (&se
, expr
);
3095 gfc_add_block_to_block (&block
, &se
.pre
);
3096 gfc_add_modify_expr (&block
, dest
,
3097 fold_convert (TREE_TYPE (dest
), se
.expr
));
3098 gfc_add_block_to_block (&block
, &se
.post
);
3101 else if (cm
->dimension
)
3103 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3104 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3105 else if (cm
->allocatable
)
3109 gfc_init_se (&se
, NULL
);
3111 rss
= gfc_walk_expr (expr
);
3112 se
.want_pointer
= 0;
3113 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3114 gfc_add_block_to_block (&block
, &se
.pre
);
3116 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3117 gfc_add_modify_expr (&block
, dest
, tmp
);
3119 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3120 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3123 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3124 TREE_TYPE(cm
->backend_decl
),
3127 gfc_add_expr_to_block (&block
, tmp
);
3129 gfc_add_block_to_block (&block
, &se
.post
);
3130 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3132 /* Shift the lbound and ubound of temporaries to being unity, rather
3133 than zero, based. Calculate the offset for all cases. */
3134 offset
= gfc_conv_descriptor_offset (dest
);
3135 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3136 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3137 for (n
= 0; n
< expr
->rank
; n
++)
3139 if (expr
->expr_type
!= EXPR_VARIABLE
3140 && expr
->expr_type
!= EXPR_CONSTANT
)
3143 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3144 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3145 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3146 gfc_add_modify_expr (&block
, tmp
,
3147 fold_build2 (PLUS_EXPR
,
3148 gfc_array_index_type
,
3149 span
, gfc_index_one_node
));
3150 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3151 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3153 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3154 gfc_conv_descriptor_lbound (dest
,
3156 gfc_conv_descriptor_stride (dest
,
3158 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3159 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3160 gfc_add_modify_expr (&block
, offset
, tmp
);
3165 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3166 gfc_add_expr_to_block (&block
, tmp
);
3169 else if (expr
->ts
.type
== BT_DERIVED
)
3171 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3173 gfc_init_se (&se
, NULL
);
3174 gfc_conv_expr (&se
, expr
);
3175 gfc_add_modify_expr (&block
, dest
,
3176 fold_convert (TREE_TYPE (dest
), se
.expr
));
3180 /* Nested constructors. */
3181 tmp
= gfc_trans_structure_assign (dest
, expr
);
3182 gfc_add_expr_to_block (&block
, tmp
);
3187 /* Scalar component. */
3188 gfc_init_se (&se
, NULL
);
3189 gfc_init_se (&lse
, NULL
);
3191 gfc_conv_expr (&se
, expr
);
3192 if (cm
->ts
.type
== BT_CHARACTER
)
3193 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3195 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3196 gfc_add_expr_to_block (&block
, tmp
);
3198 return gfc_finish_block (&block
);
3201 /* Assign a derived type constructor to a variable. */
3204 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3212 gfc_start_block (&block
);
3213 cm
= expr
->ts
.derived
->components
;
3214 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3216 /* Skip absent members in default initializers. */
3220 /* Update the type/kind of the expression if it represents either
3221 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3222 be the first place reached for initializing output variables that
3223 have components of type C_PTR/C_FUNPTR that are initialized. */
3224 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3225 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3227 c
->expr
->expr_type
= EXPR_NULL
;
3228 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3229 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3230 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3233 field
= cm
->backend_decl
;
3234 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3235 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3236 gfc_add_expr_to_block (&block
, tmp
);
3238 return gfc_finish_block (&block
);
3241 /* Build an expression for a constructor. If init is nonzero then
3242 this is part of a static variable initializer. */
3245 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3252 VEC(constructor_elt
,gc
) *v
= NULL
;
3254 gcc_assert (se
->ss
== NULL
);
3255 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3256 type
= gfc_typenode_for_spec (&expr
->ts
);
3260 /* Create a temporary variable and fill it in. */
3261 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3262 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3263 gfc_add_expr_to_block (&se
->pre
, tmp
);
3267 cm
= expr
->ts
.derived
->components
;
3269 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3271 /* Skip absent members in default initializers and allocatable
3272 components. Although the latter have a default initializer
3273 of EXPR_NULL,... by default, the static nullify is not needed
3274 since this is done every time we come into scope. */
3275 if (!c
->expr
|| cm
->allocatable
)
3278 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3279 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3281 /* Append it to the constructor list. */
3282 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3284 se
->expr
= build_constructor (type
, v
);
3288 /* Translate a substring expression. */
3291 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3297 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3299 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3300 expr
->value
.character
.string
);
3301 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3302 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3305 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3309 /* Entry point for expression translation. Evaluates a scalar quantity.
3310 EXPR is the expression to be translated, and SE is the state structure if
3311 called from within the scalarized. */
3314 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3316 if (se
->ss
&& se
->ss
->expr
== expr
3317 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3319 /* Substitute a scalar expression evaluated outside the scalarization
3321 se
->expr
= se
->ss
->data
.scalar
.expr
;
3322 se
->string_length
= se
->ss
->string_length
;
3323 gfc_advance_se_ss_chain (se
);
3327 /* We need to convert the expressions for the iso_c_binding derived types.
3328 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3329 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3330 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3331 updated to be an integer with a kind equal to the size of a (void *). */
3332 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3333 && expr
->ts
.derived
->attr
.is_iso_c
)
3335 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3336 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3338 /* Set expr_type to EXPR_NULL, which will result in
3339 null_pointer_node being used below. */
3340 expr
->expr_type
= EXPR_NULL
;
3344 /* Update the type/kind of the expression to be what the new
3345 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3346 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3347 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3348 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3352 switch (expr
->expr_type
)
3355 gfc_conv_expr_op (se
, expr
);
3359 gfc_conv_function_expr (se
, expr
);
3363 gfc_conv_constant (se
, expr
);
3367 gfc_conv_variable (se
, expr
);
3371 se
->expr
= null_pointer_node
;
3374 case EXPR_SUBSTRING
:
3375 gfc_conv_substring_expr (se
, expr
);
3378 case EXPR_STRUCTURE
:
3379 gfc_conv_structure (se
, expr
, 0);
3383 gfc_conv_array_constructor_expr (se
, expr
);
3392 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3393 of an assignment. */
3395 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3397 gfc_conv_expr (se
, expr
);
3398 /* All numeric lvalues should have empty post chains. If not we need to
3399 figure out a way of rewriting an lvalue so that it has no post chain. */
3400 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3403 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3404 numeric expressions. Used for scalar values where inserting cleanup code
3407 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3411 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3412 gfc_conv_expr (se
, expr
);
3415 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3416 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3418 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3422 /* Helper to translate an expression and convert it to a particular type. */
3424 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3426 gfc_conv_expr_val (se
, expr
);
3427 se
->expr
= convert (type
, se
->expr
);
3431 /* Converts an expression so that it can be passed by reference. Scalar
3435 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3439 if (se
->ss
&& se
->ss
->expr
== expr
3440 && se
->ss
->type
== GFC_SS_REFERENCE
)
3442 se
->expr
= se
->ss
->data
.scalar
.expr
;
3443 se
->string_length
= se
->ss
->string_length
;
3444 gfc_advance_se_ss_chain (se
);
3448 if (expr
->ts
.type
== BT_CHARACTER
)
3450 gfc_conv_expr (se
, expr
);
3451 gfc_conv_string_parameter (se
);
3455 if (expr
->expr_type
== EXPR_VARIABLE
)
3457 se
->want_pointer
= 1;
3458 gfc_conv_expr (se
, expr
);
3461 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3462 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3463 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3469 if (expr
->expr_type
== EXPR_FUNCTION
3470 && expr
->symtree
->n
.sym
->attr
.pointer
3471 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3473 se
->want_pointer
= 1;
3474 gfc_conv_expr (se
, expr
);
3475 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3476 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3482 gfc_conv_expr (se
, expr
);
3484 /* Create a temporary var to hold the value. */
3485 if (TREE_CONSTANT (se
->expr
))
3487 tree tmp
= se
->expr
;
3488 STRIP_TYPE_NOPS (tmp
);
3489 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3490 DECL_INITIAL (var
) = tmp
;
3491 TREE_STATIC (var
) = 1;
3496 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3497 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3499 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3501 /* Take the address of that value. */
3502 se
->expr
= build_fold_addr_expr (var
);
3507 gfc_trans_pointer_assign (gfc_code
* code
)
3509 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3513 /* Generate code for a pointer assignment. */
3516 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3528 gfc_start_block (&block
);
3530 gfc_init_se (&lse
, NULL
);
3532 lss
= gfc_walk_expr (expr1
);
3533 rss
= gfc_walk_expr (expr2
);
3534 if (lss
== gfc_ss_terminator
)
3536 /* Scalar pointers. */
3537 lse
.want_pointer
= 1;
3538 gfc_conv_expr (&lse
, expr1
);
3539 gcc_assert (rss
== gfc_ss_terminator
);
3540 gfc_init_se (&rse
, NULL
);
3541 rse
.want_pointer
= 1;
3542 gfc_conv_expr (&rse
, expr2
);
3543 gfc_add_block_to_block (&block
, &lse
.pre
);
3544 gfc_add_block_to_block (&block
, &rse
.pre
);
3545 gfc_add_modify_expr (&block
, lse
.expr
,
3546 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3547 gfc_add_block_to_block (&block
, &rse
.post
);
3548 gfc_add_block_to_block (&block
, &lse
.post
);
3552 /* Array pointer. */
3553 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3554 switch (expr2
->expr_type
)
3557 /* Just set the data pointer to null. */
3558 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3562 /* Assign directly to the pointer's descriptor. */
3563 lse
.direct_byref
= 1;
3564 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3566 /* If this is a subreference array pointer assignment, use the rhs
3567 descriptor element size for the lhs span. */
3568 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3570 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3571 gfc_init_se (&rse
, NULL
);
3572 rse
.descriptor_only
= 1;
3573 gfc_conv_expr (&rse
, expr2
);
3574 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3575 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3576 if (!INTEGER_CST_P (tmp
))
3577 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3578 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3584 /* Assign to a temporary descriptor and then copy that
3585 temporary to the pointer. */
3587 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3590 lse
.direct_byref
= 1;
3591 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3592 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3595 gfc_add_block_to_block (&block
, &lse
.pre
);
3596 gfc_add_block_to_block (&block
, &lse
.post
);
3598 return gfc_finish_block (&block
);
3602 /* Makes sure se is suitable for passing as a function string parameter. */
3603 /* TODO: Need to check all callers fo this function. It may be abused. */
3606 gfc_conv_string_parameter (gfc_se
* se
)
3610 if (TREE_CODE (se
->expr
) == STRING_CST
)
3612 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3616 type
= TREE_TYPE (se
->expr
);
3617 if (TYPE_STRING_FLAG (type
))
3619 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3620 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3623 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3625 type
= build_pointer_type (type
);
3626 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3630 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3631 gcc_assert (se
->string_length
3632 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3636 /* Generate code for assignment of scalar variables. Includes character
3637 strings and derived types with allocatable components. */
3640 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3641 bool l_is_temp
, bool r_is_var
)
3647 gfc_init_block (&block
);
3649 if (ts
.type
== BT_CHARACTER
)
3651 gcc_assert (lse
->string_length
!= NULL_TREE
3652 && rse
->string_length
!= NULL_TREE
);
3654 gfc_conv_string_parameter (lse
);
3655 gfc_conv_string_parameter (rse
);
3657 gfc_add_block_to_block (&block
, &lse
->pre
);
3658 gfc_add_block_to_block (&block
, &rse
->pre
);
3660 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3661 rse
->string_length
, rse
->expr
);
3663 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3667 /* Are the rhs and the lhs the same? */
3670 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3671 build_fold_addr_expr (lse
->expr
),
3672 build_fold_addr_expr (rse
->expr
));
3673 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3676 /* Deallocate the lhs allocated components as long as it is not
3677 the same as the rhs. This must be done following the assignment
3678 to prevent deallocating data that could be used in the rhs
3682 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3683 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3685 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3686 gfc_add_expr_to_block (&lse
->post
, tmp
);
3689 gfc_add_block_to_block (&block
, &rse
->pre
);
3690 gfc_add_block_to_block (&block
, &lse
->pre
);
3692 gfc_add_modify_expr (&block
, lse
->expr
,
3693 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3695 /* Do a deep copy if the rhs is a variable, if it is not the
3699 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3700 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3701 gfc_add_expr_to_block (&block
, tmp
);
3706 gfc_add_block_to_block (&block
, &lse
->pre
);
3707 gfc_add_block_to_block (&block
, &rse
->pre
);
3709 gfc_add_modify_expr (&block
, lse
->expr
,
3710 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3713 gfc_add_block_to_block (&block
, &lse
->post
);
3714 gfc_add_block_to_block (&block
, &rse
->post
);
3716 return gfc_finish_block (&block
);
3720 /* Try to translate array(:) = func (...), where func is a transformational
3721 array function, without using a temporary. Returns NULL is this isn't the
3725 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3730 bool seen_array_ref
;
3732 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3733 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3736 /* Elemental functions don't need a temporary anyway. */
3737 if (expr2
->value
.function
.esym
!= NULL
3738 && expr2
->value
.function
.esym
->attr
.elemental
)
3741 /* Fail if EXPR1 can't be expressed as a descriptor. */
3742 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3745 /* Functions returning pointers need temporaries. */
3746 if (expr2
->symtree
->n
.sym
->attr
.pointer
3747 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3750 /* Character array functions need temporaries unless the
3751 character lengths are the same. */
3752 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3754 if (expr1
->ts
.cl
->length
== NULL
3755 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3758 if (expr2
->ts
.cl
->length
== NULL
3759 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3762 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3763 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3767 /* Check that no LHS component references appear during an array
3768 reference. This is needed because we do not have the means to
3769 span any arbitrary stride with an array descriptor. This check
3770 is not needed for the rhs because the function result has to be
3772 seen_array_ref
= false;
3773 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3775 if (ref
->type
== REF_ARRAY
)
3776 seen_array_ref
= true;
3777 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3781 /* Check for a dependency. */
3782 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3783 expr2
->value
.function
.esym
,
3784 expr2
->value
.function
.actual
))
3787 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3789 gcc_assert (expr2
->value
.function
.isym
3790 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3791 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3793 ss
= gfc_walk_expr (expr1
);
3794 gcc_assert (ss
!= gfc_ss_terminator
);
3795 gfc_init_se (&se
, NULL
);
3796 gfc_start_block (&se
.pre
);
3797 se
.want_pointer
= 1;
3799 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3801 se
.direct_byref
= 1;
3802 se
.ss
= gfc_walk_expr (expr2
);
3803 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3804 gfc_conv_function_expr (&se
, expr2
);
3805 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3807 return gfc_finish_block (&se
.pre
);
3810 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3813 is_zero_initializer_p (gfc_expr
* expr
)
3815 if (expr
->expr_type
!= EXPR_CONSTANT
)
3818 /* We ignore constants with prescribed memory representations for now. */
3819 if (expr
->representation
.string
)
3822 switch (expr
->ts
.type
)
3825 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3828 return mpfr_zero_p (expr
->value
.real
)
3829 && MPFR_SIGN (expr
->value
.real
) >= 0;
3832 return expr
->value
.logical
== 0;
3835 return mpfr_zero_p (expr
->value
.complex.r
)
3836 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3837 && mpfr_zero_p (expr
->value
.complex.i
)
3838 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3846 /* Try to efficiently translate array(:) = 0. Return NULL if this
3850 gfc_trans_zero_assign (gfc_expr
* expr
)
3852 tree dest
, len
, type
;
3856 sym
= expr
->symtree
->n
.sym
;
3857 dest
= gfc_get_symbol_decl (sym
);
3859 type
= TREE_TYPE (dest
);
3860 if (POINTER_TYPE_P (type
))
3861 type
= TREE_TYPE (type
);
3862 if (!GFC_ARRAY_TYPE_P (type
))
3865 /* Determine the length of the array. */
3866 len
= GFC_TYPE_ARRAY_SIZE (type
);
3867 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3870 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3871 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3872 fold_convert (gfc_array_index_type
, tmp
));
3874 /* Convert arguments to the correct types. */
3875 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3876 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3878 dest
= fold_convert (pvoid_type_node
, dest
);
3879 len
= fold_convert (size_type_node
, len
);
3881 /* Construct call to __builtin_memset. */
3882 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3883 3, dest
, integer_zero_node
, len
);
3884 return fold_convert (void_type_node
, tmp
);
3888 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3889 that constructs the call to __builtin_memcpy. */
3892 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3896 /* Convert arguments to the correct types. */
3897 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3898 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3900 dst
= fold_convert (pvoid_type_node
, dst
);
3902 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3903 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3905 src
= fold_convert (pvoid_type_node
, src
);
3907 len
= fold_convert (size_type_node
, len
);
3909 /* Construct call to __builtin_memcpy. */
3910 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3911 return fold_convert (void_type_node
, tmp
);
3915 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3916 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3917 source/rhs, both are gfc_full_array_ref_p which have been checked for
3921 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3923 tree dst
, dlen
, dtype
;
3924 tree src
, slen
, stype
;
3927 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3928 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3930 dtype
= TREE_TYPE (dst
);
3931 if (POINTER_TYPE_P (dtype
))
3932 dtype
= TREE_TYPE (dtype
);
3933 stype
= TREE_TYPE (src
);
3934 if (POINTER_TYPE_P (stype
))
3935 stype
= TREE_TYPE (stype
);
3937 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3940 /* Determine the lengths of the arrays. */
3941 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3942 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3944 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3945 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3946 fold_convert (gfc_array_index_type
, tmp
));
3948 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3949 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3951 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3952 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3953 fold_convert (gfc_array_index_type
, tmp
));
3955 /* Sanity check that they are the same. This should always be
3956 the case, as we should already have checked for conformance. */
3957 if (!tree_int_cst_equal (slen
, dlen
))
3960 return gfc_build_memcpy_call (dst
, src
, dlen
);
3964 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3965 this can't be done. EXPR1 is the destination/lhs for which
3966 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3969 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3971 unsigned HOST_WIDE_INT nelem
;
3977 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3981 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3982 dtype
= TREE_TYPE (dst
);
3983 if (POINTER_TYPE_P (dtype
))
3984 dtype
= TREE_TYPE (dtype
);
3985 if (!GFC_ARRAY_TYPE_P (dtype
))
3988 /* Determine the lengths of the array. */
3989 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3990 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3993 /* Confirm that the constructor is the same size. */
3994 if (compare_tree_int (len
, nelem
) != 0)
3997 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3998 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3999 fold_convert (gfc_array_index_type
, tmp
));
4001 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4002 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4004 stype
= TREE_TYPE (src
);
4005 if (POINTER_TYPE_P (stype
))
4006 stype
= TREE_TYPE (stype
);
4008 return gfc_build_memcpy_call (dst
, src
, len
);
4012 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4013 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4016 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4021 gfc_ss
*lss_section
;
4029 /* Assignment of the form lhs = rhs. */
4030 gfc_start_block (&block
);
4032 gfc_init_se (&lse
, NULL
);
4033 gfc_init_se (&rse
, NULL
);
4036 lss
= gfc_walk_expr (expr1
);
4038 if (lss
!= gfc_ss_terminator
)
4040 /* The assignment needs scalarization. */
4043 /* Find a non-scalar SS from the lhs. */
4044 while (lss_section
!= gfc_ss_terminator
4045 && lss_section
->type
!= GFC_SS_SECTION
)
4046 lss_section
= lss_section
->next
;
4048 gcc_assert (lss_section
!= gfc_ss_terminator
);
4050 /* Initialize the scalarizer. */
4051 gfc_init_loopinfo (&loop
);
4054 rss
= gfc_walk_expr (expr2
);
4055 if (rss
== gfc_ss_terminator
)
4057 /* The rhs is scalar. Add a ss for the expression. */
4058 rss
= gfc_get_ss ();
4059 rss
->next
= gfc_ss_terminator
;
4060 rss
->type
= GFC_SS_SCALAR
;
4063 /* Associate the SS with the loop. */
4064 gfc_add_ss_to_loop (&loop
, lss
);
4065 gfc_add_ss_to_loop (&loop
, rss
);
4067 /* Calculate the bounds of the scalarization. */
4068 gfc_conv_ss_startstride (&loop
);
4069 /* Resolve any data dependencies in the statement. */
4070 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4071 /* Setup the scalarizing loops. */
4072 gfc_conv_loop_setup (&loop
);
4074 /* Setup the gfc_se structures. */
4075 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4076 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4079 gfc_mark_ss_chain_used (rss
, 1);
4080 if (loop
.temp_ss
== NULL
)
4083 gfc_mark_ss_chain_used (lss
, 1);
4087 lse
.ss
= loop
.temp_ss
;
4088 gfc_mark_ss_chain_used (lss
, 3);
4089 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4092 /* Start the scalarized loop body. */
4093 gfc_start_scalarized_body (&loop
, &body
);
4096 gfc_init_block (&body
);
4098 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4100 /* Translate the expression. */
4101 gfc_conv_expr (&rse
, expr2
);
4105 gfc_conv_tmp_array_ref (&lse
);
4106 gfc_advance_se_ss_chain (&lse
);
4109 gfc_conv_expr (&lse
, expr1
);
4111 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4112 l_is_temp
|| init_flag
,
4113 expr2
->expr_type
== EXPR_VARIABLE
);
4114 gfc_add_expr_to_block (&body
, tmp
);
4116 if (lss
== gfc_ss_terminator
)
4118 /* Use the scalar assignment as is. */
4119 gfc_add_block_to_block (&block
, &body
);
4123 gcc_assert (lse
.ss
== gfc_ss_terminator
4124 && rse
.ss
== gfc_ss_terminator
);
4128 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4130 /* We need to copy the temporary to the actual lhs. */
4131 gfc_init_se (&lse
, NULL
);
4132 gfc_init_se (&rse
, NULL
);
4133 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4134 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4136 rse
.ss
= loop
.temp_ss
;
4139 gfc_conv_tmp_array_ref (&rse
);
4140 gfc_advance_se_ss_chain (&rse
);
4141 gfc_conv_expr (&lse
, expr1
);
4143 gcc_assert (lse
.ss
== gfc_ss_terminator
4144 && rse
.ss
== gfc_ss_terminator
);
4146 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4148 gfc_add_expr_to_block (&body
, tmp
);
4151 /* Generate the copying loops. */
4152 gfc_trans_scalarizing_loops (&loop
, &body
);
4154 /* Wrap the whole thing up. */
4155 gfc_add_block_to_block (&block
, &loop
.pre
);
4156 gfc_add_block_to_block (&block
, &loop
.post
);
4158 gfc_cleanup_loop (&loop
);
4161 return gfc_finish_block (&block
);
4165 /* Check whether EXPR is a copyable array. */
4168 copyable_array_p (gfc_expr
* expr
)
4170 if (expr
->expr_type
!= EXPR_VARIABLE
)
4173 /* First check it's an array. */
4174 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4177 if (!gfc_full_array_ref_p (expr
->ref
))
4180 /* Next check that it's of a simple enough type. */
4181 switch (expr
->ts
.type
)
4193 return !expr
->ts
.derived
->attr
.alloc_comp
;
4202 /* Translate an assignment. */
4205 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4209 /* Special case a single function returning an array. */
4210 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4212 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4217 /* Special case assigning an array to zero. */
4218 if (copyable_array_p (expr1
)
4219 && is_zero_initializer_p (expr2
))
4221 tmp
= gfc_trans_zero_assign (expr1
);
4226 /* Special case copying one array to another. */
4227 if (copyable_array_p (expr1
)
4228 && copyable_array_p (expr2
)
4229 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4230 && !gfc_check_dependency (expr1
, expr2
, 0))
4232 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4237 /* Special case initializing an array from a constant array constructor. */
4238 if (copyable_array_p (expr1
)
4239 && expr2
->expr_type
== EXPR_ARRAY
4240 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4242 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4247 /* Fallback to the scalarizer to generate explicit loops. */
4248 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4252 gfc_trans_init_assign (gfc_code
* code
)
4254 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4258 gfc_trans_assign (gfc_code
* code
)
4260 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);