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 int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
55 dest
->loop
= src
->loop
;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
68 memset (se
, 0, sizeof (gfc_se
));
69 gfc_init_block (&se
->pre
);
70 gfc_init_block (&se
->post
);
75 gfc_copy_se_loopvars (se
, parent
);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se
* se
)
88 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se
* se
)
112 if (CONSTANT_CLASS_P (se
->expr
))
115 /* We need a temporary for this result. */
116 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
117 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol
* sym
)
130 gcc_assert (sym
->attr
.dummy
);
132 decl
= gfc_get_symbol_decl (sym
);
133 if (TREE_CODE (decl
) != PARM_DECL
)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
139 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 return build2 (NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
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
;
1610 int seen_result
= 0;
1615 /* Copying an expression does not copy its length, so do that here. */
1616 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1618 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1619 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1622 /* Apply the mapping to any references. */
1623 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1625 /* ...and to the expression's symbol, if it has one. */
1627 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1628 if (sym
->old
== expr
->symtree
->n
.sym
)
1629 expr
->symtree
= sym
->new;
1631 /* ...and to subexpressions in expr->value. */
1632 switch (expr
->expr_type
)
1635 if (expr
->symtree
->n
.sym
->attr
.result
)
1639 case EXPR_SUBSTRING
:
1643 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1644 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1648 if (expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1649 && gfc_apply_interface_mapping_to_expr (mapping
,
1650 expr
->value
.function
.actual
->expr
)
1651 && expr
->value
.function
.esym
== NULL
1652 && expr
->value
.function
.isym
!= NULL
1653 && expr
->value
.function
.isym
->generic_id
== GFC_ISYM_LEN
)
1656 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1658 gfc_free (new_expr
);
1659 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1663 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1664 if (sym
->old
== expr
->value
.function
.esym
)
1665 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1667 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1668 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1672 case EXPR_STRUCTURE
:
1673 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1680 /* Evaluate interface expression EXPR using MAPPING. Store the result
1684 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1685 gfc_se
* se
, gfc_expr
* expr
)
1687 expr
= gfc_copy_expr (expr
);
1688 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1689 gfc_conv_expr (se
, expr
);
1690 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1691 gfc_free_expr (expr
);
1694 /* Returns a reference to a temporary array into which a component of
1695 an actual argument derived type array is copied and then returned
1696 after the function call.
1697 TODO Get rid of this kludge, when array descriptors are capable of
1698 handling arrays with a bigger stride in bytes than size. */
1701 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1702 int g77
, sym_intent intent
)
1718 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1720 gfc_init_se (&lse
, NULL
);
1721 gfc_init_se (&rse
, NULL
);
1723 /* Walk the argument expression. */
1724 rss
= gfc_walk_expr (expr
);
1726 gcc_assert (rss
!= gfc_ss_terminator
);
1728 /* Initialize the scalarizer. */
1729 gfc_init_loopinfo (&loop
);
1730 gfc_add_ss_to_loop (&loop
, rss
);
1732 /* Calculate the bounds of the scalarization. */
1733 gfc_conv_ss_startstride (&loop
);
1735 /* Build an ss for the temporary. */
1736 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1737 if (GFC_ARRAY_TYPE_P (base_type
)
1738 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1739 base_type
= gfc_get_element_type (base_type
);
1741 loop
.temp_ss
= gfc_get_ss ();;
1742 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1743 loop
.temp_ss
->data
.temp
.type
= base_type
;
1745 if (expr
->ts
.type
== BT_CHARACTER
)
1747 gfc_ref
*char_ref
= expr
->ref
;
1749 for (; char_ref
; char_ref
= char_ref
->next
)
1750 if (char_ref
->type
== REF_SUBSTRING
)
1754 expr
->ts
.cl
= gfc_get_charlen ();
1755 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1756 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1758 gfc_init_se (&tmp_se
, NULL
);
1759 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1760 gfc_array_index_type
);
1761 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1762 tmp_se
.expr
, gfc_index_one_node
);
1763 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1764 gfc_init_se (&tmp_se
, NULL
);
1765 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1766 gfc_array_index_type
);
1767 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1769 expr
->ts
.cl
->backend_decl
= tmp
;
1773 loop
.temp_ss
->data
.temp
.type
1774 = gfc_typenode_for_spec (&expr
->ts
);
1775 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1778 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1779 loop
.temp_ss
->next
= gfc_ss_terminator
;
1781 /* Associate the SS with the loop. */
1782 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1784 /* Setup the scalarizing loops. */
1785 gfc_conv_loop_setup (&loop
);
1787 /* Pass the temporary descriptor back to the caller. */
1788 info
= &loop
.temp_ss
->data
.info
;
1789 parmse
->expr
= info
->descriptor
;
1791 /* Setup the gfc_se structures. */
1792 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1793 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1796 lse
.ss
= loop
.temp_ss
;
1797 gfc_mark_ss_chain_used (rss
, 1);
1798 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1800 /* Start the scalarized loop body. */
1801 gfc_start_scalarized_body (&loop
, &body
);
1803 /* Translate the expression. */
1804 gfc_conv_expr (&rse
, expr
);
1806 gfc_conv_tmp_array_ref (&lse
);
1807 gfc_advance_se_ss_chain (&lse
);
1809 if (intent
!= INTENT_OUT
)
1811 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1812 gfc_add_expr_to_block (&body
, tmp
);
1813 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1814 gfc_trans_scalarizing_loops (&loop
, &body
);
1818 /* Make sure that the temporary declaration survives by merging
1819 all the loop declarations into the current context. */
1820 for (n
= 0; n
< loop
.dimen
; n
++)
1822 gfc_merge_block_scope (&body
);
1823 body
= loop
.code
[loop
.order
[n
]];
1825 gfc_merge_block_scope (&body
);
1828 /* Add the post block after the second loop, so that any
1829 freeing of allocated memory is done at the right time. */
1830 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1832 /**********Copy the temporary back again.*********/
1834 gfc_init_se (&lse
, NULL
);
1835 gfc_init_se (&rse
, NULL
);
1837 /* Walk the argument expression. */
1838 lss
= gfc_walk_expr (expr
);
1839 rse
.ss
= loop
.temp_ss
;
1842 /* Initialize the scalarizer. */
1843 gfc_init_loopinfo (&loop2
);
1844 gfc_add_ss_to_loop (&loop2
, lss
);
1846 /* Calculate the bounds of the scalarization. */
1847 gfc_conv_ss_startstride (&loop2
);
1849 /* Setup the scalarizing loops. */
1850 gfc_conv_loop_setup (&loop2
);
1852 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1853 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1855 gfc_mark_ss_chain_used (lss
, 1);
1856 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1858 /* Declare the variable to hold the temporary offset and start the
1859 scalarized loop body. */
1860 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1861 gfc_start_scalarized_body (&loop2
, &body
);
1863 /* Build the offsets for the temporary from the loop variables. The
1864 temporary array has lbounds of zero and strides of one in all
1865 dimensions, so this is very simple. The offset is only computed
1866 outside the innermost loop, so the overall transfer could be
1867 optimized further. */
1868 info
= &rse
.ss
->data
.info
;
1870 tmp_index
= gfc_index_zero_node
;
1871 for (n
= info
->dimen
- 1; n
> 0; n
--)
1874 tmp
= rse
.loop
->loopvar
[n
];
1875 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1876 tmp
, rse
.loop
->from
[n
]);
1877 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1880 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1881 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1882 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1883 tmp_str
, gfc_index_one_node
);
1885 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1889 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1890 tmp_index
, rse
.loop
->from
[0]);
1891 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1893 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1894 rse
.loop
->loopvar
[0], offset
);
1896 /* Now use the offset for the reference. */
1897 tmp
= build_fold_indirect_ref (info
->data
);
1898 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1900 if (expr
->ts
.type
== BT_CHARACTER
)
1901 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1903 gfc_conv_expr (&lse
, expr
);
1905 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1907 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1908 gfc_add_expr_to_block (&body
, tmp
);
1910 /* Generate the copying loops. */
1911 gfc_trans_scalarizing_loops (&loop2
, &body
);
1913 /* Wrap the whole thing up by adding the second loop to the post-block
1914 and following it by the post-block of the first loop. In this way,
1915 if the temporary needs freeing, it is done after use! */
1916 if (intent
!= INTENT_IN
)
1918 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1919 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1922 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1924 gfc_cleanup_loop (&loop
);
1925 gfc_cleanup_loop (&loop2
);
1927 /* Pass the string length to the argument expression. */
1928 if (expr
->ts
.type
== BT_CHARACTER
)
1929 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1931 /* We want either the address for the data or the address of the descriptor,
1932 depending on the mode of passing array arguments. */
1934 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1936 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1941 /* Is true if an array reference is followed by a component or substring
1945 is_aliased_array (gfc_expr
* e
)
1951 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1953 if (ref
->type
== REF_ARRAY
1954 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1958 && ref
->type
!= REF_ARRAY
)
1964 /* Generate the code for argument list functions. */
1967 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
1969 /* Pass by value for g77 %VAL(arg), pass the address
1970 indirectly for %LOC, else by reference. Thus %REF
1971 is a "do-nothing" and %LOC is the same as an F95
1973 if (strncmp (name
, "%VAL", 4) == 0)
1974 gfc_conv_expr (se
, expr
);
1975 else if (strncmp (name
, "%LOC", 4) == 0)
1977 gfc_conv_expr_reference (se
, expr
);
1978 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
1980 else if (strncmp (name
, "%REF", 4) == 0)
1981 gfc_conv_expr_reference (se
, expr
);
1983 gfc_error ("Unknown argument list function at %L", &expr
->where
);
1987 /* Generate code for a procedure call. Note can return se->post != NULL.
1988 If se->direct_byref is set then se->expr contains the return parameter.
1989 Return nonzero, if the call has alternate specifiers. */
1992 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1993 gfc_actual_arglist
* arg
, tree append_args
)
1995 gfc_interface_mapping mapping
;
2009 gfc_formal_arglist
*formal
;
2010 int has_alternate_specifier
= 0;
2011 bool need_interface_mapping
;
2018 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2020 arglist
= NULL_TREE
;
2021 retargs
= NULL_TREE
;
2022 stringargs
= NULL_TREE
;
2028 if (!sym
->attr
.elemental
)
2030 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2031 if (se
->ss
->useflags
)
2033 gcc_assert (gfc_return_by_reference (sym
)
2034 && sym
->result
->attr
.dimension
);
2035 gcc_assert (se
->loop
!= NULL
);
2037 /* Access the previously obtained result. */
2038 gfc_conv_tmp_array_ref (se
);
2039 gfc_advance_se_ss_chain (se
);
2043 info
= &se
->ss
->data
.info
;
2048 gfc_init_block (&post
);
2049 gfc_init_interface_mapping (&mapping
);
2050 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2051 && sym
->ts
.cl
->length
2052 && sym
->ts
.cl
->length
->expr_type
2054 || sym
->attr
.dimension
);
2055 formal
= sym
->formal
;
2056 /* Evaluate the arguments. */
2057 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2060 fsym
= formal
? formal
->sym
: NULL
;
2061 parm_kind
= MISSING
;
2065 if (se
->ignore_optional
)
2067 /* Some intrinsics have already been resolved to the correct
2071 else if (arg
->label
)
2073 has_alternate_specifier
= 1;
2078 /* Pass a NULL pointer for an absent arg. */
2079 gfc_init_se (&parmse
, NULL
);
2080 parmse
.expr
= null_pointer_node
;
2081 if (arg
->missing_arg_type
== BT_CHARACTER
)
2082 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2085 else if (se
->ss
&& se
->ss
->useflags
)
2087 /* An elemental function inside a scalarized loop. */
2088 gfc_init_se (&parmse
, se
);
2089 gfc_conv_expr_reference (&parmse
, e
);
2090 parm_kind
= ELEMENTAL
;
2094 /* A scalar or transformational function. */
2095 gfc_init_se (&parmse
, NULL
);
2096 argss
= gfc_walk_expr (e
);
2098 if (argss
== gfc_ss_terminator
)
2101 if (fsym
&& fsym
->attr
.value
)
2103 gfc_conv_expr (&parmse
, e
);
2105 else if (arg
->name
&& arg
->name
[0] == '%')
2106 /* Argument list functions %VAL, %LOC and %REF are signalled
2107 through arg->name. */
2108 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2109 else if ((e
->expr_type
== EXPR_FUNCTION
)
2110 && e
->symtree
->n
.sym
->attr
.pointer
2111 && fsym
&& fsym
->attr
.target
)
2113 gfc_conv_expr (&parmse
, e
);
2114 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2118 gfc_conv_expr_reference (&parmse
, e
);
2119 if (fsym
&& fsym
->attr
.pointer
2120 && fsym
->attr
.flavor
!= FL_PROCEDURE
2121 && e
->expr_type
!= EXPR_NULL
)
2123 /* Scalar pointer dummy args require an extra level of
2124 indirection. The null pointer already contains
2125 this level of indirection. */
2126 parm_kind
= SCALAR_POINTER
;
2127 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2133 /* If the procedure requires an explicit interface, the actual
2134 argument is passed according to the corresponding formal
2135 argument. If the corresponding formal argument is a POINTER,
2136 ALLOCATABLE or assumed shape, we do not use g77's calling
2137 convention, and pass the address of the array descriptor
2138 instead. Otherwise we use g77's calling convention. */
2141 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2142 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2143 f
= f
|| !sym
->attr
.always_explicit
;
2145 if (e
->expr_type
== EXPR_VARIABLE
2146 && is_aliased_array (e
))
2147 /* The actual argument is a component reference to an
2148 array of derived types. In this case, the argument
2149 is converted to a temporary, which is passed and then
2150 written back after the procedure call. */
2151 gfc_conv_aliased_arg (&parmse
, e
, f
,
2152 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2154 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2156 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2157 allocated on entry, it must be deallocated. */
2158 if (fsym
&& fsym
->attr
.allocatable
2159 && fsym
->attr
.intent
== INTENT_OUT
)
2161 tmp
= build_fold_indirect_ref (parmse
.expr
);
2162 tmp
= gfc_trans_dealloc_allocated (tmp
);
2163 gfc_add_expr_to_block (&se
->pre
, tmp
);
2173 /* If an optional argument is itself an optional dummy
2174 argument, check its presence and substitute a null
2176 if (e
->expr_type
== EXPR_VARIABLE
2177 && e
->symtree
->n
.sym
->attr
.optional
2178 && fsym
->attr
.optional
)
2179 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2181 /* If an INTENT(OUT) dummy of derived type has a default
2182 initializer, it must be (re)initialized here. */
2183 if (fsym
->attr
.intent
== INTENT_OUT
2184 && fsym
->ts
.type
== BT_DERIVED
2187 gcc_assert (!fsym
->attr
.allocatable
);
2188 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2189 gfc_add_expr_to_block (&se
->pre
, tmp
);
2192 /* Obtain the character length of an assumed character
2193 length procedure from the typespec. */
2194 if (fsym
->ts
.type
== BT_CHARACTER
2195 && parmse
.string_length
== NULL_TREE
2196 && e
->ts
.type
== BT_PROCEDURE
2197 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2198 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2200 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2201 parmse
.string_length
2202 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2206 if (need_interface_mapping
)
2207 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2210 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2211 gfc_add_block_to_block (&post
, &parmse
.post
);
2213 /* Allocated allocatable components of derived types must be
2214 deallocated for INTENT(OUT) dummy arguments and non-variable
2215 scalars. Non-variable arrays are dealt with in trans-array.c
2216 (gfc_conv_array_parameter). */
2217 if (e
&& e
->ts
.type
== BT_DERIVED
2218 && e
->ts
.derived
->attr
.alloc_comp
2219 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2221 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2224 tmp
= build_fold_indirect_ref (parmse
.expr
);
2225 parm_rank
= e
->rank
;
2233 case (SCALAR_POINTER
):
2234 tmp
= build_fold_indirect_ref (tmp
);
2241 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2242 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2243 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2244 tmp
, build_empty_stmt ());
2246 if (e
->expr_type
!= EXPR_VARIABLE
)
2247 /* Don't deallocate non-variables until they have been used. */
2248 gfc_add_expr_to_block (&se
->post
, tmp
);
2251 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2252 gfc_add_expr_to_block (&se
->pre
, tmp
);
2256 /* Character strings are passed as two parameters, a length and a
2258 if (parmse
.string_length
!= NULL_TREE
)
2259 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2261 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2263 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2266 if (ts
.type
== BT_CHARACTER
)
2268 if (sym
->ts
.cl
->length
== NULL
)
2270 /* Assumed character length results are not allowed by 5.1.1.5 of the
2271 standard and are trapped in resolve.c; except in the case of SPREAD
2272 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2273 we take the character length of the first argument for the result.
2274 For dummies, we have to look through the formal argument list for
2275 this function and use the character length found there.*/
2276 if (!sym
->attr
.dummy
)
2277 cl
.backend_decl
= TREE_VALUE (stringargs
);
2280 formal
= sym
->ns
->proc_name
->formal
;
2281 for (; formal
; formal
= formal
->next
)
2282 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2283 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2290 /* Calculate the length of the returned string. */
2291 gfc_init_se (&parmse
, NULL
);
2292 if (need_interface_mapping
)
2293 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2295 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2296 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2297 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2299 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2300 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2301 build_int_cst (gfc_charlen_type_node
, 0));
2302 cl
.backend_decl
= tmp
;
2305 /* Set up a charlen structure for it. */
2310 len
= cl
.backend_decl
;
2313 byref
= gfc_return_by_reference (sym
);
2316 if (se
->direct_byref
)
2317 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2318 else if (sym
->result
->attr
.dimension
)
2320 gcc_assert (se
->loop
&& info
);
2322 /* Set the type of the array. */
2323 tmp
= gfc_typenode_for_spec (&ts
);
2324 info
->dimen
= se
->loop
->dimen
;
2326 /* Evaluate the bounds of the result, if known. */
2327 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2329 /* Create a temporary to store the result. In case the function
2330 returns a pointer, the temporary will be a shallow copy and
2331 mustn't be deallocated. */
2332 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2333 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2334 false, !sym
->attr
.pointer
, callee_alloc
);
2336 /* Pass the temporary as the first argument. */
2337 tmp
= info
->descriptor
;
2338 tmp
= build_fold_addr_expr (tmp
);
2339 retargs
= gfc_chainon_list (retargs
, tmp
);
2341 else if (ts
.type
== BT_CHARACTER
)
2343 /* Pass the string length. */
2344 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2345 type
= build_pointer_type (type
);
2347 /* Return an address to a char[0:len-1]* temporary for
2348 character pointers. */
2349 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2351 /* Build char[0:len-1] * pstr. */
2352 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2353 build_int_cst (gfc_charlen_type_node
, 1));
2354 tmp
= build_range_type (gfc_array_index_type
,
2355 gfc_index_zero_node
, tmp
);
2356 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2357 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2359 /* Provide an address expression for the function arguments. */
2360 var
= build_fold_addr_expr (var
);
2363 var
= gfc_conv_string_tmp (se
, type
, len
);
2365 retargs
= gfc_chainon_list (retargs
, var
);
2369 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2371 type
= gfc_get_complex_type (ts
.kind
);
2372 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2373 retargs
= gfc_chainon_list (retargs
, var
);
2376 /* Add the string length to the argument list. */
2377 if (ts
.type
== BT_CHARACTER
)
2378 retargs
= gfc_chainon_list (retargs
, len
);
2380 gfc_free_interface_mapping (&mapping
);
2382 /* Add the return arguments. */
2383 arglist
= chainon (retargs
, arglist
);
2385 /* Add the hidden string length parameters to the arguments. */
2386 arglist
= chainon (arglist
, stringargs
);
2388 /* We may want to append extra arguments here. This is used e.g. for
2389 calls to libgfortran_matmul_??, which need extra information. */
2390 if (append_args
!= NULL_TREE
)
2391 arglist
= chainon (arglist
, append_args
);
2393 /* Generate the actual call. */
2394 gfc_conv_function_val (se
, sym
);
2396 /* If there are alternate return labels, function type should be
2397 integer. Can't modify the type in place though, since it can be shared
2398 with other functions. For dummy arguments, the typing is done to
2399 to this result, even if it has to be repeated for each call. */
2400 if (has_alternate_specifier
2401 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2403 if (!sym
->attr
.dummy
)
2405 TREE_TYPE (sym
->backend_decl
)
2406 = build_function_type (integer_type_node
,
2407 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2408 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2411 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2414 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2415 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2417 /* If we have a pointer function, but we don't want a pointer, e.g.
2420 where f is pointer valued, we have to dereference the result. */
2421 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2422 se
->expr
= build_fold_indirect_ref (se
->expr
);
2424 /* f2c calling conventions require a scalar default real function to
2425 return a double precision result. Convert this back to default
2426 real. We only care about the cases that can happen in Fortran 77.
2428 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2429 && sym
->ts
.kind
== gfc_default_real_kind
2430 && !sym
->attr
.always_explicit
)
2431 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2433 /* A pure function may still have side-effects - it may modify its
2435 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2437 if (!sym
->attr
.pure
)
2438 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2443 /* Add the function call to the pre chain. There is no expression. */
2444 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2445 se
->expr
= NULL_TREE
;
2447 if (!se
->direct_byref
)
2449 if (sym
->attr
.dimension
)
2451 if (flag_bounds_check
)
2453 /* Check the data pointer hasn't been modified. This would
2454 happen in a function returning a pointer. */
2455 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2456 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2458 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2460 se
->expr
= info
->descriptor
;
2461 /* Bundle in the string length. */
2462 se
->string_length
= len
;
2464 else if (sym
->ts
.type
== BT_CHARACTER
)
2466 /* Dereference for character pointer results. */
2467 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2468 se
->expr
= build_fold_indirect_ref (var
);
2472 se
->string_length
= len
;
2476 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2477 se
->expr
= build_fold_indirect_ref (var
);
2482 /* Follow the function call with the argument post block. */
2484 gfc_add_block_to_block (&se
->pre
, &post
);
2486 gfc_add_block_to_block (&se
->post
, &post
);
2488 return has_alternate_specifier
;
2492 /* Generate code to copy a string. */
2495 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2496 tree slength
, tree src
)
2498 tree tmp
, dlen
, slen
;
2506 stmtblock_t tempblock
;
2508 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2509 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2511 /* Deal with single character specially. */
2512 dsc
= gfc_to_single_character (dlen
, dest
);
2513 ssc
= gfc_to_single_character (slen
, src
);
2514 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2516 gfc_add_modify_expr (block
, dsc
, ssc
);
2520 /* Do nothing if the destination length is zero. */
2521 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2522 build_int_cst (gfc_charlen_type_node
, 0));
2524 /* The following code was previously in _gfortran_copy_string:
2526 // The two strings may overlap so we use memmove.
2528 copy_string (GFC_INTEGER_4 destlen, char * dest,
2529 GFC_INTEGER_4 srclen, const char * src)
2531 if (srclen >= destlen)
2533 // This will truncate if too long.
2534 memmove (dest, src, destlen);
2538 memmove (dest, src, srclen);
2540 memset (&dest[srclen], ' ', destlen - srclen);
2544 We're now doing it here for better optimization, but the logic
2547 /* Truncate string if source is too long. */
2548 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2549 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2550 3, dest
, src
, dlen
);
2552 /* Else copy and pad with spaces. */
2553 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2554 3, dest
, src
, slen
);
2556 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2557 fold_convert (pchar_type_node
, slen
));
2558 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2560 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2561 lang_hooks
.to_target_charset (' ')),
2562 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2565 gfc_init_block (&tempblock
);
2566 gfc_add_expr_to_block (&tempblock
, tmp3
);
2567 gfc_add_expr_to_block (&tempblock
, tmp4
);
2568 tmp3
= gfc_finish_block (&tempblock
);
2570 /* The whole copy_string function is there. */
2571 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2572 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2573 gfc_add_expr_to_block (block
, tmp
);
2577 /* Translate a statement function.
2578 The value of a statement function reference is obtained by evaluating the
2579 expression using the values of the actual arguments for the values of the
2580 corresponding dummy arguments. */
2583 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2587 gfc_formal_arglist
*fargs
;
2588 gfc_actual_arglist
*args
;
2591 gfc_saved_var
*saved_vars
;
2597 sym
= expr
->symtree
->n
.sym
;
2598 args
= expr
->value
.function
.actual
;
2599 gfc_init_se (&lse
, NULL
);
2600 gfc_init_se (&rse
, NULL
);
2603 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2605 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2606 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2608 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2610 /* Each dummy shall be specified, explicitly or implicitly, to be
2612 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2615 /* Create a temporary to hold the value. */
2616 type
= gfc_typenode_for_spec (&fsym
->ts
);
2617 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2619 if (fsym
->ts
.type
== BT_CHARACTER
)
2621 /* Copy string arguments. */
2624 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2625 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2627 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2628 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2631 gfc_conv_expr (&rse
, args
->expr
);
2632 gfc_conv_string_parameter (&rse
);
2633 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2634 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2636 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2638 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2639 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2643 /* For everything else, just evaluate the expression. */
2644 gfc_conv_expr (&lse
, args
->expr
);
2646 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2647 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2648 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2654 /* Use the temporary variables in place of the real ones. */
2655 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2656 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2658 gfc_conv_expr (se
, sym
->value
);
2660 if (sym
->ts
.type
== BT_CHARACTER
)
2662 gfc_conv_const_charlen (sym
->ts
.cl
);
2664 /* Force the expression to the correct length. */
2665 if (!INTEGER_CST_P (se
->string_length
)
2666 || tree_int_cst_lt (se
->string_length
,
2667 sym
->ts
.cl
->backend_decl
))
2669 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2670 tmp
= gfc_create_var (type
, sym
->name
);
2671 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2672 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2673 se
->string_length
, se
->expr
);
2676 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2679 /* Restore the original variables. */
2680 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2681 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2682 gfc_free (saved_vars
);
2686 /* Translate a function expression. */
2689 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2693 if (expr
->value
.function
.isym
)
2695 gfc_conv_intrinsic_function (se
, expr
);
2699 /* We distinguish statement functions from general functions to improve
2700 runtime performance. */
2701 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2703 gfc_conv_statement_function (se
, expr
);
2707 /* expr.value.function.esym is the resolved (specific) function symbol for
2708 most functions. However this isn't set for dummy procedures. */
2709 sym
= expr
->value
.function
.esym
;
2711 sym
= expr
->symtree
->n
.sym
;
2712 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2717 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2719 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2720 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2722 gfc_conv_tmp_array_ref (se
);
2723 gfc_advance_se_ss_chain (se
);
2727 /* Build a static initializer. EXPR is the expression for the initial value.
2728 The other parameters describe the variable of the component being
2729 initialized. EXPR may be null. */
2732 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2733 bool array
, bool pointer
)
2737 if (!(expr
|| pointer
))
2742 /* Arrays need special handling. */
2744 return gfc_build_null_descriptor (type
);
2746 return gfc_conv_array_initializer (type
, expr
);
2749 return fold_convert (type
, null_pointer_node
);
2755 gfc_init_se (&se
, NULL
);
2756 gfc_conv_structure (&se
, expr
, 1);
2760 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2763 gfc_init_se (&se
, NULL
);
2764 gfc_conv_constant (&se
, expr
);
2771 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2783 gfc_start_block (&block
);
2785 /* Initialize the scalarizer. */
2786 gfc_init_loopinfo (&loop
);
2788 gfc_init_se (&lse
, NULL
);
2789 gfc_init_se (&rse
, NULL
);
2792 rss
= gfc_walk_expr (expr
);
2793 if (rss
== gfc_ss_terminator
)
2795 /* The rhs is scalar. Add a ss for the expression. */
2796 rss
= gfc_get_ss ();
2797 rss
->next
= gfc_ss_terminator
;
2798 rss
->type
= GFC_SS_SCALAR
;
2802 /* Create a SS for the destination. */
2803 lss
= gfc_get_ss ();
2804 lss
->type
= GFC_SS_COMPONENT
;
2806 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2807 lss
->next
= gfc_ss_terminator
;
2808 lss
->data
.info
.dimen
= cm
->as
->rank
;
2809 lss
->data
.info
.descriptor
= dest
;
2810 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2811 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2812 for (n
= 0; n
< cm
->as
->rank
; n
++)
2814 lss
->data
.info
.dim
[n
] = n
;
2815 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2816 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2818 mpz_init (lss
->shape
[n
]);
2819 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2820 cm
->as
->lower
[n
]->value
.integer
);
2821 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2824 /* Associate the SS with the loop. */
2825 gfc_add_ss_to_loop (&loop
, lss
);
2826 gfc_add_ss_to_loop (&loop
, rss
);
2828 /* Calculate the bounds of the scalarization. */
2829 gfc_conv_ss_startstride (&loop
);
2831 /* Setup the scalarizing loops. */
2832 gfc_conv_loop_setup (&loop
);
2834 /* Setup the gfc_se structures. */
2835 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2836 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2839 gfc_mark_ss_chain_used (rss
, 1);
2841 gfc_mark_ss_chain_used (lss
, 1);
2843 /* Start the scalarized loop body. */
2844 gfc_start_scalarized_body (&loop
, &body
);
2846 gfc_conv_tmp_array_ref (&lse
);
2847 if (cm
->ts
.type
== BT_CHARACTER
)
2848 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2850 gfc_conv_expr (&rse
, expr
);
2852 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2853 gfc_add_expr_to_block (&body
, tmp
);
2855 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2857 /* Generate the copying loops. */
2858 gfc_trans_scalarizing_loops (&loop
, &body
);
2860 /* Wrap the whole thing up. */
2861 gfc_add_block_to_block (&block
, &loop
.pre
);
2862 gfc_add_block_to_block (&block
, &loop
.post
);
2864 for (n
= 0; n
< cm
->as
->rank
; n
++)
2865 mpz_clear (lss
->shape
[n
]);
2866 gfc_free (lss
->shape
);
2868 gfc_cleanup_loop (&loop
);
2870 return gfc_finish_block (&block
);
2874 /* Assign a single component of a derived type constructor. */
2877 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2887 gfc_start_block (&block
);
2891 gfc_init_se (&se
, NULL
);
2892 /* Pointer component. */
2895 /* Array pointer. */
2896 if (expr
->expr_type
== EXPR_NULL
)
2897 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2900 rss
= gfc_walk_expr (expr
);
2901 se
.direct_byref
= 1;
2903 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2904 gfc_add_block_to_block (&block
, &se
.pre
);
2905 gfc_add_block_to_block (&block
, &se
.post
);
2910 /* Scalar pointers. */
2911 se
.want_pointer
= 1;
2912 gfc_conv_expr (&se
, expr
);
2913 gfc_add_block_to_block (&block
, &se
.pre
);
2914 gfc_add_modify_expr (&block
, dest
,
2915 fold_convert (TREE_TYPE (dest
), se
.expr
));
2916 gfc_add_block_to_block (&block
, &se
.post
);
2919 else if (cm
->dimension
)
2921 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2922 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2923 else if (cm
->allocatable
)
2927 gfc_init_se (&se
, NULL
);
2929 rss
= gfc_walk_expr (expr
);
2930 se
.want_pointer
= 0;
2931 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2932 gfc_add_block_to_block (&block
, &se
.pre
);
2934 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2935 gfc_add_modify_expr (&block
, dest
, tmp
);
2937 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2938 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2941 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2942 TREE_TYPE(cm
->backend_decl
),
2945 gfc_add_expr_to_block (&block
, tmp
);
2947 gfc_add_block_to_block (&block
, &se
.post
);
2948 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2950 /* Shift the lbound and ubound of temporaries to being unity, rather
2951 than zero, based. Calculate the offset for all cases. */
2952 offset
= gfc_conv_descriptor_offset (dest
);
2953 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2954 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2955 for (n
= 0; n
< expr
->rank
; n
++)
2957 if (expr
->expr_type
!= EXPR_VARIABLE
2958 && expr
->expr_type
!= EXPR_CONSTANT
)
2960 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2961 gfc_add_modify_expr (&block
, tmp
,
2962 fold_build2 (PLUS_EXPR
,
2963 gfc_array_index_type
,
2964 tmp
, gfc_index_one_node
));
2965 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2966 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2968 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2969 gfc_conv_descriptor_lbound (dest
,
2971 gfc_conv_descriptor_stride (dest
,
2973 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2974 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2975 gfc_add_modify_expr (&block
, offset
, tmp
);
2980 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2981 gfc_add_expr_to_block (&block
, tmp
);
2984 else if (expr
->ts
.type
== BT_DERIVED
)
2986 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2988 gfc_init_se (&se
, NULL
);
2989 gfc_conv_expr (&se
, expr
);
2990 gfc_add_modify_expr (&block
, dest
,
2991 fold_convert (TREE_TYPE (dest
), se
.expr
));
2995 /* Nested constructors. */
2996 tmp
= gfc_trans_structure_assign (dest
, expr
);
2997 gfc_add_expr_to_block (&block
, tmp
);
3002 /* Scalar component. */
3003 gfc_init_se (&se
, NULL
);
3004 gfc_init_se (&lse
, NULL
);
3006 gfc_conv_expr (&se
, expr
);
3007 if (cm
->ts
.type
== BT_CHARACTER
)
3008 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3010 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3011 gfc_add_expr_to_block (&block
, tmp
);
3013 return gfc_finish_block (&block
);
3016 /* Assign a derived type constructor to a variable. */
3019 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3027 gfc_start_block (&block
);
3028 cm
= expr
->ts
.derived
->components
;
3029 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3031 /* Skip absent members in default initializers. */
3035 field
= cm
->backend_decl
;
3036 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3037 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3038 gfc_add_expr_to_block (&block
, tmp
);
3040 return gfc_finish_block (&block
);
3043 /* Build an expression for a constructor. If init is nonzero then
3044 this is part of a static variable initializer. */
3047 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3054 VEC(constructor_elt
,gc
) *v
= NULL
;
3056 gcc_assert (se
->ss
== NULL
);
3057 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3058 type
= gfc_typenode_for_spec (&expr
->ts
);
3062 /* Create a temporary variable and fill it in. */
3063 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3064 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3065 gfc_add_expr_to_block (&se
->pre
, tmp
);
3069 cm
= expr
->ts
.derived
->components
;
3071 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3073 /* Skip absent members in default initializers and allocatable
3074 components. Although the latter have a default initializer
3075 of EXPR_NULL,... by default, the static nullify is not needed
3076 since this is done every time we come into scope. */
3077 if (!c
->expr
|| cm
->allocatable
)
3080 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3081 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3083 /* Append it to the constructor list. */
3084 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3086 se
->expr
= build_constructor (type
, v
);
3090 /* Translate a substring expression. */
3093 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3099 gcc_assert (ref
->type
== REF_SUBSTRING
);
3101 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3102 expr
->value
.character
.string
);
3103 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3104 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3106 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3110 /* Entry point for expression translation. Evaluates a scalar quantity.
3111 EXPR is the expression to be translated, and SE is the state structure if
3112 called from within the scalarized. */
3115 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3117 if (se
->ss
&& se
->ss
->expr
== expr
3118 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3120 /* Substitute a scalar expression evaluated outside the scalarization
3122 se
->expr
= se
->ss
->data
.scalar
.expr
;
3123 se
->string_length
= se
->ss
->string_length
;
3124 gfc_advance_se_ss_chain (se
);
3128 switch (expr
->expr_type
)
3131 gfc_conv_expr_op (se
, expr
);
3135 gfc_conv_function_expr (se
, expr
);
3139 gfc_conv_constant (se
, expr
);
3143 gfc_conv_variable (se
, expr
);
3147 se
->expr
= null_pointer_node
;
3150 case EXPR_SUBSTRING
:
3151 gfc_conv_substring_expr (se
, expr
);
3154 case EXPR_STRUCTURE
:
3155 gfc_conv_structure (se
, expr
, 0);
3159 gfc_conv_array_constructor_expr (se
, expr
);
3168 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3169 of an assignment. */
3171 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3173 gfc_conv_expr (se
, expr
);
3174 /* All numeric lvalues should have empty post chains. If not we need to
3175 figure out a way of rewriting an lvalue so that it has no post chain. */
3176 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3179 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3180 numeric expressions. Used for scalar values where inserting cleanup code
3183 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3187 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3188 gfc_conv_expr (se
, expr
);
3191 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3192 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3194 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3198 /* Helper to translate and expression and convert it to a particular type. */
3200 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3202 gfc_conv_expr_val (se
, expr
);
3203 se
->expr
= convert (type
, se
->expr
);
3207 /* Converts an expression so that it can be passed by reference. Scalar
3211 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3215 if (se
->ss
&& se
->ss
->expr
== expr
3216 && se
->ss
->type
== GFC_SS_REFERENCE
)
3218 se
->expr
= se
->ss
->data
.scalar
.expr
;
3219 se
->string_length
= se
->ss
->string_length
;
3220 gfc_advance_se_ss_chain (se
);
3224 if (expr
->ts
.type
== BT_CHARACTER
)
3226 gfc_conv_expr (se
, expr
);
3227 gfc_conv_string_parameter (se
);
3231 if (expr
->expr_type
== EXPR_VARIABLE
)
3233 se
->want_pointer
= 1;
3234 gfc_conv_expr (se
, expr
);
3237 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3238 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3239 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3245 gfc_conv_expr (se
, expr
);
3247 /* Create a temporary var to hold the value. */
3248 if (TREE_CONSTANT (se
->expr
))
3250 tree tmp
= se
->expr
;
3251 STRIP_TYPE_NOPS (tmp
);
3252 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3253 DECL_INITIAL (var
) = tmp
;
3254 TREE_STATIC (var
) = 1;
3259 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3260 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3262 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3264 /* Take the address of that value. */
3265 se
->expr
= build_fold_addr_expr (var
);
3270 gfc_trans_pointer_assign (gfc_code
* code
)
3272 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3276 /* Generate code for a pointer assignment. */
3279 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3289 gfc_start_block (&block
);
3291 gfc_init_se (&lse
, NULL
);
3293 lss
= gfc_walk_expr (expr1
);
3294 rss
= gfc_walk_expr (expr2
);
3295 if (lss
== gfc_ss_terminator
)
3297 /* Scalar pointers. */
3298 lse
.want_pointer
= 1;
3299 gfc_conv_expr (&lse
, expr1
);
3300 gcc_assert (rss
== gfc_ss_terminator
);
3301 gfc_init_se (&rse
, NULL
);
3302 rse
.want_pointer
= 1;
3303 gfc_conv_expr (&rse
, expr2
);
3304 gfc_add_block_to_block (&block
, &lse
.pre
);
3305 gfc_add_block_to_block (&block
, &rse
.pre
);
3306 gfc_add_modify_expr (&block
, lse
.expr
,
3307 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3308 gfc_add_block_to_block (&block
, &rse
.post
);
3309 gfc_add_block_to_block (&block
, &lse
.post
);
3313 /* Array pointer. */
3314 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3315 switch (expr2
->expr_type
)
3318 /* Just set the data pointer to null. */
3319 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3323 /* Assign directly to the pointer's descriptor. */
3324 lse
.direct_byref
= 1;
3325 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3329 /* Assign to a temporary descriptor and then copy that
3330 temporary to the pointer. */
3332 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3335 lse
.direct_byref
= 1;
3336 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3337 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3340 gfc_add_block_to_block (&block
, &lse
.pre
);
3341 gfc_add_block_to_block (&block
, &lse
.post
);
3343 return gfc_finish_block (&block
);
3347 /* Makes sure se is suitable for passing as a function string parameter. */
3348 /* TODO: Need to check all callers fo this function. It may be abused. */
3351 gfc_conv_string_parameter (gfc_se
* se
)
3355 if (TREE_CODE (se
->expr
) == STRING_CST
)
3357 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3361 type
= TREE_TYPE (se
->expr
);
3362 if (TYPE_STRING_FLAG (type
))
3364 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3365 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3368 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3369 gcc_assert (se
->string_length
3370 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3374 /* Generate code for assignment of scalar variables. Includes character
3375 strings and derived types with allocatable components. */
3378 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3379 bool l_is_temp
, bool r_is_var
)
3385 gfc_init_block (&block
);
3387 if (ts
.type
== BT_CHARACTER
)
3389 gcc_assert (lse
->string_length
!= NULL_TREE
3390 && rse
->string_length
!= NULL_TREE
);
3392 gfc_conv_string_parameter (lse
);
3393 gfc_conv_string_parameter (rse
);
3395 gfc_add_block_to_block (&block
, &lse
->pre
);
3396 gfc_add_block_to_block (&block
, &rse
->pre
);
3398 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3399 rse
->string_length
, rse
->expr
);
3401 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3405 /* Are the rhs and the lhs the same? */
3408 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3409 build_fold_addr_expr (lse
->expr
),
3410 build_fold_addr_expr (rse
->expr
));
3411 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3414 /* Deallocate the lhs allocated components as long as it is not
3415 the same as the rhs. */
3418 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3420 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3421 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3424 gfc_add_block_to_block (&block
, &lse
->pre
);
3425 gfc_add_block_to_block (&block
, &rse
->pre
);
3427 gfc_add_modify_expr (&block
, lse
->expr
,
3428 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3430 /* Do a deep copy if the rhs is a variable, if it is not the
3434 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3435 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3436 gfc_add_expr_to_block (&block
, tmp
);
3441 gfc_add_block_to_block (&block
, &lse
->pre
);
3442 gfc_add_block_to_block (&block
, &rse
->pre
);
3444 gfc_add_modify_expr (&block
, lse
->expr
,
3445 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3448 gfc_add_block_to_block (&block
, &lse
->post
);
3449 gfc_add_block_to_block (&block
, &rse
->post
);
3451 return gfc_finish_block (&block
);
3455 /* Try to translate array(:) = func (...), where func is a transformational
3456 array function, without using a temporary. Returns NULL is this isn't the
3460 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3465 bool seen_array_ref
;
3467 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3468 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3471 /* Elemental functions don't need a temporary anyway. */
3472 if (expr2
->value
.function
.esym
!= NULL
3473 && expr2
->value
.function
.esym
->attr
.elemental
)
3476 /* Fail if EXPR1 can't be expressed as a descriptor. */
3477 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3480 /* Functions returning pointers need temporaries. */
3481 if (expr2
->symtree
->n
.sym
->attr
.pointer
3482 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3485 /* Character array functions need temporaries unless the
3486 character lengths are the same. */
3487 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3489 if (expr1
->ts
.cl
->length
== NULL
3490 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3493 if (expr2
->ts
.cl
->length
== NULL
3494 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3497 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3498 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3502 /* Check that no LHS component references appear during an array
3503 reference. This is needed because we do not have the means to
3504 span any arbitrary stride with an array descriptor. This check
3505 is not needed for the rhs because the function result has to be
3507 seen_array_ref
= false;
3508 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3510 if (ref
->type
== REF_ARRAY
)
3511 seen_array_ref
= true;
3512 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3516 /* Check for a dependency. */
3517 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3518 expr2
->value
.function
.esym
,
3519 expr2
->value
.function
.actual
))
3522 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3524 gcc_assert (expr2
->value
.function
.isym
3525 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3526 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3528 ss
= gfc_walk_expr (expr1
);
3529 gcc_assert (ss
!= gfc_ss_terminator
);
3530 gfc_init_se (&se
, NULL
);
3531 gfc_start_block (&se
.pre
);
3532 se
.want_pointer
= 1;
3534 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3536 se
.direct_byref
= 1;
3537 se
.ss
= gfc_walk_expr (expr2
);
3538 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3539 gfc_conv_function_expr (&se
, expr2
);
3540 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3542 return gfc_finish_block (&se
.pre
);
3545 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3548 is_zero_initializer_p (gfc_expr
* expr
)
3550 if (expr
->expr_type
!= EXPR_CONSTANT
)
3552 /* We ignore Hollerith constants for the time being. */
3556 switch (expr
->ts
.type
)
3559 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3562 return mpfr_zero_p (expr
->value
.real
)
3563 && MPFR_SIGN (expr
->value
.real
) >= 0;
3566 return expr
->value
.logical
== 0;
3569 return mpfr_zero_p (expr
->value
.complex.r
)
3570 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3571 && mpfr_zero_p (expr
->value
.complex.i
)
3572 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3580 /* Try to efficiently translate array(:) = 0. Return NULL if this
3584 gfc_trans_zero_assign (gfc_expr
* expr
)
3586 tree dest
, len
, type
;
3590 sym
= expr
->symtree
->n
.sym
;
3591 dest
= gfc_get_symbol_decl (sym
);
3593 type
= TREE_TYPE (dest
);
3594 if (POINTER_TYPE_P (type
))
3595 type
= TREE_TYPE (type
);
3596 if (!GFC_ARRAY_TYPE_P (type
))
3599 /* Determine the length of the array. */
3600 len
= GFC_TYPE_ARRAY_SIZE (type
);
3601 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3604 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3605 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
3607 /* Convert arguments to the correct types. */
3608 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3609 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3611 dest
= fold_convert (pvoid_type_node
, dest
);
3612 len
= fold_convert (size_type_node
, len
);
3614 /* Construct call to __builtin_memset. */
3615 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3616 3, dest
, integer_zero_node
, len
);
3617 return fold_convert (void_type_node
, tmp
);
3621 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3622 that constructs the call to __builtin_memcpy. */
3625 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3629 /* Convert arguments to the correct types. */
3630 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3631 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3633 dst
= fold_convert (pvoid_type_node
, dst
);
3635 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3636 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3638 src
= fold_convert (pvoid_type_node
, src
);
3640 len
= fold_convert (size_type_node
, len
);
3642 /* Construct call to __builtin_memcpy. */
3643 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3644 return fold_convert (void_type_node
, tmp
);
3648 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3649 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3650 source/rhs, both are gfc_full_array_ref_p which have been checked for
3654 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3656 tree dst
, dlen
, dtype
;
3657 tree src
, slen
, stype
;
3659 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3660 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3662 dtype
= TREE_TYPE (dst
);
3663 if (POINTER_TYPE_P (dtype
))
3664 dtype
= TREE_TYPE (dtype
);
3665 stype
= TREE_TYPE (src
);
3666 if (POINTER_TYPE_P (stype
))
3667 stype
= TREE_TYPE (stype
);
3669 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3672 /* Determine the lengths of the arrays. */
3673 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3674 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3676 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3677 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3679 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3680 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3682 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3683 TYPE_SIZE_UNIT (gfc_get_element_type (stype
)));
3685 /* Sanity check that they are the same. This should always be
3686 the case, as we should already have checked for conformance. */
3687 if (!tree_int_cst_equal (slen
, dlen
))
3690 return gfc_build_memcpy_call (dst
, src
, dlen
);
3694 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3695 this can't be done. EXPR1 is the destination/lhs for which
3696 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3699 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3701 unsigned HOST_WIDE_INT nelem
;
3706 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3710 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3711 dtype
= TREE_TYPE (dst
);
3712 if (POINTER_TYPE_P (dtype
))
3713 dtype
= TREE_TYPE (dtype
);
3714 if (!GFC_ARRAY_TYPE_P (dtype
))
3717 /* Determine the lengths of the array. */
3718 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3719 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3722 /* Confirm that the constructor is the same size. */
3723 if (compare_tree_int (len
, nelem
) != 0)
3726 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3727 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3729 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3730 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3732 stype
= TREE_TYPE (src
);
3733 if (POINTER_TYPE_P (stype
))
3734 stype
= TREE_TYPE (stype
);
3736 return gfc_build_memcpy_call (dst
, src
, len
);
3740 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3741 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3744 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3749 gfc_ss
*lss_section
;
3757 /* Assignment of the form lhs = rhs. */
3758 gfc_start_block (&block
);
3760 gfc_init_se (&lse
, NULL
);
3761 gfc_init_se (&rse
, NULL
);
3764 lss
= gfc_walk_expr (expr1
);
3766 if (lss
!= gfc_ss_terminator
)
3768 /* The assignment needs scalarization. */
3771 /* Find a non-scalar SS from the lhs. */
3772 while (lss_section
!= gfc_ss_terminator
3773 && lss_section
->type
!= GFC_SS_SECTION
)
3774 lss_section
= lss_section
->next
;
3776 gcc_assert (lss_section
!= gfc_ss_terminator
);
3778 /* Initialize the scalarizer. */
3779 gfc_init_loopinfo (&loop
);
3782 rss
= gfc_walk_expr (expr2
);
3783 if (rss
== gfc_ss_terminator
)
3785 /* The rhs is scalar. Add a ss for the expression. */
3786 rss
= gfc_get_ss ();
3787 rss
->next
= gfc_ss_terminator
;
3788 rss
->type
= GFC_SS_SCALAR
;
3791 /* Associate the SS with the loop. */
3792 gfc_add_ss_to_loop (&loop
, lss
);
3793 gfc_add_ss_to_loop (&loop
, rss
);
3795 /* Calculate the bounds of the scalarization. */
3796 gfc_conv_ss_startstride (&loop
);
3797 /* Resolve any data dependencies in the statement. */
3798 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3799 /* Setup the scalarizing loops. */
3800 gfc_conv_loop_setup (&loop
);
3802 /* Setup the gfc_se structures. */
3803 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3804 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3807 gfc_mark_ss_chain_used (rss
, 1);
3808 if (loop
.temp_ss
== NULL
)
3811 gfc_mark_ss_chain_used (lss
, 1);
3815 lse
.ss
= loop
.temp_ss
;
3816 gfc_mark_ss_chain_used (lss
, 3);
3817 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3820 /* Start the scalarized loop body. */
3821 gfc_start_scalarized_body (&loop
, &body
);
3824 gfc_init_block (&body
);
3826 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3828 /* Translate the expression. */
3829 gfc_conv_expr (&rse
, expr2
);
3833 gfc_conv_tmp_array_ref (&lse
);
3834 gfc_advance_se_ss_chain (&lse
);
3837 gfc_conv_expr (&lse
, expr1
);
3839 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3840 l_is_temp
|| init_flag
,
3841 expr2
->expr_type
== EXPR_VARIABLE
);
3842 gfc_add_expr_to_block (&body
, tmp
);
3844 if (lss
== gfc_ss_terminator
)
3846 /* Use the scalar assignment as is. */
3847 gfc_add_block_to_block (&block
, &body
);
3851 gcc_assert (lse
.ss
== gfc_ss_terminator
3852 && rse
.ss
== gfc_ss_terminator
);
3856 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3858 /* We need to copy the temporary to the actual lhs. */
3859 gfc_init_se (&lse
, NULL
);
3860 gfc_init_se (&rse
, NULL
);
3861 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3862 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3864 rse
.ss
= loop
.temp_ss
;
3867 gfc_conv_tmp_array_ref (&rse
);
3868 gfc_advance_se_ss_chain (&rse
);
3869 gfc_conv_expr (&lse
, expr1
);
3871 gcc_assert (lse
.ss
== gfc_ss_terminator
3872 && rse
.ss
== gfc_ss_terminator
);
3874 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3876 gfc_add_expr_to_block (&body
, tmp
);
3879 /* Generate the copying loops. */
3880 gfc_trans_scalarizing_loops (&loop
, &body
);
3882 /* Wrap the whole thing up. */
3883 gfc_add_block_to_block (&block
, &loop
.pre
);
3884 gfc_add_block_to_block (&block
, &loop
.post
);
3886 gfc_cleanup_loop (&loop
);
3889 return gfc_finish_block (&block
);
3893 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3896 copyable_array_p (gfc_expr
* expr
)
3898 /* First check it's an array. */
3899 if (expr
->rank
< 1 || !expr
->ref
)
3902 /* Next check that it's of a simple enough type. */
3903 switch (expr
->ts
.type
)
3915 return !expr
->ts
.derived
->attr
.alloc_comp
;
3924 /* Translate an assignment. */
3927 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3931 /* Special case a single function returning an array. */
3932 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3934 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3939 /* Special case assigning an array to zero. */
3940 if (expr1
->expr_type
== EXPR_VARIABLE
3943 && gfc_full_array_ref_p (expr1
->ref
)
3944 && is_zero_initializer_p (expr2
))
3946 tmp
= gfc_trans_zero_assign (expr1
);
3951 /* Special case copying one array to another. */
3952 if (expr1
->expr_type
== EXPR_VARIABLE
3953 && copyable_array_p (expr1
)
3954 && gfc_full_array_ref_p (expr1
->ref
)
3955 && expr2
->expr_type
== EXPR_VARIABLE
3956 && copyable_array_p (expr2
)
3957 && gfc_full_array_ref_p (expr2
->ref
)
3958 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
3959 && !gfc_check_dependency (expr1
, expr2
, 0))
3961 tmp
= gfc_trans_array_copy (expr1
, expr2
);
3966 /* Special case initializing an array from a constant array constructor. */
3967 if (expr1
->expr_type
== EXPR_VARIABLE
3968 && copyable_array_p (expr1
)
3969 && gfc_full_array_ref_p (expr1
->ref
)
3970 && expr2
->expr_type
== EXPR_ARRAY
3971 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
3973 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
3978 /* Fallback to the scalarizer to generate explicit loops. */
3979 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
3983 gfc_trans_init_assign (gfc_code
* code
)
3985 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3989 gfc_trans_assign (gfc_code
* code
)
3991 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);