1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 fold_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
= fold_build3 (COND_EXPR
, gfc_charlen_type_node
,
180 present
, 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
= fold_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 && !sym
->attr
.always_explicit
)
518 se
->expr
= build_fold_indirect_ref (se
->expr
);
520 /* Dereference non-character pointer variables.
521 These must be dummies, results, or scalars. */
522 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
524 || sym
->attr
.function
526 || !sym
->attr
.dimension
))
527 se
->expr
= build_fold_indirect_ref (se
->expr
);
533 /* For character variables, also get the length. */
534 if (sym
->ts
.type
== BT_CHARACTER
)
536 /* If the character length of an entry isn't set, get the length from
537 the master function instead. */
538 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
539 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
541 se
->string_length
= sym
->ts
.cl
->backend_decl
;
542 gcc_assert (se
->string_length
);
550 /* Return the descriptor if that's what we want and this is an array
551 section reference. */
552 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
554 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
555 /* Return the descriptor for array pointers and allocations. */
557 && ref
->next
== NULL
&& (se
->descriptor_only
))
560 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
561 /* Return a pointer to an element. */
565 gfc_conv_component_ref (se
, ref
);
569 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
570 expr
->symtree
->name
, &expr
->where
);
579 /* Pointer assignment, allocation or pass by reference. Arrays are handled
581 if (se
->want_pointer
)
583 if (expr
->ts
.type
== BT_CHARACTER
)
584 gfc_conv_string_parameter (se
);
586 se
->expr
= build_fold_addr_expr (se
->expr
);
591 /* Unary ops are easy... Or they would be if ! was a valid op. */
594 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
599 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
600 /* Initialize the operand. */
601 gfc_init_se (&operand
, se
);
602 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
603 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
605 type
= gfc_typenode_for_spec (&expr
->ts
);
607 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
608 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
609 All other unary operators have an equivalent GIMPLE unary operator. */
610 if (code
== TRUTH_NOT_EXPR
)
611 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
612 build_int_cst (type
, 0));
614 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
618 /* Expand power operator to optimal multiplications when a value is raised
619 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
620 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
621 Programming", 3rd Edition, 1998. */
623 /* This code is mostly duplicated from expand_powi in the backend.
624 We establish the "optimal power tree" lookup table with the defined size.
625 The items in the table are the exponents used to calculate the index
626 exponents. Any integer n less than the value can get an "addition chain",
627 with the first node being one. */
628 #define POWI_TABLE_SIZE 256
630 /* The table is from builtins.c. */
631 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
633 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
634 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
635 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
636 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
637 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
638 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
639 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
640 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
641 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
642 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
643 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
644 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
645 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
646 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
647 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
648 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
649 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
650 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
651 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
652 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
653 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
654 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
655 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
656 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
657 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
658 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
659 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
660 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
661 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
662 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
663 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
664 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
667 /* If n is larger than lookup table's max index, we use the "window
669 #define POWI_WINDOW_SIZE 3
671 /* Recursive function to expand the power operator. The temporary
672 values are put in tmpvar. The function returns tmpvar[1] ** n. */
674 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
681 if (n
< POWI_TABLE_SIZE
)
686 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
687 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
691 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
692 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
693 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
697 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
701 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
702 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
704 if (n
< POWI_TABLE_SIZE
)
711 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
712 return 1. Else return 0 and a call to runtime library functions
713 will have to be built. */
715 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
720 tree vartmp
[POWI_TABLE_SIZE
];
722 unsigned HOST_WIDE_INT n
;
725 /* If exponent is too large, we won't expand it anyway, so don't bother
726 with large integer values. */
727 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
730 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
731 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
732 of the asymmetric range of the integer type. */
733 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
735 type
= TREE_TYPE (lhs
);
736 sgn
= tree_int_cst_sgn (rhs
);
738 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
739 || optimize_size
) && (m
> 2 || m
< -1))
745 se
->expr
= gfc_build_const (type
, integer_one_node
);
749 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
750 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
752 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
753 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
754 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
755 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
758 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
761 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
762 se
->expr
= fold_build3 (COND_EXPR
, type
,
763 tmp
, build_int_cst (type
, 1),
764 build_int_cst (type
, 0));
768 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
769 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
770 build_int_cst (type
, 0));
771 se
->expr
= fold_build3 (COND_EXPR
, type
,
772 cond
, build_int_cst (type
, 1), tmp
);
776 memset (vartmp
, 0, sizeof (vartmp
));
780 tmp
= gfc_build_const (type
, integer_one_node
);
781 vartmp
[1] = fold_build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
784 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
790 /* Power op (**). Constant integer exponent has special handling. */
793 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
795 tree gfc_int4_type_node
;
802 gfc_init_se (&lse
, se
);
803 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
804 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
805 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
807 gfc_init_se (&rse
, se
);
808 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
809 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
811 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
812 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
813 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
816 gfc_int4_type_node
= gfc_get_int_type (4);
818 kind
= expr
->value
.op
.op1
->ts
.kind
;
819 switch (expr
->value
.op
.op2
->ts
.type
)
822 ikind
= expr
->value
.op
.op2
->ts
.kind
;
827 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
849 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
850 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
875 switch (expr
->value
.op
.op1
->ts
.type
)
878 if (kind
== 3) /* Case 16 was not handled properly above. */
880 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
884 /* Use builtins for real ** int4. */
890 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
894 fndecl
= built_in_decls
[BUILT_IN_POWI
];
899 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
907 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
911 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
923 fndecl
= built_in_decls
[BUILT_IN_POWF
];
926 fndecl
= built_in_decls
[BUILT_IN_POW
];
930 fndecl
= built_in_decls
[BUILT_IN_POWL
];
941 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
944 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
948 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
960 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
964 /* Generate code to allocate a string temporary. */
967 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
972 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
974 if (gfc_can_put_var_on_stack (len
))
976 /* Create a temporary variable to hold the result. */
977 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
978 build_int_cst (gfc_charlen_type_node
, 1));
979 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
980 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
981 var
= gfc_create_var (tmp
, "str");
982 var
= gfc_build_addr_expr (type
, var
);
986 /* Allocate a temporary to hold the result. */
987 var
= gfc_create_var (type
, "pstr");
988 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
989 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
991 /* Free the temporary afterwards. */
992 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
993 gfc_add_expr_to_block (&se
->post
, tmp
);
1000 /* Handle a string concatenation operation. A temporary will be allocated to
1004 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1013 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1014 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1016 gfc_init_se (&lse
, se
);
1017 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1018 gfc_conv_string_parameter (&lse
);
1019 gfc_init_se (&rse
, se
);
1020 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1021 gfc_conv_string_parameter (&rse
);
1023 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1024 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1026 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1027 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1028 if (len
== NULL_TREE
)
1030 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1031 lse
.string_length
, rse
.string_length
);
1034 type
= build_pointer_type (type
);
1036 var
= gfc_conv_string_tmp (se
, type
, len
);
1038 /* Do the actual concatenation. */
1039 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1041 lse
.string_length
, lse
.expr
,
1042 rse
.string_length
, rse
.expr
);
1043 gfc_add_expr_to_block (&se
->pre
, tmp
);
1045 /* Add the cleanup for the operands. */
1046 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1047 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1050 se
->string_length
= len
;
1053 /* Translates an op expression. Common (binary) cases are handled by this
1054 function, others are passed on. Recursion is used in either case.
1055 We use the fact that (op1.ts == op2.ts) (except for the power
1057 Operators need no special handling for scalarized expressions as long as
1058 they call gfc_conv_simple_val to get their operands.
1059 Character strings get special handling. */
1062 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1064 enum tree_code code
;
1073 switch (expr
->value
.op
.operator)
1075 case INTRINSIC_PARENTHESES
:
1076 if (expr
->ts
.type
== BT_REAL
1077 || expr
->ts
.type
== BT_COMPLEX
)
1079 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1080 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1085 case INTRINSIC_UPLUS
:
1086 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1089 case INTRINSIC_UMINUS
:
1090 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1094 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1097 case INTRINSIC_PLUS
:
1101 case INTRINSIC_MINUS
:
1105 case INTRINSIC_TIMES
:
1109 case INTRINSIC_DIVIDE
:
1110 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1111 an integer, we must round towards zero, so we use a
1113 if (expr
->ts
.type
== BT_INTEGER
)
1114 code
= TRUNC_DIV_EXPR
;
1119 case INTRINSIC_POWER
:
1120 gfc_conv_power_op (se
, expr
);
1123 case INTRINSIC_CONCAT
:
1124 gfc_conv_concat_op (se
, expr
);
1128 code
= TRUTH_ANDIF_EXPR
;
1133 code
= TRUTH_ORIF_EXPR
;
1137 /* EQV and NEQV only work on logicals, but since we represent them
1138 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1140 case INTRINSIC_EQ_OS
:
1148 case INTRINSIC_NE_OS
:
1149 case INTRINSIC_NEQV
:
1156 case INTRINSIC_GT_OS
:
1163 case INTRINSIC_GE_OS
:
1170 case INTRINSIC_LT_OS
:
1177 case INTRINSIC_LE_OS
:
1183 case INTRINSIC_USER
:
1184 case INTRINSIC_ASSIGN
:
1185 /* These should be converted into function calls by the frontend. */
1189 fatal_error ("Unknown intrinsic op");
1193 /* The only exception to this is **, which is handled separately anyway. */
1194 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1196 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1200 gfc_init_se (&lse
, se
);
1201 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1202 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1205 gfc_init_se (&rse
, se
);
1206 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1207 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1211 gfc_conv_string_parameter (&lse
);
1212 gfc_conv_string_parameter (&rse
);
1214 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1215 rse
.string_length
, rse
.expr
);
1216 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1217 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1220 type
= gfc_typenode_for_spec (&expr
->ts
);
1224 /* The result of logical ops is always boolean_type_node. */
1225 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1226 se
->expr
= convert (type
, tmp
);
1229 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1231 /* Add the post blocks. */
1232 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1233 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1236 /* If a string's length is one, we convert it to a single character. */
1239 gfc_to_single_character (tree len
, tree str
)
1241 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1243 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1244 && TREE_INT_CST_HIGH (len
) == 0)
1246 str
= fold_convert (pchar_type_node
, str
);
1247 return build_fold_indirect_ref (str
);
1255 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1258 if (sym
->backend_decl
)
1260 /* This becomes the nominal_type in
1261 function.c:assign_parm_find_data_types. */
1262 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1263 /* This becomes the passed_type in
1264 function.c:assign_parm_find_data_types. C promotes char to
1265 integer for argument passing. */
1266 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1268 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1273 /* If we have a constant character expression, make it into an
1275 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1279 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1280 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1282 /* The expr needs to be compatible with a C int. If the
1283 conversion fails, then the 2 causes an ICE. */
1284 ts
.type
= BT_INTEGER
;
1285 ts
.kind
= gfc_c_int_kind
;
1286 gfc_convert_type (*expr
, &ts
, 2);
1289 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1291 if ((*expr
)->ref
== NULL
)
1293 se
->expr
= gfc_to_single_character
1294 (build_int_cst (integer_type_node
, 1),
1295 gfc_build_addr_expr (pchar_type_node
,
1297 ((*expr
)->symtree
->n
.sym
)));
1301 gfc_conv_variable (se
, *expr
);
1302 se
->expr
= gfc_to_single_character
1303 (build_int_cst (integer_type_node
, 1),
1304 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1311 /* Compare two strings. If they are all single characters, the result is the
1312 subtraction of them. Otherwise, we build a library call. */
1315 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1321 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1322 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1324 sc1
= gfc_to_single_character (len1
, str1
);
1325 sc2
= gfc_to_single_character (len2
, str2
);
1327 /* Deal with single character specially. */
1328 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1330 sc1
= fold_convert (integer_type_node
, sc1
);
1331 sc2
= fold_convert (integer_type_node
, sc2
);
1332 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1335 /* Build a call for the comparison. */
1336 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1337 len1
, str1
, len2
, str2
);
1342 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1346 if (sym
->attr
.dummy
)
1348 tmp
= gfc_get_symbol_decl (sym
);
1349 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1350 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1354 if (!sym
->backend_decl
)
1355 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1357 tmp
= sym
->backend_decl
;
1358 if (sym
->attr
.cray_pointee
)
1359 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1360 gfc_get_symbol_decl (sym
->cp_pointer
));
1361 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1363 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1364 tmp
= build_fold_addr_expr (tmp
);
1371 /* Translate the call for an elemental subroutine call used in an operator
1372 assignment. This is a simplified version of gfc_conv_function_call. */
1375 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1382 /* Only elemental subroutines with two arguments. */
1383 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1384 gcc_assert (sym
->formal
->next
->next
== NULL
);
1386 gfc_init_block (&block
);
1388 gfc_add_block_to_block (&block
, &lse
->pre
);
1389 gfc_add_block_to_block (&block
, &rse
->pre
);
1391 /* Build the argument list for the call, including hidden string lengths. */
1392 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1393 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1394 if (lse
->string_length
!= NULL_TREE
)
1395 args
= gfc_chainon_list (args
, lse
->string_length
);
1396 if (rse
->string_length
!= NULL_TREE
)
1397 args
= gfc_chainon_list (args
, rse
->string_length
);
1399 /* Build the function call. */
1400 gfc_init_se (&se
, NULL
);
1401 gfc_conv_function_val (&se
, sym
);
1402 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1403 tmp
= build_call_list (tmp
, se
.expr
, args
);
1404 gfc_add_expr_to_block (&block
, tmp
);
1406 gfc_add_block_to_block (&block
, &lse
->post
);
1407 gfc_add_block_to_block (&block
, &rse
->post
);
1409 return gfc_finish_block (&block
);
1413 /* Initialize MAPPING. */
1416 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1418 mapping
->syms
= NULL
;
1419 mapping
->charlens
= NULL
;
1423 /* Free all memory held by MAPPING (but not MAPPING itself). */
1426 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1428 gfc_interface_sym_mapping
*sym
;
1429 gfc_interface_sym_mapping
*nextsym
;
1431 gfc_charlen
*nextcl
;
1433 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1435 nextsym
= sym
->next
;
1436 gfc_free_symbol (sym
->new->n
.sym
);
1437 gfc_free_expr (sym
->expr
);
1438 gfc_free (sym
->new);
1441 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1444 gfc_free_expr (cl
->length
);
1450 /* Return a copy of gfc_charlen CL. Add the returned structure to
1451 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1453 static gfc_charlen
*
1454 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1459 new = gfc_get_charlen ();
1460 new->next
= mapping
->charlens
;
1461 new->length
= gfc_copy_expr (cl
->length
);
1463 mapping
->charlens
= new;
1468 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1469 array variable that can be used as the actual argument for dummy
1470 argument SYM. Add any initialization code to BLOCK. PACKED is as
1471 for gfc_get_nodesc_array_type and DATA points to the first element
1472 in the passed array. */
1475 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1476 gfc_packed packed
, tree data
)
1481 type
= gfc_typenode_for_spec (&sym
->ts
);
1482 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1484 var
= gfc_create_var (type
, "ifm");
1485 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1491 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1492 and offset of descriptorless array type TYPE given that it has the same
1493 size as DESC. Add any set-up code to BLOCK. */
1496 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1503 offset
= gfc_index_zero_node
;
1504 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1506 dim
= gfc_rank_cst
[n
];
1507 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1508 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1510 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1511 = gfc_conv_descriptor_lbound (desc
, dim
);
1512 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1513 = gfc_conv_descriptor_ubound (desc
, dim
);
1515 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1517 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1518 gfc_conv_descriptor_ubound (desc
, dim
),
1519 gfc_conv_descriptor_lbound (desc
, dim
));
1520 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1521 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1523 tmp
= gfc_evaluate_now (tmp
, block
);
1524 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1526 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1527 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1528 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1529 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1531 offset
= gfc_evaluate_now (offset
, block
);
1532 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1536 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1537 in SE. The caller may still use se->expr and se->string_length after
1538 calling this function. */
1541 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1542 gfc_symbol
* sym
, gfc_se
* se
,
1545 gfc_interface_sym_mapping
*sm
;
1549 gfc_symbol
*new_sym
;
1551 gfc_symtree
*new_symtree
;
1553 /* Create a new symbol to represent the actual argument. */
1554 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1555 new_sym
->ts
= sym
->ts
;
1556 new_sym
->attr
.referenced
= 1;
1557 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1558 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1559 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1560 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1561 new_sym
->attr
.function
= sym
->attr
.function
;
1563 /* Create a fake symtree for it. */
1565 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1566 new_symtree
->n
.sym
= new_sym
;
1567 gcc_assert (new_symtree
== root
);
1569 /* Create a dummy->actual mapping. */
1570 sm
= gfc_getmem (sizeof (*sm
));
1571 sm
->next
= mapping
->syms
;
1573 sm
->new = new_symtree
;
1574 sm
->expr
= gfc_copy_expr (expr
);
1577 /* Stabilize the argument's value. */
1578 if (!sym
->attr
.function
&& se
)
1579 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1581 if (sym
->ts
.type
== BT_CHARACTER
)
1583 /* Create a copy of the dummy argument's length. */
1584 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1585 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1587 /* If the length is specified as "*", record the length that
1588 the caller is passing. We should use the callee's length
1589 in all other cases. */
1590 if (!new_sym
->ts
.cl
->length
&& se
)
1592 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1593 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1600 /* Use the passed value as-is if the argument is a function. */
1601 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1604 /* If the argument is either a string or a pointer to a string,
1605 convert it to a boundless character type. */
1606 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1608 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1609 tmp
= build_pointer_type (tmp
);
1610 if (sym
->attr
.pointer
)
1611 value
= build_fold_indirect_ref (se
->expr
);
1614 value
= fold_convert (tmp
, value
);
1617 /* If the argument is a scalar, a pointer to an array or an allocatable,
1619 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1620 value
= build_fold_indirect_ref (se
->expr
);
1622 /* For character(*), use the actual argument's descriptor. */
1623 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1624 value
= build_fold_indirect_ref (se
->expr
);
1626 /* If the argument is an array descriptor, use it to determine
1627 information about the actual argument's shape. */
1628 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1629 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1631 /* Get the actual argument's descriptor. */
1632 desc
= build_fold_indirect_ref (se
->expr
);
1634 /* Create the replacement variable. */
1635 tmp
= gfc_conv_descriptor_data_get (desc
);
1636 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1639 /* Use DESC to work out the upper bounds, strides and offset. */
1640 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1643 /* Otherwise we have a packed array. */
1644 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1645 PACKED_FULL
, se
->expr
);
1647 new_sym
->backend_decl
= value
;
1651 /* Called once all dummy argument mappings have been added to MAPPING,
1652 but before the mapping is used to evaluate expressions. Pre-evaluate
1653 the length of each argument, adding any initialization code to PRE and
1654 any finalization code to POST. */
1657 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1658 stmtblock_t
* pre
, stmtblock_t
* post
)
1660 gfc_interface_sym_mapping
*sym
;
1664 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1665 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1666 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1668 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1669 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1670 gfc_init_se (&se
, NULL
);
1671 gfc_conv_expr (&se
, expr
);
1673 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1674 gfc_add_block_to_block (pre
, &se
.pre
);
1675 gfc_add_block_to_block (post
, &se
.post
);
1677 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1682 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1686 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1687 gfc_constructor
* c
)
1689 for (; c
; c
= c
->next
)
1691 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1694 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1695 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1696 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1702 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1706 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1711 for (; ref
; ref
= ref
->next
)
1715 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1717 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1718 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1719 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1721 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1728 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1729 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1735 /* Convert intrinsic function calls into result expressions. */
1737 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
* mapping
)
1745 arg1
= expr
->value
.function
.actual
->expr
;
1746 if (expr
->value
.function
.actual
->next
)
1747 arg2
= expr
->value
.function
.actual
->next
->expr
;
1751 sym
= arg1
->symtree
->n
.sym
;
1753 if (sym
->attr
.dummy
)
1758 switch (expr
->value
.function
.isym
->id
)
1761 /* TODO figure out why this condition is necessary. */
1762 if (sym
->attr
.function
1763 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1764 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)
1767 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1774 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1776 dup
= mpz_get_si (arg2
->value
.integer
);
1781 dup
= sym
->as
->rank
;
1785 for (; d
< dup
; d
++)
1788 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1789 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1791 new_expr
= gfc_multiply (new_expr
, tmp
);
1797 case GFC_ISYM_LBOUND
:
1798 case GFC_ISYM_UBOUND
:
1799 /* TODO These implementations of lbound and ubound do not limit if
1800 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1805 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1806 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1808 /* TODO: If the need arises, this could produce an array of
1812 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1813 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1815 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1822 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
1826 gfc_replace_expr (expr
, new_expr
);
1832 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
1833 gfc_interface_mapping
* mapping
)
1835 gfc_formal_arglist
*f
;
1836 gfc_actual_arglist
*actual
;
1838 actual
= expr
->value
.function
.actual
;
1839 f
= map_expr
->symtree
->n
.sym
->formal
;
1841 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
1846 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
1849 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
1854 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
1856 for (d
= 0; d
< as
->rank
; d
++)
1858 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
1859 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
1862 expr
->value
.function
.esym
->as
= as
;
1865 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1867 expr
->value
.function
.esym
->ts
.cl
->length
1868 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
1870 gfc_apply_interface_mapping_to_expr (mapping
,
1871 expr
->value
.function
.esym
->ts
.cl
->length
);
1876 /* EXPR is a copy of an expression that appeared in the interface
1877 associated with MAPPING. Walk it recursively looking for references to
1878 dummy arguments that MAPPING maps to actual arguments. Replace each such
1879 reference with a reference to the associated actual argument. */
1882 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1885 gfc_interface_sym_mapping
*sym
;
1886 gfc_actual_arglist
*actual
;
1891 /* Copying an expression does not copy its length, so do that here. */
1892 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1894 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1895 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1898 /* Apply the mapping to any references. */
1899 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1901 /* ...and to the expression's symbol, if it has one. */
1902 /* TODO Find out why the condition on expr->symtree had to be moved into
1903 the loop rather than being ouside it, as originally. */
1904 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1905 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
1907 if (sym
->new->n
.sym
->backend_decl
)
1908 expr
->symtree
= sym
->new;
1910 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
1913 /* ...and to subexpressions in expr->value. */
1914 switch (expr
->expr_type
)
1919 case EXPR_SUBSTRING
:
1923 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1924 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1928 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1929 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1931 if (expr
->value
.function
.esym
== NULL
1932 && expr
->value
.function
.isym
!= NULL
1933 && expr
->value
.function
.actual
->expr
->symtree
1934 && gfc_map_intrinsic_function (expr
, mapping
))
1937 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1938 if (sym
->old
== expr
->value
.function
.esym
)
1940 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1941 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
1942 expr
->value
.function
.esym
->result
= sym
->new->n
.sym
;
1947 case EXPR_STRUCTURE
:
1948 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1956 /* Evaluate interface expression EXPR using MAPPING. Store the result
1960 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1961 gfc_se
* se
, gfc_expr
* expr
)
1963 expr
= gfc_copy_expr (expr
);
1964 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1965 gfc_conv_expr (se
, expr
);
1966 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1967 gfc_free_expr (expr
);
1971 /* Returns a reference to a temporary array into which a component of
1972 an actual argument derived type array is copied and then returned
1973 after the function call. */
1975 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1976 int g77
, sym_intent intent
)
1992 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1994 gfc_init_se (&lse
, NULL
);
1995 gfc_init_se (&rse
, NULL
);
1997 /* Walk the argument expression. */
1998 rss
= gfc_walk_expr (expr
);
2000 gcc_assert (rss
!= gfc_ss_terminator
);
2002 /* Initialize the scalarizer. */
2003 gfc_init_loopinfo (&loop
);
2004 gfc_add_ss_to_loop (&loop
, rss
);
2006 /* Calculate the bounds of the scalarization. */
2007 gfc_conv_ss_startstride (&loop
);
2009 /* Build an ss for the temporary. */
2010 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
2011 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
2013 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2014 if (GFC_ARRAY_TYPE_P (base_type
)
2015 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2016 base_type
= gfc_get_element_type (base_type
);
2018 loop
.temp_ss
= gfc_get_ss ();;
2019 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2020 loop
.temp_ss
->data
.temp
.type
= base_type
;
2022 if (expr
->ts
.type
== BT_CHARACTER
)
2023 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2025 loop
.temp_ss
->string_length
= NULL
;
2027 parmse
->string_length
= loop
.temp_ss
->string_length
;
2028 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2029 loop
.temp_ss
->next
= gfc_ss_terminator
;
2031 /* Associate the SS with the loop. */
2032 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2034 /* Setup the scalarizing loops. */
2035 gfc_conv_loop_setup (&loop
);
2037 /* Pass the temporary descriptor back to the caller. */
2038 info
= &loop
.temp_ss
->data
.info
;
2039 parmse
->expr
= info
->descriptor
;
2041 /* Setup the gfc_se structures. */
2042 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2043 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2046 lse
.ss
= loop
.temp_ss
;
2047 gfc_mark_ss_chain_used (rss
, 1);
2048 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2050 /* Start the scalarized loop body. */
2051 gfc_start_scalarized_body (&loop
, &body
);
2053 /* Translate the expression. */
2054 gfc_conv_expr (&rse
, expr
);
2056 gfc_conv_tmp_array_ref (&lse
);
2057 gfc_advance_se_ss_chain (&lse
);
2059 if (intent
!= INTENT_OUT
)
2061 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2062 gfc_add_expr_to_block (&body
, tmp
);
2063 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2064 gfc_trans_scalarizing_loops (&loop
, &body
);
2068 /* Make sure that the temporary declaration survives by merging
2069 all the loop declarations into the current context. */
2070 for (n
= 0; n
< loop
.dimen
; n
++)
2072 gfc_merge_block_scope (&body
);
2073 body
= loop
.code
[loop
.order
[n
]];
2075 gfc_merge_block_scope (&body
);
2078 /* Add the post block after the second loop, so that any
2079 freeing of allocated memory is done at the right time. */
2080 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2082 /**********Copy the temporary back again.*********/
2084 gfc_init_se (&lse
, NULL
);
2085 gfc_init_se (&rse
, NULL
);
2087 /* Walk the argument expression. */
2088 lss
= gfc_walk_expr (expr
);
2089 rse
.ss
= loop
.temp_ss
;
2092 /* Initialize the scalarizer. */
2093 gfc_init_loopinfo (&loop2
);
2094 gfc_add_ss_to_loop (&loop2
, lss
);
2096 /* Calculate the bounds of the scalarization. */
2097 gfc_conv_ss_startstride (&loop2
);
2099 /* Setup the scalarizing loops. */
2100 gfc_conv_loop_setup (&loop2
);
2102 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2103 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2105 gfc_mark_ss_chain_used (lss
, 1);
2106 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2108 /* Declare the variable to hold the temporary offset and start the
2109 scalarized loop body. */
2110 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2111 gfc_start_scalarized_body (&loop2
, &body
);
2113 /* Build the offsets for the temporary from the loop variables. The
2114 temporary array has lbounds of zero and strides of one in all
2115 dimensions, so this is very simple. The offset is only computed
2116 outside the innermost loop, so the overall transfer could be
2117 optimized further. */
2118 info
= &rse
.ss
->data
.info
;
2120 tmp_index
= gfc_index_zero_node
;
2121 for (n
= info
->dimen
- 1; n
> 0; n
--)
2124 tmp
= rse
.loop
->loopvar
[n
];
2125 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2126 tmp
, rse
.loop
->from
[n
]);
2127 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2130 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2131 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2132 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2133 tmp_str
, gfc_index_one_node
);
2135 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2139 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2140 tmp_index
, rse
.loop
->from
[0]);
2141 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
2143 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2144 rse
.loop
->loopvar
[0], offset
);
2146 /* Now use the offset for the reference. */
2147 tmp
= build_fold_indirect_ref (info
->data
);
2148 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2150 if (expr
->ts
.type
== BT_CHARACTER
)
2151 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2153 gfc_conv_expr (&lse
, expr
);
2155 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2157 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2158 gfc_add_expr_to_block (&body
, tmp
);
2160 /* Generate the copying loops. */
2161 gfc_trans_scalarizing_loops (&loop2
, &body
);
2163 /* Wrap the whole thing up by adding the second loop to the post-block
2164 and following it by the post-block of the first loop. In this way,
2165 if the temporary needs freeing, it is done after use! */
2166 if (intent
!= INTENT_IN
)
2168 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2169 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2172 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2174 gfc_cleanup_loop (&loop
);
2175 gfc_cleanup_loop (&loop2
);
2177 /* Pass the string length to the argument expression. */
2178 if (expr
->ts
.type
== BT_CHARACTER
)
2179 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2181 /* We want either the address for the data or the address of the descriptor,
2182 depending on the mode of passing array arguments. */
2184 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2186 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2192 /* Generate the code for argument list functions. */
2195 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2197 /* Pass by value for g77 %VAL(arg), pass the address
2198 indirectly for %LOC, else by reference. Thus %REF
2199 is a "do-nothing" and %LOC is the same as an F95
2201 if (strncmp (name
, "%VAL", 4) == 0)
2202 gfc_conv_expr (se
, expr
);
2203 else if (strncmp (name
, "%LOC", 4) == 0)
2205 gfc_conv_expr_reference (se
, expr
);
2206 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2208 else if (strncmp (name
, "%REF", 4) == 0)
2209 gfc_conv_expr_reference (se
, expr
);
2211 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2215 /* Generate code for a procedure call. Note can return se->post != NULL.
2216 If se->direct_byref is set then se->expr contains the return parameter.
2217 Return nonzero, if the call has alternate specifiers. */
2220 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2221 gfc_actual_arglist
* arg
, tree append_args
)
2223 gfc_interface_mapping mapping
;
2237 gfc_formal_arglist
*formal
;
2238 int has_alternate_specifier
= 0;
2239 bool need_interface_mapping
;
2246 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2248 arglist
= NULL_TREE
;
2249 retargs
= NULL_TREE
;
2250 stringargs
= NULL_TREE
;
2254 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2256 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2258 if (arg
->expr
->rank
== 0)
2259 gfc_conv_expr_reference (se
, arg
->expr
);
2263 /* This is really the actual arg because no formal arglist is
2264 created for C_LOC. */
2265 fsym
= arg
->expr
->symtree
->n
.sym
;
2267 /* We should want it to do g77 calling convention. */
2269 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2270 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2271 f
= f
|| !sym
->attr
.always_explicit
;
2273 argss
= gfc_walk_expr (arg
->expr
);
2274 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2277 /* TODO -- the following two lines shouldn't be necessary, but
2278 they're removed a bug is exposed later in the codepath.
2279 This is workaround was thus introduced, but will have to be
2280 removed; please see PR 35150 for details about the issue. */
2281 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2282 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2286 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2288 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2289 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2290 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2291 gfc_conv_expr_reference (se
, arg
->expr
);
2295 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2300 /* Build the addr_expr for the first argument. The argument is
2301 already an *address* so we don't need to set want_pointer in
2303 gfc_init_se (&arg1se
, NULL
);
2304 gfc_conv_expr (&arg1se
, arg
->expr
);
2305 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2306 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2308 /* See if we were given two arguments. */
2309 if (arg
->next
== NULL
)
2310 /* Only given one arg so generate a null and do a
2311 not-equal comparison against the first arg. */
2312 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2313 fold_convert (TREE_TYPE (arg1se
.expr
),
2314 null_pointer_node
));
2320 /* Given two arguments so build the arg2se from second arg. */
2321 gfc_init_se (&arg2se
, NULL
);
2322 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2323 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2324 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2326 /* Generate test to compare that the two args are equal. */
2327 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2328 arg1se
.expr
, arg2se
.expr
);
2329 /* Generate test to ensure that the first arg is not null. */
2330 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2331 arg1se
.expr
, null_pointer_node
);
2333 /* Finally, the generated test must check that both arg1 is not
2334 NULL and that it is equal to the second arg. */
2335 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2336 not_null_expr
, eq_expr
);
2345 if (!sym
->attr
.elemental
)
2347 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2348 if (se
->ss
->useflags
)
2350 gcc_assert (gfc_return_by_reference (sym
)
2351 && sym
->result
->attr
.dimension
);
2352 gcc_assert (se
->loop
!= NULL
);
2354 /* Access the previously obtained result. */
2355 gfc_conv_tmp_array_ref (se
);
2356 gfc_advance_se_ss_chain (se
);
2360 info
= &se
->ss
->data
.info
;
2365 gfc_init_block (&post
);
2366 gfc_init_interface_mapping (&mapping
);
2367 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2368 && sym
->ts
.cl
->length
2369 && sym
->ts
.cl
->length
->expr_type
2371 || sym
->attr
.dimension
);
2372 formal
= sym
->formal
;
2373 /* Evaluate the arguments. */
2374 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2377 fsym
= formal
? formal
->sym
: NULL
;
2378 parm_kind
= MISSING
;
2382 if (se
->ignore_optional
)
2384 /* Some intrinsics have already been resolved to the correct
2388 else if (arg
->label
)
2390 has_alternate_specifier
= 1;
2395 /* Pass a NULL pointer for an absent arg. */
2396 gfc_init_se (&parmse
, NULL
);
2397 parmse
.expr
= null_pointer_node
;
2398 if (arg
->missing_arg_type
== BT_CHARACTER
)
2399 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2402 else if (se
->ss
&& se
->ss
->useflags
)
2404 /* An elemental function inside a scalarized loop. */
2405 gfc_init_se (&parmse
, se
);
2406 gfc_conv_expr_reference (&parmse
, e
);
2407 parm_kind
= ELEMENTAL
;
2411 /* A scalar or transformational function. */
2412 gfc_init_se (&parmse
, NULL
);
2413 argss
= gfc_walk_expr (e
);
2415 if (argss
== gfc_ss_terminator
)
2417 if (fsym
&& fsym
->attr
.value
)
2419 if (fsym
->ts
.type
== BT_CHARACTER
2420 && fsym
->ts
.is_c_interop
2421 && fsym
->ns
->proc_name
!= NULL
2422 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2425 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2426 if (parmse
.expr
== NULL
)
2427 gfc_conv_expr (&parmse
, e
);
2430 gfc_conv_expr (&parmse
, e
);
2432 else if (arg
->name
&& arg
->name
[0] == '%')
2433 /* Argument list functions %VAL, %LOC and %REF are signalled
2434 through arg->name. */
2435 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2436 else if ((e
->expr_type
== EXPR_FUNCTION
)
2437 && e
->symtree
->n
.sym
->attr
.pointer
2438 && fsym
&& fsym
->attr
.target
)
2440 gfc_conv_expr (&parmse
, e
);
2441 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2445 gfc_conv_expr_reference (&parmse
, e
);
2446 if (fsym
&& fsym
->attr
.pointer
2447 && fsym
->attr
.flavor
!= FL_PROCEDURE
2448 && e
->expr_type
!= EXPR_NULL
)
2450 /* Scalar pointer dummy args require an extra level of
2451 indirection. The null pointer already contains
2452 this level of indirection. */
2453 parm_kind
= SCALAR_POINTER
;
2454 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2460 /* If the procedure requires an explicit interface, the actual
2461 argument is passed according to the corresponding formal
2462 argument. If the corresponding formal argument is a POINTER,
2463 ALLOCATABLE or assumed shape, we do not use g77's calling
2464 convention, and pass the address of the array descriptor
2465 instead. Otherwise we use g77's calling convention. */
2468 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2469 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2470 f
= f
|| !sym
->attr
.always_explicit
;
2472 if (e
->expr_type
== EXPR_VARIABLE
2473 && is_subref_array (e
))
2474 /* The actual argument is a component reference to an
2475 array of derived types. In this case, the argument
2476 is converted to a temporary, which is passed and then
2477 written back after the procedure call. */
2478 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2479 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2481 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2483 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2484 allocated on entry, it must be deallocated. */
2485 if (fsym
&& fsym
->attr
.allocatable
2486 && fsym
->attr
.intent
== INTENT_OUT
)
2488 tmp
= build_fold_indirect_ref (parmse
.expr
);
2489 tmp
= gfc_trans_dealloc_allocated (tmp
);
2490 gfc_add_expr_to_block (&se
->pre
, tmp
);
2496 /* The case with fsym->attr.optional is that of a user subroutine
2497 with an interface indicating an optional argument. When we call
2498 an intrinsic subroutine, however, fsym is NULL, but we might still
2499 have an optional argument, so we proceed to the substitution
2501 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2503 /* If an optional argument is itself an optional dummy argument,
2504 check its presence and substitute a null if absent. */
2505 if (e
->expr_type
== EXPR_VARIABLE
2506 && e
->symtree
->n
.sym
->attr
.optional
)
2507 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2508 e
->representation
.length
);
2513 /* Obtain the character length of an assumed character length
2514 length procedure from the typespec. */
2515 if (fsym
->ts
.type
== BT_CHARACTER
2516 && parmse
.string_length
== NULL_TREE
2517 && e
->ts
.type
== BT_PROCEDURE
2518 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2519 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2521 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2522 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2526 if (fsym
&& need_interface_mapping
&& e
)
2527 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2529 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2530 gfc_add_block_to_block (&post
, &parmse
.post
);
2532 /* Allocated allocatable components of derived types must be
2533 deallocated for INTENT(OUT) dummy arguments and non-variable
2534 scalars. Non-variable arrays are dealt with in trans-array.c
2535 (gfc_conv_array_parameter). */
2536 if (e
&& e
->ts
.type
== BT_DERIVED
2537 && e
->ts
.derived
->attr
.alloc_comp
2538 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2540 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2543 tmp
= build_fold_indirect_ref (parmse
.expr
);
2544 parm_rank
= e
->rank
;
2552 case (SCALAR_POINTER
):
2553 tmp
= build_fold_indirect_ref (tmp
);
2560 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2561 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2562 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2563 tmp
, build_empty_stmt ());
2565 if (e
->expr_type
!= EXPR_VARIABLE
)
2566 /* Don't deallocate non-variables until they have been used. */
2567 gfc_add_expr_to_block (&se
->post
, tmp
);
2570 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2571 gfc_add_expr_to_block (&se
->pre
, tmp
);
2575 /* Character strings are passed as two parameters, a length and a
2576 pointer - except for Bind(c) which only passes the pointer. */
2577 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2578 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2580 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2582 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2585 if (ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2587 if (sym
->ts
.cl
->length
== NULL
)
2589 /* Assumed character length results are not allowed by 5.1.1.5 of the
2590 standard and are trapped in resolve.c; except in the case of SPREAD
2591 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2592 we take the character length of the first argument for the result.
2593 For dummies, we have to look through the formal argument list for
2594 this function and use the character length found there.*/
2595 if (!sym
->attr
.dummy
)
2596 cl
.backend_decl
= TREE_VALUE (stringargs
);
2599 formal
= sym
->ns
->proc_name
->formal
;
2600 for (; formal
; formal
= formal
->next
)
2601 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2602 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2609 /* Calculate the length of the returned string. */
2610 gfc_init_se (&parmse
, NULL
);
2611 if (need_interface_mapping
)
2612 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2614 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2615 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2616 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2618 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2619 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2620 build_int_cst (gfc_charlen_type_node
, 0));
2621 cl
.backend_decl
= tmp
;
2624 /* Set up a charlen structure for it. */
2629 len
= cl
.backend_decl
;
2632 byref
= gfc_return_by_reference (sym
);
2635 if (se
->direct_byref
)
2637 /* Sometimes, too much indirection can be applied; eg. for
2638 function_result = array_valued_recursive_function. */
2639 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2640 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2641 && GFC_DESCRIPTOR_TYPE_P
2642 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2643 se
->expr
= build_fold_indirect_ref (se
->expr
);
2645 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2647 else if (sym
->result
->attr
.dimension
)
2649 gcc_assert (se
->loop
&& info
);
2651 /* Set the type of the array. */
2652 tmp
= gfc_typenode_for_spec (&ts
);
2653 info
->dimen
= se
->loop
->dimen
;
2655 /* Evaluate the bounds of the result, if known. */
2656 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2658 /* Create a temporary to store the result. In case the function
2659 returns a pointer, the temporary will be a shallow copy and
2660 mustn't be deallocated. */
2661 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2662 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2663 false, !sym
->attr
.pointer
, callee_alloc
);
2665 /* Pass the temporary as the first argument. */
2666 tmp
= info
->descriptor
;
2667 tmp
= build_fold_addr_expr (tmp
);
2668 retargs
= gfc_chainon_list (retargs
, tmp
);
2670 else if (ts
.type
== BT_CHARACTER
)
2672 /* Pass the string length. */
2673 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2674 type
= build_pointer_type (type
);
2676 /* Return an address to a char[0:len-1]* temporary for
2677 character pointers. */
2678 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2680 var
= gfc_create_var (type
, "pstr");
2682 /* Provide an address expression for the function arguments. */
2683 var
= build_fold_addr_expr (var
);
2686 var
= gfc_conv_string_tmp (se
, type
, len
);
2688 retargs
= gfc_chainon_list (retargs
, var
);
2692 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2694 type
= gfc_get_complex_type (ts
.kind
);
2695 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2696 retargs
= gfc_chainon_list (retargs
, var
);
2699 /* Add the string length to the argument list. */
2700 if (ts
.type
== BT_CHARACTER
)
2701 retargs
= gfc_chainon_list (retargs
, len
);
2703 gfc_free_interface_mapping (&mapping
);
2705 /* Add the return arguments. */
2706 arglist
= chainon (retargs
, arglist
);
2708 /* Add the hidden string length parameters to the arguments. */
2709 arglist
= chainon (arglist
, stringargs
);
2711 /* We may want to append extra arguments here. This is used e.g. for
2712 calls to libgfortran_matmul_??, which need extra information. */
2713 if (append_args
!= NULL_TREE
)
2714 arglist
= chainon (arglist
, append_args
);
2716 /* Generate the actual call. */
2717 gfc_conv_function_val (se
, sym
);
2719 /* If there are alternate return labels, function type should be
2720 integer. Can't modify the type in place though, since it can be shared
2721 with other functions. For dummy arguments, the typing is done to
2722 to this result, even if it has to be repeated for each call. */
2723 if (has_alternate_specifier
2724 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2726 if (!sym
->attr
.dummy
)
2728 TREE_TYPE (sym
->backend_decl
)
2729 = build_function_type (integer_type_node
,
2730 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2731 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2734 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2737 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2738 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2740 /* If we have a pointer function, but we don't want a pointer, e.g.
2743 where f is pointer valued, we have to dereference the result. */
2744 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2745 se
->expr
= build_fold_indirect_ref (se
->expr
);
2747 /* f2c calling conventions require a scalar default real function to
2748 return a double precision result. Convert this back to default
2749 real. We only care about the cases that can happen in Fortran 77.
2751 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2752 && sym
->ts
.kind
== gfc_default_real_kind
2753 && !sym
->attr
.always_explicit
)
2754 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2756 /* A pure function may still have side-effects - it may modify its
2758 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2760 if (!sym
->attr
.pure
)
2761 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2766 /* Add the function call to the pre chain. There is no expression. */
2767 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2768 se
->expr
= NULL_TREE
;
2770 if (!se
->direct_byref
)
2772 if (sym
->attr
.dimension
)
2774 if (flag_bounds_check
)
2776 /* Check the data pointer hasn't been modified. This would
2777 happen in a function returning a pointer. */
2778 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2779 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2781 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2783 se
->expr
= info
->descriptor
;
2784 /* Bundle in the string length. */
2785 se
->string_length
= len
;
2787 else if (sym
->ts
.type
== BT_CHARACTER
)
2789 /* Dereference for character pointer results. */
2790 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2791 se
->expr
= build_fold_indirect_ref (var
);
2795 se
->string_length
= len
;
2799 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2800 se
->expr
= build_fold_indirect_ref (var
);
2805 /* Follow the function call with the argument post block. */
2807 gfc_add_block_to_block (&se
->pre
, &post
);
2809 gfc_add_block_to_block (&se
->post
, &post
);
2811 return has_alternate_specifier
;
2815 /* Generate code to copy a string. */
2818 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2819 tree slength
, tree src
)
2821 tree tmp
, dlen
, slen
;
2829 stmtblock_t tempblock
;
2831 if (slength
!= NULL_TREE
)
2833 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2834 ssc
= gfc_to_single_character (slen
, src
);
2838 slen
= build_int_cst (size_type_node
, 1);
2842 if (dlength
!= NULL_TREE
)
2844 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2845 dsc
= gfc_to_single_character (slen
, dest
);
2849 dlen
= build_int_cst (size_type_node
, 1);
2853 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
2854 ssc
= gfc_to_single_character (slen
, src
);
2855 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
2856 dsc
= gfc_to_single_character (dlen
, dest
);
2859 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2861 gfc_add_modify_expr (block
, dsc
, ssc
);
2865 /* Do nothing if the destination length is zero. */
2866 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2867 build_int_cst (size_type_node
, 0));
2869 /* The following code was previously in _gfortran_copy_string:
2871 // The two strings may overlap so we use memmove.
2873 copy_string (GFC_INTEGER_4 destlen, char * dest,
2874 GFC_INTEGER_4 srclen, const char * src)
2876 if (srclen >= destlen)
2878 // This will truncate if too long.
2879 memmove (dest, src, destlen);
2883 memmove (dest, src, srclen);
2885 memset (&dest[srclen], ' ', destlen - srclen);
2889 We're now doing it here for better optimization, but the logic
2893 dest
= fold_convert (pvoid_type_node
, dest
);
2895 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
2898 src
= fold_convert (pvoid_type_node
, src
);
2900 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
2902 /* Truncate string if source is too long. */
2903 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2904 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2905 3, dest
, src
, dlen
);
2907 /* Else copy and pad with spaces. */
2908 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2909 3, dest
, src
, slen
);
2911 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
2912 fold_convert (sizetype
, slen
));
2913 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2915 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2916 lang_hooks
.to_target_charset (' ')),
2917 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2920 gfc_init_block (&tempblock
);
2921 gfc_add_expr_to_block (&tempblock
, tmp3
);
2922 gfc_add_expr_to_block (&tempblock
, tmp4
);
2923 tmp3
= gfc_finish_block (&tempblock
);
2925 /* The whole copy_string function is there. */
2926 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2927 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2928 gfc_add_expr_to_block (block
, tmp
);
2932 /* Translate a statement function.
2933 The value of a statement function reference is obtained by evaluating the
2934 expression using the values of the actual arguments for the values of the
2935 corresponding dummy arguments. */
2938 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2942 gfc_formal_arglist
*fargs
;
2943 gfc_actual_arglist
*args
;
2946 gfc_saved_var
*saved_vars
;
2952 sym
= expr
->symtree
->n
.sym
;
2953 args
= expr
->value
.function
.actual
;
2954 gfc_init_se (&lse
, NULL
);
2955 gfc_init_se (&rse
, NULL
);
2958 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2960 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2961 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2963 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2965 /* Each dummy shall be specified, explicitly or implicitly, to be
2967 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2970 /* Create a temporary to hold the value. */
2971 type
= gfc_typenode_for_spec (&fsym
->ts
);
2972 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2974 if (fsym
->ts
.type
== BT_CHARACTER
)
2976 /* Copy string arguments. */
2979 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2980 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2982 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2983 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2986 gfc_conv_expr (&rse
, args
->expr
);
2987 gfc_conv_string_parameter (&rse
);
2988 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2989 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2991 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2993 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2994 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2998 /* For everything else, just evaluate the expression. */
2999 gfc_conv_expr (&lse
, args
->expr
);
3001 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3002 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
3003 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3009 /* Use the temporary variables in place of the real ones. */
3010 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3011 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3013 gfc_conv_expr (se
, sym
->value
);
3015 if (sym
->ts
.type
== BT_CHARACTER
)
3017 gfc_conv_const_charlen (sym
->ts
.cl
);
3019 /* Force the expression to the correct length. */
3020 if (!INTEGER_CST_P (se
->string_length
)
3021 || tree_int_cst_lt (se
->string_length
,
3022 sym
->ts
.cl
->backend_decl
))
3024 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3025 tmp
= gfc_create_var (type
, sym
->name
);
3026 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3027 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3028 se
->string_length
, se
->expr
);
3031 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3034 /* Restore the original variables. */
3035 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3036 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3037 gfc_free (saved_vars
);
3041 /* Translate a function expression. */
3044 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3048 if (expr
->value
.function
.isym
)
3050 gfc_conv_intrinsic_function (se
, expr
);
3054 /* We distinguish statement functions from general functions to improve
3055 runtime performance. */
3056 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3058 gfc_conv_statement_function (se
, expr
);
3062 /* expr.value.function.esym is the resolved (specific) function symbol for
3063 most functions. However this isn't set for dummy procedures. */
3064 sym
= expr
->value
.function
.esym
;
3066 sym
= expr
->symtree
->n
.sym
;
3067 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
3072 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3074 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3075 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3077 gfc_conv_tmp_array_ref (se
);
3078 gfc_advance_se_ss_chain (se
);
3082 /* Build a static initializer. EXPR is the expression for the initial value.
3083 The other parameters describe the variable of the component being
3084 initialized. EXPR may be null. */
3087 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3088 bool array
, bool pointer
)
3092 if (!(expr
|| pointer
))
3095 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3096 (these are the only two iso_c_binding derived types that can be
3097 used as initialization expressions). If so, we need to modify
3098 the 'expr' to be that for a (void *). */
3099 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3100 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3102 gfc_symbol
*derived
= expr
->ts
.derived
;
3104 expr
= gfc_int_expr (0);
3106 /* The derived symbol has already been converted to a (void *). Use
3108 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3109 expr
->ts
.kind
= derived
->ts
.kind
;
3114 /* Arrays need special handling. */
3116 return gfc_build_null_descriptor (type
);
3118 return gfc_conv_array_initializer (type
, expr
);
3121 return fold_convert (type
, null_pointer_node
);
3127 gfc_init_se (&se
, NULL
);
3128 gfc_conv_structure (&se
, expr
, 1);
3132 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3135 gfc_init_se (&se
, NULL
);
3136 gfc_conv_constant (&se
, expr
);
3143 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3155 gfc_start_block (&block
);
3157 /* Initialize the scalarizer. */
3158 gfc_init_loopinfo (&loop
);
3160 gfc_init_se (&lse
, NULL
);
3161 gfc_init_se (&rse
, NULL
);
3164 rss
= gfc_walk_expr (expr
);
3165 if (rss
== gfc_ss_terminator
)
3167 /* The rhs is scalar. Add a ss for the expression. */
3168 rss
= gfc_get_ss ();
3169 rss
->next
= gfc_ss_terminator
;
3170 rss
->type
= GFC_SS_SCALAR
;
3174 /* Create a SS for the destination. */
3175 lss
= gfc_get_ss ();
3176 lss
->type
= GFC_SS_COMPONENT
;
3178 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3179 lss
->next
= gfc_ss_terminator
;
3180 lss
->data
.info
.dimen
= cm
->as
->rank
;
3181 lss
->data
.info
.descriptor
= dest
;
3182 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3183 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3184 for (n
= 0; n
< cm
->as
->rank
; n
++)
3186 lss
->data
.info
.dim
[n
] = n
;
3187 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3188 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3190 mpz_init (lss
->shape
[n
]);
3191 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3192 cm
->as
->lower
[n
]->value
.integer
);
3193 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3196 /* Associate the SS with the loop. */
3197 gfc_add_ss_to_loop (&loop
, lss
);
3198 gfc_add_ss_to_loop (&loop
, rss
);
3200 /* Calculate the bounds of the scalarization. */
3201 gfc_conv_ss_startstride (&loop
);
3203 /* Setup the scalarizing loops. */
3204 gfc_conv_loop_setup (&loop
);
3206 /* Setup the gfc_se structures. */
3207 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3208 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3211 gfc_mark_ss_chain_used (rss
, 1);
3213 gfc_mark_ss_chain_used (lss
, 1);
3215 /* Start the scalarized loop body. */
3216 gfc_start_scalarized_body (&loop
, &body
);
3218 gfc_conv_tmp_array_ref (&lse
);
3219 if (cm
->ts
.type
== BT_CHARACTER
)
3220 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3222 gfc_conv_expr (&rse
, expr
);
3224 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3225 gfc_add_expr_to_block (&body
, tmp
);
3227 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3229 /* Generate the copying loops. */
3230 gfc_trans_scalarizing_loops (&loop
, &body
);
3232 /* Wrap the whole thing up. */
3233 gfc_add_block_to_block (&block
, &loop
.pre
);
3234 gfc_add_block_to_block (&block
, &loop
.post
);
3236 for (n
= 0; n
< cm
->as
->rank
; n
++)
3237 mpz_clear (lss
->shape
[n
]);
3238 gfc_free (lss
->shape
);
3240 gfc_cleanup_loop (&loop
);
3242 return gfc_finish_block (&block
);
3246 /* Assign a single component of a derived type constructor. */
3249 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3259 gfc_start_block (&block
);
3263 gfc_init_se (&se
, NULL
);
3264 /* Pointer component. */
3267 /* Array pointer. */
3268 if (expr
->expr_type
== EXPR_NULL
)
3269 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3272 rss
= gfc_walk_expr (expr
);
3273 se
.direct_byref
= 1;
3275 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3276 gfc_add_block_to_block (&block
, &se
.pre
);
3277 gfc_add_block_to_block (&block
, &se
.post
);
3282 /* Scalar pointers. */
3283 se
.want_pointer
= 1;
3284 gfc_conv_expr (&se
, expr
);
3285 gfc_add_block_to_block (&block
, &se
.pre
);
3286 gfc_add_modify_expr (&block
, dest
,
3287 fold_convert (TREE_TYPE (dest
), se
.expr
));
3288 gfc_add_block_to_block (&block
, &se
.post
);
3291 else if (cm
->dimension
)
3293 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3294 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3295 else if (cm
->allocatable
)
3299 gfc_init_se (&se
, NULL
);
3301 rss
= gfc_walk_expr (expr
);
3302 se
.want_pointer
= 0;
3303 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3304 gfc_add_block_to_block (&block
, &se
.pre
);
3306 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3307 gfc_add_modify_expr (&block
, dest
, tmp
);
3309 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3310 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3313 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3314 TREE_TYPE(cm
->backend_decl
),
3317 gfc_add_expr_to_block (&block
, tmp
);
3319 gfc_add_block_to_block (&block
, &se
.post
);
3320 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3322 /* Shift the lbound and ubound of temporaries to being unity, rather
3323 than zero, based. Calculate the offset for all cases. */
3324 offset
= gfc_conv_descriptor_offset (dest
);
3325 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3326 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3327 for (n
= 0; n
< expr
->rank
; n
++)
3329 if (expr
->expr_type
!= EXPR_VARIABLE
3330 && expr
->expr_type
!= EXPR_CONSTANT
)
3333 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3334 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3335 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3336 gfc_add_modify_expr (&block
, tmp
,
3337 fold_build2 (PLUS_EXPR
,
3338 gfc_array_index_type
,
3339 span
, gfc_index_one_node
));
3340 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3341 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3343 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3344 gfc_conv_descriptor_lbound (dest
,
3346 gfc_conv_descriptor_stride (dest
,
3348 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3349 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3350 gfc_add_modify_expr (&block
, offset
, tmp
);
3355 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3356 gfc_add_expr_to_block (&block
, tmp
);
3359 else if (expr
->ts
.type
== BT_DERIVED
)
3361 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3363 gfc_init_se (&se
, NULL
);
3364 gfc_conv_expr (&se
, expr
);
3365 gfc_add_modify_expr (&block
, dest
,
3366 fold_convert (TREE_TYPE (dest
), se
.expr
));
3370 /* Nested constructors. */
3371 tmp
= gfc_trans_structure_assign (dest
, expr
);
3372 gfc_add_expr_to_block (&block
, tmp
);
3377 /* Scalar component. */
3378 gfc_init_se (&se
, NULL
);
3379 gfc_init_se (&lse
, NULL
);
3381 gfc_conv_expr (&se
, expr
);
3382 if (cm
->ts
.type
== BT_CHARACTER
)
3383 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3385 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3386 gfc_add_expr_to_block (&block
, tmp
);
3388 return gfc_finish_block (&block
);
3391 /* Assign a derived type constructor to a variable. */
3394 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3402 gfc_start_block (&block
);
3403 cm
= expr
->ts
.derived
->components
;
3404 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3406 /* Skip absent members in default initializers. */
3410 /* Update the type/kind of the expression if it represents either
3411 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3412 be the first place reached for initializing output variables that
3413 have components of type C_PTR/C_FUNPTR that are initialized. */
3414 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3415 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3417 c
->expr
->expr_type
= EXPR_NULL
;
3418 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3419 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3420 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3423 field
= cm
->backend_decl
;
3424 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
3425 dest
, field
, NULL_TREE
);
3426 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3427 gfc_add_expr_to_block (&block
, tmp
);
3429 return gfc_finish_block (&block
);
3432 /* Build an expression for a constructor. If init is nonzero then
3433 this is part of a static variable initializer. */
3436 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3443 VEC(constructor_elt
,gc
) *v
= NULL
;
3445 gcc_assert (se
->ss
== NULL
);
3446 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3447 type
= gfc_typenode_for_spec (&expr
->ts
);
3451 /* Create a temporary variable and fill it in. */
3452 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3453 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3454 gfc_add_expr_to_block (&se
->pre
, tmp
);
3458 cm
= expr
->ts
.derived
->components
;
3460 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3462 /* Skip absent members in default initializers and allocatable
3463 components. Although the latter have a default initializer
3464 of EXPR_NULL,... by default, the static nullify is not needed
3465 since this is done every time we come into scope. */
3466 if (!c
->expr
|| cm
->allocatable
)
3469 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3470 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3472 /* Append it to the constructor list. */
3473 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3475 se
->expr
= build_constructor (type
, v
);
3478 TREE_CONSTANT(se
->expr
) = 1;
3479 TREE_INVARIANT(se
->expr
) = 1;
3484 /* Translate a substring expression. */
3487 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3493 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3495 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3496 expr
->value
.character
.string
);
3497 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3498 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3501 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3505 /* Entry point for expression translation. Evaluates a scalar quantity.
3506 EXPR is the expression to be translated, and SE is the state structure if
3507 called from within the scalarized. */
3510 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3512 if (se
->ss
&& se
->ss
->expr
== expr
3513 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3515 /* Substitute a scalar expression evaluated outside the scalarization
3517 se
->expr
= se
->ss
->data
.scalar
.expr
;
3518 se
->string_length
= se
->ss
->string_length
;
3519 gfc_advance_se_ss_chain (se
);
3523 /* We need to convert the expressions for the iso_c_binding derived types.
3524 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3525 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3526 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3527 updated to be an integer with a kind equal to the size of a (void *). */
3528 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3529 && expr
->ts
.derived
->attr
.is_iso_c
)
3531 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3532 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3534 /* Set expr_type to EXPR_NULL, which will result in
3535 null_pointer_node being used below. */
3536 expr
->expr_type
= EXPR_NULL
;
3540 /* Update the type/kind of the expression to be what the new
3541 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3542 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3543 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3544 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3548 switch (expr
->expr_type
)
3551 gfc_conv_expr_op (se
, expr
);
3555 gfc_conv_function_expr (se
, expr
);
3559 gfc_conv_constant (se
, expr
);
3563 gfc_conv_variable (se
, expr
);
3567 se
->expr
= null_pointer_node
;
3570 case EXPR_SUBSTRING
:
3571 gfc_conv_substring_expr (se
, expr
);
3574 case EXPR_STRUCTURE
:
3575 gfc_conv_structure (se
, expr
, 0);
3579 gfc_conv_array_constructor_expr (se
, expr
);
3588 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3589 of an assignment. */
3591 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3593 gfc_conv_expr (se
, expr
);
3594 /* All numeric lvalues should have empty post chains. If not we need to
3595 figure out a way of rewriting an lvalue so that it has no post chain. */
3596 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3599 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3600 numeric expressions. Used for scalar values where inserting cleanup code
3603 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3607 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3608 gfc_conv_expr (se
, expr
);
3611 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3612 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3614 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3618 /* Helper to translate an expression and convert it to a particular type. */
3620 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3622 gfc_conv_expr_val (se
, expr
);
3623 se
->expr
= convert (type
, se
->expr
);
3627 /* Converts an expression so that it can be passed by reference. Scalar
3631 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3635 if (se
->ss
&& se
->ss
->expr
== expr
3636 && se
->ss
->type
== GFC_SS_REFERENCE
)
3638 se
->expr
= se
->ss
->data
.scalar
.expr
;
3639 se
->string_length
= se
->ss
->string_length
;
3640 gfc_advance_se_ss_chain (se
);
3644 if (expr
->ts
.type
== BT_CHARACTER
)
3646 gfc_conv_expr (se
, expr
);
3647 gfc_conv_string_parameter (se
);
3651 if (expr
->expr_type
== EXPR_VARIABLE
)
3653 se
->want_pointer
= 1;
3654 gfc_conv_expr (se
, expr
);
3657 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3658 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3659 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3665 if (expr
->expr_type
== EXPR_FUNCTION
3666 && expr
->symtree
->n
.sym
->attr
.pointer
3667 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3669 se
->want_pointer
= 1;
3670 gfc_conv_expr (se
, expr
);
3671 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3672 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3678 gfc_conv_expr (se
, expr
);
3680 /* Create a temporary var to hold the value. */
3681 if (TREE_CONSTANT (se
->expr
))
3683 tree tmp
= se
->expr
;
3684 STRIP_TYPE_NOPS (tmp
);
3685 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3686 DECL_INITIAL (var
) = tmp
;
3687 TREE_STATIC (var
) = 1;
3692 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3693 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3695 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3697 /* Take the address of that value. */
3698 se
->expr
= build_fold_addr_expr (var
);
3703 gfc_trans_pointer_assign (gfc_code
* code
)
3705 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3709 /* Generate code for a pointer assignment. */
3712 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3724 gfc_start_block (&block
);
3726 gfc_init_se (&lse
, NULL
);
3728 lss
= gfc_walk_expr (expr1
);
3729 rss
= gfc_walk_expr (expr2
);
3730 if (lss
== gfc_ss_terminator
)
3732 /* Scalar pointers. */
3733 lse
.want_pointer
= 1;
3734 gfc_conv_expr (&lse
, expr1
);
3735 gcc_assert (rss
== gfc_ss_terminator
);
3736 gfc_init_se (&rse
, NULL
);
3737 rse
.want_pointer
= 1;
3738 gfc_conv_expr (&rse
, expr2
);
3739 gfc_add_block_to_block (&block
, &lse
.pre
);
3740 gfc_add_block_to_block (&block
, &rse
.pre
);
3741 gfc_add_modify_expr (&block
, lse
.expr
,
3742 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3743 gfc_add_block_to_block (&block
, &rse
.post
);
3744 gfc_add_block_to_block (&block
, &lse
.post
);
3748 /* Array pointer. */
3749 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3750 switch (expr2
->expr_type
)
3753 /* Just set the data pointer to null. */
3754 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3758 /* Assign directly to the pointer's descriptor. */
3759 lse
.direct_byref
= 1;
3760 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3762 /* If this is a subreference array pointer assignment, use the rhs
3763 descriptor element size for the lhs span. */
3764 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3766 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3767 gfc_init_se (&rse
, NULL
);
3768 rse
.descriptor_only
= 1;
3769 gfc_conv_expr (&rse
, expr2
);
3770 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3771 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3772 if (!INTEGER_CST_P (tmp
))
3773 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3774 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3780 /* Assign to a temporary descriptor and then copy that
3781 temporary to the pointer. */
3783 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3786 lse
.direct_byref
= 1;
3787 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3788 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3791 gfc_add_block_to_block (&block
, &lse
.pre
);
3792 gfc_add_block_to_block (&block
, &lse
.post
);
3794 return gfc_finish_block (&block
);
3798 /* Makes sure se is suitable for passing as a function string parameter. */
3799 /* TODO: Need to check all callers fo this function. It may be abused. */
3802 gfc_conv_string_parameter (gfc_se
* se
)
3806 if (TREE_CODE (se
->expr
) == STRING_CST
)
3808 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3812 type
= TREE_TYPE (se
->expr
);
3813 if (TYPE_STRING_FLAG (type
))
3815 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3816 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3819 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3821 type
= build_pointer_type (type
);
3822 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3826 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3827 gcc_assert (se
->string_length
3828 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3832 /* Generate code for assignment of scalar variables. Includes character
3833 strings and derived types with allocatable components. */
3836 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3837 bool l_is_temp
, bool r_is_var
)
3843 gfc_init_block (&block
);
3845 if (ts
.type
== BT_CHARACTER
)
3850 if (lse
->string_length
!= NULL_TREE
)
3852 gfc_conv_string_parameter (lse
);
3853 gfc_add_block_to_block (&block
, &lse
->pre
);
3854 llen
= lse
->string_length
;
3857 if (rse
->string_length
!= NULL_TREE
)
3859 gcc_assert (rse
->string_length
!= NULL_TREE
);
3860 gfc_conv_string_parameter (rse
);
3861 gfc_add_block_to_block (&block
, &rse
->pre
);
3862 rlen
= rse
->string_length
;
3865 gfc_trans_string_copy (&block
, llen
, lse
->expr
, rlen
, rse
->expr
);
3867 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3871 /* Are the rhs and the lhs the same? */
3874 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3875 build_fold_addr_expr (lse
->expr
),
3876 build_fold_addr_expr (rse
->expr
));
3877 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3880 /* Deallocate the lhs allocated components as long as it is not
3881 the same as the rhs. This must be done following the assignment
3882 to prevent deallocating data that could be used in the rhs
3886 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3887 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3889 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3890 gfc_add_expr_to_block (&lse
->post
, tmp
);
3893 gfc_add_block_to_block (&block
, &rse
->pre
);
3894 gfc_add_block_to_block (&block
, &lse
->pre
);
3896 gfc_add_modify_expr (&block
, lse
->expr
,
3897 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3899 /* Do a deep copy if the rhs is a variable, if it is not the
3903 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3904 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3905 gfc_add_expr_to_block (&block
, tmp
);
3910 gfc_add_block_to_block (&block
, &lse
->pre
);
3911 gfc_add_block_to_block (&block
, &rse
->pre
);
3913 gfc_add_modify_expr (&block
, lse
->expr
,
3914 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3917 gfc_add_block_to_block (&block
, &lse
->post
);
3918 gfc_add_block_to_block (&block
, &rse
->post
);
3920 return gfc_finish_block (&block
);
3924 /* Try to translate array(:) = func (...), where func is a transformational
3925 array function, without using a temporary. Returns NULL is this isn't the
3929 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3934 bool seen_array_ref
;
3936 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3937 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3940 /* Elemental functions don't need a temporary anyway. */
3941 if (expr2
->value
.function
.esym
!= NULL
3942 && expr2
->value
.function
.esym
->attr
.elemental
)
3945 /* Fail if EXPR1 can't be expressed as a descriptor. */
3946 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3949 /* Functions returning pointers need temporaries. */
3950 if (expr2
->symtree
->n
.sym
->attr
.pointer
3951 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3954 /* Character array functions need temporaries unless the
3955 character lengths are the same. */
3956 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3958 if (expr1
->ts
.cl
->length
== NULL
3959 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3962 if (expr2
->ts
.cl
->length
== NULL
3963 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3966 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3967 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3971 /* Check that no LHS component references appear during an array
3972 reference. This is needed because we do not have the means to
3973 span any arbitrary stride with an array descriptor. This check
3974 is not needed for the rhs because the function result has to be
3976 seen_array_ref
= false;
3977 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3979 if (ref
->type
== REF_ARRAY
)
3980 seen_array_ref
= true;
3981 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3985 /* Check for a dependency. */
3986 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3987 expr2
->value
.function
.esym
,
3988 expr2
->value
.function
.actual
))
3991 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3993 gcc_assert (expr2
->value
.function
.isym
3994 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3995 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3997 ss
= gfc_walk_expr (expr1
);
3998 gcc_assert (ss
!= gfc_ss_terminator
);
3999 gfc_init_se (&se
, NULL
);
4000 gfc_start_block (&se
.pre
);
4001 se
.want_pointer
= 1;
4003 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
4005 se
.direct_byref
= 1;
4006 se
.ss
= gfc_walk_expr (expr2
);
4007 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4008 gfc_conv_function_expr (&se
, expr2
);
4009 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4011 return gfc_finish_block (&se
.pre
);
4014 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4017 is_zero_initializer_p (gfc_expr
* expr
)
4019 if (expr
->expr_type
!= EXPR_CONSTANT
)
4022 /* We ignore constants with prescribed memory representations for now. */
4023 if (expr
->representation
.string
)
4026 switch (expr
->ts
.type
)
4029 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4032 return mpfr_zero_p (expr
->value
.real
)
4033 && MPFR_SIGN (expr
->value
.real
) >= 0;
4036 return expr
->value
.logical
== 0;
4039 return mpfr_zero_p (expr
->value
.complex.r
)
4040 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
4041 && mpfr_zero_p (expr
->value
.complex.i
)
4042 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
4050 /* Try to efficiently translate array(:) = 0. Return NULL if this
4054 gfc_trans_zero_assign (gfc_expr
* expr
)
4056 tree dest
, len
, type
;
4060 sym
= expr
->symtree
->n
.sym
;
4061 dest
= gfc_get_symbol_decl (sym
);
4063 type
= TREE_TYPE (dest
);
4064 if (POINTER_TYPE_P (type
))
4065 type
= TREE_TYPE (type
);
4066 if (!GFC_ARRAY_TYPE_P (type
))
4069 /* Determine the length of the array. */
4070 len
= GFC_TYPE_ARRAY_SIZE (type
);
4071 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4074 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4075 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4076 fold_convert (gfc_array_index_type
, tmp
));
4078 /* Convert arguments to the correct types. */
4079 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4080 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4082 dest
= fold_convert (pvoid_type_node
, dest
);
4083 len
= fold_convert (size_type_node
, len
);
4085 /* Construct call to __builtin_memset. */
4086 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4087 3, dest
, integer_zero_node
, len
);
4088 return fold_convert (void_type_node
, tmp
);
4092 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4093 that constructs the call to __builtin_memcpy. */
4096 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4100 /* Convert arguments to the correct types. */
4101 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4102 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4104 dst
= fold_convert (pvoid_type_node
, dst
);
4106 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4107 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4109 src
= fold_convert (pvoid_type_node
, src
);
4111 len
= fold_convert (size_type_node
, len
);
4113 /* Construct call to __builtin_memcpy. */
4114 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4115 return fold_convert (void_type_node
, tmp
);
4119 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4120 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4121 source/rhs, both are gfc_full_array_ref_p which have been checked for
4125 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4127 tree dst
, dlen
, dtype
;
4128 tree src
, slen
, stype
;
4131 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4132 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4134 dtype
= TREE_TYPE (dst
);
4135 if (POINTER_TYPE_P (dtype
))
4136 dtype
= TREE_TYPE (dtype
);
4137 stype
= TREE_TYPE (src
);
4138 if (POINTER_TYPE_P (stype
))
4139 stype
= TREE_TYPE (stype
);
4141 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4144 /* Determine the lengths of the arrays. */
4145 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4146 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4148 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4149 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4150 fold_convert (gfc_array_index_type
, tmp
));
4152 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4153 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4155 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4156 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4157 fold_convert (gfc_array_index_type
, tmp
));
4159 /* Sanity check that they are the same. This should always be
4160 the case, as we should already have checked for conformance. */
4161 if (!tree_int_cst_equal (slen
, dlen
))
4164 return gfc_build_memcpy_call (dst
, src
, dlen
);
4168 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4169 this can't be done. EXPR1 is the destination/lhs for which
4170 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4173 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4175 unsigned HOST_WIDE_INT nelem
;
4181 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4185 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4186 dtype
= TREE_TYPE (dst
);
4187 if (POINTER_TYPE_P (dtype
))
4188 dtype
= TREE_TYPE (dtype
);
4189 if (!GFC_ARRAY_TYPE_P (dtype
))
4192 /* Determine the lengths of the array. */
4193 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4194 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4197 /* Confirm that the constructor is the same size. */
4198 if (compare_tree_int (len
, nelem
) != 0)
4201 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4202 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4203 fold_convert (gfc_array_index_type
, tmp
));
4205 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4206 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4208 stype
= TREE_TYPE (src
);
4209 if (POINTER_TYPE_P (stype
))
4210 stype
= TREE_TYPE (stype
);
4212 return gfc_build_memcpy_call (dst
, src
, len
);
4216 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4217 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4220 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4225 gfc_ss
*lss_section
;
4233 /* Assignment of the form lhs = rhs. */
4234 gfc_start_block (&block
);
4236 gfc_init_se (&lse
, NULL
);
4237 gfc_init_se (&rse
, NULL
);
4240 lss
= gfc_walk_expr (expr1
);
4242 if (lss
!= gfc_ss_terminator
)
4244 /* The assignment needs scalarization. */
4247 /* Find a non-scalar SS from the lhs. */
4248 while (lss_section
!= gfc_ss_terminator
4249 && lss_section
->type
!= GFC_SS_SECTION
)
4250 lss_section
= lss_section
->next
;
4252 gcc_assert (lss_section
!= gfc_ss_terminator
);
4254 /* Initialize the scalarizer. */
4255 gfc_init_loopinfo (&loop
);
4258 rss
= gfc_walk_expr (expr2
);
4259 if (rss
== gfc_ss_terminator
)
4261 /* The rhs is scalar. Add a ss for the expression. */
4262 rss
= gfc_get_ss ();
4263 rss
->next
= gfc_ss_terminator
;
4264 rss
->type
= GFC_SS_SCALAR
;
4267 /* Associate the SS with the loop. */
4268 gfc_add_ss_to_loop (&loop
, lss
);
4269 gfc_add_ss_to_loop (&loop
, rss
);
4271 /* Calculate the bounds of the scalarization. */
4272 gfc_conv_ss_startstride (&loop
);
4273 /* Resolve any data dependencies in the statement. */
4274 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4275 /* Setup the scalarizing loops. */
4276 gfc_conv_loop_setup (&loop
);
4278 /* Setup the gfc_se structures. */
4279 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4280 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4283 gfc_mark_ss_chain_used (rss
, 1);
4284 if (loop
.temp_ss
== NULL
)
4287 gfc_mark_ss_chain_used (lss
, 1);
4291 lse
.ss
= loop
.temp_ss
;
4292 gfc_mark_ss_chain_used (lss
, 3);
4293 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4296 /* Start the scalarized loop body. */
4297 gfc_start_scalarized_body (&loop
, &body
);
4300 gfc_init_block (&body
);
4302 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4304 /* Translate the expression. */
4305 gfc_conv_expr (&rse
, expr2
);
4309 gfc_conv_tmp_array_ref (&lse
);
4310 gfc_advance_se_ss_chain (&lse
);
4313 gfc_conv_expr (&lse
, expr1
);
4315 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4316 l_is_temp
|| init_flag
,
4317 expr2
->expr_type
== EXPR_VARIABLE
);
4318 gfc_add_expr_to_block (&body
, tmp
);
4320 if (lss
== gfc_ss_terminator
)
4322 /* Use the scalar assignment as is. */
4323 gfc_add_block_to_block (&block
, &body
);
4327 gcc_assert (lse
.ss
== gfc_ss_terminator
4328 && rse
.ss
== gfc_ss_terminator
);
4332 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4334 /* We need to copy the temporary to the actual lhs. */
4335 gfc_init_se (&lse
, NULL
);
4336 gfc_init_se (&rse
, NULL
);
4337 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4338 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4340 rse
.ss
= loop
.temp_ss
;
4343 gfc_conv_tmp_array_ref (&rse
);
4344 gfc_advance_se_ss_chain (&rse
);
4345 gfc_conv_expr (&lse
, expr1
);
4347 gcc_assert (lse
.ss
== gfc_ss_terminator
4348 && rse
.ss
== gfc_ss_terminator
);
4350 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4352 gfc_add_expr_to_block (&body
, tmp
);
4355 /* Generate the copying loops. */
4356 gfc_trans_scalarizing_loops (&loop
, &body
);
4358 /* Wrap the whole thing up. */
4359 gfc_add_block_to_block (&block
, &loop
.pre
);
4360 gfc_add_block_to_block (&block
, &loop
.post
);
4362 gfc_cleanup_loop (&loop
);
4365 return gfc_finish_block (&block
);
4369 /* Check whether EXPR is a copyable array. */
4372 copyable_array_p (gfc_expr
* expr
)
4374 if (expr
->expr_type
!= EXPR_VARIABLE
)
4377 /* First check it's an array. */
4378 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4381 if (!gfc_full_array_ref_p (expr
->ref
))
4384 /* Next check that it's of a simple enough type. */
4385 switch (expr
->ts
.type
)
4397 return !expr
->ts
.derived
->attr
.alloc_comp
;
4406 /* Translate an assignment. */
4409 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4413 /* Special case a single function returning an array. */
4414 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4416 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4421 /* Special case assigning an array to zero. */
4422 if (copyable_array_p (expr1
)
4423 && is_zero_initializer_p (expr2
))
4425 tmp
= gfc_trans_zero_assign (expr1
);
4430 /* Special case copying one array to another. */
4431 if (copyable_array_p (expr1
)
4432 && copyable_array_p (expr2
)
4433 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4434 && !gfc_check_dependency (expr1
, expr2
, 0))
4436 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4441 /* Special case initializing an array from a constant array constructor. */
4442 if (copyable_array_p (expr1
)
4443 && expr2
->expr_type
== EXPR_ARRAY
4444 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4446 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4451 /* Fallback to the scalarizer to generate explicit loops. */
4452 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4456 gfc_trans_init_assign (gfc_code
* code
)
4458 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4462 gfc_trans_assign (gfc_code
* code
)
4464 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);