1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
46 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
55 dest
->loop
= src
->loop
;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
68 memset (se
, 0, sizeof (gfc_se
));
69 gfc_init_block (&se
->pre
);
70 gfc_init_block (&se
->post
);
75 gfc_copy_se_loopvars (se
, parent
);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se
* se
)
88 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se
* se
)
112 if (CONSTANT_CLASS_P (se
->expr
))
115 /* We need a temporary for this result. */
116 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
117 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol
* sym
)
130 gcc_assert (sym
->attr
.dummy
);
132 decl
= gfc_get_symbol_decl (sym
);
133 if (TREE_CODE (decl
) != PARM_DECL
)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
139 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 return build2 (NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
154 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
155 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
156 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
158 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
160 if (ts
.type
== BT_CHARACTER
)
162 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
163 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
164 se
->string_length
, tmp
);
165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
166 se
->string_length
= tmp
;
172 /* Get the character length of an expression, looking through gfc_refs
176 gfc_get_expr_charlen (gfc_expr
*e
)
181 gcc_assert (e
->expr_type
== EXPR_VARIABLE
182 && e
->ts
.type
== BT_CHARACTER
);
184 length
= NULL
; /* To silence compiler warning. */
186 /* First candidate: if the variable is of type CHARACTER, the
187 expression's length could be the length of the character
189 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
190 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
192 /* Look through the reference chain for component references. */
193 for (r
= e
->ref
; r
; r
= r
->next
)
198 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
199 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
207 /* We should never got substring references here. These will be
208 broken down by the scalarizer. */
213 gcc_assert (length
!= NULL
);
219 /* Generate code to initialize a string length variable. Returns the
223 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
228 gfc_init_se (&se
, NULL
);
229 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
230 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
231 build_int_cst (gfc_charlen_type_node
, 0));
232 gfc_add_block_to_block (pblock
, &se
.pre
);
234 tmp
= cl
->backend_decl
;
235 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
240 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
241 const char *name
, locus
*where
)
251 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
252 type
= build_pointer_type (type
);
255 gfc_init_se (&start
, se
);
256 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
257 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
259 if (integer_onep (start
.expr
))
260 gfc_conv_string_parameter (se
);
263 /* Change the start of the string. */
264 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
267 tmp
= build_fold_indirect_ref (se
->expr
);
268 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
269 se
->expr
= gfc_build_addr_expr (type
, tmp
);
272 /* Length = end + 1 - start. */
273 gfc_init_se (&end
, se
);
274 if (ref
->u
.ss
.end
== NULL
)
275 end
.expr
= se
->string_length
;
278 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
279 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
281 if (flag_bounds_check
)
283 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
284 start
.expr
, end
.expr
);
286 /* Check lower bound. */
287 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
288 build_int_cst (gfc_charlen_type_node
, 1));
289 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
292 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
293 "is less than one", name
);
295 asprintf (&msg
, "Substring out of bounds: lower bound "
297 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
300 /* Check upper bound. */
301 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
303 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
306 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
307 "exceeds string length", name
);
309 asprintf (&msg
, "Substring out of bounds: upper bound "
310 "exceeds string length");
311 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
315 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
316 build_int_cst (gfc_charlen_type_node
, 1),
318 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
319 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
320 build_int_cst (gfc_charlen_type_node
, 0));
321 se
->string_length
= tmp
;
325 /* Convert a derived type component reference. */
328 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
335 c
= ref
->u
.c
.component
;
337 gcc_assert (c
->backend_decl
);
339 field
= c
->backend_decl
;
340 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
342 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
346 if (c
->ts
.type
== BT_CHARACTER
)
348 tmp
= c
->ts
.cl
->backend_decl
;
349 /* Components must always be constant length. */
350 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
351 se
->string_length
= tmp
;
354 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
355 se
->expr
= build_fold_indirect_ref (se
->expr
);
359 /* Return the contents of a variable. Also handles reference/pointer
360 variables (all Fortran pointer references are implicit). */
363 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
370 bool alternate_entry
;
373 sym
= expr
->symtree
->n
.sym
;
376 /* Check that something hasn't gone horribly wrong. */
377 gcc_assert (se
->ss
!= gfc_ss_terminator
);
378 gcc_assert (se
->ss
->expr
== expr
);
380 /* A scalarized term. We already know the descriptor. */
381 se
->expr
= se
->ss
->data
.info
.descriptor
;
382 se
->string_length
= se
->ss
->string_length
;
383 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
384 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
389 tree se_expr
= NULL_TREE
;
391 se
->expr
= gfc_get_symbol_decl (sym
);
393 /* Deal with references to a parent results or entries by storing
394 the current_function_decl and moving to the parent_decl. */
395 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
396 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
397 && sym
->result
== sym
;
398 entry_master
= sym
->attr
.result
399 && sym
->ns
->proc_name
->attr
.entry_master
400 && !gfc_return_by_reference (sym
->ns
->proc_name
);
401 parent_decl
= DECL_CONTEXT (current_function_decl
);
403 if ((se
->expr
== parent_decl
&& return_value
)
404 || (sym
->ns
&& sym
->ns
->proc_name
406 && sym
->ns
->proc_name
->backend_decl
== parent_decl
407 && (alternate_entry
|| entry_master
)))
412 /* Special case for assigning the return value of a function.
413 Self recursive functions must have an explicit return value. */
414 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
415 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
417 /* Similarly for alternate entry points. */
418 else if (alternate_entry
419 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
422 gfc_entry_list
*el
= NULL
;
424 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
427 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
432 else if (entry_master
433 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
435 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
440 /* Procedure actual arguments. */
441 else if (sym
->attr
.flavor
== FL_PROCEDURE
442 && se
->expr
!= current_function_decl
)
444 gcc_assert (se
->want_pointer
);
445 if (!sym
->attr
.dummy
)
447 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
448 se
->expr
= build_fold_addr_expr (se
->expr
);
454 /* Dereference the expression, where needed. Since characters
455 are entirely different from other types, they are treated
457 if (sym
->ts
.type
== BT_CHARACTER
)
459 /* Dereference character pointer dummy arguments
461 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
463 || sym
->attr
.function
464 || sym
->attr
.result
))
465 se
->expr
= build_fold_indirect_ref (se
->expr
);
467 /* A character with VALUE attribute needs an address
470 se
->expr
= build_fold_addr_expr (se
->expr
);
473 else if (!sym
->attr
.value
)
475 /* Dereference non-character scalar dummy arguments. */
476 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
477 se
->expr
= build_fold_indirect_ref (se
->expr
);
479 /* Dereference scalar hidden result. */
480 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
481 && (sym
->attr
.function
|| sym
->attr
.result
)
482 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
483 se
->expr
= build_fold_indirect_ref (se
->expr
);
485 /* Dereference non-character pointer variables.
486 These must be dummies, results, or scalars. */
487 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
489 || sym
->attr
.function
491 || !sym
->attr
.dimension
))
492 se
->expr
= build_fold_indirect_ref (se
->expr
);
498 /* For character variables, also get the length. */
499 if (sym
->ts
.type
== BT_CHARACTER
)
501 /* If the character length of an entry isn't set, get the length from
502 the master function instead. */
503 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
504 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
506 se
->string_length
= sym
->ts
.cl
->backend_decl
;
507 gcc_assert (se
->string_length
);
515 /* Return the descriptor if that's what we want and this is an array
516 section reference. */
517 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
519 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
520 /* Return the descriptor for array pointers and allocations. */
522 && ref
->next
== NULL
&& (se
->descriptor_only
))
525 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
526 /* Return a pointer to an element. */
530 gfc_conv_component_ref (se
, ref
);
534 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
535 expr
->symtree
->name
, &expr
->where
);
544 /* Pointer assignment, allocation or pass by reference. Arrays are handled
546 if (se
->want_pointer
)
548 if (expr
->ts
.type
== BT_CHARACTER
)
549 gfc_conv_string_parameter (se
);
551 se
->expr
= build_fold_addr_expr (se
->expr
);
556 /* Unary ops are easy... Or they would be if ! was a valid op. */
559 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
564 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
565 /* Initialize the operand. */
566 gfc_init_se (&operand
, se
);
567 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
568 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
570 type
= gfc_typenode_for_spec (&expr
->ts
);
572 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
573 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
574 All other unary operators have an equivalent GIMPLE unary operator. */
575 if (code
== TRUTH_NOT_EXPR
)
576 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
577 build_int_cst (type
, 0));
579 se
->expr
= build1 (code
, type
, operand
.expr
);
583 /* Expand power operator to optimal multiplications when a value is raised
584 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
585 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
586 Programming", 3rd Edition, 1998. */
588 /* This code is mostly duplicated from expand_powi in the backend.
589 We establish the "optimal power tree" lookup table with the defined size.
590 The items in the table are the exponents used to calculate the index
591 exponents. Any integer n less than the value can get an "addition chain",
592 with the first node being one. */
593 #define POWI_TABLE_SIZE 256
595 /* The table is from builtins.c. */
596 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
598 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
599 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
600 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
601 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
602 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
603 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
604 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
605 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
606 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
607 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
608 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
609 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
610 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
611 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
612 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
613 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
614 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
615 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
616 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
617 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
618 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
619 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
620 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
621 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
622 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
623 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
624 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
625 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
626 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
627 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
628 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
629 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
632 /* If n is larger than lookup table's max index, we use the "window
634 #define POWI_WINDOW_SIZE 3
636 /* Recursive function to expand the power operator. The temporary
637 values are put in tmpvar. The function returns tmpvar[1] ** n. */
639 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
646 if (n
< POWI_TABLE_SIZE
)
651 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
652 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
656 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
657 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
658 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
662 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
666 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
667 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
669 if (n
< POWI_TABLE_SIZE
)
676 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
677 return 1. Else return 0 and a call to runtime library functions
678 will have to be built. */
680 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
685 tree vartmp
[POWI_TABLE_SIZE
];
687 unsigned HOST_WIDE_INT n
;
690 /* If exponent is too large, we won't expand it anyway, so don't bother
691 with large integer values. */
692 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
695 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
696 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
697 of the asymmetric range of the integer type. */
698 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
700 type
= TREE_TYPE (lhs
);
701 sgn
= tree_int_cst_sgn (rhs
);
703 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
704 || optimize_size
) && (m
> 2 || m
< -1))
710 se
->expr
= gfc_build_const (type
, integer_one_node
);
714 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
715 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
717 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
718 build_int_cst (TREE_TYPE (lhs
), -1));
719 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
720 build_int_cst (TREE_TYPE (lhs
), 1));
723 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
726 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
727 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
728 build_int_cst (type
, 0));
732 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
733 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
734 build_int_cst (type
, 0));
735 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
739 memset (vartmp
, 0, sizeof (vartmp
));
743 tmp
= gfc_build_const (type
, integer_one_node
);
744 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
747 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
753 /* Power op (**). Constant integer exponent has special handling. */
756 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
758 tree gfc_int4_type_node
;
765 gfc_init_se (&lse
, se
);
766 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
767 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
768 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
770 gfc_init_se (&rse
, se
);
771 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
772 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
774 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
775 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
776 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
779 gfc_int4_type_node
= gfc_get_int_type (4);
781 kind
= expr
->value
.op
.op1
->ts
.kind
;
782 switch (expr
->value
.op
.op2
->ts
.type
)
785 ikind
= expr
->value
.op
.op2
->ts
.kind
;
790 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
812 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
813 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
838 switch (expr
->value
.op
.op1
->ts
.type
)
841 if (kind
== 3) /* Case 16 was not handled properly above. */
843 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
847 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
851 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
863 fndecl
= built_in_decls
[BUILT_IN_POWF
];
866 fndecl
= built_in_decls
[BUILT_IN_POW
];
870 fndecl
= built_in_decls
[BUILT_IN_POWL
];
881 fndecl
= gfor_fndecl_math_cpowf
;
884 fndecl
= gfor_fndecl_math_cpow
;
887 fndecl
= gfor_fndecl_math_cpowl10
;
890 fndecl
= gfor_fndecl_math_cpowl16
;
902 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
906 /* Generate code to allocate a string temporary. */
909 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
914 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
916 if (gfc_can_put_var_on_stack (len
))
918 /* Create a temporary variable to hold the result. */
919 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
920 build_int_cst (gfc_charlen_type_node
, 1));
921 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
922 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
923 var
= gfc_create_var (tmp
, "str");
924 var
= gfc_build_addr_expr (type
, var
);
928 /* Allocate a temporary to hold the result. */
929 var
= gfc_create_var (type
, "pstr");
930 tmp
= build_call_expr (gfor_fndecl_internal_malloc
, 1, len
);
931 tmp
= convert (type
, tmp
);
932 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
934 /* Free the temporary afterwards. */
935 tmp
= convert (pvoid_type_node
, var
);
936 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmp
);
937 gfc_add_expr_to_block (&se
->post
, tmp
);
944 /* Handle a string concatenation operation. A temporary will be allocated to
948 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
957 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
958 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
960 gfc_init_se (&lse
, se
);
961 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
962 gfc_conv_string_parameter (&lse
);
963 gfc_init_se (&rse
, se
);
964 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
965 gfc_conv_string_parameter (&rse
);
967 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
968 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
970 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
971 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
972 if (len
== NULL_TREE
)
974 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
975 lse
.string_length
, rse
.string_length
);
978 type
= build_pointer_type (type
);
980 var
= gfc_conv_string_tmp (se
, type
, len
);
982 /* Do the actual concatenation. */
983 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
985 lse
.string_length
, lse
.expr
,
986 rse
.string_length
, rse
.expr
);
987 gfc_add_expr_to_block (&se
->pre
, tmp
);
989 /* Add the cleanup for the operands. */
990 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
991 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
994 se
->string_length
= len
;
997 /* Translates an op expression. Common (binary) cases are handled by this
998 function, others are passed on. Recursion is used in either case.
999 We use the fact that (op1.ts == op2.ts) (except for the power
1001 Operators need no special handling for scalarized expressions as long as
1002 they call gfc_conv_simple_val to get their operands.
1003 Character strings get special handling. */
1006 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1008 enum tree_code code
;
1018 switch (expr
->value
.op
.operator)
1020 case INTRINSIC_UPLUS
:
1021 case INTRINSIC_PARENTHESES
:
1022 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1025 case INTRINSIC_UMINUS
:
1026 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1030 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1033 case INTRINSIC_PLUS
:
1037 case INTRINSIC_MINUS
:
1041 case INTRINSIC_TIMES
:
1045 case INTRINSIC_DIVIDE
:
1046 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1047 an integer, we must round towards zero, so we use a
1049 if (expr
->ts
.type
== BT_INTEGER
)
1050 code
= TRUNC_DIV_EXPR
;
1055 case INTRINSIC_POWER
:
1056 gfc_conv_power_op (se
, expr
);
1059 case INTRINSIC_CONCAT
:
1060 gfc_conv_concat_op (se
, expr
);
1064 code
= TRUTH_ANDIF_EXPR
;
1069 code
= TRUTH_ORIF_EXPR
;
1073 /* EQV and NEQV only work on logicals, but since we represent them
1074 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1083 case INTRINSIC_NEQV
:
1113 case INTRINSIC_USER
:
1114 case INTRINSIC_ASSIGN
:
1115 /* These should be converted into function calls by the frontend. */
1119 fatal_error ("Unknown intrinsic op");
1123 /* The only exception to this is **, which is handled separately anyway. */
1124 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1126 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1130 gfc_init_se (&lse
, se
);
1131 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1132 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1135 gfc_init_se (&rse
, se
);
1136 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1137 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1141 gfc_conv_string_parameter (&lse
);
1142 gfc_conv_string_parameter (&rse
);
1144 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1145 rse
.string_length
, rse
.expr
);
1146 rse
.expr
= integer_zero_node
;
1147 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1150 type
= gfc_typenode_for_spec (&expr
->ts
);
1154 /* The result of logical ops is always boolean_type_node. */
1155 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1156 se
->expr
= convert (type
, tmp
);
1159 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1161 /* Add the post blocks. */
1162 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1163 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1166 /* If a string's length is one, we convert it to a single character. */
1169 gfc_to_single_character (tree len
, tree str
)
1171 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1173 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1174 && TREE_INT_CST_HIGH (len
) == 0)
1176 str
= fold_convert (pchar_type_node
, str
);
1177 return build_fold_indirect_ref (str
);
1183 /* Compare two strings. If they are all single characters, the result is the
1184 subtraction of them. Otherwise, we build a library call. */
1187 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1194 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1195 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1197 type
= gfc_get_int_type (gfc_default_integer_kind
);
1199 sc1
= gfc_to_single_character (len1
, str1
);
1200 sc2
= gfc_to_single_character (len2
, str2
);
1202 /* Deal with single character specially. */
1203 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1205 sc1
= fold_convert (type
, sc1
);
1206 sc2
= fold_convert (type
, sc2
);
1207 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1210 /* Build a call for the comparison. */
1211 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1212 len1
, str1
, len2
, str2
);
1217 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1221 if (sym
->attr
.dummy
)
1223 tmp
= gfc_get_symbol_decl (sym
);
1224 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1225 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1229 if (!sym
->backend_decl
)
1230 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1232 tmp
= sym
->backend_decl
;
1233 if (sym
->attr
.cray_pointee
)
1234 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1235 gfc_get_symbol_decl (sym
->cp_pointer
));
1236 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1238 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1239 tmp
= build_fold_addr_expr (tmp
);
1246 /* Translate the call for an elemental subroutine call used in an operator
1247 assignment. This is a simplified version of gfc_conv_function_call. */
1250 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1257 /* Only elemental subroutines with two arguments. */
1258 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1259 gcc_assert (sym
->formal
->next
->next
== NULL
);
1261 gfc_init_block (&block
);
1263 gfc_add_block_to_block (&block
, &lse
->pre
);
1264 gfc_add_block_to_block (&block
, &rse
->pre
);
1266 /* Build the argument list for the call, including hidden string lengths. */
1267 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1268 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1269 if (lse
->string_length
!= NULL_TREE
)
1270 args
= gfc_chainon_list (args
, lse
->string_length
);
1271 if (rse
->string_length
!= NULL_TREE
)
1272 args
= gfc_chainon_list (args
, rse
->string_length
);
1274 /* Build the function call. */
1275 gfc_init_se (&se
, NULL
);
1276 gfc_conv_function_val (&se
, sym
);
1277 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1278 tmp
= build_call_list (tmp
, se
.expr
, args
);
1279 gfc_add_expr_to_block (&block
, tmp
);
1281 gfc_add_block_to_block (&block
, &lse
->post
);
1282 gfc_add_block_to_block (&block
, &rse
->post
);
1284 return gfc_finish_block (&block
);
1288 /* Initialize MAPPING. */
1291 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1293 mapping
->syms
= NULL
;
1294 mapping
->charlens
= NULL
;
1298 /* Free all memory held by MAPPING (but not MAPPING itself). */
1301 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1303 gfc_interface_sym_mapping
*sym
;
1304 gfc_interface_sym_mapping
*nextsym
;
1306 gfc_charlen
*nextcl
;
1308 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1310 nextsym
= sym
->next
;
1311 gfc_free_symbol (sym
->new->n
.sym
);
1312 gfc_free (sym
->new);
1315 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1318 gfc_free_expr (cl
->length
);
1324 /* Return a copy of gfc_charlen CL. Add the returned structure to
1325 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1327 static gfc_charlen
*
1328 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1333 new = gfc_get_charlen ();
1334 new->next
= mapping
->charlens
;
1335 new->length
= gfc_copy_expr (cl
->length
);
1337 mapping
->charlens
= new;
1342 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1343 array variable that can be used as the actual argument for dummy
1344 argument SYM. Add any initialization code to BLOCK. PACKED is as
1345 for gfc_get_nodesc_array_type and DATA points to the first element
1346 in the passed array. */
1349 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1350 int packed
, tree data
)
1355 type
= gfc_typenode_for_spec (&sym
->ts
);
1356 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1358 var
= gfc_create_var (type
, "ifm");
1359 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1365 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1366 and offset of descriptorless array type TYPE given that it has the same
1367 size as DESC. Add any set-up code to BLOCK. */
1370 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1377 offset
= gfc_index_zero_node
;
1378 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1380 dim
= gfc_rank_cst
[n
];
1381 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1382 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1384 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1385 = gfc_conv_descriptor_lbound (desc
, dim
);
1386 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1387 = gfc_conv_descriptor_ubound (desc
, dim
);
1389 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1391 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1392 gfc_conv_descriptor_ubound (desc
, dim
),
1393 gfc_conv_descriptor_lbound (desc
, dim
));
1394 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1395 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1397 tmp
= gfc_evaluate_now (tmp
, block
);
1398 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1400 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1401 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1402 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1403 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1405 offset
= gfc_evaluate_now (offset
, block
);
1406 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1410 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1411 in SE. The caller may still use se->expr and se->string_length after
1412 calling this function. */
1415 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1416 gfc_symbol
* sym
, gfc_se
* se
)
1418 gfc_interface_sym_mapping
*sm
;
1422 gfc_symbol
*new_sym
;
1424 gfc_symtree
*new_symtree
;
1426 /* Create a new symbol to represent the actual argument. */
1427 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1428 new_sym
->ts
= sym
->ts
;
1429 new_sym
->attr
.referenced
= 1;
1430 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1431 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1432 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1433 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1435 /* Create a fake symtree for it. */
1437 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1438 new_symtree
->n
.sym
= new_sym
;
1439 gcc_assert (new_symtree
== root
);
1441 /* Create a dummy->actual mapping. */
1442 sm
= gfc_getmem (sizeof (*sm
));
1443 sm
->next
= mapping
->syms
;
1445 sm
->new = new_symtree
;
1448 /* Stabilize the argument's value. */
1449 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1451 if (sym
->ts
.type
== BT_CHARACTER
)
1453 /* Create a copy of the dummy argument's length. */
1454 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1456 /* If the length is specified as "*", record the length that
1457 the caller is passing. We should use the callee's length
1458 in all other cases. */
1459 if (!new_sym
->ts
.cl
->length
)
1461 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1462 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1466 /* Use the passed value as-is if the argument is a function. */
1467 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1470 /* If the argument is either a string or a pointer to a string,
1471 convert it to a boundless character type. */
1472 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1474 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1475 tmp
= build_pointer_type (tmp
);
1476 if (sym
->attr
.pointer
)
1477 value
= build_fold_indirect_ref (se
->expr
);
1480 value
= fold_convert (tmp
, value
);
1483 /* If the argument is a scalar, a pointer to an array or an allocatable,
1485 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1486 value
= build_fold_indirect_ref (se
->expr
);
1488 /* For character(*), use the actual argument's descriptor. */
1489 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1490 value
= build_fold_indirect_ref (se
->expr
);
1492 /* If the argument is an array descriptor, use it to determine
1493 information about the actual argument's shape. */
1494 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1495 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1497 /* Get the actual argument's descriptor. */
1498 desc
= build_fold_indirect_ref (se
->expr
);
1500 /* Create the replacement variable. */
1501 tmp
= gfc_conv_descriptor_data_get (desc
);
1502 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1504 /* Use DESC to work out the upper bounds, strides and offset. */
1505 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1508 /* Otherwise we have a packed array. */
1509 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1511 new_sym
->backend_decl
= value
;
1515 /* Called once all dummy argument mappings have been added to MAPPING,
1516 but before the mapping is used to evaluate expressions. Pre-evaluate
1517 the length of each argument, adding any initialization code to PRE and
1518 any finalization code to POST. */
1521 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1522 stmtblock_t
* pre
, stmtblock_t
* post
)
1524 gfc_interface_sym_mapping
*sym
;
1528 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1529 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1530 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1532 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1533 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1534 gfc_init_se (&se
, NULL
);
1535 gfc_conv_expr (&se
, expr
);
1537 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1538 gfc_add_block_to_block (pre
, &se
.pre
);
1539 gfc_add_block_to_block (post
, &se
.post
);
1541 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1546 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1550 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1551 gfc_constructor
* c
)
1553 for (; c
; c
= c
->next
)
1555 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1558 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1559 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1560 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1566 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1570 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1575 for (; ref
; ref
= ref
->next
)
1579 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1581 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1582 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1583 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1585 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1592 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1593 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1599 /* EXPR is a copy of an expression that appeared in the interface
1600 associated with MAPPING. Walk it recursively looking for references to
1601 dummy arguments that MAPPING maps to actual arguments. Replace each such
1602 reference with a reference to the associated actual argument. */
1605 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1608 gfc_interface_sym_mapping
*sym
;
1609 gfc_actual_arglist
*actual
;
1614 /* Copying an expression does not copy its length, so do that here. */
1615 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1617 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1618 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1621 /* Apply the mapping to any references. */
1622 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1624 /* ...and to the expression's symbol, if it has one. */
1626 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1627 if (sym
->old
== expr
->symtree
->n
.sym
)
1628 expr
->symtree
= sym
->new;
1630 /* ...and to subexpressions in expr->value. */
1631 switch (expr
->expr_type
)
1636 case EXPR_SUBSTRING
:
1640 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1641 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1645 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1646 if (sym
->old
== expr
->value
.function
.esym
)
1647 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1649 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1650 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1654 case EXPR_STRUCTURE
:
1655 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1661 /* Evaluate interface expression EXPR using MAPPING. Store the result
1665 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1666 gfc_se
* se
, gfc_expr
* expr
)
1668 expr
= gfc_copy_expr (expr
);
1669 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1670 gfc_conv_expr (se
, expr
);
1671 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1672 gfc_free_expr (expr
);
1675 /* Returns a reference to a temporary array into which a component of
1676 an actual argument derived type array is copied and then returned
1677 after the function call.
1678 TODO Get rid of this kludge, when array descriptors are capable of
1679 handling arrays with a bigger stride in bytes than size. */
1682 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1683 int g77
, sym_intent intent
)
1699 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1701 gfc_init_se (&lse
, NULL
);
1702 gfc_init_se (&rse
, NULL
);
1704 /* Walk the argument expression. */
1705 rss
= gfc_walk_expr (expr
);
1707 gcc_assert (rss
!= gfc_ss_terminator
);
1709 /* Initialize the scalarizer. */
1710 gfc_init_loopinfo (&loop
);
1711 gfc_add_ss_to_loop (&loop
, rss
);
1713 /* Calculate the bounds of the scalarization. */
1714 gfc_conv_ss_startstride (&loop
);
1716 /* Build an ss for the temporary. */
1717 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1718 if (GFC_ARRAY_TYPE_P (base_type
)
1719 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1720 base_type
= gfc_get_element_type (base_type
);
1722 loop
.temp_ss
= gfc_get_ss ();;
1723 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1724 loop
.temp_ss
->data
.temp
.type
= base_type
;
1726 if (expr
->ts
.type
== BT_CHARACTER
)
1728 gfc_ref
*char_ref
= expr
->ref
;
1730 for (; char_ref
; char_ref
= char_ref
->next
)
1731 if (char_ref
->type
== REF_SUBSTRING
)
1735 expr
->ts
.cl
= gfc_get_charlen ();
1736 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1737 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1739 gfc_init_se (&tmp_se
, NULL
);
1740 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1741 gfc_array_index_type
);
1742 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1743 tmp_se
.expr
, gfc_index_one_node
);
1744 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1745 gfc_init_se (&tmp_se
, NULL
);
1746 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1747 gfc_array_index_type
);
1748 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1750 expr
->ts
.cl
->backend_decl
= tmp
;
1754 loop
.temp_ss
->data
.temp
.type
1755 = gfc_typenode_for_spec (&expr
->ts
);
1756 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1759 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1760 loop
.temp_ss
->next
= gfc_ss_terminator
;
1762 /* Associate the SS with the loop. */
1763 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1765 /* Setup the scalarizing loops. */
1766 gfc_conv_loop_setup (&loop
);
1768 /* Pass the temporary descriptor back to the caller. */
1769 info
= &loop
.temp_ss
->data
.info
;
1770 parmse
->expr
= info
->descriptor
;
1772 /* Setup the gfc_se structures. */
1773 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1774 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1777 lse
.ss
= loop
.temp_ss
;
1778 gfc_mark_ss_chain_used (rss
, 1);
1779 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1781 /* Start the scalarized loop body. */
1782 gfc_start_scalarized_body (&loop
, &body
);
1784 /* Translate the expression. */
1785 gfc_conv_expr (&rse
, expr
);
1787 gfc_conv_tmp_array_ref (&lse
);
1788 gfc_advance_se_ss_chain (&lse
);
1790 if (intent
!= INTENT_OUT
)
1792 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1793 gfc_add_expr_to_block (&body
, tmp
);
1794 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1795 gfc_trans_scalarizing_loops (&loop
, &body
);
1799 /* Make sure that the temporary declaration survives by merging
1800 all the loop declarations into the current context. */
1801 for (n
= 0; n
< loop
.dimen
; n
++)
1803 gfc_merge_block_scope (&body
);
1804 body
= loop
.code
[loop
.order
[n
]];
1806 gfc_merge_block_scope (&body
);
1809 /* Add the post block after the second loop, so that any
1810 freeing of allocated memory is done at the right time. */
1811 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1813 /**********Copy the temporary back again.*********/
1815 gfc_init_se (&lse
, NULL
);
1816 gfc_init_se (&rse
, NULL
);
1818 /* Walk the argument expression. */
1819 lss
= gfc_walk_expr (expr
);
1820 rse
.ss
= loop
.temp_ss
;
1823 /* Initialize the scalarizer. */
1824 gfc_init_loopinfo (&loop2
);
1825 gfc_add_ss_to_loop (&loop2
, lss
);
1827 /* Calculate the bounds of the scalarization. */
1828 gfc_conv_ss_startstride (&loop2
);
1830 /* Setup the scalarizing loops. */
1831 gfc_conv_loop_setup (&loop2
);
1833 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1834 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1836 gfc_mark_ss_chain_used (lss
, 1);
1837 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1839 /* Declare the variable to hold the temporary offset and start the
1840 scalarized loop body. */
1841 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1842 gfc_start_scalarized_body (&loop2
, &body
);
1844 /* Build the offsets for the temporary from the loop variables. The
1845 temporary array has lbounds of zero and strides of one in all
1846 dimensions, so this is very simple. The offset is only computed
1847 outside the innermost loop, so the overall transfer could be
1848 optimized further. */
1849 info
= &rse
.ss
->data
.info
;
1851 tmp_index
= gfc_index_zero_node
;
1852 for (n
= info
->dimen
- 1; n
> 0; n
--)
1855 tmp
= rse
.loop
->loopvar
[n
];
1856 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1857 tmp
, rse
.loop
->from
[n
]);
1858 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1861 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1862 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1863 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1864 tmp_str
, gfc_index_one_node
);
1866 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1870 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1871 tmp_index
, rse
.loop
->from
[0]);
1872 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1874 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1875 rse
.loop
->loopvar
[0], offset
);
1877 /* Now use the offset for the reference. */
1878 tmp
= build_fold_indirect_ref (info
->data
);
1879 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1881 if (expr
->ts
.type
== BT_CHARACTER
)
1882 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1884 gfc_conv_expr (&lse
, expr
);
1886 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1888 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1889 gfc_add_expr_to_block (&body
, tmp
);
1891 /* Generate the copying loops. */
1892 gfc_trans_scalarizing_loops (&loop2
, &body
);
1894 /* Wrap the whole thing up by adding the second loop to the post-block
1895 and following it by the post-block of the first loop. In this way,
1896 if the temporary needs freeing, it is done after use! */
1897 if (intent
!= INTENT_IN
)
1899 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1900 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1903 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1905 gfc_cleanup_loop (&loop
);
1906 gfc_cleanup_loop (&loop2
);
1908 /* Pass the string length to the argument expression. */
1909 if (expr
->ts
.type
== BT_CHARACTER
)
1910 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1912 /* We want either the address for the data or the address of the descriptor,
1913 depending on the mode of passing array arguments. */
1915 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1917 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1922 /* Is true if an array reference is followed by a component or substring
1926 is_aliased_array (gfc_expr
* e
)
1932 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1934 if (ref
->type
== REF_ARRAY
1935 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1939 && ref
->type
!= REF_ARRAY
)
1945 /* Generate the code for argument list functions. */
1948 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
1950 /* Pass by value for g77 %VAL(arg), pass the address
1951 indirectly for %LOC, else by reference. Thus %REF
1952 is a "do-nothing" and %LOC is the same as an F95
1954 if (strncmp (name
, "%VAL", 4) == 0)
1955 gfc_conv_expr (se
, expr
);
1956 else if (strncmp (name
, "%LOC", 4) == 0)
1958 gfc_conv_expr_reference (se
, expr
);
1959 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
1961 else if (strncmp (name
, "%REF", 4) == 0)
1962 gfc_conv_expr_reference (se
, expr
);
1964 gfc_error ("Unknown argument list function at %L", &expr
->where
);
1968 /* Generate code for a procedure call. Note can return se->post != NULL.
1969 If se->direct_byref is set then se->expr contains the return parameter.
1970 Return nonzero, if the call has alternate specifiers. */
1973 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1974 gfc_actual_arglist
* arg
, tree append_args
)
1976 gfc_interface_mapping mapping
;
1990 gfc_formal_arglist
*formal
;
1991 int has_alternate_specifier
= 0;
1992 bool need_interface_mapping
;
1999 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2001 arglist
= NULL_TREE
;
2002 retargs
= NULL_TREE
;
2003 stringargs
= NULL_TREE
;
2009 if (!sym
->attr
.elemental
)
2011 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2012 if (se
->ss
->useflags
)
2014 gcc_assert (gfc_return_by_reference (sym
)
2015 && sym
->result
->attr
.dimension
);
2016 gcc_assert (se
->loop
!= NULL
);
2018 /* Access the previously obtained result. */
2019 gfc_conv_tmp_array_ref (se
);
2020 gfc_advance_se_ss_chain (se
);
2024 info
= &se
->ss
->data
.info
;
2029 gfc_init_block (&post
);
2030 gfc_init_interface_mapping (&mapping
);
2031 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2032 && sym
->ts
.cl
->length
2033 && sym
->ts
.cl
->length
->expr_type
2035 || sym
->attr
.dimension
);
2036 formal
= sym
->formal
;
2037 /* Evaluate the arguments. */
2038 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2041 fsym
= formal
? formal
->sym
: NULL
;
2042 parm_kind
= MISSING
;
2046 if (se
->ignore_optional
)
2048 /* Some intrinsics have already been resolved to the correct
2052 else if (arg
->label
)
2054 has_alternate_specifier
= 1;
2059 /* Pass a NULL pointer for an absent arg. */
2060 gfc_init_se (&parmse
, NULL
);
2061 parmse
.expr
= null_pointer_node
;
2062 if (arg
->missing_arg_type
== BT_CHARACTER
)
2063 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2066 else if (se
->ss
&& se
->ss
->useflags
)
2068 /* An elemental function inside a scalarized loop. */
2069 gfc_init_se (&parmse
, se
);
2070 gfc_conv_expr_reference (&parmse
, e
);
2071 parm_kind
= ELEMENTAL
;
2075 /* A scalar or transformational function. */
2076 gfc_init_se (&parmse
, NULL
);
2077 argss
= gfc_walk_expr (e
);
2079 if (argss
== gfc_ss_terminator
)
2082 if (fsym
&& fsym
->attr
.value
)
2084 gfc_conv_expr (&parmse
, e
);
2086 else if (arg
->name
&& arg
->name
[0] == '%')
2087 /* Argument list functions %VAL, %LOC and %REF are signalled
2088 through arg->name. */
2089 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2092 gfc_conv_expr_reference (&parmse
, e
);
2093 if (fsym
&& fsym
->attr
.pointer
2094 && e
->expr_type
!= EXPR_NULL
)
2096 /* Scalar pointer dummy args require an extra level of
2097 indirection. The null pointer already contains
2098 this level of indirection. */
2099 parm_kind
= SCALAR_POINTER
;
2100 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2106 /* If the procedure requires an explicit interface, the actual
2107 argument is passed according to the corresponding formal
2108 argument. If the corresponding formal argument is a POINTER,
2109 ALLOCATABLE or assumed shape, we do not use g77's calling
2110 convention, and pass the address of the array descriptor
2111 instead. Otherwise we use g77's calling convention. */
2114 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2115 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2116 f
= f
|| !sym
->attr
.always_explicit
;
2118 if (e
->expr_type
== EXPR_VARIABLE
2119 && is_aliased_array (e
))
2120 /* The actual argument is a component reference to an
2121 array of derived types. In this case, the argument
2122 is converted to a temporary, which is passed and then
2123 written back after the procedure call. */
2124 gfc_conv_aliased_arg (&parmse
, e
, f
,
2125 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2127 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2129 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2130 allocated on entry, it must be deallocated. */
2131 if (fsym
&& fsym
->attr
.allocatable
2132 && fsym
->attr
.intent
== INTENT_OUT
)
2134 tmp
= build_fold_indirect_ref (parmse
.expr
);
2135 tmp
= gfc_trans_dealloc_allocated (tmp
);
2136 gfc_add_expr_to_block (&se
->pre
, tmp
);
2146 /* If an optional argument is itself an optional dummy
2147 argument, check its presence and substitute a null
2149 if (e
->expr_type
== EXPR_VARIABLE
2150 && e
->symtree
->n
.sym
->attr
.optional
2151 && fsym
->attr
.optional
)
2152 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2154 /* If an INTENT(OUT) dummy of derived type has a default
2155 initializer, it must be (re)initialized here. */
2156 if (fsym
->attr
.intent
== INTENT_OUT
2157 && fsym
->ts
.type
== BT_DERIVED
2160 gcc_assert (!fsym
->attr
.allocatable
);
2161 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2162 gfc_add_expr_to_block (&se
->pre
, tmp
);
2165 /* Obtain the character length of an assumed character
2166 length procedure from the typespec. */
2167 if (fsym
->ts
.type
== BT_CHARACTER
2168 && parmse
.string_length
== NULL_TREE
2169 && e
->ts
.type
== BT_PROCEDURE
2170 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2171 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2173 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2174 parmse
.string_length
2175 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2179 if (need_interface_mapping
)
2180 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2183 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2184 gfc_add_block_to_block (&post
, &parmse
.post
);
2186 /* Allocated allocatable components of derived types must be
2187 deallocated for INTENT(OUT) dummy arguments and non-variable
2188 scalars. Non-variable arrays are dealt with in trans-array.c
2189 (gfc_conv_array_parameter). */
2190 if (e
&& e
->ts
.type
== BT_DERIVED
2191 && e
->ts
.derived
->attr
.alloc_comp
2192 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2194 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2197 tmp
= build_fold_indirect_ref (parmse
.expr
);
2198 parm_rank
= e
->rank
;
2206 case (SCALAR_POINTER
):
2207 tmp
= build_fold_indirect_ref (tmp
);
2214 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2215 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2216 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2217 tmp
, build_empty_stmt ());
2219 if (e
->expr_type
!= EXPR_VARIABLE
)
2220 /* Don't deallocate non-variables until they have been used. */
2221 gfc_add_expr_to_block (&se
->post
, tmp
);
2224 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2225 gfc_add_expr_to_block (&se
->pre
, tmp
);
2229 /* Character strings are passed as two parameters, a length and a
2231 if (parmse
.string_length
!= NULL_TREE
)
2232 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2234 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2236 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2239 if (ts
.type
== BT_CHARACTER
)
2241 if (sym
->ts
.cl
->length
== NULL
)
2243 /* Assumed character length results are not allowed by 5.1.1.5 of the
2244 standard and are trapped in resolve.c; except in the case of SPREAD
2245 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2246 we take the character length of the first argument for the result.
2247 For dummies, we have to look through the formal argument list for
2248 this function and use the character length found there.*/
2249 if (!sym
->attr
.dummy
)
2250 cl
.backend_decl
= TREE_VALUE (stringargs
);
2253 formal
= sym
->ns
->proc_name
->formal
;
2254 for (; formal
; formal
= formal
->next
)
2255 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2256 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2263 /* Calculate the length of the returned string. */
2264 gfc_init_se (&parmse
, NULL
);
2265 if (need_interface_mapping
)
2266 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2268 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2269 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2270 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2272 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2273 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2274 build_int_cst (gfc_charlen_type_node
, 0));
2275 cl
.backend_decl
= tmp
;
2278 /* Set up a charlen structure for it. */
2283 len
= cl
.backend_decl
;
2286 byref
= gfc_return_by_reference (sym
);
2289 if (se
->direct_byref
)
2290 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2291 else if (sym
->result
->attr
.dimension
)
2293 gcc_assert (se
->loop
&& info
);
2295 /* Set the type of the array. */
2296 tmp
= gfc_typenode_for_spec (&ts
);
2297 info
->dimen
= se
->loop
->dimen
;
2299 /* Evaluate the bounds of the result, if known. */
2300 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2302 /* Create a temporary to store the result. In case the function
2303 returns a pointer, the temporary will be a shallow copy and
2304 mustn't be deallocated. */
2305 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2306 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2307 false, !sym
->attr
.pointer
, callee_alloc
);
2309 /* Pass the temporary as the first argument. */
2310 tmp
= info
->descriptor
;
2311 tmp
= build_fold_addr_expr (tmp
);
2312 retargs
= gfc_chainon_list (retargs
, tmp
);
2314 else if (ts
.type
== BT_CHARACTER
)
2316 /* Pass the string length. */
2317 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2318 type
= build_pointer_type (type
);
2320 /* Return an address to a char[0:len-1]* temporary for
2321 character pointers. */
2322 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2324 /* Build char[0:len-1] * pstr. */
2325 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2326 build_int_cst (gfc_charlen_type_node
, 1));
2327 tmp
= build_range_type (gfc_array_index_type
,
2328 gfc_index_zero_node
, tmp
);
2329 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2330 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2332 /* Provide an address expression for the function arguments. */
2333 var
= build_fold_addr_expr (var
);
2336 var
= gfc_conv_string_tmp (se
, type
, len
);
2338 retargs
= gfc_chainon_list (retargs
, var
);
2342 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2344 type
= gfc_get_complex_type (ts
.kind
);
2345 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2346 retargs
= gfc_chainon_list (retargs
, var
);
2349 /* Add the string length to the argument list. */
2350 if (ts
.type
== BT_CHARACTER
)
2351 retargs
= gfc_chainon_list (retargs
, len
);
2353 gfc_free_interface_mapping (&mapping
);
2355 /* Add the return arguments. */
2356 arglist
= chainon (retargs
, arglist
);
2358 /* Add the hidden string length parameters to the arguments. */
2359 arglist
= chainon (arglist
, stringargs
);
2361 /* We may want to append extra arguments here. This is used e.g. for
2362 calls to libgfortran_matmul_??, which need extra information. */
2363 if (append_args
!= NULL_TREE
)
2364 arglist
= chainon (arglist
, append_args
);
2366 /* Generate the actual call. */
2367 gfc_conv_function_val (se
, sym
);
2368 /* If there are alternate return labels, function type should be
2369 integer. Can't modify the type in place though, since it can be shared
2370 with other functions. */
2371 if (has_alternate_specifier
2372 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2374 gcc_assert (! sym
->attr
.dummy
);
2375 TREE_TYPE (sym
->backend_decl
)
2376 = build_function_type (integer_type_node
,
2377 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2378 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2381 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2382 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2384 /* If we have a pointer function, but we don't want a pointer, e.g.
2387 where f is pointer valued, we have to dereference the result. */
2388 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2389 se
->expr
= build_fold_indirect_ref (se
->expr
);
2391 /* f2c calling conventions require a scalar default real function to
2392 return a double precision result. Convert this back to default
2393 real. We only care about the cases that can happen in Fortran 77.
2395 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2396 && sym
->ts
.kind
== gfc_default_real_kind
2397 && !sym
->attr
.always_explicit
)
2398 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2400 /* A pure function may still have side-effects - it may modify its
2402 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2404 if (!sym
->attr
.pure
)
2405 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2410 /* Add the function call to the pre chain. There is no expression. */
2411 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2412 se
->expr
= NULL_TREE
;
2414 if (!se
->direct_byref
)
2416 if (sym
->attr
.dimension
)
2418 if (flag_bounds_check
)
2420 /* Check the data pointer hasn't been modified. This would
2421 happen in a function returning a pointer. */
2422 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2423 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2425 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2427 se
->expr
= info
->descriptor
;
2428 /* Bundle in the string length. */
2429 se
->string_length
= len
;
2431 else if (sym
->ts
.type
== BT_CHARACTER
)
2433 /* Dereference for character pointer results. */
2434 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2435 se
->expr
= build_fold_indirect_ref (var
);
2439 se
->string_length
= len
;
2443 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2444 se
->expr
= build_fold_indirect_ref (var
);
2449 /* Follow the function call with the argument post block. */
2451 gfc_add_block_to_block (&se
->pre
, &post
);
2453 gfc_add_block_to_block (&se
->post
, &post
);
2455 return has_alternate_specifier
;
2459 /* Generate code to copy a string. */
2462 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2463 tree slength
, tree src
)
2465 tree tmp
, dlen
, slen
;
2473 stmtblock_t tempblock
;
2475 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2476 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2478 /* Deal with single character specially. */
2479 dsc
= gfc_to_single_character (dlen
, dest
);
2480 ssc
= gfc_to_single_character (slen
, src
);
2481 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2483 gfc_add_modify_expr (block
, dsc
, ssc
);
2487 /* Do nothing if the destination length is zero. */
2488 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2489 build_int_cst (gfc_charlen_type_node
, 0));
2491 /* The following code was previously in _gfortran_copy_string:
2493 // The two strings may overlap so we use memmove.
2495 copy_string (GFC_INTEGER_4 destlen, char * dest,
2496 GFC_INTEGER_4 srclen, const char * src)
2498 if (srclen >= destlen)
2500 // This will truncate if too long.
2501 memmove (dest, src, destlen);
2505 memmove (dest, src, srclen);
2507 memset (&dest[srclen], ' ', destlen - srclen);
2511 We're now doing it here for better optimization, but the logic
2514 /* Truncate string if source is too long. */
2515 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2516 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2517 3, dest
, src
, dlen
);
2519 /* Else copy and pad with spaces. */
2520 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2521 3, dest
, src
, slen
);
2523 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2524 fold_convert (pchar_type_node
, slen
));
2525 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2527 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2528 lang_hooks
.to_target_charset (' ')),
2529 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2532 gfc_init_block (&tempblock
);
2533 gfc_add_expr_to_block (&tempblock
, tmp3
);
2534 gfc_add_expr_to_block (&tempblock
, tmp4
);
2535 tmp3
= gfc_finish_block (&tempblock
);
2537 /* The whole copy_string function is there. */
2538 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2539 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2540 gfc_add_expr_to_block (block
, tmp
);
2544 /* Translate a statement function.
2545 The value of a statement function reference is obtained by evaluating the
2546 expression using the values of the actual arguments for the values of the
2547 corresponding dummy arguments. */
2550 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2554 gfc_formal_arglist
*fargs
;
2555 gfc_actual_arglist
*args
;
2558 gfc_saved_var
*saved_vars
;
2564 sym
= expr
->symtree
->n
.sym
;
2565 args
= expr
->value
.function
.actual
;
2566 gfc_init_se (&lse
, NULL
);
2567 gfc_init_se (&rse
, NULL
);
2570 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2572 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2573 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2575 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2577 /* Each dummy shall be specified, explicitly or implicitly, to be
2579 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2582 /* Create a temporary to hold the value. */
2583 type
= gfc_typenode_for_spec (&fsym
->ts
);
2584 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2586 if (fsym
->ts
.type
== BT_CHARACTER
)
2588 /* Copy string arguments. */
2591 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2592 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2594 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2595 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2598 gfc_conv_expr (&rse
, args
->expr
);
2599 gfc_conv_string_parameter (&rse
);
2600 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2601 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2603 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2605 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2606 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2610 /* For everything else, just evaluate the expression. */
2611 gfc_conv_expr (&lse
, args
->expr
);
2613 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2614 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2615 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2621 /* Use the temporary variables in place of the real ones. */
2622 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2623 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2625 gfc_conv_expr (se
, sym
->value
);
2627 if (sym
->ts
.type
== BT_CHARACTER
)
2629 gfc_conv_const_charlen (sym
->ts
.cl
);
2631 /* Force the expression to the correct length. */
2632 if (!INTEGER_CST_P (se
->string_length
)
2633 || tree_int_cst_lt (se
->string_length
,
2634 sym
->ts
.cl
->backend_decl
))
2636 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2637 tmp
= gfc_create_var (type
, sym
->name
);
2638 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2639 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2640 se
->string_length
, se
->expr
);
2643 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2646 /* Restore the original variables. */
2647 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2648 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2649 gfc_free (saved_vars
);
2653 /* Translate a function expression. */
2656 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2660 if (expr
->value
.function
.isym
)
2662 gfc_conv_intrinsic_function (se
, expr
);
2666 /* We distinguish statement functions from general functions to improve
2667 runtime performance. */
2668 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2670 gfc_conv_statement_function (se
, expr
);
2674 /* expr.value.function.esym is the resolved (specific) function symbol for
2675 most functions. However this isn't set for dummy procedures. */
2676 sym
= expr
->value
.function
.esym
;
2678 sym
= expr
->symtree
->n
.sym
;
2679 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2684 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2686 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2687 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2689 gfc_conv_tmp_array_ref (se
);
2690 gfc_advance_se_ss_chain (se
);
2694 /* Build a static initializer. EXPR is the expression for the initial value.
2695 The other parameters describe the variable of the component being
2696 initialized. EXPR may be null. */
2699 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2700 bool array
, bool pointer
)
2704 if (!(expr
|| pointer
))
2709 /* Arrays need special handling. */
2711 return gfc_build_null_descriptor (type
);
2713 return gfc_conv_array_initializer (type
, expr
);
2716 return fold_convert (type
, null_pointer_node
);
2722 gfc_init_se (&se
, NULL
);
2723 gfc_conv_structure (&se
, expr
, 1);
2727 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2730 gfc_init_se (&se
, NULL
);
2731 gfc_conv_constant (&se
, expr
);
2738 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2750 gfc_start_block (&block
);
2752 /* Initialize the scalarizer. */
2753 gfc_init_loopinfo (&loop
);
2755 gfc_init_se (&lse
, NULL
);
2756 gfc_init_se (&rse
, NULL
);
2759 rss
= gfc_walk_expr (expr
);
2760 if (rss
== gfc_ss_terminator
)
2762 /* The rhs is scalar. Add a ss for the expression. */
2763 rss
= gfc_get_ss ();
2764 rss
->next
= gfc_ss_terminator
;
2765 rss
->type
= GFC_SS_SCALAR
;
2769 /* Create a SS for the destination. */
2770 lss
= gfc_get_ss ();
2771 lss
->type
= GFC_SS_COMPONENT
;
2773 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2774 lss
->next
= gfc_ss_terminator
;
2775 lss
->data
.info
.dimen
= cm
->as
->rank
;
2776 lss
->data
.info
.descriptor
= dest
;
2777 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2778 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2779 for (n
= 0; n
< cm
->as
->rank
; n
++)
2781 lss
->data
.info
.dim
[n
] = n
;
2782 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2783 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2785 mpz_init (lss
->shape
[n
]);
2786 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2787 cm
->as
->lower
[n
]->value
.integer
);
2788 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2791 /* Associate the SS with the loop. */
2792 gfc_add_ss_to_loop (&loop
, lss
);
2793 gfc_add_ss_to_loop (&loop
, rss
);
2795 /* Calculate the bounds of the scalarization. */
2796 gfc_conv_ss_startstride (&loop
);
2798 /* Setup the scalarizing loops. */
2799 gfc_conv_loop_setup (&loop
);
2801 /* Setup the gfc_se structures. */
2802 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2803 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2806 gfc_mark_ss_chain_used (rss
, 1);
2808 gfc_mark_ss_chain_used (lss
, 1);
2810 /* Start the scalarized loop body. */
2811 gfc_start_scalarized_body (&loop
, &body
);
2813 gfc_conv_tmp_array_ref (&lse
);
2814 if (cm
->ts
.type
== BT_CHARACTER
)
2815 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2817 gfc_conv_expr (&rse
, expr
);
2819 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2820 gfc_add_expr_to_block (&body
, tmp
);
2822 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2824 /* Generate the copying loops. */
2825 gfc_trans_scalarizing_loops (&loop
, &body
);
2827 /* Wrap the whole thing up. */
2828 gfc_add_block_to_block (&block
, &loop
.pre
);
2829 gfc_add_block_to_block (&block
, &loop
.post
);
2831 for (n
= 0; n
< cm
->as
->rank
; n
++)
2832 mpz_clear (lss
->shape
[n
]);
2833 gfc_free (lss
->shape
);
2835 gfc_cleanup_loop (&loop
);
2837 return gfc_finish_block (&block
);
2841 /* Assign a single component of a derived type constructor. */
2844 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2854 gfc_start_block (&block
);
2858 gfc_init_se (&se
, NULL
);
2859 /* Pointer component. */
2862 /* Array pointer. */
2863 if (expr
->expr_type
== EXPR_NULL
)
2864 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2867 rss
= gfc_walk_expr (expr
);
2868 se
.direct_byref
= 1;
2870 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2871 gfc_add_block_to_block (&block
, &se
.pre
);
2872 gfc_add_block_to_block (&block
, &se
.post
);
2877 /* Scalar pointers. */
2878 se
.want_pointer
= 1;
2879 gfc_conv_expr (&se
, expr
);
2880 gfc_add_block_to_block (&block
, &se
.pre
);
2881 gfc_add_modify_expr (&block
, dest
,
2882 fold_convert (TREE_TYPE (dest
), se
.expr
));
2883 gfc_add_block_to_block (&block
, &se
.post
);
2886 else if (cm
->dimension
)
2888 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2889 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2890 else if (cm
->allocatable
)
2894 gfc_init_se (&se
, NULL
);
2896 rss
= gfc_walk_expr (expr
);
2897 se
.want_pointer
= 0;
2898 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2899 gfc_add_block_to_block (&block
, &se
.pre
);
2901 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2902 gfc_add_modify_expr (&block
, dest
, tmp
);
2904 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2905 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2908 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2909 TREE_TYPE(cm
->backend_decl
),
2912 gfc_add_expr_to_block (&block
, tmp
);
2914 gfc_add_block_to_block (&block
, &se
.post
);
2915 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2917 /* Shift the lbound and ubound of temporaries to being unity, rather
2918 than zero, based. Calculate the offset for all cases. */
2919 offset
= gfc_conv_descriptor_offset (dest
);
2920 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2921 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2922 for (n
= 0; n
< expr
->rank
; n
++)
2924 if (expr
->expr_type
!= EXPR_VARIABLE
2925 && expr
->expr_type
!= EXPR_CONSTANT
)
2927 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2928 gfc_add_modify_expr (&block
, tmp
,
2929 fold_build2 (PLUS_EXPR
,
2930 gfc_array_index_type
,
2931 tmp
, gfc_index_one_node
));
2932 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2933 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2935 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2936 gfc_conv_descriptor_lbound (dest
,
2938 gfc_conv_descriptor_stride (dest
,
2940 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2941 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2942 gfc_add_modify_expr (&block
, offset
, tmp
);
2947 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2948 gfc_add_expr_to_block (&block
, tmp
);
2951 else if (expr
->ts
.type
== BT_DERIVED
)
2953 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2955 gfc_init_se (&se
, NULL
);
2956 gfc_conv_expr (&se
, expr
);
2957 gfc_add_modify_expr (&block
, dest
,
2958 fold_convert (TREE_TYPE (dest
), se
.expr
));
2962 /* Nested constructors. */
2963 tmp
= gfc_trans_structure_assign (dest
, expr
);
2964 gfc_add_expr_to_block (&block
, tmp
);
2969 /* Scalar component. */
2970 gfc_init_se (&se
, NULL
);
2971 gfc_init_se (&lse
, NULL
);
2973 gfc_conv_expr (&se
, expr
);
2974 if (cm
->ts
.type
== BT_CHARACTER
)
2975 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2977 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
2978 gfc_add_expr_to_block (&block
, tmp
);
2980 return gfc_finish_block (&block
);
2983 /* Assign a derived type constructor to a variable. */
2986 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2994 gfc_start_block (&block
);
2995 cm
= expr
->ts
.derived
->components
;
2996 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2998 /* Skip absent members in default initializers. */
3002 field
= cm
->backend_decl
;
3003 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3004 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3005 gfc_add_expr_to_block (&block
, tmp
);
3007 return gfc_finish_block (&block
);
3010 /* Build an expression for a constructor. If init is nonzero then
3011 this is part of a static variable initializer. */
3014 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3021 VEC(constructor_elt
,gc
) *v
= NULL
;
3023 gcc_assert (se
->ss
== NULL
);
3024 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3025 type
= gfc_typenode_for_spec (&expr
->ts
);
3029 /* Create a temporary variable and fill it in. */
3030 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3031 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3032 gfc_add_expr_to_block (&se
->pre
, tmp
);
3036 cm
= expr
->ts
.derived
->components
;
3038 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3040 /* Skip absent members in default initializers and allocatable
3041 components. Although the latter have a default initializer
3042 of EXPR_NULL,... by default, the static nullify is not needed
3043 since this is done every time we come into scope. */
3044 if (!c
->expr
|| cm
->allocatable
)
3047 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3048 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3050 /* Append it to the constructor list. */
3051 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3053 se
->expr
= build_constructor (type
, v
);
3057 /* Translate a substring expression. */
3060 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3066 gcc_assert (ref
->type
== REF_SUBSTRING
);
3068 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3069 expr
->value
.character
.string
);
3070 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3071 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3073 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3077 /* Entry point for expression translation. Evaluates a scalar quantity.
3078 EXPR is the expression to be translated, and SE is the state structure if
3079 called from within the scalarized. */
3082 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3084 if (se
->ss
&& se
->ss
->expr
== expr
3085 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3087 /* Substitute a scalar expression evaluated outside the scalarization
3089 se
->expr
= se
->ss
->data
.scalar
.expr
;
3090 se
->string_length
= se
->ss
->string_length
;
3091 gfc_advance_se_ss_chain (se
);
3095 switch (expr
->expr_type
)
3098 gfc_conv_expr_op (se
, expr
);
3102 gfc_conv_function_expr (se
, expr
);
3106 gfc_conv_constant (se
, expr
);
3110 gfc_conv_variable (se
, expr
);
3114 se
->expr
= null_pointer_node
;
3117 case EXPR_SUBSTRING
:
3118 gfc_conv_substring_expr (se
, expr
);
3121 case EXPR_STRUCTURE
:
3122 gfc_conv_structure (se
, expr
, 0);
3126 gfc_conv_array_constructor_expr (se
, expr
);
3135 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3136 of an assignment. */
3138 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3140 gfc_conv_expr (se
, expr
);
3141 /* All numeric lvalues should have empty post chains. If not we need to
3142 figure out a way of rewriting an lvalue so that it has no post chain. */
3143 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3146 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3147 numeric expressions. Used for scalar values where inserting cleanup code
3150 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3154 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3155 gfc_conv_expr (se
, expr
);
3158 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3159 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3161 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3165 /* Helper to translate and expression and convert it to a particular type. */
3167 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3169 gfc_conv_expr_val (se
, expr
);
3170 se
->expr
= convert (type
, se
->expr
);
3174 /* Converts an expression so that it can be passed by reference. Scalar
3178 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3182 if (se
->ss
&& se
->ss
->expr
== expr
3183 && se
->ss
->type
== GFC_SS_REFERENCE
)
3185 se
->expr
= se
->ss
->data
.scalar
.expr
;
3186 se
->string_length
= se
->ss
->string_length
;
3187 gfc_advance_se_ss_chain (se
);
3191 if (expr
->ts
.type
== BT_CHARACTER
)
3193 gfc_conv_expr (se
, expr
);
3194 gfc_conv_string_parameter (se
);
3198 if (expr
->expr_type
== EXPR_VARIABLE
)
3200 se
->want_pointer
= 1;
3201 gfc_conv_expr (se
, expr
);
3204 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3205 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3206 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3212 gfc_conv_expr (se
, expr
);
3214 /* Create a temporary var to hold the value. */
3215 if (TREE_CONSTANT (se
->expr
))
3217 tree tmp
= se
->expr
;
3218 STRIP_TYPE_NOPS (tmp
);
3219 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3220 DECL_INITIAL (var
) = tmp
;
3221 TREE_STATIC (var
) = 1;
3226 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3227 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3229 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3231 /* Take the address of that value. */
3232 se
->expr
= build_fold_addr_expr (var
);
3237 gfc_trans_pointer_assign (gfc_code
* code
)
3239 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3243 /* Generate code for a pointer assignment. */
3246 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3256 gfc_start_block (&block
);
3258 gfc_init_se (&lse
, NULL
);
3260 lss
= gfc_walk_expr (expr1
);
3261 rss
= gfc_walk_expr (expr2
);
3262 if (lss
== gfc_ss_terminator
)
3264 /* Scalar pointers. */
3265 lse
.want_pointer
= 1;
3266 gfc_conv_expr (&lse
, expr1
);
3267 gcc_assert (rss
== gfc_ss_terminator
);
3268 gfc_init_se (&rse
, NULL
);
3269 rse
.want_pointer
= 1;
3270 gfc_conv_expr (&rse
, expr2
);
3271 gfc_add_block_to_block (&block
, &lse
.pre
);
3272 gfc_add_block_to_block (&block
, &rse
.pre
);
3273 gfc_add_modify_expr (&block
, lse
.expr
,
3274 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3275 gfc_add_block_to_block (&block
, &rse
.post
);
3276 gfc_add_block_to_block (&block
, &lse
.post
);
3280 /* Array pointer. */
3281 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3282 switch (expr2
->expr_type
)
3285 /* Just set the data pointer to null. */
3286 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3290 /* Assign directly to the pointer's descriptor. */
3291 lse
.direct_byref
= 1;
3292 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3296 /* Assign to a temporary descriptor and then copy that
3297 temporary to the pointer. */
3299 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3302 lse
.direct_byref
= 1;
3303 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3304 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3307 gfc_add_block_to_block (&block
, &lse
.pre
);
3308 gfc_add_block_to_block (&block
, &lse
.post
);
3310 return gfc_finish_block (&block
);
3314 /* Makes sure se is suitable for passing as a function string parameter. */
3315 /* TODO: Need to check all callers fo this function. It may be abused. */
3318 gfc_conv_string_parameter (gfc_se
* se
)
3322 if (TREE_CODE (se
->expr
) == STRING_CST
)
3324 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3328 type
= TREE_TYPE (se
->expr
);
3329 if (TYPE_STRING_FLAG (type
))
3331 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3332 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3335 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3336 gcc_assert (se
->string_length
3337 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3341 /* Generate code for assignment of scalar variables. Includes character
3342 strings and derived types with allocatable components. */
3345 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3346 bool l_is_temp
, bool r_is_var
)
3352 gfc_init_block (&block
);
3354 if (ts
.type
== BT_CHARACTER
)
3356 gcc_assert (lse
->string_length
!= NULL_TREE
3357 && rse
->string_length
!= NULL_TREE
);
3359 gfc_conv_string_parameter (lse
);
3360 gfc_conv_string_parameter (rse
);
3362 gfc_add_block_to_block (&block
, &lse
->pre
);
3363 gfc_add_block_to_block (&block
, &rse
->pre
);
3365 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3366 rse
->string_length
, rse
->expr
);
3368 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3372 /* Are the rhs and the lhs the same? */
3375 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3376 build_fold_addr_expr (lse
->expr
),
3377 build_fold_addr_expr (rse
->expr
));
3378 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3381 /* Deallocate the lhs allocated components as long as it is not
3382 the same as the rhs. */
3385 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3387 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3388 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3391 gfc_add_block_to_block (&block
, &lse
->pre
);
3392 gfc_add_block_to_block (&block
, &rse
->pre
);
3394 gfc_add_modify_expr (&block
, lse
->expr
,
3395 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3397 /* Do a deep copy if the rhs is a variable, if it is not the
3401 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3402 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3403 gfc_add_expr_to_block (&block
, tmp
);
3408 gfc_add_block_to_block (&block
, &lse
->pre
);
3409 gfc_add_block_to_block (&block
, &rse
->pre
);
3411 gfc_add_modify_expr (&block
, lse
->expr
,
3412 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3415 gfc_add_block_to_block (&block
, &lse
->post
);
3416 gfc_add_block_to_block (&block
, &rse
->post
);
3418 return gfc_finish_block (&block
);
3422 /* Try to translate array(:) = func (...), where func is a transformational
3423 array function, without using a temporary. Returns NULL is this isn't the
3427 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3432 bool seen_array_ref
;
3434 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3435 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3438 /* Elemental functions don't need a temporary anyway. */
3439 if (expr2
->value
.function
.esym
!= NULL
3440 && expr2
->value
.function
.esym
->attr
.elemental
)
3443 /* Fail if EXPR1 can't be expressed as a descriptor. */
3444 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3447 /* Functions returning pointers need temporaries. */
3448 if (expr2
->symtree
->n
.sym
->attr
.pointer
3449 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3452 /* Character array functions need temporaries unless the
3453 character lengths are the same. */
3454 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3456 if (expr1
->ts
.cl
->length
== NULL
3457 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3460 if (expr2
->ts
.cl
->length
== NULL
3461 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3464 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3465 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3469 /* Check that no LHS component references appear during an array
3470 reference. This is needed because we do not have the means to
3471 span any arbitrary stride with an array descriptor. This check
3472 is not needed for the rhs because the function result has to be
3474 seen_array_ref
= false;
3475 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3477 if (ref
->type
== REF_ARRAY
)
3478 seen_array_ref
= true;
3479 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3483 /* Check for a dependency. */
3484 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3485 expr2
->value
.function
.esym
,
3486 expr2
->value
.function
.actual
))
3489 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3491 gcc_assert (expr2
->value
.function
.isym
3492 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3493 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3495 ss
= gfc_walk_expr (expr1
);
3496 gcc_assert (ss
!= gfc_ss_terminator
);
3497 gfc_init_se (&se
, NULL
);
3498 gfc_start_block (&se
.pre
);
3499 se
.want_pointer
= 1;
3501 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3503 se
.direct_byref
= 1;
3504 se
.ss
= gfc_walk_expr (expr2
);
3505 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3506 gfc_conv_function_expr (&se
, expr2
);
3507 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3509 return gfc_finish_block (&se
.pre
);
3512 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3515 is_zero_initializer_p (gfc_expr
* expr
)
3517 if (expr
->expr_type
!= EXPR_CONSTANT
)
3519 /* We ignore Hollerith constants for the time being. */
3523 switch (expr
->ts
.type
)
3526 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3529 return mpfr_zero_p (expr
->value
.real
)
3530 && MPFR_SIGN (expr
->value
.real
) >= 0;
3533 return expr
->value
.logical
== 0;
3536 return mpfr_zero_p (expr
->value
.complex.r
)
3537 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3538 && mpfr_zero_p (expr
->value
.complex.i
)
3539 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3547 /* Try to efficiently translate array(:) = 0. Return NULL if this
3551 gfc_trans_zero_assign (gfc_expr
* expr
)
3553 tree dest
, len
, type
;
3557 sym
= expr
->symtree
->n
.sym
;
3558 dest
= gfc_get_symbol_decl (sym
);
3560 type
= TREE_TYPE (dest
);
3561 if (POINTER_TYPE_P (type
))
3562 type
= TREE_TYPE (type
);
3563 if (!GFC_ARRAY_TYPE_P (type
))
3566 /* Determine the length of the array. */
3567 len
= GFC_TYPE_ARRAY_SIZE (type
);
3568 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3571 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3572 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
3574 /* Convert arguments to the correct types. */
3575 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3576 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3578 dest
= fold_convert (pvoid_type_node
, dest
);
3579 len
= fold_convert (size_type_node
, len
);
3581 /* Construct call to __builtin_memset. */
3582 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3583 3, dest
, integer_zero_node
, len
);
3584 return fold_convert (void_type_node
, tmp
);
3588 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3589 that constructs the call to __builtin_memcpy. */
3592 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3596 /* Convert arguments to the correct types. */
3597 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3598 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3600 dst
= fold_convert (pvoid_type_node
, dst
);
3602 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3603 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3605 src
= fold_convert (pvoid_type_node
, src
);
3607 len
= fold_convert (size_type_node
, len
);
3609 /* Construct call to __builtin_memcpy. */
3610 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3611 return fold_convert (void_type_node
, tmp
);
3615 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3616 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3617 source/rhs, both are gfc_full_array_ref_p which have been checked for
3621 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3623 tree dst
, dlen
, dtype
;
3624 tree src
, slen
, stype
;
3626 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3627 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3629 dtype
= TREE_TYPE (dst
);
3630 if (POINTER_TYPE_P (dtype
))
3631 dtype
= TREE_TYPE (dtype
);
3632 stype
= TREE_TYPE (src
);
3633 if (POINTER_TYPE_P (stype
))
3634 stype
= TREE_TYPE (stype
);
3636 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3639 /* Determine the lengths of the arrays. */
3640 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3641 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3643 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3644 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3646 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3647 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3649 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3650 TYPE_SIZE_UNIT (gfc_get_element_type (stype
)));
3652 /* Sanity check that they are the same. This should always be
3653 the case, as we should already have checked for conformance. */
3654 if (!tree_int_cst_equal (slen
, dlen
))
3657 return gfc_build_memcpy_call (dst
, src
, dlen
);
3661 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3662 this can't be done. EXPR1 is the destination/lhs for which
3663 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3666 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3668 unsigned HOST_WIDE_INT nelem
;
3673 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3677 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3678 dtype
= TREE_TYPE (dst
);
3679 if (POINTER_TYPE_P (dtype
))
3680 dtype
= TREE_TYPE (dtype
);
3681 if (!GFC_ARRAY_TYPE_P (dtype
))
3684 /* Determine the lengths of the array. */
3685 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3686 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3689 /* Confirm that the constructor is the same size. */
3690 if (compare_tree_int (len
, nelem
) != 0)
3693 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3694 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3696 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3697 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3699 stype
= TREE_TYPE (src
);
3700 if (POINTER_TYPE_P (stype
))
3701 stype
= TREE_TYPE (stype
);
3703 return gfc_build_memcpy_call (dst
, src
, len
);
3707 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3708 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3711 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3716 gfc_ss
*lss_section
;
3724 /* Assignment of the form lhs = rhs. */
3725 gfc_start_block (&block
);
3727 gfc_init_se (&lse
, NULL
);
3728 gfc_init_se (&rse
, NULL
);
3731 lss
= gfc_walk_expr (expr1
);
3733 if (lss
!= gfc_ss_terminator
)
3735 /* The assignment needs scalarization. */
3738 /* Find a non-scalar SS from the lhs. */
3739 while (lss_section
!= gfc_ss_terminator
3740 && lss_section
->type
!= GFC_SS_SECTION
)
3741 lss_section
= lss_section
->next
;
3743 gcc_assert (lss_section
!= gfc_ss_terminator
);
3745 /* Initialize the scalarizer. */
3746 gfc_init_loopinfo (&loop
);
3749 rss
= gfc_walk_expr (expr2
);
3750 if (rss
== gfc_ss_terminator
)
3752 /* The rhs is scalar. Add a ss for the expression. */
3753 rss
= gfc_get_ss ();
3754 rss
->next
= gfc_ss_terminator
;
3755 rss
->type
= GFC_SS_SCALAR
;
3758 /* Associate the SS with the loop. */
3759 gfc_add_ss_to_loop (&loop
, lss
);
3760 gfc_add_ss_to_loop (&loop
, rss
);
3762 /* Calculate the bounds of the scalarization. */
3763 gfc_conv_ss_startstride (&loop
);
3764 /* Resolve any data dependencies in the statement. */
3765 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3766 /* Setup the scalarizing loops. */
3767 gfc_conv_loop_setup (&loop
);
3769 /* Setup the gfc_se structures. */
3770 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3771 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3774 gfc_mark_ss_chain_used (rss
, 1);
3775 if (loop
.temp_ss
== NULL
)
3778 gfc_mark_ss_chain_used (lss
, 1);
3782 lse
.ss
= loop
.temp_ss
;
3783 gfc_mark_ss_chain_used (lss
, 3);
3784 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3787 /* Start the scalarized loop body. */
3788 gfc_start_scalarized_body (&loop
, &body
);
3791 gfc_init_block (&body
);
3793 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3795 /* Translate the expression. */
3796 gfc_conv_expr (&rse
, expr2
);
3800 gfc_conv_tmp_array_ref (&lse
);
3801 gfc_advance_se_ss_chain (&lse
);
3804 gfc_conv_expr (&lse
, expr1
);
3806 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3807 l_is_temp
|| init_flag
,
3808 expr2
->expr_type
== EXPR_VARIABLE
);
3809 gfc_add_expr_to_block (&body
, tmp
);
3811 if (lss
== gfc_ss_terminator
)
3813 /* Use the scalar assignment as is. */
3814 gfc_add_block_to_block (&block
, &body
);
3818 gcc_assert (lse
.ss
== gfc_ss_terminator
3819 && rse
.ss
== gfc_ss_terminator
);
3823 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3825 /* We need to copy the temporary to the actual lhs. */
3826 gfc_init_se (&lse
, NULL
);
3827 gfc_init_se (&rse
, NULL
);
3828 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3829 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3831 rse
.ss
= loop
.temp_ss
;
3834 gfc_conv_tmp_array_ref (&rse
);
3835 gfc_advance_se_ss_chain (&rse
);
3836 gfc_conv_expr (&lse
, expr1
);
3838 gcc_assert (lse
.ss
== gfc_ss_terminator
3839 && rse
.ss
== gfc_ss_terminator
);
3841 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3843 gfc_add_expr_to_block (&body
, tmp
);
3846 /* Generate the copying loops. */
3847 gfc_trans_scalarizing_loops (&loop
, &body
);
3849 /* Wrap the whole thing up. */
3850 gfc_add_block_to_block (&block
, &loop
.pre
);
3851 gfc_add_block_to_block (&block
, &loop
.post
);
3853 gfc_cleanup_loop (&loop
);
3856 return gfc_finish_block (&block
);
3860 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3863 copyable_array_p (gfc_expr
* expr
)
3865 /* First check it's an array. */
3866 if (expr
->rank
< 1 || !expr
->ref
)
3869 /* Next check that it's of a simple enough type. */
3870 switch (expr
->ts
.type
)
3882 return !expr
->ts
.derived
->attr
.alloc_comp
;
3891 /* Translate an assignment. */
3894 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3898 /* Special case a single function returning an array. */
3899 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3901 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3906 /* Special case assigning an array to zero. */
3907 if (expr1
->expr_type
== EXPR_VARIABLE
3910 && gfc_full_array_ref_p (expr1
->ref
)
3911 && is_zero_initializer_p (expr2
))
3913 tmp
= gfc_trans_zero_assign (expr1
);
3918 /* Special case copying one array to another. */
3919 if (expr1
->expr_type
== EXPR_VARIABLE
3920 && copyable_array_p (expr1
)
3921 && gfc_full_array_ref_p (expr1
->ref
)
3922 && expr2
->expr_type
== EXPR_VARIABLE
3923 && copyable_array_p (expr2
)
3924 && gfc_full_array_ref_p (expr2
->ref
)
3925 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
3926 && !gfc_check_dependency (expr1
, expr2
, 0))
3928 tmp
= gfc_trans_array_copy (expr1
, expr2
);
3933 /* Special case initializing an array from a constant array constructor. */
3934 if (expr1
->expr_type
== EXPR_VARIABLE
3935 && copyable_array_p (expr1
)
3936 && gfc_full_array_ref_p (expr1
->ref
)
3937 && expr2
->expr_type
== EXPR_ARRAY
3938 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
3940 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
3945 /* Fallback to the scalarizer to generate explicit loops. */
3946 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
3950 gfc_trans_init_assign (gfc_code
* code
)
3952 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3956 gfc_trans_assign (gfc_code
* code
)
3958 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);