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"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
159 /* Create a temporary and convert it to the correct type. */
160 tmp
= gfc_get_int_type (kind
);
161 tmp
= fold_convert (tmp
, build_fold_indirect_ref (se
->expr
));
163 /* Test for a NULL value. */
164 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
, tmp
, integer_one_node
);
165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
166 se
->expr
= build_fold_addr_expr (tmp
);
170 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
171 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
172 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
176 if (ts
.type
== BT_CHARACTER
)
178 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
179 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
180 se
->string_length
, tmp
);
181 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
182 se
->string_length
= tmp
;
188 /* Get the character length of an expression, looking through gfc_refs
192 gfc_get_expr_charlen (gfc_expr
*e
)
197 gcc_assert (e
->expr_type
== EXPR_VARIABLE
198 && e
->ts
.type
== BT_CHARACTER
);
200 length
= NULL
; /* To silence compiler warning. */
202 if (is_subref_array (e
) && e
->ts
.cl
->length
)
205 gfc_init_se (&tmpse
, NULL
);
206 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
207 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
211 /* First candidate: if the variable is of type CHARACTER, the
212 expression's length could be the length of the character
214 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
215 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
217 /* Look through the reference chain for component references. */
218 for (r
= e
->ref
; r
; r
= r
->next
)
223 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
224 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
232 /* We should never got substring references here. These will be
233 broken down by the scalarizer. */
239 gcc_assert (length
!= NULL
);
245 /* Generate code to initialize a string length variable. Returns the
249 gfc_conv_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
253 gfc_init_se (&se
, NULL
);
254 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
255 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
256 build_int_cst (gfc_charlen_type_node
, 0));
257 gfc_add_block_to_block (pblock
, &se
.pre
);
259 if (cl
->backend_decl
)
260 gfc_add_modify_expr (pblock
, cl
->backend_decl
, se
.expr
);
262 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
267 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
268 const char *name
, locus
*where
)
278 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
279 type
= build_pointer_type (type
);
282 gfc_init_se (&start
, se
);
283 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
284 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
286 if (integer_onep (start
.expr
))
287 gfc_conv_string_parameter (se
);
290 /* Avoid multiple evaluation of substring start. */
291 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
292 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
294 /* Change the start of the string. */
295 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
298 tmp
= build_fold_indirect_ref (se
->expr
);
299 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
300 se
->expr
= gfc_build_addr_expr (type
, tmp
);
303 /* Length = end + 1 - start. */
304 gfc_init_se (&end
, se
);
305 if (ref
->u
.ss
.end
== NULL
)
306 end
.expr
= se
->string_length
;
309 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
310 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
312 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
313 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
315 if (flag_bounds_check
)
317 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
318 start
.expr
, end
.expr
);
320 /* Check lower bound. */
321 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
322 build_int_cst (gfc_charlen_type_node
, 1));
323 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
326 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
327 "is less than one", name
);
329 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
331 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
332 fold_convert (long_integer_type_node
,
336 /* Check upper bound. */
337 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
339 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
342 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
343 "exceeds string length (%%ld)", name
);
345 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
346 "exceeds string length (%%ld)");
347 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
348 fold_convert (long_integer_type_node
, end
.expr
),
349 fold_convert (long_integer_type_node
,
354 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
355 build_int_cst (gfc_charlen_type_node
, 1),
357 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
358 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
359 build_int_cst (gfc_charlen_type_node
, 0));
360 se
->string_length
= tmp
;
364 /* Convert a derived type component reference. */
367 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
374 c
= ref
->u
.c
.component
;
376 gcc_assert (c
->backend_decl
);
378 field
= c
->backend_decl
;
379 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
381 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
385 if (c
->ts
.type
== BT_CHARACTER
)
387 tmp
= c
->ts
.cl
->backend_decl
;
388 /* Components must always be constant length. */
389 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
390 se
->string_length
= tmp
;
393 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
394 se
->expr
= build_fold_indirect_ref (se
->expr
);
398 /* Return the contents of a variable. Also handles reference/pointer
399 variables (all Fortran pointer references are implicit). */
402 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
409 bool alternate_entry
;
412 sym
= expr
->symtree
->n
.sym
;
415 /* Check that something hasn't gone horribly wrong. */
416 gcc_assert (se
->ss
!= gfc_ss_terminator
);
417 gcc_assert (se
->ss
->expr
== expr
);
419 /* A scalarized term. We already know the descriptor. */
420 se
->expr
= se
->ss
->data
.info
.descriptor
;
421 se
->string_length
= se
->ss
->string_length
;
422 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
423 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
428 tree se_expr
= NULL_TREE
;
430 se
->expr
= gfc_get_symbol_decl (sym
);
432 /* Deal with references to a parent results or entries by storing
433 the current_function_decl and moving to the parent_decl. */
434 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
435 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
436 && sym
->result
== sym
;
437 entry_master
= sym
->attr
.result
438 && sym
->ns
->proc_name
->attr
.entry_master
439 && !gfc_return_by_reference (sym
->ns
->proc_name
);
440 parent_decl
= DECL_CONTEXT (current_function_decl
);
442 if ((se
->expr
== parent_decl
&& return_value
)
443 || (sym
->ns
&& sym
->ns
->proc_name
445 && sym
->ns
->proc_name
->backend_decl
== parent_decl
446 && (alternate_entry
|| entry_master
)))
451 /* Special case for assigning the return value of a function.
452 Self recursive functions must have an explicit return value. */
453 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
454 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
456 /* Similarly for alternate entry points. */
457 else if (alternate_entry
458 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
461 gfc_entry_list
*el
= NULL
;
463 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
466 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
471 else if (entry_master
472 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
474 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
479 /* Procedure actual arguments. */
480 else if (sym
->attr
.flavor
== FL_PROCEDURE
481 && se
->expr
!= current_function_decl
)
483 gcc_assert (se
->want_pointer
);
484 if (!sym
->attr
.dummy
)
486 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
487 se
->expr
= build_fold_addr_expr (se
->expr
);
493 /* Dereference the expression, where needed. Since characters
494 are entirely different from other types, they are treated
496 if (sym
->ts
.type
== BT_CHARACTER
)
498 /* Dereference character pointer dummy arguments
500 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
502 || sym
->attr
.function
503 || sym
->attr
.result
))
504 se
->expr
= build_fold_indirect_ref (se
->expr
);
507 else if (!sym
->attr
.value
)
509 /* Dereference non-character scalar dummy arguments. */
510 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
511 se
->expr
= build_fold_indirect_ref (se
->expr
);
513 /* Dereference scalar hidden result. */
514 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
515 && (sym
->attr
.function
|| sym
->attr
.result
)
516 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
517 se
->expr
= build_fold_indirect_ref (se
->expr
);
519 /* Dereference non-character pointer variables.
520 These must be dummies, results, or scalars. */
521 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
523 || sym
->attr
.function
525 || !sym
->attr
.dimension
))
526 se
->expr
= build_fold_indirect_ref (se
->expr
);
532 /* For character variables, also get the length. */
533 if (sym
->ts
.type
== BT_CHARACTER
)
535 /* If the character length of an entry isn't set, get the length from
536 the master function instead. */
537 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
538 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
540 se
->string_length
= sym
->ts
.cl
->backend_decl
;
541 gcc_assert (se
->string_length
);
549 /* Return the descriptor if that's what we want and this is an array
550 section reference. */
551 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
553 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
554 /* Return the descriptor for array pointers and allocations. */
556 && ref
->next
== NULL
&& (se
->descriptor_only
))
559 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
560 /* Return a pointer to an element. */
564 gfc_conv_component_ref (se
, ref
);
568 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
569 expr
->symtree
->name
, &expr
->where
);
578 /* Pointer assignment, allocation or pass by reference. Arrays are handled
580 if (se
->want_pointer
)
582 if (expr
->ts
.type
== BT_CHARACTER
)
583 gfc_conv_string_parameter (se
);
585 se
->expr
= build_fold_addr_expr (se
->expr
);
590 /* Unary ops are easy... Or they would be if ! was a valid op. */
593 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
598 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
599 /* Initialize the operand. */
600 gfc_init_se (&operand
, se
);
601 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
602 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
604 type
= gfc_typenode_for_spec (&expr
->ts
);
606 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
607 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
608 All other unary operators have an equivalent GIMPLE unary operator. */
609 if (code
== TRUTH_NOT_EXPR
)
610 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
611 build_int_cst (type
, 0));
613 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
617 /* Expand power operator to optimal multiplications when a value is raised
618 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
619 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
620 Programming", 3rd Edition, 1998. */
622 /* This code is mostly duplicated from expand_powi in the backend.
623 We establish the "optimal power tree" lookup table with the defined size.
624 The items in the table are the exponents used to calculate the index
625 exponents. Any integer n less than the value can get an "addition chain",
626 with the first node being one. */
627 #define POWI_TABLE_SIZE 256
629 /* The table is from builtins.c. */
630 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
632 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
633 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
634 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
635 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
636 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
637 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
638 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
639 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
640 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
641 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
642 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
643 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
644 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
645 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
646 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
647 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
648 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
649 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
650 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
651 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
652 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
653 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
654 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
655 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
656 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
657 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
658 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
659 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
660 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
661 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
662 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
663 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
666 /* If n is larger than lookup table's max index, we use the "window
668 #define POWI_WINDOW_SIZE 3
670 /* Recursive function to expand the power operator. The temporary
671 values are put in tmpvar. The function returns tmpvar[1] ** n. */
673 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
680 if (n
< POWI_TABLE_SIZE
)
685 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
686 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
690 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
691 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
692 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
696 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
700 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
701 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
703 if (n
< POWI_TABLE_SIZE
)
710 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
711 return 1. Else return 0 and a call to runtime library functions
712 will have to be built. */
714 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
719 tree vartmp
[POWI_TABLE_SIZE
];
721 unsigned HOST_WIDE_INT n
;
724 /* If exponent is too large, we won't expand it anyway, so don't bother
725 with large integer values. */
726 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
729 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
730 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
731 of the asymmetric range of the integer type. */
732 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
734 type
= TREE_TYPE (lhs
);
735 sgn
= tree_int_cst_sgn (rhs
);
737 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
738 || optimize_size
) && (m
> 2 || m
< -1))
744 se
->expr
= gfc_build_const (type
, integer_one_node
);
748 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
749 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
751 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
752 build_int_cst (TREE_TYPE (lhs
), -1));
753 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
754 build_int_cst (TREE_TYPE (lhs
), 1));
757 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
760 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
761 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
762 build_int_cst (type
, 0));
766 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
767 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
768 build_int_cst (type
, 0));
769 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
773 memset (vartmp
, 0, sizeof (vartmp
));
777 tmp
= gfc_build_const (type
, integer_one_node
);
778 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
781 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
787 /* Power op (**). Constant integer exponent has special handling. */
790 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
792 tree gfc_int4_type_node
;
799 gfc_init_se (&lse
, se
);
800 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
801 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
802 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
804 gfc_init_se (&rse
, se
);
805 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
806 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
808 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
809 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
810 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
813 gfc_int4_type_node
= gfc_get_int_type (4);
815 kind
= expr
->value
.op
.op1
->ts
.kind
;
816 switch (expr
->value
.op
.op2
->ts
.type
)
819 ikind
= expr
->value
.op
.op2
->ts
.kind
;
824 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
846 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
847 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
872 switch (expr
->value
.op
.op1
->ts
.type
)
875 if (kind
== 3) /* Case 16 was not handled properly above. */
877 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
881 /* Use builtins for real ** int4. */
887 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
891 fndecl
= built_in_decls
[BUILT_IN_POWI
];
896 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
904 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
908 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
920 fndecl
= built_in_decls
[BUILT_IN_POWF
];
923 fndecl
= built_in_decls
[BUILT_IN_POW
];
927 fndecl
= built_in_decls
[BUILT_IN_POWL
];
938 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
941 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
945 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
957 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
961 /* Generate code to allocate a string temporary. */
964 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
969 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
971 if (gfc_can_put_var_on_stack (len
))
973 /* Create a temporary variable to hold the result. */
974 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
975 build_int_cst (gfc_charlen_type_node
, 1));
976 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
977 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
978 var
= gfc_create_var (tmp
, "str");
979 var
= gfc_build_addr_expr (type
, var
);
983 /* Allocate a temporary to hold the result. */
984 var
= gfc_create_var (type
, "pstr");
985 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
986 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
988 /* Free the temporary afterwards. */
989 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
990 gfc_add_expr_to_block (&se
->post
, tmp
);
997 /* Handle a string concatenation operation. A temporary will be allocated to
1001 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1010 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1011 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1013 gfc_init_se (&lse
, se
);
1014 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1015 gfc_conv_string_parameter (&lse
);
1016 gfc_init_se (&rse
, se
);
1017 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1018 gfc_conv_string_parameter (&rse
);
1020 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1021 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1023 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1024 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1025 if (len
== NULL_TREE
)
1027 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1028 lse
.string_length
, rse
.string_length
);
1031 type
= build_pointer_type (type
);
1033 var
= gfc_conv_string_tmp (se
, type
, len
);
1035 /* Do the actual concatenation. */
1036 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1038 lse
.string_length
, lse
.expr
,
1039 rse
.string_length
, rse
.expr
);
1040 gfc_add_expr_to_block (&se
->pre
, tmp
);
1042 /* Add the cleanup for the operands. */
1043 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1044 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1047 se
->string_length
= len
;
1050 /* Translates an op expression. Common (binary) cases are handled by this
1051 function, others are passed on. Recursion is used in either case.
1052 We use the fact that (op1.ts == op2.ts) (except for the power
1054 Operators need no special handling for scalarized expressions as long as
1055 they call gfc_conv_simple_val to get their operands.
1056 Character strings get special handling. */
1059 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1061 enum tree_code code
;
1070 switch (expr
->value
.op
.operator)
1072 case INTRINSIC_PARENTHESES
:
1073 if (expr
->ts
.type
== BT_REAL
1074 || expr
->ts
.type
== BT_COMPLEX
)
1076 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1077 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1082 case INTRINSIC_UPLUS
:
1083 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1086 case INTRINSIC_UMINUS
:
1087 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1091 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1094 case INTRINSIC_PLUS
:
1098 case INTRINSIC_MINUS
:
1102 case INTRINSIC_TIMES
:
1106 case INTRINSIC_DIVIDE
:
1107 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1108 an integer, we must round towards zero, so we use a
1110 if (expr
->ts
.type
== BT_INTEGER
)
1111 code
= TRUNC_DIV_EXPR
;
1116 case INTRINSIC_POWER
:
1117 gfc_conv_power_op (se
, expr
);
1120 case INTRINSIC_CONCAT
:
1121 gfc_conv_concat_op (se
, expr
);
1125 code
= TRUTH_ANDIF_EXPR
;
1130 code
= TRUTH_ORIF_EXPR
;
1134 /* EQV and NEQV only work on logicals, but since we represent them
1135 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1137 case INTRINSIC_EQ_OS
:
1145 case INTRINSIC_NE_OS
:
1146 case INTRINSIC_NEQV
:
1153 case INTRINSIC_GT_OS
:
1160 case INTRINSIC_GE_OS
:
1167 case INTRINSIC_LT_OS
:
1174 case INTRINSIC_LE_OS
:
1180 case INTRINSIC_USER
:
1181 case INTRINSIC_ASSIGN
:
1182 /* These should be converted into function calls by the frontend. */
1186 fatal_error ("Unknown intrinsic op");
1190 /* The only exception to this is **, which is handled separately anyway. */
1191 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1193 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1197 gfc_init_se (&lse
, se
);
1198 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1199 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1202 gfc_init_se (&rse
, se
);
1203 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1204 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1208 gfc_conv_string_parameter (&lse
);
1209 gfc_conv_string_parameter (&rse
);
1211 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1212 rse
.string_length
, rse
.expr
);
1213 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1214 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1217 type
= gfc_typenode_for_spec (&expr
->ts
);
1221 /* The result of logical ops is always boolean_type_node. */
1222 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1223 se
->expr
= convert (type
, tmp
);
1226 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1228 /* Add the post blocks. */
1229 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1230 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1233 /* If a string's length is one, we convert it to a single character. */
1236 gfc_to_single_character (tree len
, tree str
)
1238 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1240 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1241 && TREE_INT_CST_HIGH (len
) == 0)
1243 str
= fold_convert (pchar_type_node
, str
);
1244 return build_fold_indirect_ref (str
);
1252 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1255 if (sym
->backend_decl
)
1257 /* This becomes the nominal_type in
1258 function.c:assign_parm_find_data_types. */
1259 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1260 /* This becomes the passed_type in
1261 function.c:assign_parm_find_data_types. C promotes char to
1262 integer for argument passing. */
1263 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1265 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1270 /* If we have a constant character expression, make it into an
1272 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1276 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1277 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1279 /* The expr needs to be compatible with a C int. If the
1280 conversion fails, then the 2 causes an ICE. */
1281 ts
.type
= BT_INTEGER
;
1282 ts
.kind
= gfc_c_int_kind
;
1283 gfc_convert_type (*expr
, &ts
, 2);
1286 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1288 if ((*expr
)->ref
== NULL
)
1290 se
->expr
= gfc_to_single_character
1291 (build_int_cst (integer_type_node
, 1),
1292 gfc_build_addr_expr (pchar_type_node
,
1294 ((*expr
)->symtree
->n
.sym
)));
1298 gfc_conv_variable (se
, *expr
);
1299 se
->expr
= gfc_to_single_character
1300 (build_int_cst (integer_type_node
, 1),
1301 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1308 /* Compare two strings. If they are all single characters, the result is the
1309 subtraction of them. Otherwise, we build a library call. */
1312 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1318 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1319 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1321 sc1
= gfc_to_single_character (len1
, str1
);
1322 sc2
= gfc_to_single_character (len2
, str2
);
1324 /* Deal with single character specially. */
1325 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1327 sc1
= fold_convert (integer_type_node
, sc1
);
1328 sc2
= fold_convert (integer_type_node
, sc2
);
1329 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1332 /* Build a call for the comparison. */
1333 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1334 len1
, str1
, len2
, str2
);
1339 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1343 if (sym
->attr
.dummy
)
1345 tmp
= gfc_get_symbol_decl (sym
);
1346 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1347 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1351 if (!sym
->backend_decl
)
1352 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1354 tmp
= sym
->backend_decl
;
1355 if (sym
->attr
.cray_pointee
)
1356 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1357 gfc_get_symbol_decl (sym
->cp_pointer
));
1358 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1360 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1361 tmp
= build_fold_addr_expr (tmp
);
1368 /* Translate the call for an elemental subroutine call used in an operator
1369 assignment. This is a simplified version of gfc_conv_function_call. */
1372 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1379 /* Only elemental subroutines with two arguments. */
1380 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1381 gcc_assert (sym
->formal
->next
->next
== NULL
);
1383 gfc_init_block (&block
);
1385 gfc_add_block_to_block (&block
, &lse
->pre
);
1386 gfc_add_block_to_block (&block
, &rse
->pre
);
1388 /* Build the argument list for the call, including hidden string lengths. */
1389 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1390 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1391 if (lse
->string_length
!= NULL_TREE
)
1392 args
= gfc_chainon_list (args
, lse
->string_length
);
1393 if (rse
->string_length
!= NULL_TREE
)
1394 args
= gfc_chainon_list (args
, rse
->string_length
);
1396 /* Build the function call. */
1397 gfc_init_se (&se
, NULL
);
1398 gfc_conv_function_val (&se
, sym
);
1399 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1400 tmp
= build_call_list (tmp
, se
.expr
, args
);
1401 gfc_add_expr_to_block (&block
, tmp
);
1403 gfc_add_block_to_block (&block
, &lse
->post
);
1404 gfc_add_block_to_block (&block
, &rse
->post
);
1406 return gfc_finish_block (&block
);
1410 /* Initialize MAPPING. */
1413 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1415 mapping
->syms
= NULL
;
1416 mapping
->charlens
= NULL
;
1420 /* Free all memory held by MAPPING (but not MAPPING itself). */
1423 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1425 gfc_interface_sym_mapping
*sym
;
1426 gfc_interface_sym_mapping
*nextsym
;
1428 gfc_charlen
*nextcl
;
1430 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1432 nextsym
= sym
->next
;
1433 gfc_free_symbol (sym
->new->n
.sym
);
1434 gfc_free_expr (sym
->expr
);
1435 gfc_free (sym
->new);
1438 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1441 gfc_free_expr (cl
->length
);
1447 /* Return a copy of gfc_charlen CL. Add the returned structure to
1448 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1450 static gfc_charlen
*
1451 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1456 new = gfc_get_charlen ();
1457 new->next
= mapping
->charlens
;
1458 new->length
= gfc_copy_expr (cl
->length
);
1460 mapping
->charlens
= new;
1465 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1466 array variable that can be used as the actual argument for dummy
1467 argument SYM. Add any initialization code to BLOCK. PACKED is as
1468 for gfc_get_nodesc_array_type and DATA points to the first element
1469 in the passed array. */
1472 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1473 gfc_packed packed
, tree data
)
1478 type
= gfc_typenode_for_spec (&sym
->ts
);
1479 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1481 var
= gfc_create_var (type
, "ifm");
1482 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1488 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1489 and offset of descriptorless array type TYPE given that it has the same
1490 size as DESC. Add any set-up code to BLOCK. */
1493 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1500 offset
= gfc_index_zero_node
;
1501 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1503 dim
= gfc_rank_cst
[n
];
1504 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1505 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1507 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1508 = gfc_conv_descriptor_lbound (desc
, dim
);
1509 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1510 = gfc_conv_descriptor_ubound (desc
, dim
);
1512 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1514 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1515 gfc_conv_descriptor_ubound (desc
, dim
),
1516 gfc_conv_descriptor_lbound (desc
, dim
));
1517 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1518 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1520 tmp
= gfc_evaluate_now (tmp
, block
);
1521 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1523 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1524 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1525 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1526 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1528 offset
= gfc_evaluate_now (offset
, block
);
1529 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1533 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1534 in SE. The caller may still use se->expr and se->string_length after
1535 calling this function. */
1538 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1539 gfc_symbol
* sym
, gfc_se
* se
,
1542 gfc_interface_sym_mapping
*sm
;
1546 gfc_symbol
*new_sym
;
1548 gfc_symtree
*new_symtree
;
1550 /* Create a new symbol to represent the actual argument. */
1551 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1552 new_sym
->ts
= sym
->ts
;
1553 new_sym
->attr
.referenced
= 1;
1554 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1555 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1556 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1557 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1558 new_sym
->attr
.function
= sym
->attr
.function
;
1560 /* Create a fake symtree for it. */
1562 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1563 new_symtree
->n
.sym
= new_sym
;
1564 gcc_assert (new_symtree
== root
);
1566 /* Create a dummy->actual mapping. */
1567 sm
= gfc_getmem (sizeof (*sm
));
1568 sm
->next
= mapping
->syms
;
1570 sm
->new = new_symtree
;
1571 sm
->expr
= gfc_copy_expr (expr
);
1574 /* Stabilize the argument's value. */
1575 if (!sym
->attr
.function
&& se
)
1576 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1578 if (sym
->ts
.type
== BT_CHARACTER
)
1580 /* Create a copy of the dummy argument's length. */
1581 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1582 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1584 /* If the length is specified as "*", record the length that
1585 the caller is passing. We should use the callee's length
1586 in all other cases. */
1587 if (!new_sym
->ts
.cl
->length
&& se
)
1589 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1590 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1597 /* Use the passed value as-is if the argument is a function. */
1598 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1601 /* If the argument is either a string or a pointer to a string,
1602 convert it to a boundless character type. */
1603 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1605 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1606 tmp
= build_pointer_type (tmp
);
1607 if (sym
->attr
.pointer
)
1608 value
= build_fold_indirect_ref (se
->expr
);
1611 value
= fold_convert (tmp
, value
);
1614 /* If the argument is a scalar, a pointer to an array or an allocatable,
1616 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1617 value
= build_fold_indirect_ref (se
->expr
);
1619 /* For character(*), use the actual argument's descriptor. */
1620 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1621 value
= build_fold_indirect_ref (se
->expr
);
1623 /* If the argument is an array descriptor, use it to determine
1624 information about the actual argument's shape. */
1625 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1626 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1628 /* Get the actual argument's descriptor. */
1629 desc
= build_fold_indirect_ref (se
->expr
);
1631 /* Create the replacement variable. */
1632 tmp
= gfc_conv_descriptor_data_get (desc
);
1633 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1636 /* Use DESC to work out the upper bounds, strides and offset. */
1637 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1640 /* Otherwise we have a packed array. */
1641 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1642 PACKED_FULL
, se
->expr
);
1644 new_sym
->backend_decl
= value
;
1648 /* Called once all dummy argument mappings have been added to MAPPING,
1649 but before the mapping is used to evaluate expressions. Pre-evaluate
1650 the length of each argument, adding any initialization code to PRE and
1651 any finalization code to POST. */
1654 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1655 stmtblock_t
* pre
, stmtblock_t
* post
)
1657 gfc_interface_sym_mapping
*sym
;
1661 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1662 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1663 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1665 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1666 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1667 gfc_init_se (&se
, NULL
);
1668 gfc_conv_expr (&se
, expr
);
1670 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1671 gfc_add_block_to_block (pre
, &se
.pre
);
1672 gfc_add_block_to_block (post
, &se
.post
);
1674 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1679 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1683 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1684 gfc_constructor
* c
)
1686 for (; c
; c
= c
->next
)
1688 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1691 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1692 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1693 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1699 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1703 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1708 for (; ref
; ref
= ref
->next
)
1712 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1714 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1715 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1716 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1718 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1725 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1726 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1732 /* Convert intrinsic function calls into result expressions. */
1734 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
* mapping
)
1742 arg1
= expr
->value
.function
.actual
->expr
;
1743 if (expr
->value
.function
.actual
->next
)
1744 arg2
= expr
->value
.function
.actual
->next
->expr
;
1748 sym
= arg1
->symtree
->n
.sym
;
1750 if (sym
->attr
.dummy
)
1755 switch (expr
->value
.function
.isym
->id
)
1758 /* TODO figure out why this condition is necessary. */
1759 if (sym
->attr
.function
1760 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1761 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)
1764 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1771 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1773 dup
= mpz_get_si (arg2
->value
.integer
);
1778 dup
= sym
->as
->rank
;
1782 for (; d
< dup
; d
++)
1785 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1786 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1788 new_expr
= gfc_multiply (new_expr
, tmp
);
1794 case GFC_ISYM_LBOUND
:
1795 case GFC_ISYM_UBOUND
:
1796 /* TODO These implementations of lbound and ubound do not limit if
1797 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1802 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1803 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1805 /* TODO: If the need arises, this could produce an array of
1809 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1810 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1812 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1819 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
1823 gfc_replace_expr (expr
, new_expr
);
1829 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
1830 gfc_interface_mapping
* mapping
)
1832 gfc_formal_arglist
*f
;
1833 gfc_actual_arglist
*actual
;
1835 actual
= expr
->value
.function
.actual
;
1836 f
= map_expr
->symtree
->n
.sym
->formal
;
1838 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
1843 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
1846 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
1851 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
1853 for (d
= 0; d
< as
->rank
; d
++)
1855 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
1856 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
1859 expr
->value
.function
.esym
->as
= as
;
1862 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1864 expr
->value
.function
.esym
->ts
.cl
->length
1865 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
1867 gfc_apply_interface_mapping_to_expr (mapping
,
1868 expr
->value
.function
.esym
->ts
.cl
->length
);
1873 /* EXPR is a copy of an expression that appeared in the interface
1874 associated with MAPPING. Walk it recursively looking for references to
1875 dummy arguments that MAPPING maps to actual arguments. Replace each such
1876 reference with a reference to the associated actual argument. */
1879 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1882 gfc_interface_sym_mapping
*sym
;
1883 gfc_actual_arglist
*actual
;
1888 /* Copying an expression does not copy its length, so do that here. */
1889 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1891 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1892 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1895 /* Apply the mapping to any references. */
1896 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1898 /* ...and to the expression's symbol, if it has one. */
1899 /* TODO Find out why the condition on expr->symtree had to be moved into
1900 the loop rather than being ouside it, as originally. */
1901 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1902 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
1904 if (sym
->new->n
.sym
->backend_decl
)
1905 expr
->symtree
= sym
->new;
1907 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
1910 /* ...and to subexpressions in expr->value. */
1911 switch (expr
->expr_type
)
1916 case EXPR_SUBSTRING
:
1920 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1921 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1925 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1926 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1928 if (expr
->value
.function
.esym
== NULL
1929 && expr
->value
.function
.isym
!= NULL
1930 && expr
->value
.function
.actual
->expr
->symtree
1931 && gfc_map_intrinsic_function (expr
, mapping
))
1934 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1935 if (sym
->old
== expr
->value
.function
.esym
)
1937 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1938 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
1939 expr
->value
.function
.esym
->result
= sym
->new->n
.sym
;
1944 case EXPR_STRUCTURE
:
1945 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1953 /* Evaluate interface expression EXPR using MAPPING. Store the result
1957 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1958 gfc_se
* se
, gfc_expr
* expr
)
1960 expr
= gfc_copy_expr (expr
);
1961 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1962 gfc_conv_expr (se
, expr
);
1963 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1964 gfc_free_expr (expr
);
1968 /* Returns a reference to a temporary array into which a component of
1969 an actual argument derived type array is copied and then returned
1970 after the function call. */
1972 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1973 int g77
, sym_intent intent
)
1989 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1991 gfc_init_se (&lse
, NULL
);
1992 gfc_init_se (&rse
, NULL
);
1994 /* Walk the argument expression. */
1995 rss
= gfc_walk_expr (expr
);
1997 gcc_assert (rss
!= gfc_ss_terminator
);
1999 /* Initialize the scalarizer. */
2000 gfc_init_loopinfo (&loop
);
2001 gfc_add_ss_to_loop (&loop
, rss
);
2003 /* Calculate the bounds of the scalarization. */
2004 gfc_conv_ss_startstride (&loop
);
2006 /* Build an ss for the temporary. */
2007 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
2008 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
2010 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2011 if (GFC_ARRAY_TYPE_P (base_type
)
2012 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2013 base_type
= gfc_get_element_type (base_type
);
2015 loop
.temp_ss
= gfc_get_ss ();;
2016 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2017 loop
.temp_ss
->data
.temp
.type
= base_type
;
2019 if (expr
->ts
.type
== BT_CHARACTER
)
2020 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2022 loop
.temp_ss
->string_length
= NULL
;
2024 parmse
->string_length
= loop
.temp_ss
->string_length
;
2025 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2026 loop
.temp_ss
->next
= gfc_ss_terminator
;
2028 /* Associate the SS with the loop. */
2029 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2031 /* Setup the scalarizing loops. */
2032 gfc_conv_loop_setup (&loop
);
2034 /* Pass the temporary descriptor back to the caller. */
2035 info
= &loop
.temp_ss
->data
.info
;
2036 parmse
->expr
= info
->descriptor
;
2038 /* Setup the gfc_se structures. */
2039 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2040 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2043 lse
.ss
= loop
.temp_ss
;
2044 gfc_mark_ss_chain_used (rss
, 1);
2045 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2047 /* Start the scalarized loop body. */
2048 gfc_start_scalarized_body (&loop
, &body
);
2050 /* Translate the expression. */
2051 gfc_conv_expr (&rse
, expr
);
2053 gfc_conv_tmp_array_ref (&lse
);
2054 gfc_advance_se_ss_chain (&lse
);
2056 if (intent
!= INTENT_OUT
)
2058 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2059 gfc_add_expr_to_block (&body
, tmp
);
2060 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2061 gfc_trans_scalarizing_loops (&loop
, &body
);
2065 /* Make sure that the temporary declaration survives by merging
2066 all the loop declarations into the current context. */
2067 for (n
= 0; n
< loop
.dimen
; n
++)
2069 gfc_merge_block_scope (&body
);
2070 body
= loop
.code
[loop
.order
[n
]];
2072 gfc_merge_block_scope (&body
);
2075 /* Add the post block after the second loop, so that any
2076 freeing of allocated memory is done at the right time. */
2077 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2079 /**********Copy the temporary back again.*********/
2081 gfc_init_se (&lse
, NULL
);
2082 gfc_init_se (&rse
, NULL
);
2084 /* Walk the argument expression. */
2085 lss
= gfc_walk_expr (expr
);
2086 rse
.ss
= loop
.temp_ss
;
2089 /* Initialize the scalarizer. */
2090 gfc_init_loopinfo (&loop2
);
2091 gfc_add_ss_to_loop (&loop2
, lss
);
2093 /* Calculate the bounds of the scalarization. */
2094 gfc_conv_ss_startstride (&loop2
);
2096 /* Setup the scalarizing loops. */
2097 gfc_conv_loop_setup (&loop2
);
2099 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2100 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2102 gfc_mark_ss_chain_used (lss
, 1);
2103 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2105 /* Declare the variable to hold the temporary offset and start the
2106 scalarized loop body. */
2107 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2108 gfc_start_scalarized_body (&loop2
, &body
);
2110 /* Build the offsets for the temporary from the loop variables. The
2111 temporary array has lbounds of zero and strides of one in all
2112 dimensions, so this is very simple. The offset is only computed
2113 outside the innermost loop, so the overall transfer could be
2114 optimized further. */
2115 info
= &rse
.ss
->data
.info
;
2117 tmp_index
= gfc_index_zero_node
;
2118 for (n
= info
->dimen
- 1; n
> 0; n
--)
2121 tmp
= rse
.loop
->loopvar
[n
];
2122 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2123 tmp
, rse
.loop
->from
[n
]);
2124 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2127 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2128 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2129 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2130 tmp_str
, gfc_index_one_node
);
2132 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2136 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2137 tmp_index
, rse
.loop
->from
[0]);
2138 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
2140 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2141 rse
.loop
->loopvar
[0], offset
);
2143 /* Now use the offset for the reference. */
2144 tmp
= build_fold_indirect_ref (info
->data
);
2145 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2147 if (expr
->ts
.type
== BT_CHARACTER
)
2148 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2150 gfc_conv_expr (&lse
, expr
);
2152 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2154 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2155 gfc_add_expr_to_block (&body
, tmp
);
2157 /* Generate the copying loops. */
2158 gfc_trans_scalarizing_loops (&loop2
, &body
);
2160 /* Wrap the whole thing up by adding the second loop to the post-block
2161 and following it by the post-block of the first loop. In this way,
2162 if the temporary needs freeing, it is done after use! */
2163 if (intent
!= INTENT_IN
)
2165 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2166 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2169 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2171 gfc_cleanup_loop (&loop
);
2172 gfc_cleanup_loop (&loop2
);
2174 /* Pass the string length to the argument expression. */
2175 if (expr
->ts
.type
== BT_CHARACTER
)
2176 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2178 /* We want either the address for the data or the address of the descriptor,
2179 depending on the mode of passing array arguments. */
2181 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2183 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2189 /* Generate the code for argument list functions. */
2192 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2194 /* Pass by value for g77 %VAL(arg), pass the address
2195 indirectly for %LOC, else by reference. Thus %REF
2196 is a "do-nothing" and %LOC is the same as an F95
2198 if (strncmp (name
, "%VAL", 4) == 0)
2199 gfc_conv_expr (se
, expr
);
2200 else if (strncmp (name
, "%LOC", 4) == 0)
2202 gfc_conv_expr_reference (se
, expr
);
2203 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2205 else if (strncmp (name
, "%REF", 4) == 0)
2206 gfc_conv_expr_reference (se
, expr
);
2208 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2212 /* Generate code for a procedure call. Note can return se->post != NULL.
2213 If se->direct_byref is set then se->expr contains the return parameter.
2214 Return nonzero, if the call has alternate specifiers. */
2217 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2218 gfc_actual_arglist
* arg
, tree append_args
)
2220 gfc_interface_mapping mapping
;
2234 gfc_formal_arglist
*formal
;
2235 int has_alternate_specifier
= 0;
2236 bool need_interface_mapping
;
2243 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2245 arglist
= NULL_TREE
;
2246 retargs
= NULL_TREE
;
2247 stringargs
= NULL_TREE
;
2251 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2253 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2255 if (arg
->expr
->rank
== 0)
2256 gfc_conv_expr_reference (se
, arg
->expr
);
2260 /* This is really the actual arg because no formal arglist is
2261 created for C_LOC. */
2262 fsym
= arg
->expr
->symtree
->n
.sym
;
2264 /* We should want it to do g77 calling convention. */
2266 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2267 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2268 f
= f
|| !sym
->attr
.always_explicit
;
2270 argss
= gfc_walk_expr (arg
->expr
);
2271 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2274 /* TODO -- the following two lines shouldn't be necessary, but
2275 they're removed a bug is exposed later in the codepath.
2276 This is workaround was thus introduced, but will have to be
2277 removed; please see PR 35150 for details about the issue. */
2278 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2279 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2283 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2285 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2286 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2287 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2288 gfc_conv_expr_reference (se
, arg
->expr
);
2292 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2297 /* Build the addr_expr for the first argument. The argument is
2298 already an *address* so we don't need to set want_pointer in
2300 gfc_init_se (&arg1se
, NULL
);
2301 gfc_conv_expr (&arg1se
, arg
->expr
);
2302 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2303 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2305 /* See if we were given two arguments. */
2306 if (arg
->next
== NULL
)
2307 /* Only given one arg so generate a null and do a
2308 not-equal comparison against the first arg. */
2309 se
->expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2310 fold_convert (TREE_TYPE (arg1se
.expr
),
2311 null_pointer_node
));
2317 /* Given two arguments so build the arg2se from second arg. */
2318 gfc_init_se (&arg2se
, NULL
);
2319 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2320 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2321 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2323 /* Generate test to compare that the two args are equal. */
2324 eq_expr
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
,
2326 /* Generate test to ensure that the first arg is not null. */
2327 not_null_expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2330 /* Finally, the generated test must check that both arg1 is not
2331 NULL and that it is equal to the second arg. */
2332 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2333 not_null_expr
, eq_expr
);
2342 if (!sym
->attr
.elemental
)
2344 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2345 if (se
->ss
->useflags
)
2347 gcc_assert (gfc_return_by_reference (sym
)
2348 && sym
->result
->attr
.dimension
);
2349 gcc_assert (se
->loop
!= NULL
);
2351 /* Access the previously obtained result. */
2352 gfc_conv_tmp_array_ref (se
);
2353 gfc_advance_se_ss_chain (se
);
2357 info
= &se
->ss
->data
.info
;
2362 gfc_init_block (&post
);
2363 gfc_init_interface_mapping (&mapping
);
2364 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2365 && sym
->ts
.cl
->length
2366 && sym
->ts
.cl
->length
->expr_type
2368 || sym
->attr
.dimension
);
2369 formal
= sym
->formal
;
2370 /* Evaluate the arguments. */
2371 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2374 fsym
= formal
? formal
->sym
: NULL
;
2375 parm_kind
= MISSING
;
2379 if (se
->ignore_optional
)
2381 /* Some intrinsics have already been resolved to the correct
2385 else if (arg
->label
)
2387 has_alternate_specifier
= 1;
2392 /* Pass a NULL pointer for an absent arg. */
2393 gfc_init_se (&parmse
, NULL
);
2394 parmse
.expr
= null_pointer_node
;
2395 if (arg
->missing_arg_type
== BT_CHARACTER
)
2396 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2399 else if (se
->ss
&& se
->ss
->useflags
)
2401 /* An elemental function inside a scalarized loop. */
2402 gfc_init_se (&parmse
, se
);
2403 gfc_conv_expr_reference (&parmse
, e
);
2404 parm_kind
= ELEMENTAL
;
2408 /* A scalar or transformational function. */
2409 gfc_init_se (&parmse
, NULL
);
2410 argss
= gfc_walk_expr (e
);
2412 if (argss
== gfc_ss_terminator
)
2414 if (fsym
&& fsym
->attr
.value
)
2416 if (fsym
->ts
.type
== BT_CHARACTER
2417 && fsym
->ts
.is_c_interop
2418 && fsym
->ns
->proc_name
!= NULL
2419 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2422 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2423 if (parmse
.expr
== NULL
)
2424 gfc_conv_expr (&parmse
, e
);
2427 gfc_conv_expr (&parmse
, e
);
2429 else if (arg
->name
&& arg
->name
[0] == '%')
2430 /* Argument list functions %VAL, %LOC and %REF are signalled
2431 through arg->name. */
2432 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2433 else if ((e
->expr_type
== EXPR_FUNCTION
)
2434 && e
->symtree
->n
.sym
->attr
.pointer
2435 && fsym
&& fsym
->attr
.target
)
2437 gfc_conv_expr (&parmse
, e
);
2438 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2442 gfc_conv_expr_reference (&parmse
, e
);
2443 if (fsym
&& fsym
->attr
.pointer
2444 && fsym
->attr
.flavor
!= FL_PROCEDURE
2445 && e
->expr_type
!= EXPR_NULL
)
2447 /* Scalar pointer dummy args require an extra level of
2448 indirection. The null pointer already contains
2449 this level of indirection. */
2450 parm_kind
= SCALAR_POINTER
;
2451 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2457 /* If the procedure requires an explicit interface, the actual
2458 argument is passed according to the corresponding formal
2459 argument. If the corresponding formal argument is a POINTER,
2460 ALLOCATABLE or assumed shape, we do not use g77's calling
2461 convention, and pass the address of the array descriptor
2462 instead. Otherwise we use g77's calling convention. */
2465 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2466 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2467 f
= f
|| !sym
->attr
.always_explicit
;
2469 if (e
->expr_type
== EXPR_VARIABLE
2470 && is_subref_array (e
))
2471 /* The actual argument is a component reference to an
2472 array of derived types. In this case, the argument
2473 is converted to a temporary, which is passed and then
2474 written back after the procedure call. */
2475 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2476 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2478 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2480 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2481 allocated on entry, it must be deallocated. */
2482 if (fsym
&& fsym
->attr
.allocatable
2483 && fsym
->attr
.intent
== INTENT_OUT
)
2485 tmp
= build_fold_indirect_ref (parmse
.expr
);
2486 tmp
= gfc_trans_dealloc_allocated (tmp
);
2487 gfc_add_expr_to_block (&se
->pre
, tmp
);
2493 /* The case with fsym->attr.optional is that of a user subroutine
2494 with an interface indicating an optional argument. When we call
2495 an intrinsic subroutine, however, fsym is NULL, but we might still
2496 have an optional argument, so we proceed to the substitution
2498 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2500 /* If an optional argument is itself an optional dummy argument,
2501 check its presence and substitute a null if absent. */
2502 if (e
->expr_type
== EXPR_VARIABLE
2503 && e
->symtree
->n
.sym
->attr
.optional
)
2504 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2505 e
->representation
.length
);
2510 /* Obtain the character length of an assumed character length
2511 length procedure from the typespec. */
2512 if (fsym
->ts
.type
== BT_CHARACTER
2513 && parmse
.string_length
== NULL_TREE
2514 && e
->ts
.type
== BT_PROCEDURE
2515 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2516 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2518 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2519 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2523 if (fsym
&& need_interface_mapping
&& e
)
2524 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2526 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2527 gfc_add_block_to_block (&post
, &parmse
.post
);
2529 /* Allocated allocatable components of derived types must be
2530 deallocated for INTENT(OUT) dummy arguments and non-variable
2531 scalars. Non-variable arrays are dealt with in trans-array.c
2532 (gfc_conv_array_parameter). */
2533 if (e
&& e
->ts
.type
== BT_DERIVED
2534 && e
->ts
.derived
->attr
.alloc_comp
2535 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2537 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2540 tmp
= build_fold_indirect_ref (parmse
.expr
);
2541 parm_rank
= e
->rank
;
2549 case (SCALAR_POINTER
):
2550 tmp
= build_fold_indirect_ref (tmp
);
2557 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2558 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2559 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2560 tmp
, build_empty_stmt ());
2562 if (e
->expr_type
!= EXPR_VARIABLE
)
2563 /* Don't deallocate non-variables until they have been used. */
2564 gfc_add_expr_to_block (&se
->post
, tmp
);
2567 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2568 gfc_add_expr_to_block (&se
->pre
, tmp
);
2572 /* Character strings are passed as two parameters, a length and a
2573 pointer - except for Bind(c) which only passes the pointer. */
2574 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2575 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2577 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2579 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2582 if (ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2584 if (sym
->ts
.cl
->length
== NULL
)
2586 /* Assumed character length results are not allowed by 5.1.1.5 of the
2587 standard and are trapped in resolve.c; except in the case of SPREAD
2588 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2589 we take the character length of the first argument for the result.
2590 For dummies, we have to look through the formal argument list for
2591 this function and use the character length found there.*/
2592 if (!sym
->attr
.dummy
)
2593 cl
.backend_decl
= TREE_VALUE (stringargs
);
2596 formal
= sym
->ns
->proc_name
->formal
;
2597 for (; formal
; formal
= formal
->next
)
2598 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2599 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2606 /* Calculate the length of the returned string. */
2607 gfc_init_se (&parmse
, NULL
);
2608 if (need_interface_mapping
)
2609 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2611 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2612 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2613 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2615 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2616 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2617 build_int_cst (gfc_charlen_type_node
, 0));
2618 cl
.backend_decl
= tmp
;
2621 /* Set up a charlen structure for it. */
2626 len
= cl
.backend_decl
;
2629 byref
= gfc_return_by_reference (sym
);
2632 if (se
->direct_byref
)
2634 /* Sometimes, too much indirection can be applied; eg. for
2635 function_result = array_valued_recursive_function. */
2636 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2637 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2638 && GFC_DESCRIPTOR_TYPE_P
2639 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2640 se
->expr
= build_fold_indirect_ref (se
->expr
);
2642 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2644 else if (sym
->result
->attr
.dimension
)
2646 gcc_assert (se
->loop
&& info
);
2648 /* Set the type of the array. */
2649 tmp
= gfc_typenode_for_spec (&ts
);
2650 info
->dimen
= se
->loop
->dimen
;
2652 /* Evaluate the bounds of the result, if known. */
2653 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2655 /* Create a temporary to store the result. In case the function
2656 returns a pointer, the temporary will be a shallow copy and
2657 mustn't be deallocated. */
2658 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2659 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2660 false, !sym
->attr
.pointer
, callee_alloc
);
2662 /* Pass the temporary as the first argument. */
2663 tmp
= info
->descriptor
;
2664 tmp
= build_fold_addr_expr (tmp
);
2665 retargs
= gfc_chainon_list (retargs
, tmp
);
2667 else if (ts
.type
== BT_CHARACTER
)
2669 /* Pass the string length. */
2670 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2671 type
= build_pointer_type (type
);
2673 /* Return an address to a char[0:len-1]* temporary for
2674 character pointers. */
2675 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2677 var
= gfc_create_var (type
, "pstr");
2679 /* Provide an address expression for the function arguments. */
2680 var
= build_fold_addr_expr (var
);
2683 var
= gfc_conv_string_tmp (se
, type
, len
);
2685 retargs
= gfc_chainon_list (retargs
, var
);
2689 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2691 type
= gfc_get_complex_type (ts
.kind
);
2692 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2693 retargs
= gfc_chainon_list (retargs
, var
);
2696 /* Add the string length to the argument list. */
2697 if (ts
.type
== BT_CHARACTER
)
2698 retargs
= gfc_chainon_list (retargs
, len
);
2700 gfc_free_interface_mapping (&mapping
);
2702 /* Add the return arguments. */
2703 arglist
= chainon (retargs
, arglist
);
2705 /* Add the hidden string length parameters to the arguments. */
2706 arglist
= chainon (arglist
, stringargs
);
2708 /* We may want to append extra arguments here. This is used e.g. for
2709 calls to libgfortran_matmul_??, which need extra information. */
2710 if (append_args
!= NULL_TREE
)
2711 arglist
= chainon (arglist
, append_args
);
2713 /* Generate the actual call. */
2714 gfc_conv_function_val (se
, sym
);
2716 /* If there are alternate return labels, function type should be
2717 integer. Can't modify the type in place though, since it can be shared
2718 with other functions. For dummy arguments, the typing is done to
2719 to this result, even if it has to be repeated for each call. */
2720 if (has_alternate_specifier
2721 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2723 if (!sym
->attr
.dummy
)
2725 TREE_TYPE (sym
->backend_decl
)
2726 = build_function_type (integer_type_node
,
2727 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2728 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2731 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2734 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2735 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2737 /* If we have a pointer function, but we don't want a pointer, e.g.
2740 where f is pointer valued, we have to dereference the result. */
2741 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2742 se
->expr
= build_fold_indirect_ref (se
->expr
);
2744 /* f2c calling conventions require a scalar default real function to
2745 return a double precision result. Convert this back to default
2746 real. We only care about the cases that can happen in Fortran 77.
2748 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2749 && sym
->ts
.kind
== gfc_default_real_kind
2750 && !sym
->attr
.always_explicit
)
2751 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2753 /* A pure function may still have side-effects - it may modify its
2755 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2757 if (!sym
->attr
.pure
)
2758 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2763 /* Add the function call to the pre chain. There is no expression. */
2764 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2765 se
->expr
= NULL_TREE
;
2767 if (!se
->direct_byref
)
2769 if (sym
->attr
.dimension
)
2771 if (flag_bounds_check
)
2773 /* Check the data pointer hasn't been modified. This would
2774 happen in a function returning a pointer. */
2775 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2776 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2778 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2780 se
->expr
= info
->descriptor
;
2781 /* Bundle in the string length. */
2782 se
->string_length
= len
;
2784 else if (sym
->ts
.type
== BT_CHARACTER
)
2786 /* Dereference for character pointer results. */
2787 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2788 se
->expr
= build_fold_indirect_ref (var
);
2792 se
->string_length
= len
;
2796 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2797 se
->expr
= build_fold_indirect_ref (var
);
2802 /* Follow the function call with the argument post block. */
2804 gfc_add_block_to_block (&se
->pre
, &post
);
2806 gfc_add_block_to_block (&se
->post
, &post
);
2808 return has_alternate_specifier
;
2812 /* Generate code to copy a string. */
2815 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2816 tree slength
, tree src
)
2818 tree tmp
, dlen
, slen
;
2826 stmtblock_t tempblock
;
2828 if (slength
!= NULL_TREE
)
2830 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2831 ssc
= gfc_to_single_character (slen
, src
);
2835 slen
= build_int_cst (size_type_node
, 1);
2839 if (dlength
!= NULL_TREE
)
2841 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2842 dsc
= gfc_to_single_character (slen
, dest
);
2846 dlen
= build_int_cst (size_type_node
, 1);
2850 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
2851 ssc
= gfc_to_single_character (slen
, src
);
2852 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
2853 dsc
= gfc_to_single_character (dlen
, dest
);
2856 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2858 gfc_add_modify_expr (block
, dsc
, ssc
);
2862 /* Do nothing if the destination length is zero. */
2863 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2864 build_int_cst (size_type_node
, 0));
2866 /* The following code was previously in _gfortran_copy_string:
2868 // The two strings may overlap so we use memmove.
2870 copy_string (GFC_INTEGER_4 destlen, char * dest,
2871 GFC_INTEGER_4 srclen, const char * src)
2873 if (srclen >= destlen)
2875 // This will truncate if too long.
2876 memmove (dest, src, destlen);
2880 memmove (dest, src, srclen);
2882 memset (&dest[srclen], ' ', destlen - srclen);
2886 We're now doing it here for better optimization, but the logic
2890 dest
= fold_convert (pvoid_type_node
, dest
);
2892 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
2895 src
= fold_convert (pvoid_type_node
, src
);
2897 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
2899 /* Truncate string if source is too long. */
2900 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2901 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2902 3, dest
, src
, dlen
);
2904 /* Else copy and pad with spaces. */
2905 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2906 3, dest
, src
, slen
);
2908 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
2909 fold_convert (sizetype
, slen
));
2910 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2912 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2913 lang_hooks
.to_target_charset (' ')),
2914 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2917 gfc_init_block (&tempblock
);
2918 gfc_add_expr_to_block (&tempblock
, tmp3
);
2919 gfc_add_expr_to_block (&tempblock
, tmp4
);
2920 tmp3
= gfc_finish_block (&tempblock
);
2922 /* The whole copy_string function is there. */
2923 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2924 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2925 gfc_add_expr_to_block (block
, tmp
);
2929 /* Translate a statement function.
2930 The value of a statement function reference is obtained by evaluating the
2931 expression using the values of the actual arguments for the values of the
2932 corresponding dummy arguments. */
2935 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2939 gfc_formal_arglist
*fargs
;
2940 gfc_actual_arglist
*args
;
2943 gfc_saved_var
*saved_vars
;
2949 sym
= expr
->symtree
->n
.sym
;
2950 args
= expr
->value
.function
.actual
;
2951 gfc_init_se (&lse
, NULL
);
2952 gfc_init_se (&rse
, NULL
);
2955 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2957 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2958 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2960 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2962 /* Each dummy shall be specified, explicitly or implicitly, to be
2964 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2967 /* Create a temporary to hold the value. */
2968 type
= gfc_typenode_for_spec (&fsym
->ts
);
2969 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2971 if (fsym
->ts
.type
== BT_CHARACTER
)
2973 /* Copy string arguments. */
2976 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2977 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2979 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2980 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2983 gfc_conv_expr (&rse
, args
->expr
);
2984 gfc_conv_string_parameter (&rse
);
2985 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2986 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2988 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2990 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2991 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2995 /* For everything else, just evaluate the expression. */
2996 gfc_conv_expr (&lse
, args
->expr
);
2998 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2999 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
3000 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3006 /* Use the temporary variables in place of the real ones. */
3007 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3008 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3010 gfc_conv_expr (se
, sym
->value
);
3012 if (sym
->ts
.type
== BT_CHARACTER
)
3014 gfc_conv_const_charlen (sym
->ts
.cl
);
3016 /* Force the expression to the correct length. */
3017 if (!INTEGER_CST_P (se
->string_length
)
3018 || tree_int_cst_lt (se
->string_length
,
3019 sym
->ts
.cl
->backend_decl
))
3021 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3022 tmp
= gfc_create_var (type
, sym
->name
);
3023 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3024 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3025 se
->string_length
, se
->expr
);
3028 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3031 /* Restore the original variables. */
3032 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3033 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3034 gfc_free (saved_vars
);
3038 /* Translate a function expression. */
3041 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3045 if (expr
->value
.function
.isym
)
3047 gfc_conv_intrinsic_function (se
, expr
);
3051 /* We distinguish statement functions from general functions to improve
3052 runtime performance. */
3053 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3055 gfc_conv_statement_function (se
, expr
);
3059 /* expr.value.function.esym is the resolved (specific) function symbol for
3060 most functions. However this isn't set for dummy procedures. */
3061 sym
= expr
->value
.function
.esym
;
3063 sym
= expr
->symtree
->n
.sym
;
3064 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
3069 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3071 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3072 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3074 gfc_conv_tmp_array_ref (se
);
3075 gfc_advance_se_ss_chain (se
);
3079 /* Build a static initializer. EXPR is the expression for the initial value.
3080 The other parameters describe the variable of the component being
3081 initialized. EXPR may be null. */
3084 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3085 bool array
, bool pointer
)
3089 if (!(expr
|| pointer
))
3092 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3093 (these are the only two iso_c_binding derived types that can be
3094 used as initialization expressions). If so, we need to modify
3095 the 'expr' to be that for a (void *). */
3096 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3097 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3099 gfc_symbol
*derived
= expr
->ts
.derived
;
3101 expr
= gfc_int_expr (0);
3103 /* The derived symbol has already been converted to a (void *). Use
3105 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3106 expr
->ts
.kind
= derived
->ts
.kind
;
3111 /* Arrays need special handling. */
3113 return gfc_build_null_descriptor (type
);
3115 return gfc_conv_array_initializer (type
, expr
);
3118 return fold_convert (type
, null_pointer_node
);
3124 gfc_init_se (&se
, NULL
);
3125 gfc_conv_structure (&se
, expr
, 1);
3129 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3132 gfc_init_se (&se
, NULL
);
3133 gfc_conv_constant (&se
, expr
);
3140 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3152 gfc_start_block (&block
);
3154 /* Initialize the scalarizer. */
3155 gfc_init_loopinfo (&loop
);
3157 gfc_init_se (&lse
, NULL
);
3158 gfc_init_se (&rse
, NULL
);
3161 rss
= gfc_walk_expr (expr
);
3162 if (rss
== gfc_ss_terminator
)
3164 /* The rhs is scalar. Add a ss for the expression. */
3165 rss
= gfc_get_ss ();
3166 rss
->next
= gfc_ss_terminator
;
3167 rss
->type
= GFC_SS_SCALAR
;
3171 /* Create a SS for the destination. */
3172 lss
= gfc_get_ss ();
3173 lss
->type
= GFC_SS_COMPONENT
;
3175 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3176 lss
->next
= gfc_ss_terminator
;
3177 lss
->data
.info
.dimen
= cm
->as
->rank
;
3178 lss
->data
.info
.descriptor
= dest
;
3179 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3180 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3181 for (n
= 0; n
< cm
->as
->rank
; n
++)
3183 lss
->data
.info
.dim
[n
] = n
;
3184 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3185 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3187 mpz_init (lss
->shape
[n
]);
3188 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3189 cm
->as
->lower
[n
]->value
.integer
);
3190 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3193 /* Associate the SS with the loop. */
3194 gfc_add_ss_to_loop (&loop
, lss
);
3195 gfc_add_ss_to_loop (&loop
, rss
);
3197 /* Calculate the bounds of the scalarization. */
3198 gfc_conv_ss_startstride (&loop
);
3200 /* Setup the scalarizing loops. */
3201 gfc_conv_loop_setup (&loop
);
3203 /* Setup the gfc_se structures. */
3204 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3205 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3208 gfc_mark_ss_chain_used (rss
, 1);
3210 gfc_mark_ss_chain_used (lss
, 1);
3212 /* Start the scalarized loop body. */
3213 gfc_start_scalarized_body (&loop
, &body
);
3215 gfc_conv_tmp_array_ref (&lse
);
3216 if (cm
->ts
.type
== BT_CHARACTER
)
3217 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3219 gfc_conv_expr (&rse
, expr
);
3221 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3222 gfc_add_expr_to_block (&body
, tmp
);
3224 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3226 /* Generate the copying loops. */
3227 gfc_trans_scalarizing_loops (&loop
, &body
);
3229 /* Wrap the whole thing up. */
3230 gfc_add_block_to_block (&block
, &loop
.pre
);
3231 gfc_add_block_to_block (&block
, &loop
.post
);
3233 for (n
= 0; n
< cm
->as
->rank
; n
++)
3234 mpz_clear (lss
->shape
[n
]);
3235 gfc_free (lss
->shape
);
3237 gfc_cleanup_loop (&loop
);
3239 return gfc_finish_block (&block
);
3243 /* Assign a single component of a derived type constructor. */
3246 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3256 gfc_start_block (&block
);
3260 gfc_init_se (&se
, NULL
);
3261 /* Pointer component. */
3264 /* Array pointer. */
3265 if (expr
->expr_type
== EXPR_NULL
)
3266 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3269 rss
= gfc_walk_expr (expr
);
3270 se
.direct_byref
= 1;
3272 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3273 gfc_add_block_to_block (&block
, &se
.pre
);
3274 gfc_add_block_to_block (&block
, &se
.post
);
3279 /* Scalar pointers. */
3280 se
.want_pointer
= 1;
3281 gfc_conv_expr (&se
, expr
);
3282 gfc_add_block_to_block (&block
, &se
.pre
);
3283 gfc_add_modify_expr (&block
, dest
,
3284 fold_convert (TREE_TYPE (dest
), se
.expr
));
3285 gfc_add_block_to_block (&block
, &se
.post
);
3288 else if (cm
->dimension
)
3290 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3291 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3292 else if (cm
->allocatable
)
3296 gfc_init_se (&se
, NULL
);
3298 rss
= gfc_walk_expr (expr
);
3299 se
.want_pointer
= 0;
3300 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3301 gfc_add_block_to_block (&block
, &se
.pre
);
3303 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3304 gfc_add_modify_expr (&block
, dest
, tmp
);
3306 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3307 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3310 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3311 TREE_TYPE(cm
->backend_decl
),
3314 gfc_add_expr_to_block (&block
, tmp
);
3316 gfc_add_block_to_block (&block
, &se
.post
);
3317 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3319 /* Shift the lbound and ubound of temporaries to being unity, rather
3320 than zero, based. Calculate the offset for all cases. */
3321 offset
= gfc_conv_descriptor_offset (dest
);
3322 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3323 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3324 for (n
= 0; n
< expr
->rank
; n
++)
3326 if (expr
->expr_type
!= EXPR_VARIABLE
3327 && expr
->expr_type
!= EXPR_CONSTANT
)
3330 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3331 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3332 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3333 gfc_add_modify_expr (&block
, tmp
,
3334 fold_build2 (PLUS_EXPR
,
3335 gfc_array_index_type
,
3336 span
, gfc_index_one_node
));
3337 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3338 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3340 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3341 gfc_conv_descriptor_lbound (dest
,
3343 gfc_conv_descriptor_stride (dest
,
3345 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3346 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3347 gfc_add_modify_expr (&block
, offset
, tmp
);
3352 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3353 gfc_add_expr_to_block (&block
, tmp
);
3356 else if (expr
->ts
.type
== BT_DERIVED
)
3358 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3360 gfc_init_se (&se
, NULL
);
3361 gfc_conv_expr (&se
, expr
);
3362 gfc_add_modify_expr (&block
, dest
,
3363 fold_convert (TREE_TYPE (dest
), se
.expr
));
3367 /* Nested constructors. */
3368 tmp
= gfc_trans_structure_assign (dest
, expr
);
3369 gfc_add_expr_to_block (&block
, tmp
);
3374 /* Scalar component. */
3375 gfc_init_se (&se
, NULL
);
3376 gfc_init_se (&lse
, NULL
);
3378 gfc_conv_expr (&se
, expr
);
3379 if (cm
->ts
.type
== BT_CHARACTER
)
3380 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3382 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3383 gfc_add_expr_to_block (&block
, tmp
);
3385 return gfc_finish_block (&block
);
3388 /* Assign a derived type constructor to a variable. */
3391 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3399 gfc_start_block (&block
);
3400 cm
= expr
->ts
.derived
->components
;
3401 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3403 /* Skip absent members in default initializers. */
3407 /* Update the type/kind of the expression if it represents either
3408 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3409 be the first place reached for initializing output variables that
3410 have components of type C_PTR/C_FUNPTR that are initialized. */
3411 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3412 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3414 c
->expr
->expr_type
= EXPR_NULL
;
3415 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3416 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3417 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3420 field
= cm
->backend_decl
;
3421 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3422 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3423 gfc_add_expr_to_block (&block
, tmp
);
3425 return gfc_finish_block (&block
);
3428 /* Build an expression for a constructor. If init is nonzero then
3429 this is part of a static variable initializer. */
3432 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3439 VEC(constructor_elt
,gc
) *v
= NULL
;
3441 gcc_assert (se
->ss
== NULL
);
3442 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3443 type
= gfc_typenode_for_spec (&expr
->ts
);
3447 /* Create a temporary variable and fill it in. */
3448 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3449 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3450 gfc_add_expr_to_block (&se
->pre
, tmp
);
3454 cm
= expr
->ts
.derived
->components
;
3456 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3458 /* Skip absent members in default initializers and allocatable
3459 components. Although the latter have a default initializer
3460 of EXPR_NULL,... by default, the static nullify is not needed
3461 since this is done every time we come into scope. */
3462 if (!c
->expr
|| cm
->allocatable
)
3465 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3466 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3468 /* Append it to the constructor list. */
3469 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3471 se
->expr
= build_constructor (type
, v
);
3474 TREE_CONSTANT(se
->expr
) = 1;
3475 TREE_INVARIANT(se
->expr
) = 1;
3480 /* Translate a substring expression. */
3483 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3489 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3491 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3492 expr
->value
.character
.string
);
3493 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3494 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3497 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3501 /* Entry point for expression translation. Evaluates a scalar quantity.
3502 EXPR is the expression to be translated, and SE is the state structure if
3503 called from within the scalarized. */
3506 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3508 if (se
->ss
&& se
->ss
->expr
== expr
3509 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3511 /* Substitute a scalar expression evaluated outside the scalarization
3513 se
->expr
= se
->ss
->data
.scalar
.expr
;
3514 se
->string_length
= se
->ss
->string_length
;
3515 gfc_advance_se_ss_chain (se
);
3519 /* We need to convert the expressions for the iso_c_binding derived types.
3520 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3521 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3522 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3523 updated to be an integer with a kind equal to the size of a (void *). */
3524 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3525 && expr
->ts
.derived
->attr
.is_iso_c
)
3527 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3528 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3530 /* Set expr_type to EXPR_NULL, which will result in
3531 null_pointer_node being used below. */
3532 expr
->expr_type
= EXPR_NULL
;
3536 /* Update the type/kind of the expression to be what the new
3537 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3538 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3539 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3540 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3544 switch (expr
->expr_type
)
3547 gfc_conv_expr_op (se
, expr
);
3551 gfc_conv_function_expr (se
, expr
);
3555 gfc_conv_constant (se
, expr
);
3559 gfc_conv_variable (se
, expr
);
3563 se
->expr
= null_pointer_node
;
3566 case EXPR_SUBSTRING
:
3567 gfc_conv_substring_expr (se
, expr
);
3570 case EXPR_STRUCTURE
:
3571 gfc_conv_structure (se
, expr
, 0);
3575 gfc_conv_array_constructor_expr (se
, expr
);
3584 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3585 of an assignment. */
3587 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3589 gfc_conv_expr (se
, expr
);
3590 /* All numeric lvalues should have empty post chains. If not we need to
3591 figure out a way of rewriting an lvalue so that it has no post chain. */
3592 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3595 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3596 numeric expressions. Used for scalar values where inserting cleanup code
3599 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3603 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3604 gfc_conv_expr (se
, expr
);
3607 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3608 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3610 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3614 /* Helper to translate an expression and convert it to a particular type. */
3616 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3618 gfc_conv_expr_val (se
, expr
);
3619 se
->expr
= convert (type
, se
->expr
);
3623 /* Converts an expression so that it can be passed by reference. Scalar
3627 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3631 if (se
->ss
&& se
->ss
->expr
== expr
3632 && se
->ss
->type
== GFC_SS_REFERENCE
)
3634 se
->expr
= se
->ss
->data
.scalar
.expr
;
3635 se
->string_length
= se
->ss
->string_length
;
3636 gfc_advance_se_ss_chain (se
);
3640 if (expr
->ts
.type
== BT_CHARACTER
)
3642 gfc_conv_expr (se
, expr
);
3643 gfc_conv_string_parameter (se
);
3647 if (expr
->expr_type
== EXPR_VARIABLE
)
3649 se
->want_pointer
= 1;
3650 gfc_conv_expr (se
, expr
);
3653 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3654 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3655 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3661 if (expr
->expr_type
== EXPR_FUNCTION
3662 && expr
->symtree
->n
.sym
->attr
.pointer
3663 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3665 se
->want_pointer
= 1;
3666 gfc_conv_expr (se
, expr
);
3667 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3668 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3674 gfc_conv_expr (se
, expr
);
3676 /* Create a temporary var to hold the value. */
3677 if (TREE_CONSTANT (se
->expr
))
3679 tree tmp
= se
->expr
;
3680 STRIP_TYPE_NOPS (tmp
);
3681 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3682 DECL_INITIAL (var
) = tmp
;
3683 TREE_STATIC (var
) = 1;
3688 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3689 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3691 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3693 /* Take the address of that value. */
3694 se
->expr
= build_fold_addr_expr (var
);
3699 gfc_trans_pointer_assign (gfc_code
* code
)
3701 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3705 /* Generate code for a pointer assignment. */
3708 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3720 gfc_start_block (&block
);
3722 gfc_init_se (&lse
, NULL
);
3724 lss
= gfc_walk_expr (expr1
);
3725 rss
= gfc_walk_expr (expr2
);
3726 if (lss
== gfc_ss_terminator
)
3728 /* Scalar pointers. */
3729 lse
.want_pointer
= 1;
3730 gfc_conv_expr (&lse
, expr1
);
3731 gcc_assert (rss
== gfc_ss_terminator
);
3732 gfc_init_se (&rse
, NULL
);
3733 rse
.want_pointer
= 1;
3734 gfc_conv_expr (&rse
, expr2
);
3735 gfc_add_block_to_block (&block
, &lse
.pre
);
3736 gfc_add_block_to_block (&block
, &rse
.pre
);
3737 gfc_add_modify_expr (&block
, lse
.expr
,
3738 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3739 gfc_add_block_to_block (&block
, &rse
.post
);
3740 gfc_add_block_to_block (&block
, &lse
.post
);
3744 /* Array pointer. */
3745 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3746 switch (expr2
->expr_type
)
3749 /* Just set the data pointer to null. */
3750 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3754 /* Assign directly to the pointer's descriptor. */
3755 lse
.direct_byref
= 1;
3756 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3758 /* If this is a subreference array pointer assignment, use the rhs
3759 descriptor element size for the lhs span. */
3760 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3762 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3763 gfc_init_se (&rse
, NULL
);
3764 rse
.descriptor_only
= 1;
3765 gfc_conv_expr (&rse
, expr2
);
3766 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3767 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3768 if (!INTEGER_CST_P (tmp
))
3769 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3770 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3776 /* Assign to a temporary descriptor and then copy that
3777 temporary to the pointer. */
3779 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3782 lse
.direct_byref
= 1;
3783 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3784 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3787 gfc_add_block_to_block (&block
, &lse
.pre
);
3788 gfc_add_block_to_block (&block
, &lse
.post
);
3790 return gfc_finish_block (&block
);
3794 /* Makes sure se is suitable for passing as a function string parameter. */
3795 /* TODO: Need to check all callers fo this function. It may be abused. */
3798 gfc_conv_string_parameter (gfc_se
* se
)
3802 if (TREE_CODE (se
->expr
) == STRING_CST
)
3804 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3808 type
= TREE_TYPE (se
->expr
);
3809 if (TYPE_STRING_FLAG (type
))
3811 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3812 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3815 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3817 type
= build_pointer_type (type
);
3818 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3822 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3823 gcc_assert (se
->string_length
3824 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3828 /* Generate code for assignment of scalar variables. Includes character
3829 strings and derived types with allocatable components. */
3832 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3833 bool l_is_temp
, bool r_is_var
)
3839 gfc_init_block (&block
);
3841 if (ts
.type
== BT_CHARACTER
)
3846 if (lse
->string_length
!= NULL_TREE
)
3848 gfc_conv_string_parameter (lse
);
3849 gfc_add_block_to_block (&block
, &lse
->pre
);
3850 llen
= lse
->string_length
;
3853 if (rse
->string_length
!= NULL_TREE
)
3855 gcc_assert (rse
->string_length
!= NULL_TREE
);
3856 gfc_conv_string_parameter (rse
);
3857 gfc_add_block_to_block (&block
, &rse
->pre
);
3858 rlen
= rse
->string_length
;
3861 gfc_trans_string_copy (&block
, llen
, lse
->expr
, rlen
, rse
->expr
);
3863 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3867 /* Are the rhs and the lhs the same? */
3870 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3871 build_fold_addr_expr (lse
->expr
),
3872 build_fold_addr_expr (rse
->expr
));
3873 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3876 /* Deallocate the lhs allocated components as long as it is not
3877 the same as the rhs. This must be done following the assignment
3878 to prevent deallocating data that could be used in the rhs
3882 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3883 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3885 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3886 gfc_add_expr_to_block (&lse
->post
, tmp
);
3889 gfc_add_block_to_block (&block
, &rse
->pre
);
3890 gfc_add_block_to_block (&block
, &lse
->pre
);
3892 gfc_add_modify_expr (&block
, lse
->expr
,
3893 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3895 /* Do a deep copy if the rhs is a variable, if it is not the
3899 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3900 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3901 gfc_add_expr_to_block (&block
, tmp
);
3906 gfc_add_block_to_block (&block
, &lse
->pre
);
3907 gfc_add_block_to_block (&block
, &rse
->pre
);
3909 gfc_add_modify_expr (&block
, lse
->expr
,
3910 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3913 gfc_add_block_to_block (&block
, &lse
->post
);
3914 gfc_add_block_to_block (&block
, &rse
->post
);
3916 return gfc_finish_block (&block
);
3920 /* Try to translate array(:) = func (...), where func is a transformational
3921 array function, without using a temporary. Returns NULL is this isn't the
3925 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3930 bool seen_array_ref
;
3932 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3933 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3936 /* Elemental functions don't need a temporary anyway. */
3937 if (expr2
->value
.function
.esym
!= NULL
3938 && expr2
->value
.function
.esym
->attr
.elemental
)
3941 /* Fail if EXPR1 can't be expressed as a descriptor. */
3942 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3945 /* Functions returning pointers need temporaries. */
3946 if (expr2
->symtree
->n
.sym
->attr
.pointer
3947 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3950 /* Character array functions need temporaries unless the
3951 character lengths are the same. */
3952 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3954 if (expr1
->ts
.cl
->length
== NULL
3955 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3958 if (expr2
->ts
.cl
->length
== NULL
3959 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3962 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3963 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3967 /* Check that no LHS component references appear during an array
3968 reference. This is needed because we do not have the means to
3969 span any arbitrary stride with an array descriptor. This check
3970 is not needed for the rhs because the function result has to be
3972 seen_array_ref
= false;
3973 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3975 if (ref
->type
== REF_ARRAY
)
3976 seen_array_ref
= true;
3977 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3981 /* Check for a dependency. */
3982 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3983 expr2
->value
.function
.esym
,
3984 expr2
->value
.function
.actual
))
3987 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3989 gcc_assert (expr2
->value
.function
.isym
3990 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3991 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3993 ss
= gfc_walk_expr (expr1
);
3994 gcc_assert (ss
!= gfc_ss_terminator
);
3995 gfc_init_se (&se
, NULL
);
3996 gfc_start_block (&se
.pre
);
3997 se
.want_pointer
= 1;
3999 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
4001 se
.direct_byref
= 1;
4002 se
.ss
= gfc_walk_expr (expr2
);
4003 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4004 gfc_conv_function_expr (&se
, expr2
);
4005 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4007 return gfc_finish_block (&se
.pre
);
4010 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4013 is_zero_initializer_p (gfc_expr
* expr
)
4015 if (expr
->expr_type
!= EXPR_CONSTANT
)
4018 /* We ignore constants with prescribed memory representations for now. */
4019 if (expr
->representation
.string
)
4022 switch (expr
->ts
.type
)
4025 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4028 return mpfr_zero_p (expr
->value
.real
)
4029 && MPFR_SIGN (expr
->value
.real
) >= 0;
4032 return expr
->value
.logical
== 0;
4035 return mpfr_zero_p (expr
->value
.complex.r
)
4036 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
4037 && mpfr_zero_p (expr
->value
.complex.i
)
4038 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
4046 /* Try to efficiently translate array(:) = 0. Return NULL if this
4050 gfc_trans_zero_assign (gfc_expr
* expr
)
4052 tree dest
, len
, type
;
4056 sym
= expr
->symtree
->n
.sym
;
4057 dest
= gfc_get_symbol_decl (sym
);
4059 type
= TREE_TYPE (dest
);
4060 if (POINTER_TYPE_P (type
))
4061 type
= TREE_TYPE (type
);
4062 if (!GFC_ARRAY_TYPE_P (type
))
4065 /* Determine the length of the array. */
4066 len
= GFC_TYPE_ARRAY_SIZE (type
);
4067 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4070 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4071 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4072 fold_convert (gfc_array_index_type
, tmp
));
4074 /* Convert arguments to the correct types. */
4075 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4076 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4078 dest
= fold_convert (pvoid_type_node
, dest
);
4079 len
= fold_convert (size_type_node
, len
);
4081 /* Construct call to __builtin_memset. */
4082 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4083 3, dest
, integer_zero_node
, len
);
4084 return fold_convert (void_type_node
, tmp
);
4088 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4089 that constructs the call to __builtin_memcpy. */
4092 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4096 /* Convert arguments to the correct types. */
4097 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4098 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4100 dst
= fold_convert (pvoid_type_node
, dst
);
4102 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4103 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4105 src
= fold_convert (pvoid_type_node
, src
);
4107 len
= fold_convert (size_type_node
, len
);
4109 /* Construct call to __builtin_memcpy. */
4110 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4111 return fold_convert (void_type_node
, tmp
);
4115 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4116 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4117 source/rhs, both are gfc_full_array_ref_p which have been checked for
4121 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4123 tree dst
, dlen
, dtype
;
4124 tree src
, slen
, stype
;
4127 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4128 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4130 dtype
= TREE_TYPE (dst
);
4131 if (POINTER_TYPE_P (dtype
))
4132 dtype
= TREE_TYPE (dtype
);
4133 stype
= TREE_TYPE (src
);
4134 if (POINTER_TYPE_P (stype
))
4135 stype
= TREE_TYPE (stype
);
4137 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4140 /* Determine the lengths of the arrays. */
4141 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4142 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4144 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4145 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4146 fold_convert (gfc_array_index_type
, tmp
));
4148 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4149 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4151 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4152 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4153 fold_convert (gfc_array_index_type
, tmp
));
4155 /* Sanity check that they are the same. This should always be
4156 the case, as we should already have checked for conformance. */
4157 if (!tree_int_cst_equal (slen
, dlen
))
4160 return gfc_build_memcpy_call (dst
, src
, dlen
);
4164 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4165 this can't be done. EXPR1 is the destination/lhs for which
4166 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4169 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4171 unsigned HOST_WIDE_INT nelem
;
4177 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4181 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4182 dtype
= TREE_TYPE (dst
);
4183 if (POINTER_TYPE_P (dtype
))
4184 dtype
= TREE_TYPE (dtype
);
4185 if (!GFC_ARRAY_TYPE_P (dtype
))
4188 /* Determine the lengths of the array. */
4189 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4190 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4193 /* Confirm that the constructor is the same size. */
4194 if (compare_tree_int (len
, nelem
) != 0)
4197 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4198 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4199 fold_convert (gfc_array_index_type
, tmp
));
4201 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4202 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4204 stype
= TREE_TYPE (src
);
4205 if (POINTER_TYPE_P (stype
))
4206 stype
= TREE_TYPE (stype
);
4208 return gfc_build_memcpy_call (dst
, src
, len
);
4212 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4213 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4216 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4221 gfc_ss
*lss_section
;
4229 /* Assignment of the form lhs = rhs. */
4230 gfc_start_block (&block
);
4232 gfc_init_se (&lse
, NULL
);
4233 gfc_init_se (&rse
, NULL
);
4236 lss
= gfc_walk_expr (expr1
);
4238 if (lss
!= gfc_ss_terminator
)
4240 /* The assignment needs scalarization. */
4243 /* Find a non-scalar SS from the lhs. */
4244 while (lss_section
!= gfc_ss_terminator
4245 && lss_section
->type
!= GFC_SS_SECTION
)
4246 lss_section
= lss_section
->next
;
4248 gcc_assert (lss_section
!= gfc_ss_terminator
);
4250 /* Initialize the scalarizer. */
4251 gfc_init_loopinfo (&loop
);
4254 rss
= gfc_walk_expr (expr2
);
4255 if (rss
== gfc_ss_terminator
)
4257 /* The rhs is scalar. Add a ss for the expression. */
4258 rss
= gfc_get_ss ();
4259 rss
->next
= gfc_ss_terminator
;
4260 rss
->type
= GFC_SS_SCALAR
;
4263 /* Associate the SS with the loop. */
4264 gfc_add_ss_to_loop (&loop
, lss
);
4265 gfc_add_ss_to_loop (&loop
, rss
);
4267 /* Calculate the bounds of the scalarization. */
4268 gfc_conv_ss_startstride (&loop
);
4269 /* Resolve any data dependencies in the statement. */
4270 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4271 /* Setup the scalarizing loops. */
4272 gfc_conv_loop_setup (&loop
);
4274 /* Setup the gfc_se structures. */
4275 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4276 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4279 gfc_mark_ss_chain_used (rss
, 1);
4280 if (loop
.temp_ss
== NULL
)
4283 gfc_mark_ss_chain_used (lss
, 1);
4287 lse
.ss
= loop
.temp_ss
;
4288 gfc_mark_ss_chain_used (lss
, 3);
4289 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4292 /* Start the scalarized loop body. */
4293 gfc_start_scalarized_body (&loop
, &body
);
4296 gfc_init_block (&body
);
4298 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4300 /* Translate the expression. */
4301 gfc_conv_expr (&rse
, expr2
);
4305 gfc_conv_tmp_array_ref (&lse
);
4306 gfc_advance_se_ss_chain (&lse
);
4309 gfc_conv_expr (&lse
, expr1
);
4311 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4312 l_is_temp
|| init_flag
,
4313 expr2
->expr_type
== EXPR_VARIABLE
);
4314 gfc_add_expr_to_block (&body
, tmp
);
4316 if (lss
== gfc_ss_terminator
)
4318 /* Use the scalar assignment as is. */
4319 gfc_add_block_to_block (&block
, &body
);
4323 gcc_assert (lse
.ss
== gfc_ss_terminator
4324 && rse
.ss
== gfc_ss_terminator
);
4328 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4330 /* We need to copy the temporary to the actual lhs. */
4331 gfc_init_se (&lse
, NULL
);
4332 gfc_init_se (&rse
, NULL
);
4333 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4334 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4336 rse
.ss
= loop
.temp_ss
;
4339 gfc_conv_tmp_array_ref (&rse
);
4340 gfc_advance_se_ss_chain (&rse
);
4341 gfc_conv_expr (&lse
, expr1
);
4343 gcc_assert (lse
.ss
== gfc_ss_terminator
4344 && rse
.ss
== gfc_ss_terminator
);
4346 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4348 gfc_add_expr_to_block (&body
, tmp
);
4351 /* Generate the copying loops. */
4352 gfc_trans_scalarizing_loops (&loop
, &body
);
4354 /* Wrap the whole thing up. */
4355 gfc_add_block_to_block (&block
, &loop
.pre
);
4356 gfc_add_block_to_block (&block
, &loop
.post
);
4358 gfc_cleanup_loop (&loop
);
4361 return gfc_finish_block (&block
);
4365 /* Check whether EXPR is a copyable array. */
4368 copyable_array_p (gfc_expr
* expr
)
4370 if (expr
->expr_type
!= EXPR_VARIABLE
)
4373 /* First check it's an array. */
4374 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4377 if (!gfc_full_array_ref_p (expr
->ref
))
4380 /* Next check that it's of a simple enough type. */
4381 switch (expr
->ts
.type
)
4393 return !expr
->ts
.derived
->attr
.alloc_comp
;
4402 /* Translate an assignment. */
4405 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4409 /* Special case a single function returning an array. */
4410 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4412 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4417 /* Special case assigning an array to zero. */
4418 if (copyable_array_p (expr1
)
4419 && is_zero_initializer_p (expr2
))
4421 tmp
= gfc_trans_zero_assign (expr1
);
4426 /* Special case copying one array to another. */
4427 if (copyable_array_p (expr1
)
4428 && copyable_array_p (expr2
)
4429 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4430 && !gfc_check_dependency (expr1
, expr2
, 0))
4432 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4437 /* Special case initializing an array from a constant array constructor. */
4438 if (copyable_array_p (expr1
)
4439 && expr2
->expr_type
== EXPR_ARRAY
4440 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4442 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4447 /* Fallback to the scalarizer to generate explicit loops. */
4448 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4452 gfc_trans_init_assign (gfc_code
* code
)
4454 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4458 gfc_trans_assign (gfc_code
* code
)
4460 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);