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
);
981 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
982 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
984 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
986 var
= gfc_create_var (tmp
, "str");
987 var
= gfc_build_addr_expr (type
, var
);
991 /* Allocate a temporary to hold the result. */
992 var
= gfc_create_var (type
, "pstr");
993 tmp
= gfc_call_malloc (&se
->pre
, type
,
994 fold_build2 (MULT_EXPR
, TREE_TYPE (len
), len
,
995 fold_convert (TREE_TYPE (len
),
997 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
999 /* Free the temporary afterwards. */
1000 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1001 gfc_add_expr_to_block (&se
->post
, tmp
);
1008 /* Handle a string concatenation operation. A temporary will be allocated to
1012 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1015 tree len
, type
, var
, tmp
, fndecl
;
1017 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1018 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1019 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1021 gfc_init_se (&lse
, se
);
1022 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1023 gfc_conv_string_parameter (&lse
);
1024 gfc_init_se (&rse
, se
);
1025 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1026 gfc_conv_string_parameter (&rse
);
1028 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1029 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1031 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1032 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1033 if (len
== NULL_TREE
)
1035 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1036 lse
.string_length
, rse
.string_length
);
1039 type
= build_pointer_type (type
);
1041 var
= gfc_conv_string_tmp (se
, type
, len
);
1043 /* Do the actual concatenation. */
1044 if (expr
->ts
.kind
== 1)
1045 fndecl
= gfor_fndecl_concat_string
;
1046 else if (expr
->ts
.kind
== 4)
1047 fndecl
= gfor_fndecl_concat_string_char4
;
1051 tmp
= build_call_expr (fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1052 rse
.string_length
, rse
.expr
);
1053 gfc_add_expr_to_block (&se
->pre
, tmp
);
1055 /* Add the cleanup for the operands. */
1056 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1057 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1060 se
->string_length
= len
;
1063 /* Translates an op expression. Common (binary) cases are handled by this
1064 function, others are passed on. Recursion is used in either case.
1065 We use the fact that (op1.ts == op2.ts) (except for the power
1067 Operators need no special handling for scalarized expressions as long as
1068 they call gfc_conv_simple_val to get their operands.
1069 Character strings get special handling. */
1072 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1074 enum tree_code code
;
1083 switch (expr
->value
.op
.operator)
1085 case INTRINSIC_PARENTHESES
:
1086 if (expr
->ts
.type
== BT_REAL
1087 || expr
->ts
.type
== BT_COMPLEX
)
1089 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1090 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1095 case INTRINSIC_UPLUS
:
1096 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1099 case INTRINSIC_UMINUS
:
1100 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1104 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1107 case INTRINSIC_PLUS
:
1111 case INTRINSIC_MINUS
:
1115 case INTRINSIC_TIMES
:
1119 case INTRINSIC_DIVIDE
:
1120 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1121 an integer, we must round towards zero, so we use a
1123 if (expr
->ts
.type
== BT_INTEGER
)
1124 code
= TRUNC_DIV_EXPR
;
1129 case INTRINSIC_POWER
:
1130 gfc_conv_power_op (se
, expr
);
1133 case INTRINSIC_CONCAT
:
1134 gfc_conv_concat_op (se
, expr
);
1138 code
= TRUTH_ANDIF_EXPR
;
1143 code
= TRUTH_ORIF_EXPR
;
1147 /* EQV and NEQV only work on logicals, but since we represent them
1148 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1150 case INTRINSIC_EQ_OS
:
1158 case INTRINSIC_NE_OS
:
1159 case INTRINSIC_NEQV
:
1166 case INTRINSIC_GT_OS
:
1173 case INTRINSIC_GE_OS
:
1180 case INTRINSIC_LT_OS
:
1187 case INTRINSIC_LE_OS
:
1193 case INTRINSIC_USER
:
1194 case INTRINSIC_ASSIGN
:
1195 /* These should be converted into function calls by the frontend. */
1199 fatal_error ("Unknown intrinsic op");
1203 /* The only exception to this is **, which is handled separately anyway. */
1204 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1206 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1210 gfc_init_se (&lse
, se
);
1211 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1212 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1215 gfc_init_se (&rse
, se
);
1216 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1217 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1221 gfc_conv_string_parameter (&lse
);
1222 gfc_conv_string_parameter (&rse
);
1224 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1225 rse
.string_length
, rse
.expr
,
1226 expr
->value
.op
.op1
->ts
.kind
);
1227 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1228 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1231 type
= gfc_typenode_for_spec (&expr
->ts
);
1235 /* The result of logical ops is always boolean_type_node. */
1236 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1237 se
->expr
= convert (type
, tmp
);
1240 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1242 /* Add the post blocks. */
1243 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1244 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1247 /* If a string's length is one, we convert it to a single character. */
1250 string_to_single_character (tree len
, tree str
, int kind
)
1252 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1254 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1255 && TREE_INT_CST_HIGH (len
) == 0)
1257 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1258 return build_fold_indirect_ref (str
);
1266 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1269 if (sym
->backend_decl
)
1271 /* This becomes the nominal_type in
1272 function.c:assign_parm_find_data_types. */
1273 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1274 /* This becomes the passed_type in
1275 function.c:assign_parm_find_data_types. C promotes char to
1276 integer for argument passing. */
1277 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1279 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1284 /* If we have a constant character expression, make it into an
1286 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1291 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1292 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1294 /* The expr needs to be compatible with a C int. If the
1295 conversion fails, then the 2 causes an ICE. */
1296 ts
.type
= BT_INTEGER
;
1297 ts
.kind
= gfc_c_int_kind
;
1298 gfc_convert_type (*expr
, &ts
, 2);
1301 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1303 if ((*expr
)->ref
== NULL
)
1305 se
->expr
= string_to_single_character
1306 (build_int_cst (integer_type_node
, 1),
1307 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1309 ((*expr
)->symtree
->n
.sym
)),
1314 gfc_conv_variable (se
, *expr
);
1315 se
->expr
= string_to_single_character
1316 (build_int_cst (integer_type_node
, 1),
1317 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1326 /* Compare two strings. If they are all single characters, the result is the
1327 subtraction of them. Otherwise, we build a library call. */
1330 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
)
1336 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1337 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1339 sc1
= string_to_single_character (len1
, str1
, kind
);
1340 sc2
= string_to_single_character (len2
, str2
, kind
);
1342 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1344 /* Deal with single character specially. */
1345 sc1
= fold_convert (integer_type_node
, sc1
);
1346 sc2
= fold_convert (integer_type_node
, sc2
);
1347 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1351 /* Build a call for the comparison. */
1355 fndecl
= gfor_fndecl_compare_string
;
1357 fndecl
= gfor_fndecl_compare_string_char4
;
1361 tmp
= build_call_expr (fndecl
, 4, len1
, str1
, len2
, str2
);
1368 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1372 if (sym
->attr
.dummy
)
1374 tmp
= gfc_get_symbol_decl (sym
);
1375 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1376 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1380 if (!sym
->backend_decl
)
1381 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1383 tmp
= sym
->backend_decl
;
1384 if (sym
->attr
.cray_pointee
)
1385 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1386 gfc_get_symbol_decl (sym
->cp_pointer
));
1387 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1389 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1390 tmp
= build_fold_addr_expr (tmp
);
1397 /* Translate the call for an elemental subroutine call used in an operator
1398 assignment. This is a simplified version of gfc_conv_function_call. */
1401 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1408 /* Only elemental subroutines with two arguments. */
1409 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1410 gcc_assert (sym
->formal
->next
->next
== NULL
);
1412 gfc_init_block (&block
);
1414 gfc_add_block_to_block (&block
, &lse
->pre
);
1415 gfc_add_block_to_block (&block
, &rse
->pre
);
1417 /* Build the argument list for the call, including hidden string lengths. */
1418 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1419 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1420 if (lse
->string_length
!= NULL_TREE
)
1421 args
= gfc_chainon_list (args
, lse
->string_length
);
1422 if (rse
->string_length
!= NULL_TREE
)
1423 args
= gfc_chainon_list (args
, rse
->string_length
);
1425 /* Build the function call. */
1426 gfc_init_se (&se
, NULL
);
1427 gfc_conv_function_val (&se
, sym
);
1428 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1429 tmp
= build_call_list (tmp
, se
.expr
, args
);
1430 gfc_add_expr_to_block (&block
, tmp
);
1432 gfc_add_block_to_block (&block
, &lse
->post
);
1433 gfc_add_block_to_block (&block
, &rse
->post
);
1435 return gfc_finish_block (&block
);
1439 /* Initialize MAPPING. */
1442 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1444 mapping
->syms
= NULL
;
1445 mapping
->charlens
= NULL
;
1449 /* Free all memory held by MAPPING (but not MAPPING itself). */
1452 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1454 gfc_interface_sym_mapping
*sym
;
1455 gfc_interface_sym_mapping
*nextsym
;
1457 gfc_charlen
*nextcl
;
1459 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1461 nextsym
= sym
->next
;
1462 gfc_free_symbol (sym
->new->n
.sym
);
1463 gfc_free_expr (sym
->expr
);
1464 gfc_free (sym
->new);
1467 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1470 gfc_free_expr (cl
->length
);
1476 /* Return a copy of gfc_charlen CL. Add the returned structure to
1477 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1479 static gfc_charlen
*
1480 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1485 new = gfc_get_charlen ();
1486 new->next
= mapping
->charlens
;
1487 new->length
= gfc_copy_expr (cl
->length
);
1489 mapping
->charlens
= new;
1494 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1495 array variable that can be used as the actual argument for dummy
1496 argument SYM. Add any initialization code to BLOCK. PACKED is as
1497 for gfc_get_nodesc_array_type and DATA points to the first element
1498 in the passed array. */
1501 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1502 gfc_packed packed
, tree data
)
1507 type
= gfc_typenode_for_spec (&sym
->ts
);
1508 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1510 var
= gfc_create_var (type
, "ifm");
1511 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1517 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1518 and offset of descriptorless array type TYPE given that it has the same
1519 size as DESC. Add any set-up code to BLOCK. */
1522 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1529 offset
= gfc_index_zero_node
;
1530 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1532 dim
= gfc_rank_cst
[n
];
1533 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1534 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1536 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1537 = gfc_conv_descriptor_lbound (desc
, dim
);
1538 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1539 = gfc_conv_descriptor_ubound (desc
, dim
);
1541 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1543 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1544 gfc_conv_descriptor_ubound (desc
, dim
),
1545 gfc_conv_descriptor_lbound (desc
, dim
));
1546 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1547 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1549 tmp
= gfc_evaluate_now (tmp
, block
);
1550 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1552 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1553 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1554 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1555 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1557 offset
= gfc_evaluate_now (offset
, block
);
1558 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1562 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1563 in SE. The caller may still use se->expr and se->string_length after
1564 calling this function. */
1567 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1568 gfc_symbol
* sym
, gfc_se
* se
,
1571 gfc_interface_sym_mapping
*sm
;
1575 gfc_symbol
*new_sym
;
1577 gfc_symtree
*new_symtree
;
1579 /* Create a new symbol to represent the actual argument. */
1580 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1581 new_sym
->ts
= sym
->ts
;
1582 new_sym
->attr
.referenced
= 1;
1583 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1584 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1585 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1586 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1587 new_sym
->attr
.function
= sym
->attr
.function
;
1589 /* Create a fake symtree for it. */
1591 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1592 new_symtree
->n
.sym
= new_sym
;
1593 gcc_assert (new_symtree
== root
);
1595 /* Create a dummy->actual mapping. */
1596 sm
= gfc_getmem (sizeof (*sm
));
1597 sm
->next
= mapping
->syms
;
1599 sm
->new = new_symtree
;
1600 sm
->expr
= gfc_copy_expr (expr
);
1603 /* Stabilize the argument's value. */
1604 if (!sym
->attr
.function
&& se
)
1605 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1607 if (sym
->ts
.type
== BT_CHARACTER
)
1609 /* Create a copy of the dummy argument's length. */
1610 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1611 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1613 /* If the length is specified as "*", record the length that
1614 the caller is passing. We should use the callee's length
1615 in all other cases. */
1616 if (!new_sym
->ts
.cl
->length
&& se
)
1618 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1619 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1626 /* Use the passed value as-is if the argument is a function. */
1627 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1630 /* If the argument is either a string or a pointer to a string,
1631 convert it to a boundless character type. */
1632 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1634 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1635 tmp
= build_pointer_type (tmp
);
1636 if (sym
->attr
.pointer
)
1637 value
= build_fold_indirect_ref (se
->expr
);
1640 value
= fold_convert (tmp
, value
);
1643 /* If the argument is a scalar, a pointer to an array or an allocatable,
1645 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1646 value
= build_fold_indirect_ref (se
->expr
);
1648 /* For character(*), use the actual argument's descriptor. */
1649 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1650 value
= build_fold_indirect_ref (se
->expr
);
1652 /* If the argument is an array descriptor, use it to determine
1653 information about the actual argument's shape. */
1654 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1655 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1657 /* Get the actual argument's descriptor. */
1658 desc
= build_fold_indirect_ref (se
->expr
);
1660 /* Create the replacement variable. */
1661 tmp
= gfc_conv_descriptor_data_get (desc
);
1662 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1665 /* Use DESC to work out the upper bounds, strides and offset. */
1666 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1669 /* Otherwise we have a packed array. */
1670 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1671 PACKED_FULL
, se
->expr
);
1673 new_sym
->backend_decl
= value
;
1677 /* Called once all dummy argument mappings have been added to MAPPING,
1678 but before the mapping is used to evaluate expressions. Pre-evaluate
1679 the length of each argument, adding any initialization code to PRE and
1680 any finalization code to POST. */
1683 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1684 stmtblock_t
* pre
, stmtblock_t
* post
)
1686 gfc_interface_sym_mapping
*sym
;
1690 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1691 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1692 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1694 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1695 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1696 gfc_init_se (&se
, NULL
);
1697 gfc_conv_expr (&se
, expr
);
1699 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1700 gfc_add_block_to_block (pre
, &se
.pre
);
1701 gfc_add_block_to_block (post
, &se
.post
);
1703 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1708 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1712 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1713 gfc_constructor
* c
)
1715 for (; c
; c
= c
->next
)
1717 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1720 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1721 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1722 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1728 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1732 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1737 for (; ref
; ref
= ref
->next
)
1741 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1743 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1744 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1745 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1747 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1754 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1755 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1761 /* Convert intrinsic function calls into result expressions. */
1763 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
* mapping
)
1771 arg1
= expr
->value
.function
.actual
->expr
;
1772 if (expr
->value
.function
.actual
->next
)
1773 arg2
= expr
->value
.function
.actual
->next
->expr
;
1777 sym
= arg1
->symtree
->n
.sym
;
1779 if (sym
->attr
.dummy
)
1784 switch (expr
->value
.function
.isym
->id
)
1787 /* TODO figure out why this condition is necessary. */
1788 if (sym
->attr
.function
1789 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1790 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)
1793 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1800 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1802 dup
= mpz_get_si (arg2
->value
.integer
);
1807 dup
= sym
->as
->rank
;
1811 for (; d
< dup
; d
++)
1814 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1815 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1817 new_expr
= gfc_multiply (new_expr
, tmp
);
1823 case GFC_ISYM_LBOUND
:
1824 case GFC_ISYM_UBOUND
:
1825 /* TODO These implementations of lbound and ubound do not limit if
1826 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1831 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1832 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1834 /* TODO: If the need arises, this could produce an array of
1838 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1839 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1841 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1848 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
1852 gfc_replace_expr (expr
, new_expr
);
1858 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
1859 gfc_interface_mapping
* mapping
)
1861 gfc_formal_arglist
*f
;
1862 gfc_actual_arglist
*actual
;
1864 actual
= expr
->value
.function
.actual
;
1865 f
= map_expr
->symtree
->n
.sym
->formal
;
1867 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
1872 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
1875 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
1880 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
1882 for (d
= 0; d
< as
->rank
; d
++)
1884 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
1885 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
1888 expr
->value
.function
.esym
->as
= as
;
1891 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1893 expr
->value
.function
.esym
->ts
.cl
->length
1894 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
1896 gfc_apply_interface_mapping_to_expr (mapping
,
1897 expr
->value
.function
.esym
->ts
.cl
->length
);
1902 /* EXPR is a copy of an expression that appeared in the interface
1903 associated with MAPPING. Walk it recursively looking for references to
1904 dummy arguments that MAPPING maps to actual arguments. Replace each such
1905 reference with a reference to the associated actual argument. */
1908 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1911 gfc_interface_sym_mapping
*sym
;
1912 gfc_actual_arglist
*actual
;
1917 /* Copying an expression does not copy its length, so do that here. */
1918 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1920 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1921 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1924 /* Apply the mapping to any references. */
1925 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1927 /* ...and to the expression's symbol, if it has one. */
1928 /* TODO Find out why the condition on expr->symtree had to be moved into
1929 the loop rather than being ouside it, as originally. */
1930 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1931 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
1933 if (sym
->new->n
.sym
->backend_decl
)
1934 expr
->symtree
= sym
->new;
1936 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
1939 /* ...and to subexpressions in expr->value. */
1940 switch (expr
->expr_type
)
1945 case EXPR_SUBSTRING
:
1949 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1950 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1954 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1955 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1957 if (expr
->value
.function
.esym
== NULL
1958 && expr
->value
.function
.isym
!= NULL
1959 && expr
->value
.function
.actual
->expr
->symtree
1960 && gfc_map_intrinsic_function (expr
, mapping
))
1963 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1964 if (sym
->old
== expr
->value
.function
.esym
)
1966 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1967 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
1968 expr
->value
.function
.esym
->result
= sym
->new->n
.sym
;
1973 case EXPR_STRUCTURE
:
1974 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1982 /* Evaluate interface expression EXPR using MAPPING. Store the result
1986 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1987 gfc_se
* se
, gfc_expr
* expr
)
1989 expr
= gfc_copy_expr (expr
);
1990 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1991 gfc_conv_expr (se
, expr
);
1992 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1993 gfc_free_expr (expr
);
1997 /* Returns a reference to a temporary array into which a component of
1998 an actual argument derived type array is copied and then returned
1999 after the function call. */
2001 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
2002 int g77
, sym_intent intent
)
2018 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2020 gfc_init_se (&lse
, NULL
);
2021 gfc_init_se (&rse
, NULL
);
2023 /* Walk the argument expression. */
2024 rss
= gfc_walk_expr (expr
);
2026 gcc_assert (rss
!= gfc_ss_terminator
);
2028 /* Initialize the scalarizer. */
2029 gfc_init_loopinfo (&loop
);
2030 gfc_add_ss_to_loop (&loop
, rss
);
2032 /* Calculate the bounds of the scalarization. */
2033 gfc_conv_ss_startstride (&loop
);
2035 /* Build an ss for the temporary. */
2036 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
2037 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
2039 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2040 if (GFC_ARRAY_TYPE_P (base_type
)
2041 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2042 base_type
= gfc_get_element_type (base_type
);
2044 loop
.temp_ss
= gfc_get_ss ();;
2045 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2046 loop
.temp_ss
->data
.temp
.type
= base_type
;
2048 if (expr
->ts
.type
== BT_CHARACTER
)
2049 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2051 loop
.temp_ss
->string_length
= NULL
;
2053 parmse
->string_length
= loop
.temp_ss
->string_length
;
2054 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2055 loop
.temp_ss
->next
= gfc_ss_terminator
;
2057 /* Associate the SS with the loop. */
2058 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2060 /* Setup the scalarizing loops. */
2061 gfc_conv_loop_setup (&loop
);
2063 /* Pass the temporary descriptor back to the caller. */
2064 info
= &loop
.temp_ss
->data
.info
;
2065 parmse
->expr
= info
->descriptor
;
2067 /* Setup the gfc_se structures. */
2068 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2069 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2072 lse
.ss
= loop
.temp_ss
;
2073 gfc_mark_ss_chain_used (rss
, 1);
2074 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2076 /* Start the scalarized loop body. */
2077 gfc_start_scalarized_body (&loop
, &body
);
2079 /* Translate the expression. */
2080 gfc_conv_expr (&rse
, expr
);
2082 gfc_conv_tmp_array_ref (&lse
);
2083 gfc_advance_se_ss_chain (&lse
);
2085 if (intent
!= INTENT_OUT
)
2087 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2088 gfc_add_expr_to_block (&body
, tmp
);
2089 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2090 gfc_trans_scalarizing_loops (&loop
, &body
);
2094 /* Make sure that the temporary declaration survives by merging
2095 all the loop declarations into the current context. */
2096 for (n
= 0; n
< loop
.dimen
; n
++)
2098 gfc_merge_block_scope (&body
);
2099 body
= loop
.code
[loop
.order
[n
]];
2101 gfc_merge_block_scope (&body
);
2104 /* Add the post block after the second loop, so that any
2105 freeing of allocated memory is done at the right time. */
2106 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2108 /**********Copy the temporary back again.*********/
2110 gfc_init_se (&lse
, NULL
);
2111 gfc_init_se (&rse
, NULL
);
2113 /* Walk the argument expression. */
2114 lss
= gfc_walk_expr (expr
);
2115 rse
.ss
= loop
.temp_ss
;
2118 /* Initialize the scalarizer. */
2119 gfc_init_loopinfo (&loop2
);
2120 gfc_add_ss_to_loop (&loop2
, lss
);
2122 /* Calculate the bounds of the scalarization. */
2123 gfc_conv_ss_startstride (&loop2
);
2125 /* Setup the scalarizing loops. */
2126 gfc_conv_loop_setup (&loop2
);
2128 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2129 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2131 gfc_mark_ss_chain_used (lss
, 1);
2132 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2134 /* Declare the variable to hold the temporary offset and start the
2135 scalarized loop body. */
2136 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2137 gfc_start_scalarized_body (&loop2
, &body
);
2139 /* Build the offsets for the temporary from the loop variables. The
2140 temporary array has lbounds of zero and strides of one in all
2141 dimensions, so this is very simple. The offset is only computed
2142 outside the innermost loop, so the overall transfer could be
2143 optimized further. */
2144 info
= &rse
.ss
->data
.info
;
2146 tmp_index
= gfc_index_zero_node
;
2147 for (n
= info
->dimen
- 1; n
> 0; n
--)
2150 tmp
= rse
.loop
->loopvar
[n
];
2151 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2152 tmp
, rse
.loop
->from
[n
]);
2153 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2156 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2157 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2158 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2159 tmp_str
, gfc_index_one_node
);
2161 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2165 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2166 tmp_index
, rse
.loop
->from
[0]);
2167 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
2169 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2170 rse
.loop
->loopvar
[0], offset
);
2172 /* Now use the offset for the reference. */
2173 tmp
= build_fold_indirect_ref (info
->data
);
2174 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2176 if (expr
->ts
.type
== BT_CHARACTER
)
2177 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2179 gfc_conv_expr (&lse
, expr
);
2181 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2183 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2184 gfc_add_expr_to_block (&body
, tmp
);
2186 /* Generate the copying loops. */
2187 gfc_trans_scalarizing_loops (&loop2
, &body
);
2189 /* Wrap the whole thing up by adding the second loop to the post-block
2190 and following it by the post-block of the first loop. In this way,
2191 if the temporary needs freeing, it is done after use! */
2192 if (intent
!= INTENT_IN
)
2194 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2195 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2198 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2200 gfc_cleanup_loop (&loop
);
2201 gfc_cleanup_loop (&loop2
);
2203 /* Pass the string length to the argument expression. */
2204 if (expr
->ts
.type
== BT_CHARACTER
)
2205 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2207 /* We want either the address for the data or the address of the descriptor,
2208 depending on the mode of passing array arguments. */
2210 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2212 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2218 /* Generate the code for argument list functions. */
2221 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2223 /* Pass by value for g77 %VAL(arg), pass the address
2224 indirectly for %LOC, else by reference. Thus %REF
2225 is a "do-nothing" and %LOC is the same as an F95
2227 if (strncmp (name
, "%VAL", 4) == 0)
2228 gfc_conv_expr (se
, expr
);
2229 else if (strncmp (name
, "%LOC", 4) == 0)
2231 gfc_conv_expr_reference (se
, expr
);
2232 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2234 else if (strncmp (name
, "%REF", 4) == 0)
2235 gfc_conv_expr_reference (se
, expr
);
2237 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2241 /* Generate code for a procedure call. Note can return se->post != NULL.
2242 If se->direct_byref is set then se->expr contains the return parameter.
2243 Return nonzero, if the call has alternate specifiers. */
2246 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2247 gfc_actual_arglist
* arg
, tree append_args
)
2249 gfc_interface_mapping mapping
;
2263 gfc_formal_arglist
*formal
;
2264 int has_alternate_specifier
= 0;
2265 bool need_interface_mapping
;
2272 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2274 arglist
= NULL_TREE
;
2275 retargs
= NULL_TREE
;
2276 stringargs
= NULL_TREE
;
2281 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2283 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2285 if (arg
->expr
->rank
== 0)
2286 gfc_conv_expr_reference (se
, arg
->expr
);
2290 /* This is really the actual arg because no formal arglist is
2291 created for C_LOC. */
2292 fsym
= arg
->expr
->symtree
->n
.sym
;
2294 /* We should want it to do g77 calling convention. */
2296 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2297 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2298 f
= f
|| !sym
->attr
.always_explicit
;
2300 argss
= gfc_walk_expr (arg
->expr
);
2301 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2304 /* TODO -- the following two lines shouldn't be necessary, but
2305 they're removed a bug is exposed later in the codepath.
2306 This is workaround was thus introduced, but will have to be
2307 removed; please see PR 35150 for details about the issue. */
2308 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2309 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2313 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2315 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2316 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2317 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2318 gfc_conv_expr_reference (se
, arg
->expr
);
2322 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2323 && arg
->next
->expr
->rank
== 0)
2324 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2326 /* Convert c_f_pointer if fptr is a scalar
2327 and convert c_f_procpointer. */
2331 gfc_init_se (&cptrse
, NULL
);
2332 gfc_conv_expr (&cptrse
, arg
->expr
);
2333 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2334 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2336 gfc_init_se (&fptrse
, NULL
);
2337 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2338 fptrse
.want_pointer
= 1;
2340 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2341 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2342 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2344 tmp
= arg
->next
->expr
->symtree
->n
.sym
->backend_decl
;
2345 se
->expr
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (tmp
), fptrse
.expr
,
2346 fold_convert (TREE_TYPE (tmp
), cptrse
.expr
));
2350 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2355 /* Build the addr_expr for the first argument. The argument is
2356 already an *address* so we don't need to set want_pointer in
2358 gfc_init_se (&arg1se
, NULL
);
2359 gfc_conv_expr (&arg1se
, arg
->expr
);
2360 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2361 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2363 /* See if we were given two arguments. */
2364 if (arg
->next
== NULL
)
2365 /* Only given one arg so generate a null and do a
2366 not-equal comparison against the first arg. */
2367 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2368 fold_convert (TREE_TYPE (arg1se
.expr
),
2369 null_pointer_node
));
2375 /* Given two arguments so build the arg2se from second arg. */
2376 gfc_init_se (&arg2se
, NULL
);
2377 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2378 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2379 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2381 /* Generate test to compare that the two args are equal. */
2382 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2383 arg1se
.expr
, arg2se
.expr
);
2384 /* Generate test to ensure that the first arg is not null. */
2385 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2386 arg1se
.expr
, null_pointer_node
);
2388 /* Finally, the generated test must check that both arg1 is not
2389 NULL and that it is equal to the second arg. */
2390 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2391 not_null_expr
, eq_expr
);
2400 if (!sym
->attr
.elemental
)
2402 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2403 if (se
->ss
->useflags
)
2405 gcc_assert (gfc_return_by_reference (sym
)
2406 && sym
->result
->attr
.dimension
);
2407 gcc_assert (se
->loop
!= NULL
);
2409 /* Access the previously obtained result. */
2410 gfc_conv_tmp_array_ref (se
);
2411 gfc_advance_se_ss_chain (se
);
2415 info
= &se
->ss
->data
.info
;
2420 gfc_init_block (&post
);
2421 gfc_init_interface_mapping (&mapping
);
2422 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2423 && sym
->ts
.cl
->length
2424 && sym
->ts
.cl
->length
->expr_type
2426 || sym
->attr
.dimension
);
2427 formal
= sym
->formal
;
2428 /* Evaluate the arguments. */
2429 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2432 fsym
= formal
? formal
->sym
: NULL
;
2433 parm_kind
= MISSING
;
2437 if (se
->ignore_optional
)
2439 /* Some intrinsics have already been resolved to the correct
2443 else if (arg
->label
)
2445 has_alternate_specifier
= 1;
2450 /* Pass a NULL pointer for an absent arg. */
2451 gfc_init_se (&parmse
, NULL
);
2452 parmse
.expr
= null_pointer_node
;
2453 if (arg
->missing_arg_type
== BT_CHARACTER
)
2454 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2457 else if (se
->ss
&& se
->ss
->useflags
)
2459 /* An elemental function inside a scalarized loop. */
2460 gfc_init_se (&parmse
, se
);
2461 gfc_conv_expr_reference (&parmse
, e
);
2462 parm_kind
= ELEMENTAL
;
2466 /* A scalar or transformational function. */
2467 gfc_init_se (&parmse
, NULL
);
2468 argss
= gfc_walk_expr (e
);
2470 if (argss
== gfc_ss_terminator
)
2472 if (fsym
&& fsym
->attr
.value
)
2474 if (fsym
->ts
.type
== BT_CHARACTER
2475 && fsym
->ts
.is_c_interop
2476 && fsym
->ns
->proc_name
!= NULL
2477 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2480 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2481 if (parmse
.expr
== NULL
)
2482 gfc_conv_expr (&parmse
, e
);
2485 gfc_conv_expr (&parmse
, e
);
2487 else if (arg
->name
&& arg
->name
[0] == '%')
2488 /* Argument list functions %VAL, %LOC and %REF are signalled
2489 through arg->name. */
2490 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2491 else if ((e
->expr_type
== EXPR_FUNCTION
)
2492 && e
->symtree
->n
.sym
->attr
.pointer
2493 && fsym
&& fsym
->attr
.target
)
2495 gfc_conv_expr (&parmse
, e
);
2496 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2500 gfc_conv_expr_reference (&parmse
, e
);
2501 if (fsym
&& fsym
->attr
.pointer
2502 && fsym
->attr
.flavor
!= FL_PROCEDURE
2503 && e
->expr_type
!= EXPR_NULL
)
2505 /* Scalar pointer dummy args require an extra level of
2506 indirection. The null pointer already contains
2507 this level of indirection. */
2508 parm_kind
= SCALAR_POINTER
;
2509 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2515 /* If the procedure requires an explicit interface, the actual
2516 argument is passed according to the corresponding formal
2517 argument. If the corresponding formal argument is a POINTER,
2518 ALLOCATABLE or assumed shape, we do not use g77's calling
2519 convention, and pass the address of the array descriptor
2520 instead. Otherwise we use g77's calling convention. */
2523 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2524 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2525 f
= f
|| !sym
->attr
.always_explicit
;
2527 if (e
->expr_type
== EXPR_VARIABLE
2528 && is_subref_array (e
))
2529 /* The actual argument is a component reference to an
2530 array of derived types. In this case, the argument
2531 is converted to a temporary, which is passed and then
2532 written back after the procedure call. */
2533 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2534 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2536 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2538 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2539 allocated on entry, it must be deallocated. */
2540 if (fsym
&& fsym
->attr
.allocatable
2541 && fsym
->attr
.intent
== INTENT_OUT
)
2543 tmp
= build_fold_indirect_ref (parmse
.expr
);
2544 tmp
= gfc_trans_dealloc_allocated (tmp
);
2545 gfc_add_expr_to_block (&se
->pre
, tmp
);
2551 /* The case with fsym->attr.optional is that of a user subroutine
2552 with an interface indicating an optional argument. When we call
2553 an intrinsic subroutine, however, fsym is NULL, but we might still
2554 have an optional argument, so we proceed to the substitution
2556 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2558 /* If an optional argument is itself an optional dummy argument,
2559 check its presence and substitute a null if absent. */
2560 if (e
->expr_type
== EXPR_VARIABLE
2561 && e
->symtree
->n
.sym
->attr
.optional
)
2562 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2563 e
->representation
.length
);
2568 /* Obtain the character length of an assumed character length
2569 length procedure from the typespec. */
2570 if (fsym
->ts
.type
== BT_CHARACTER
2571 && parmse
.string_length
== NULL_TREE
2572 && e
->ts
.type
== BT_PROCEDURE
2573 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2574 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2576 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2577 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2581 if (fsym
&& need_interface_mapping
&& e
)
2582 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2584 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2585 gfc_add_block_to_block (&post
, &parmse
.post
);
2587 /* Allocated allocatable components of derived types must be
2588 deallocated for INTENT(OUT) dummy arguments and non-variable
2589 scalars. Non-variable arrays are dealt with in trans-array.c
2590 (gfc_conv_array_parameter). */
2591 if (e
&& e
->ts
.type
== BT_DERIVED
2592 && e
->ts
.derived
->attr
.alloc_comp
2593 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2595 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2598 tmp
= build_fold_indirect_ref (parmse
.expr
);
2599 parm_rank
= e
->rank
;
2607 case (SCALAR_POINTER
):
2608 tmp
= build_fold_indirect_ref (tmp
);
2615 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2616 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2617 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2618 tmp
, build_empty_stmt ());
2620 if (e
->expr_type
!= EXPR_VARIABLE
)
2621 /* Don't deallocate non-variables until they have been used. */
2622 gfc_add_expr_to_block (&se
->post
, tmp
);
2625 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2626 gfc_add_expr_to_block (&se
->pre
, tmp
);
2630 /* Character strings are passed as two parameters, a length and a
2631 pointer - except for Bind(c) which only passes the pointer. */
2632 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2633 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2635 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2637 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2640 if (ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2642 if (sym
->ts
.cl
->length
== NULL
)
2644 /* Assumed character length results are not allowed by 5.1.1.5 of the
2645 standard and are trapped in resolve.c; except in the case of SPREAD
2646 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2647 we take the character length of the first argument for the result.
2648 For dummies, we have to look through the formal argument list for
2649 this function and use the character length found there.*/
2650 if (!sym
->attr
.dummy
)
2651 cl
.backend_decl
= TREE_VALUE (stringargs
);
2654 formal
= sym
->ns
->proc_name
->formal
;
2655 for (; formal
; formal
= formal
->next
)
2656 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2657 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2664 /* Calculate the length of the returned string. */
2665 gfc_init_se (&parmse
, NULL
);
2666 if (need_interface_mapping
)
2667 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2669 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2670 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2671 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2673 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2674 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2675 build_int_cst (gfc_charlen_type_node
, 0));
2676 cl
.backend_decl
= tmp
;
2679 /* Set up a charlen structure for it. */
2684 len
= cl
.backend_decl
;
2687 byref
= gfc_return_by_reference (sym
);
2690 if (se
->direct_byref
)
2692 /* Sometimes, too much indirection can be applied; eg. for
2693 function_result = array_valued_recursive_function. */
2694 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2695 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2696 && GFC_DESCRIPTOR_TYPE_P
2697 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2698 se
->expr
= build_fold_indirect_ref (se
->expr
);
2700 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2702 else if (sym
->result
->attr
.dimension
)
2704 gcc_assert (se
->loop
&& info
);
2706 /* Set the type of the array. */
2707 tmp
= gfc_typenode_for_spec (&ts
);
2708 info
->dimen
= se
->loop
->dimen
;
2710 /* Evaluate the bounds of the result, if known. */
2711 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2713 /* Create a temporary to store the result. In case the function
2714 returns a pointer, the temporary will be a shallow copy and
2715 mustn't be deallocated. */
2716 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2717 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2718 false, !sym
->attr
.pointer
, callee_alloc
);
2720 /* Pass the temporary as the first argument. */
2721 tmp
= info
->descriptor
;
2722 tmp
= build_fold_addr_expr (tmp
);
2723 retargs
= gfc_chainon_list (retargs
, tmp
);
2725 else if (ts
.type
== BT_CHARACTER
)
2727 /* Pass the string length. */
2728 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2729 type
= build_pointer_type (type
);
2731 /* Return an address to a char[0:len-1]* temporary for
2732 character pointers. */
2733 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2735 var
= gfc_create_var (type
, "pstr");
2737 /* Provide an address expression for the function arguments. */
2738 var
= build_fold_addr_expr (var
);
2741 var
= gfc_conv_string_tmp (se
, type
, len
);
2743 retargs
= gfc_chainon_list (retargs
, var
);
2747 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2749 type
= gfc_get_complex_type (ts
.kind
);
2750 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2751 retargs
= gfc_chainon_list (retargs
, var
);
2754 /* Add the string length to the argument list. */
2755 if (ts
.type
== BT_CHARACTER
)
2756 retargs
= gfc_chainon_list (retargs
, len
);
2758 gfc_free_interface_mapping (&mapping
);
2760 /* Add the return arguments. */
2761 arglist
= chainon (retargs
, arglist
);
2763 /* Add the hidden string length parameters to the arguments. */
2764 arglist
= chainon (arglist
, stringargs
);
2766 /* We may want to append extra arguments here. This is used e.g. for
2767 calls to libgfortran_matmul_??, which need extra information. */
2768 if (append_args
!= NULL_TREE
)
2769 arglist
= chainon (arglist
, append_args
);
2771 /* Generate the actual call. */
2772 gfc_conv_function_val (se
, sym
);
2774 /* If there are alternate return labels, function type should be
2775 integer. Can't modify the type in place though, since it can be shared
2776 with other functions. For dummy arguments, the typing is done to
2777 to this result, even if it has to be repeated for each call. */
2778 if (has_alternate_specifier
2779 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2781 if (!sym
->attr
.dummy
)
2783 TREE_TYPE (sym
->backend_decl
)
2784 = build_function_type (integer_type_node
,
2785 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2786 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2789 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2792 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2793 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2795 /* If we have a pointer function, but we don't want a pointer, e.g.
2798 where f is pointer valued, we have to dereference the result. */
2799 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2800 se
->expr
= build_fold_indirect_ref (se
->expr
);
2802 /* f2c calling conventions require a scalar default real function to
2803 return a double precision result. Convert this back to default
2804 real. We only care about the cases that can happen in Fortran 77.
2806 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2807 && sym
->ts
.kind
== gfc_default_real_kind
2808 && !sym
->attr
.always_explicit
)
2809 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2811 /* A pure function may still have side-effects - it may modify its
2813 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2815 if (!sym
->attr
.pure
)
2816 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2821 /* Add the function call to the pre chain. There is no expression. */
2822 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2823 se
->expr
= NULL_TREE
;
2825 if (!se
->direct_byref
)
2827 if (sym
->attr
.dimension
)
2829 if (flag_bounds_check
)
2831 /* Check the data pointer hasn't been modified. This would
2832 happen in a function returning a pointer. */
2833 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2834 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2836 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2838 se
->expr
= info
->descriptor
;
2839 /* Bundle in the string length. */
2840 se
->string_length
= len
;
2842 else if (sym
->ts
.type
== BT_CHARACTER
)
2844 /* Dereference for character pointer results. */
2845 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2846 se
->expr
= build_fold_indirect_ref (var
);
2850 se
->string_length
= len
;
2854 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2855 se
->expr
= build_fold_indirect_ref (var
);
2860 /* Follow the function call with the argument post block. */
2862 gfc_add_block_to_block (&se
->pre
, &post
);
2864 gfc_add_block_to_block (&se
->post
, &post
);
2866 return has_alternate_specifier
;
2870 /* Fill a character string with spaces. */
2873 fill_with_spaces (tree start
, tree type
, tree size
)
2875 stmtblock_t block
, loop
;
2876 tree i
, el
, exit_label
, cond
, tmp
;
2878 /* For a simple char type, we can call memset(). */
2879 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
2880 return build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
2881 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2882 lang_hooks
.to_target_charset (' ')),
2885 /* Otherwise, we use a loop:
2886 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
2890 /* Initialize variables. */
2891 gfc_init_block (&block
);
2892 i
= gfc_create_var (sizetype
, "i");
2893 gfc_add_modify_expr (&block
, i
, fold_convert (sizetype
, size
));
2894 el
= gfc_create_var (build_pointer_type (type
), "el");
2895 gfc_add_modify_expr (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
2896 exit_label
= gfc_build_label_decl (NULL_TREE
);
2897 TREE_USED (exit_label
) = 1;
2901 gfc_init_block (&loop
);
2903 /* Exit condition. */
2904 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
2905 fold_convert (sizetype
, integer_zero_node
));
2906 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2907 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2908 gfc_add_expr_to_block (&loop
, tmp
);
2911 gfc_add_modify_expr (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
2912 build_int_cst (type
,
2913 lang_hooks
.to_target_charset (' ')));
2915 /* Increment loop variables. */
2916 gfc_add_modify_expr (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
2917 TYPE_SIZE_UNIT (type
)));
2918 gfc_add_modify_expr (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
2920 TYPE_SIZE_UNIT (type
)));
2922 /* Making the loop... actually loop! */
2923 tmp
= gfc_finish_block (&loop
);
2924 tmp
= build1_v (LOOP_EXPR
, tmp
);
2925 gfc_add_expr_to_block (&block
, tmp
);
2927 /* The exit label. */
2928 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2929 gfc_add_expr_to_block (&block
, tmp
);
2932 return gfc_finish_block (&block
);
2936 /* Generate code to copy a string. */
2939 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2940 int dkind
, tree slength
, tree src
, int skind
)
2942 tree tmp
, dlen
, slen
;
2951 stmtblock_t tempblock
;
2953 gcc_assert (dkind
== skind
);
2955 if (slength
!= NULL_TREE
)
2957 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2958 ssc
= string_to_single_character (slen
, src
, skind
);
2962 slen
= build_int_cst (size_type_node
, 1);
2966 if (dlength
!= NULL_TREE
)
2968 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2969 dsc
= string_to_single_character (slen
, dest
, dkind
);
2973 dlen
= build_int_cst (size_type_node
, 1);
2977 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
2978 ssc
= string_to_single_character (slen
, src
, skind
);
2979 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
2980 dsc
= string_to_single_character (dlen
, dest
, dkind
);
2983 /* Assign directly if the types are compatible. */
2984 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
2985 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
2987 gfc_add_modify_expr (block
, dsc
, ssc
);
2991 /* Do nothing if the destination length is zero. */
2992 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2993 build_int_cst (size_type_node
, 0));
2995 /* The following code was previously in _gfortran_copy_string:
2997 // The two strings may overlap so we use memmove.
2999 copy_string (GFC_INTEGER_4 destlen, char * dest,
3000 GFC_INTEGER_4 srclen, const char * src)
3002 if (srclen >= destlen)
3004 // This will truncate if too long.
3005 memmove (dest, src, destlen);
3009 memmove (dest, src, srclen);
3011 memset (&dest[srclen], ' ', destlen - srclen);
3015 We're now doing it here for better optimization, but the logic
3018 /* For non-default character kinds, we have to multiply the string
3019 length by the base type size. */
3020 chartype
= gfc_get_char_type (dkind
);
3021 slen
= fold_build2 (MULT_EXPR
, size_type_node
, slen
,
3022 TYPE_SIZE_UNIT (chartype
));
3023 dlen
= fold_build2 (MULT_EXPR
, size_type_node
, dlen
,
3024 TYPE_SIZE_UNIT (chartype
));
3027 dest
= fold_convert (pvoid_type_node
, dest
);
3029 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3032 src
= fold_convert (pvoid_type_node
, src
);
3034 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3036 /* Truncate string if source is too long. */
3037 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3038 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
3039 3, dest
, src
, dlen
);
3041 /* Else copy and pad with spaces. */
3042 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
3043 3, dest
, src
, slen
);
3045 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3046 fold_convert (sizetype
, slen
));
3047 tmp4
= fill_with_spaces (tmp4
, chartype
,
3048 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3051 gfc_init_block (&tempblock
);
3052 gfc_add_expr_to_block (&tempblock
, tmp3
);
3053 gfc_add_expr_to_block (&tempblock
, tmp4
);
3054 tmp3
= gfc_finish_block (&tempblock
);
3056 /* The whole copy_string function is there. */
3057 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3058 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
3059 gfc_add_expr_to_block (block
, tmp
);
3063 /* Translate a statement function.
3064 The value of a statement function reference is obtained by evaluating the
3065 expression using the values of the actual arguments for the values of the
3066 corresponding dummy arguments. */
3069 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3073 gfc_formal_arglist
*fargs
;
3074 gfc_actual_arglist
*args
;
3077 gfc_saved_var
*saved_vars
;
3083 sym
= expr
->symtree
->n
.sym
;
3084 args
= expr
->value
.function
.actual
;
3085 gfc_init_se (&lse
, NULL
);
3086 gfc_init_se (&rse
, NULL
);
3089 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3091 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3092 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3094 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3096 /* Each dummy shall be specified, explicitly or implicitly, to be
3098 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3101 /* Create a temporary to hold the value. */
3102 type
= gfc_typenode_for_spec (&fsym
->ts
);
3103 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3105 if (fsym
->ts
.type
== BT_CHARACTER
)
3107 /* Copy string arguments. */
3110 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
3111 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3113 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3114 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3117 gfc_conv_expr (&rse
, args
->expr
);
3118 gfc_conv_string_parameter (&rse
);
3119 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3120 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3122 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3123 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3124 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3125 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3129 /* For everything else, just evaluate the expression. */
3130 gfc_conv_expr (&lse
, args
->expr
);
3132 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3133 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
3134 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3140 /* Use the temporary variables in place of the real ones. */
3141 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3142 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3144 gfc_conv_expr (se
, sym
->value
);
3146 if (sym
->ts
.type
== BT_CHARACTER
)
3148 gfc_conv_const_charlen (sym
->ts
.cl
);
3150 /* Force the expression to the correct length. */
3151 if (!INTEGER_CST_P (se
->string_length
)
3152 || tree_int_cst_lt (se
->string_length
,
3153 sym
->ts
.cl
->backend_decl
))
3155 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3156 tmp
= gfc_create_var (type
, sym
->name
);
3157 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3158 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3159 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3163 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3166 /* Restore the original variables. */
3167 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3168 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3169 gfc_free (saved_vars
);
3173 /* Translate a function expression. */
3176 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3180 if (expr
->value
.function
.isym
)
3182 gfc_conv_intrinsic_function (se
, expr
);
3186 /* We distinguish statement functions from general functions to improve
3187 runtime performance. */
3188 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3190 gfc_conv_statement_function (se
, expr
);
3194 /* expr.value.function.esym is the resolved (specific) function symbol for
3195 most functions. However this isn't set for dummy procedures. */
3196 sym
= expr
->value
.function
.esym
;
3198 sym
= expr
->symtree
->n
.sym
;
3199 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
3204 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3206 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3207 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3209 gfc_conv_tmp_array_ref (se
);
3210 gfc_advance_se_ss_chain (se
);
3214 /* Build a static initializer. EXPR is the expression for the initial value.
3215 The other parameters describe the variable of the component being
3216 initialized. EXPR may be null. */
3219 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3220 bool array
, bool pointer
)
3224 if (!(expr
|| pointer
))
3227 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3228 (these are the only two iso_c_binding derived types that can be
3229 used as initialization expressions). If so, we need to modify
3230 the 'expr' to be that for a (void *). */
3231 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3232 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3234 gfc_symbol
*derived
= expr
->ts
.derived
;
3236 expr
= gfc_int_expr (0);
3238 /* The derived symbol has already been converted to a (void *). Use
3240 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3241 expr
->ts
.kind
= derived
->ts
.kind
;
3246 /* Arrays need special handling. */
3248 return gfc_build_null_descriptor (type
);
3250 return gfc_conv_array_initializer (type
, expr
);
3253 return fold_convert (type
, null_pointer_node
);
3259 gfc_init_se (&se
, NULL
);
3260 gfc_conv_structure (&se
, expr
, 1);
3264 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3267 gfc_init_se (&se
, NULL
);
3268 gfc_conv_constant (&se
, expr
);
3275 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3287 gfc_start_block (&block
);
3289 /* Initialize the scalarizer. */
3290 gfc_init_loopinfo (&loop
);
3292 gfc_init_se (&lse
, NULL
);
3293 gfc_init_se (&rse
, NULL
);
3296 rss
= gfc_walk_expr (expr
);
3297 if (rss
== gfc_ss_terminator
)
3299 /* The rhs is scalar. Add a ss for the expression. */
3300 rss
= gfc_get_ss ();
3301 rss
->next
= gfc_ss_terminator
;
3302 rss
->type
= GFC_SS_SCALAR
;
3306 /* Create a SS for the destination. */
3307 lss
= gfc_get_ss ();
3308 lss
->type
= GFC_SS_COMPONENT
;
3310 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3311 lss
->next
= gfc_ss_terminator
;
3312 lss
->data
.info
.dimen
= cm
->as
->rank
;
3313 lss
->data
.info
.descriptor
= dest
;
3314 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3315 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3316 for (n
= 0; n
< cm
->as
->rank
; n
++)
3318 lss
->data
.info
.dim
[n
] = n
;
3319 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3320 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3322 mpz_init (lss
->shape
[n
]);
3323 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3324 cm
->as
->lower
[n
]->value
.integer
);
3325 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3328 /* Associate the SS with the loop. */
3329 gfc_add_ss_to_loop (&loop
, lss
);
3330 gfc_add_ss_to_loop (&loop
, rss
);
3332 /* Calculate the bounds of the scalarization. */
3333 gfc_conv_ss_startstride (&loop
);
3335 /* Setup the scalarizing loops. */
3336 gfc_conv_loop_setup (&loop
);
3338 /* Setup the gfc_se structures. */
3339 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3340 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3343 gfc_mark_ss_chain_used (rss
, 1);
3345 gfc_mark_ss_chain_used (lss
, 1);
3347 /* Start the scalarized loop body. */
3348 gfc_start_scalarized_body (&loop
, &body
);
3350 gfc_conv_tmp_array_ref (&lse
);
3351 if (cm
->ts
.type
== BT_CHARACTER
)
3352 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3354 gfc_conv_expr (&rse
, expr
);
3356 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3357 gfc_add_expr_to_block (&body
, tmp
);
3359 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3361 /* Generate the copying loops. */
3362 gfc_trans_scalarizing_loops (&loop
, &body
);
3364 /* Wrap the whole thing up. */
3365 gfc_add_block_to_block (&block
, &loop
.pre
);
3366 gfc_add_block_to_block (&block
, &loop
.post
);
3368 for (n
= 0; n
< cm
->as
->rank
; n
++)
3369 mpz_clear (lss
->shape
[n
]);
3370 gfc_free (lss
->shape
);
3372 gfc_cleanup_loop (&loop
);
3374 return gfc_finish_block (&block
);
3378 /* Assign a single component of a derived type constructor. */
3381 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3391 gfc_start_block (&block
);
3395 gfc_init_se (&se
, NULL
);
3396 /* Pointer component. */
3399 /* Array pointer. */
3400 if (expr
->expr_type
== EXPR_NULL
)
3401 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3404 rss
= gfc_walk_expr (expr
);
3405 se
.direct_byref
= 1;
3407 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3408 gfc_add_block_to_block (&block
, &se
.pre
);
3409 gfc_add_block_to_block (&block
, &se
.post
);
3414 /* Scalar pointers. */
3415 se
.want_pointer
= 1;
3416 gfc_conv_expr (&se
, expr
);
3417 gfc_add_block_to_block (&block
, &se
.pre
);
3418 gfc_add_modify_expr (&block
, dest
,
3419 fold_convert (TREE_TYPE (dest
), se
.expr
));
3420 gfc_add_block_to_block (&block
, &se
.post
);
3423 else if (cm
->dimension
)
3425 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3426 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3427 else if (cm
->allocatable
)
3431 gfc_init_se (&se
, NULL
);
3433 rss
= gfc_walk_expr (expr
);
3434 se
.want_pointer
= 0;
3435 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3436 gfc_add_block_to_block (&block
, &se
.pre
);
3438 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3439 gfc_add_modify_expr (&block
, dest
, tmp
);
3441 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3442 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3445 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3446 TREE_TYPE(cm
->backend_decl
),
3449 gfc_add_expr_to_block (&block
, tmp
);
3451 gfc_add_block_to_block (&block
, &se
.post
);
3452 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3454 /* Shift the lbound and ubound of temporaries to being unity, rather
3455 than zero, based. Calculate the offset for all cases. */
3456 offset
= gfc_conv_descriptor_offset (dest
);
3457 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3458 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3459 for (n
= 0; n
< expr
->rank
; n
++)
3461 if (expr
->expr_type
!= EXPR_VARIABLE
3462 && expr
->expr_type
!= EXPR_CONSTANT
)
3465 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3466 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3467 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3468 gfc_add_modify_expr (&block
, tmp
,
3469 fold_build2 (PLUS_EXPR
,
3470 gfc_array_index_type
,
3471 span
, gfc_index_one_node
));
3472 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3473 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3475 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3476 gfc_conv_descriptor_lbound (dest
,
3478 gfc_conv_descriptor_stride (dest
,
3480 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3481 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3482 gfc_add_modify_expr (&block
, offset
, tmp
);
3487 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3488 gfc_add_expr_to_block (&block
, tmp
);
3491 else if (expr
->ts
.type
== BT_DERIVED
)
3493 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3495 gfc_init_se (&se
, NULL
);
3496 gfc_conv_expr (&se
, expr
);
3497 gfc_add_modify_expr (&block
, dest
,
3498 fold_convert (TREE_TYPE (dest
), se
.expr
));
3502 /* Nested constructors. */
3503 tmp
= gfc_trans_structure_assign (dest
, expr
);
3504 gfc_add_expr_to_block (&block
, tmp
);
3509 /* Scalar component. */
3510 gfc_init_se (&se
, NULL
);
3511 gfc_init_se (&lse
, NULL
);
3513 gfc_conv_expr (&se
, expr
);
3514 if (cm
->ts
.type
== BT_CHARACTER
)
3515 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3517 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3518 gfc_add_expr_to_block (&block
, tmp
);
3520 return gfc_finish_block (&block
);
3523 /* Assign a derived type constructor to a variable. */
3526 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3534 gfc_start_block (&block
);
3535 cm
= expr
->ts
.derived
->components
;
3536 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3538 /* Skip absent members in default initializers. */
3542 /* Update the type/kind of the expression if it represents either
3543 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3544 be the first place reached for initializing output variables that
3545 have components of type C_PTR/C_FUNPTR that are initialized. */
3546 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3547 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3549 c
->expr
->expr_type
= EXPR_NULL
;
3550 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3551 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3552 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3555 field
= cm
->backend_decl
;
3556 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
3557 dest
, field
, NULL_TREE
);
3558 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3559 gfc_add_expr_to_block (&block
, tmp
);
3561 return gfc_finish_block (&block
);
3564 /* Build an expression for a constructor. If init is nonzero then
3565 this is part of a static variable initializer. */
3568 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3575 VEC(constructor_elt
,gc
) *v
= NULL
;
3577 gcc_assert (se
->ss
== NULL
);
3578 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3579 type
= gfc_typenode_for_spec (&expr
->ts
);
3583 /* Create a temporary variable and fill it in. */
3584 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3585 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3586 gfc_add_expr_to_block (&se
->pre
, tmp
);
3590 cm
= expr
->ts
.derived
->components
;
3592 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3594 /* Skip absent members in default initializers and allocatable
3595 components. Although the latter have a default initializer
3596 of EXPR_NULL,... by default, the static nullify is not needed
3597 since this is done every time we come into scope. */
3598 if (!c
->expr
|| cm
->allocatable
)
3601 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3602 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3604 /* Append it to the constructor list. */
3605 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3607 se
->expr
= build_constructor (type
, v
);
3609 TREE_CONSTANT (se
->expr
) = 1;
3613 /* Translate a substring expression. */
3616 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3622 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3624 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
3625 expr
->value
.character
.length
,
3626 expr
->value
.character
.string
);
3628 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3629 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3632 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3636 /* Entry point for expression translation. Evaluates a scalar quantity.
3637 EXPR is the expression to be translated, and SE is the state structure if
3638 called from within the scalarized. */
3641 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3643 if (se
->ss
&& se
->ss
->expr
== expr
3644 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3646 /* Substitute a scalar expression evaluated outside the scalarization
3648 se
->expr
= se
->ss
->data
.scalar
.expr
;
3649 se
->string_length
= se
->ss
->string_length
;
3650 gfc_advance_se_ss_chain (se
);
3654 /* We need to convert the expressions for the iso_c_binding derived types.
3655 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3656 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3657 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3658 updated to be an integer with a kind equal to the size of a (void *). */
3659 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3660 && expr
->ts
.derived
->attr
.is_iso_c
)
3662 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3663 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3665 /* Set expr_type to EXPR_NULL, which will result in
3666 null_pointer_node being used below. */
3667 expr
->expr_type
= EXPR_NULL
;
3671 /* Update the type/kind of the expression to be what the new
3672 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3673 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3674 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3675 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3679 switch (expr
->expr_type
)
3682 gfc_conv_expr_op (se
, expr
);
3686 gfc_conv_function_expr (se
, expr
);
3690 gfc_conv_constant (se
, expr
);
3694 gfc_conv_variable (se
, expr
);
3698 se
->expr
= null_pointer_node
;
3701 case EXPR_SUBSTRING
:
3702 gfc_conv_substring_expr (se
, expr
);
3705 case EXPR_STRUCTURE
:
3706 gfc_conv_structure (se
, expr
, 0);
3710 gfc_conv_array_constructor_expr (se
, expr
);
3719 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3720 of an assignment. */
3722 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3724 gfc_conv_expr (se
, expr
);
3725 /* All numeric lvalues should have empty post chains. If not we need to
3726 figure out a way of rewriting an lvalue so that it has no post chain. */
3727 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3730 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3731 numeric expressions. Used for scalar values where inserting cleanup code
3734 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3738 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3739 gfc_conv_expr (se
, expr
);
3742 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3743 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3745 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3749 /* Helper to translate an expression and convert it to a particular type. */
3751 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3753 gfc_conv_expr_val (se
, expr
);
3754 se
->expr
= convert (type
, se
->expr
);
3758 /* Converts an expression so that it can be passed by reference. Scalar
3762 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3766 if (se
->ss
&& se
->ss
->expr
== expr
3767 && se
->ss
->type
== GFC_SS_REFERENCE
)
3769 se
->expr
= se
->ss
->data
.scalar
.expr
;
3770 se
->string_length
= se
->ss
->string_length
;
3771 gfc_advance_se_ss_chain (se
);
3775 if (expr
->ts
.type
== BT_CHARACTER
)
3777 gfc_conv_expr (se
, expr
);
3778 gfc_conv_string_parameter (se
);
3782 if (expr
->expr_type
== EXPR_VARIABLE
)
3784 se
->want_pointer
= 1;
3785 gfc_conv_expr (se
, expr
);
3788 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3789 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3790 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3796 if (expr
->expr_type
== EXPR_FUNCTION
3797 && expr
->symtree
->n
.sym
->attr
.pointer
3798 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3800 se
->want_pointer
= 1;
3801 gfc_conv_expr (se
, expr
);
3802 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3803 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3809 gfc_conv_expr (se
, expr
);
3811 /* Create a temporary var to hold the value. */
3812 if (TREE_CONSTANT (se
->expr
))
3814 tree tmp
= se
->expr
;
3815 STRIP_TYPE_NOPS (tmp
);
3816 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3817 DECL_INITIAL (var
) = tmp
;
3818 TREE_STATIC (var
) = 1;
3823 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3824 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3826 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3828 /* Take the address of that value. */
3829 se
->expr
= build_fold_addr_expr (var
);
3834 gfc_trans_pointer_assign (gfc_code
* code
)
3836 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3840 /* Generate code for a pointer assignment. */
3843 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3855 gfc_start_block (&block
);
3857 gfc_init_se (&lse
, NULL
);
3859 lss
= gfc_walk_expr (expr1
);
3860 rss
= gfc_walk_expr (expr2
);
3861 if (lss
== gfc_ss_terminator
)
3863 /* Scalar pointers. */
3864 lse
.want_pointer
= 1;
3865 gfc_conv_expr (&lse
, expr1
);
3866 gcc_assert (rss
== gfc_ss_terminator
);
3867 gfc_init_se (&rse
, NULL
);
3868 rse
.want_pointer
= 1;
3869 gfc_conv_expr (&rse
, expr2
);
3870 gfc_add_block_to_block (&block
, &lse
.pre
);
3871 gfc_add_block_to_block (&block
, &rse
.pre
);
3872 gfc_add_modify_expr (&block
, lse
.expr
,
3873 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3874 gfc_add_block_to_block (&block
, &rse
.post
);
3875 gfc_add_block_to_block (&block
, &lse
.post
);
3879 /* Array pointer. */
3880 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3881 switch (expr2
->expr_type
)
3884 /* Just set the data pointer to null. */
3885 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3889 /* Assign directly to the pointer's descriptor. */
3890 lse
.direct_byref
= 1;
3891 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3893 /* If this is a subreference array pointer assignment, use the rhs
3894 descriptor element size for the lhs span. */
3895 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3897 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3898 gfc_init_se (&rse
, NULL
);
3899 rse
.descriptor_only
= 1;
3900 gfc_conv_expr (&rse
, expr2
);
3901 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3902 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3903 if (!INTEGER_CST_P (tmp
))
3904 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3905 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3911 /* Assign to a temporary descriptor and then copy that
3912 temporary to the pointer. */
3914 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3917 lse
.direct_byref
= 1;
3918 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3919 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3922 gfc_add_block_to_block (&block
, &lse
.pre
);
3923 gfc_add_block_to_block (&block
, &lse
.post
);
3925 return gfc_finish_block (&block
);
3929 /* Makes sure se is suitable for passing as a function string parameter. */
3930 /* TODO: Need to check all callers fo this function. It may be abused. */
3933 gfc_conv_string_parameter (gfc_se
* se
)
3937 if (TREE_CODE (se
->expr
) == STRING_CST
)
3939 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
3940 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
3944 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
3946 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3948 type
= TREE_TYPE (se
->expr
);
3949 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
3953 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3955 type
= build_pointer_type (type
);
3956 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3960 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3961 gcc_assert (se
->string_length
3962 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3966 /* Generate code for assignment of scalar variables. Includes character
3967 strings and derived types with allocatable components. */
3970 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3971 bool l_is_temp
, bool r_is_var
)
3977 gfc_init_block (&block
);
3979 if (ts
.type
== BT_CHARACTER
)
3984 if (lse
->string_length
!= NULL_TREE
)
3986 gfc_conv_string_parameter (lse
);
3987 gfc_add_block_to_block (&block
, &lse
->pre
);
3988 llen
= lse
->string_length
;
3991 if (rse
->string_length
!= NULL_TREE
)
3993 gcc_assert (rse
->string_length
!= NULL_TREE
);
3994 gfc_conv_string_parameter (rse
);
3995 gfc_add_block_to_block (&block
, &rse
->pre
);
3996 rlen
= rse
->string_length
;
3999 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4000 rse
->expr
, ts
.kind
);
4002 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
4006 /* Are the rhs and the lhs the same? */
4009 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4010 build_fold_addr_expr (lse
->expr
),
4011 build_fold_addr_expr (rse
->expr
));
4012 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4015 /* Deallocate the lhs allocated components as long as it is not
4016 the same as the rhs. This must be done following the assignment
4017 to prevent deallocating data that could be used in the rhs
4021 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4022 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
4024 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
4025 gfc_add_expr_to_block (&lse
->post
, tmp
);
4028 gfc_add_block_to_block (&block
, &rse
->pre
);
4029 gfc_add_block_to_block (&block
, &lse
->pre
);
4031 gfc_add_modify_expr (&block
, lse
->expr
,
4032 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4034 /* Do a deep copy if the rhs is a variable, if it is not the
4038 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
4039 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
4040 gfc_add_expr_to_block (&block
, tmp
);
4045 gfc_add_block_to_block (&block
, &lse
->pre
);
4046 gfc_add_block_to_block (&block
, &rse
->pre
);
4048 gfc_add_modify_expr (&block
, lse
->expr
,
4049 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4052 gfc_add_block_to_block (&block
, &lse
->post
);
4053 gfc_add_block_to_block (&block
, &rse
->post
);
4055 return gfc_finish_block (&block
);
4059 /* Try to translate array(:) = func (...), where func is a transformational
4060 array function, without using a temporary. Returns NULL is this isn't the
4064 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4069 bool seen_array_ref
;
4071 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4072 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
4075 /* Elemental functions don't need a temporary anyway. */
4076 if (expr2
->value
.function
.esym
!= NULL
4077 && expr2
->value
.function
.esym
->attr
.elemental
)
4080 /* Fail if EXPR1 can't be expressed as a descriptor. */
4081 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4084 /* Functions returning pointers need temporaries. */
4085 if (expr2
->symtree
->n
.sym
->attr
.pointer
4086 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4089 /* Character array functions need temporaries unless the
4090 character lengths are the same. */
4091 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4093 if (expr1
->ts
.cl
->length
== NULL
4094 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4097 if (expr2
->ts
.cl
->length
== NULL
4098 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4101 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
4102 expr2
->ts
.cl
->length
->value
.integer
) != 0)
4106 /* Check that no LHS component references appear during an array
4107 reference. This is needed because we do not have the means to
4108 span any arbitrary stride with an array descriptor. This check
4109 is not needed for the rhs because the function result has to be
4111 seen_array_ref
= false;
4112 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
4114 if (ref
->type
== REF_ARRAY
)
4115 seen_array_ref
= true;
4116 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
4120 /* Check for a dependency. */
4121 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
4122 expr2
->value
.function
.esym
,
4123 expr2
->value
.function
.actual
))
4126 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4128 gcc_assert (expr2
->value
.function
.isym
4129 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
4130 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
4132 ss
= gfc_walk_expr (expr1
);
4133 gcc_assert (ss
!= gfc_ss_terminator
);
4134 gfc_init_se (&se
, NULL
);
4135 gfc_start_block (&se
.pre
);
4136 se
.want_pointer
= 1;
4138 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
4140 se
.direct_byref
= 1;
4141 se
.ss
= gfc_walk_expr (expr2
);
4142 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4143 gfc_conv_function_expr (&se
, expr2
);
4144 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4146 return gfc_finish_block (&se
.pre
);
4149 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4152 is_zero_initializer_p (gfc_expr
* expr
)
4154 if (expr
->expr_type
!= EXPR_CONSTANT
)
4157 /* We ignore constants with prescribed memory representations for now. */
4158 if (expr
->representation
.string
)
4161 switch (expr
->ts
.type
)
4164 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4167 return mpfr_zero_p (expr
->value
.real
)
4168 && MPFR_SIGN (expr
->value
.real
) >= 0;
4171 return expr
->value
.logical
== 0;
4174 return mpfr_zero_p (expr
->value
.complex.r
)
4175 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
4176 && mpfr_zero_p (expr
->value
.complex.i
)
4177 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
4185 /* Try to efficiently translate array(:) = 0. Return NULL if this
4189 gfc_trans_zero_assign (gfc_expr
* expr
)
4191 tree dest
, len
, type
;
4195 sym
= expr
->symtree
->n
.sym
;
4196 dest
= gfc_get_symbol_decl (sym
);
4198 type
= TREE_TYPE (dest
);
4199 if (POINTER_TYPE_P (type
))
4200 type
= TREE_TYPE (type
);
4201 if (!GFC_ARRAY_TYPE_P (type
))
4204 /* Determine the length of the array. */
4205 len
= GFC_TYPE_ARRAY_SIZE (type
);
4206 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4209 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4210 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4211 fold_convert (gfc_array_index_type
, tmp
));
4213 /* Convert arguments to the correct types. */
4214 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4215 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4217 dest
= fold_convert (pvoid_type_node
, dest
);
4218 len
= fold_convert (size_type_node
, len
);
4220 /* Construct call to __builtin_memset. */
4221 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4222 3, dest
, integer_zero_node
, len
);
4223 return fold_convert (void_type_node
, tmp
);
4227 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4228 that constructs the call to __builtin_memcpy. */
4231 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4235 /* Convert arguments to the correct types. */
4236 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4237 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4239 dst
= fold_convert (pvoid_type_node
, dst
);
4241 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4242 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4244 src
= fold_convert (pvoid_type_node
, src
);
4246 len
= fold_convert (size_type_node
, len
);
4248 /* Construct call to __builtin_memcpy. */
4249 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4250 return fold_convert (void_type_node
, tmp
);
4254 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4255 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4256 source/rhs, both are gfc_full_array_ref_p which have been checked for
4260 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4262 tree dst
, dlen
, dtype
;
4263 tree src
, slen
, stype
;
4266 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4267 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4269 dtype
= TREE_TYPE (dst
);
4270 if (POINTER_TYPE_P (dtype
))
4271 dtype
= TREE_TYPE (dtype
);
4272 stype
= TREE_TYPE (src
);
4273 if (POINTER_TYPE_P (stype
))
4274 stype
= TREE_TYPE (stype
);
4276 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4279 /* Determine the lengths of the arrays. */
4280 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4281 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4283 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4284 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4285 fold_convert (gfc_array_index_type
, tmp
));
4287 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4288 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4290 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4291 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4292 fold_convert (gfc_array_index_type
, tmp
));
4294 /* Sanity check that they are the same. This should always be
4295 the case, as we should already have checked for conformance. */
4296 if (!tree_int_cst_equal (slen
, dlen
))
4299 return gfc_build_memcpy_call (dst
, src
, dlen
);
4303 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4304 this can't be done. EXPR1 is the destination/lhs for which
4305 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4308 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4310 unsigned HOST_WIDE_INT nelem
;
4316 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4320 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4321 dtype
= TREE_TYPE (dst
);
4322 if (POINTER_TYPE_P (dtype
))
4323 dtype
= TREE_TYPE (dtype
);
4324 if (!GFC_ARRAY_TYPE_P (dtype
))
4327 /* Determine the lengths of the array. */
4328 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4329 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4332 /* Confirm that the constructor is the same size. */
4333 if (compare_tree_int (len
, nelem
) != 0)
4336 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4337 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4338 fold_convert (gfc_array_index_type
, tmp
));
4340 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4341 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4343 stype
= TREE_TYPE (src
);
4344 if (POINTER_TYPE_P (stype
))
4345 stype
= TREE_TYPE (stype
);
4347 return gfc_build_memcpy_call (dst
, src
, len
);
4351 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4352 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4355 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4360 gfc_ss
*lss_section
;
4368 /* Assignment of the form lhs = rhs. */
4369 gfc_start_block (&block
);
4371 gfc_init_se (&lse
, NULL
);
4372 gfc_init_se (&rse
, NULL
);
4375 lss
= gfc_walk_expr (expr1
);
4377 if (lss
!= gfc_ss_terminator
)
4379 /* The assignment needs scalarization. */
4382 /* Find a non-scalar SS from the lhs. */
4383 while (lss_section
!= gfc_ss_terminator
4384 && lss_section
->type
!= GFC_SS_SECTION
)
4385 lss_section
= lss_section
->next
;
4387 gcc_assert (lss_section
!= gfc_ss_terminator
);
4389 /* Initialize the scalarizer. */
4390 gfc_init_loopinfo (&loop
);
4393 rss
= gfc_walk_expr (expr2
);
4394 if (rss
== gfc_ss_terminator
)
4396 /* The rhs is scalar. Add a ss for the expression. */
4397 rss
= gfc_get_ss ();
4398 rss
->next
= gfc_ss_terminator
;
4399 rss
->type
= GFC_SS_SCALAR
;
4402 /* Associate the SS with the loop. */
4403 gfc_add_ss_to_loop (&loop
, lss
);
4404 gfc_add_ss_to_loop (&loop
, rss
);
4406 /* Calculate the bounds of the scalarization. */
4407 gfc_conv_ss_startstride (&loop
);
4408 /* Resolve any data dependencies in the statement. */
4409 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4410 /* Setup the scalarizing loops. */
4411 gfc_conv_loop_setup (&loop
);
4413 /* Setup the gfc_se structures. */
4414 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4415 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4418 gfc_mark_ss_chain_used (rss
, 1);
4419 if (loop
.temp_ss
== NULL
)
4422 gfc_mark_ss_chain_used (lss
, 1);
4426 lse
.ss
= loop
.temp_ss
;
4427 gfc_mark_ss_chain_used (lss
, 3);
4428 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4431 /* Start the scalarized loop body. */
4432 gfc_start_scalarized_body (&loop
, &body
);
4435 gfc_init_block (&body
);
4437 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4439 /* Translate the expression. */
4440 gfc_conv_expr (&rse
, expr2
);
4444 gfc_conv_tmp_array_ref (&lse
);
4445 gfc_advance_se_ss_chain (&lse
);
4448 gfc_conv_expr (&lse
, expr1
);
4450 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4451 l_is_temp
|| init_flag
,
4452 expr2
->expr_type
== EXPR_VARIABLE
);
4453 gfc_add_expr_to_block (&body
, tmp
);
4455 if (lss
== gfc_ss_terminator
)
4457 /* Use the scalar assignment as is. */
4458 gfc_add_block_to_block (&block
, &body
);
4462 gcc_assert (lse
.ss
== gfc_ss_terminator
4463 && rse
.ss
== gfc_ss_terminator
);
4467 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4469 /* We need to copy the temporary to the actual lhs. */
4470 gfc_init_se (&lse
, NULL
);
4471 gfc_init_se (&rse
, NULL
);
4472 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4473 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4475 rse
.ss
= loop
.temp_ss
;
4478 gfc_conv_tmp_array_ref (&rse
);
4479 gfc_advance_se_ss_chain (&rse
);
4480 gfc_conv_expr (&lse
, expr1
);
4482 gcc_assert (lse
.ss
== gfc_ss_terminator
4483 && rse
.ss
== gfc_ss_terminator
);
4485 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4487 gfc_add_expr_to_block (&body
, tmp
);
4490 /* Generate the copying loops. */
4491 gfc_trans_scalarizing_loops (&loop
, &body
);
4493 /* Wrap the whole thing up. */
4494 gfc_add_block_to_block (&block
, &loop
.pre
);
4495 gfc_add_block_to_block (&block
, &loop
.post
);
4497 gfc_cleanup_loop (&loop
);
4500 return gfc_finish_block (&block
);
4504 /* Check whether EXPR is a copyable array. */
4507 copyable_array_p (gfc_expr
* expr
)
4509 if (expr
->expr_type
!= EXPR_VARIABLE
)
4512 /* First check it's an array. */
4513 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4516 if (!gfc_full_array_ref_p (expr
->ref
))
4519 /* Next check that it's of a simple enough type. */
4520 switch (expr
->ts
.type
)
4532 return !expr
->ts
.derived
->attr
.alloc_comp
;
4541 /* Translate an assignment. */
4544 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4548 /* Special case a single function returning an array. */
4549 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4551 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4556 /* Special case assigning an array to zero. */
4557 if (copyable_array_p (expr1
)
4558 && is_zero_initializer_p (expr2
))
4560 tmp
= gfc_trans_zero_assign (expr1
);
4565 /* Special case copying one array to another. */
4566 if (copyable_array_p (expr1
)
4567 && copyable_array_p (expr2
)
4568 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4569 && !gfc_check_dependency (expr1
, expr2
, 0))
4571 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4576 /* Special case initializing an array from a constant array constructor. */
4577 if (copyable_array_p (expr1
)
4578 && expr2
->expr_type
== EXPR_ARRAY
4579 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4581 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4586 /* Fallback to the scalarizer to generate explicit loops. */
4587 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4591 gfc_trans_init_assign (gfc_code
* code
)
4593 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4597 gfc_trans_assign (gfc_code
* code
)
4599 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);