1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
46 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
55 dest
->loop
= src
->loop
;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
68 memset (se
, 0, sizeof (gfc_se
));
69 gfc_init_block (&se
->pre
);
70 gfc_init_block (&se
->post
);
75 gfc_copy_se_loopvars (se
, parent
);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se
* se
)
88 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se
* se
)
112 if (CONSTANT_CLASS_P (se
->expr
))
115 /* We need a temporary for this result. */
116 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
117 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol
* sym
)
130 gcc_assert (sym
->attr
.dummy
);
132 decl
= gfc_get_symbol_decl (sym
);
133 if (TREE_CODE (decl
) != PARM_DECL
)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
139 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 return build2 (NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
154 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
155 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
156 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
158 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
160 if (ts
.type
== BT_CHARACTER
)
162 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
163 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
164 se
->string_length
, tmp
);
165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
166 se
->string_length
= tmp
;
172 /* Get the character length of an expression, looking through gfc_refs
176 gfc_get_expr_charlen (gfc_expr
*e
)
181 gcc_assert (e
->expr_type
== EXPR_VARIABLE
182 && e
->ts
.type
== BT_CHARACTER
);
184 length
= NULL
; /* To silence compiler warning. */
186 /* First candidate: if the variable is of type CHARACTER, the
187 expression's length could be the length of the character
189 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
190 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
192 /* Look through the reference chain for component references. */
193 for (r
= e
->ref
; r
; r
= r
->next
)
198 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
199 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
207 /* We should never got substring references here. These will be
208 broken down by the scalarizer. */
213 gcc_assert (length
!= NULL
);
219 /* Generate code to initialize a string length variable. Returns the
223 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
228 gfc_init_se (&se
, NULL
);
229 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
230 gfc_add_block_to_block (pblock
, &se
.pre
);
232 tmp
= cl
->backend_decl
;
233 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
238 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
239 const char *name
, locus
*where
)
249 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
250 type
= build_pointer_type (type
);
253 gfc_init_se (&start
, se
);
254 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
255 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
257 if (integer_onep (start
.expr
))
258 gfc_conv_string_parameter (se
);
261 /* Change the start of the string. */
262 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
265 tmp
= build_fold_indirect_ref (se
->expr
);
266 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
267 se
->expr
= gfc_build_addr_expr (type
, tmp
);
270 /* Length = end + 1 - start. */
271 gfc_init_se (&end
, se
);
272 if (ref
->u
.ss
.end
== NULL
)
273 end
.expr
= se
->string_length
;
276 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
277 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
279 if (flag_bounds_check
)
281 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
282 start
.expr
, end
.expr
);
284 /* Check lower bound. */
285 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
286 build_int_cst (gfc_charlen_type_node
, 1));
287 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
290 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
291 "is less than one", name
);
293 asprintf (&msg
, "Substring out of bounds: lower bound "
295 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
298 /* Check upper bound. */
299 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
301 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
304 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
305 "exceeds string length", name
);
307 asprintf (&msg
, "Substring out of bounds: upper bound "
308 "exceeds string length");
309 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
313 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
314 build_int_cst (gfc_charlen_type_node
, 1),
316 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
317 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
318 build_int_cst (gfc_charlen_type_node
, 0));
319 se
->string_length
= tmp
;
323 /* Convert a derived type component reference. */
326 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
333 c
= ref
->u
.c
.component
;
335 gcc_assert (c
->backend_decl
);
337 field
= c
->backend_decl
;
338 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
340 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
344 if (c
->ts
.type
== BT_CHARACTER
)
346 tmp
= c
->ts
.cl
->backend_decl
;
347 /* Components must always be constant length. */
348 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
349 se
->string_length
= tmp
;
352 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
353 se
->expr
= build_fold_indirect_ref (se
->expr
);
357 /* Return the contents of a variable. Also handles reference/pointer
358 variables (all Fortran pointer references are implicit). */
361 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
368 bool alternate_entry
;
371 sym
= expr
->symtree
->n
.sym
;
374 /* Check that something hasn't gone horribly wrong. */
375 gcc_assert (se
->ss
!= gfc_ss_terminator
);
376 gcc_assert (se
->ss
->expr
== expr
);
378 /* A scalarized term. We already know the descriptor. */
379 se
->expr
= se
->ss
->data
.info
.descriptor
;
380 se
->string_length
= se
->ss
->string_length
;
381 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
382 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
387 tree se_expr
= NULL_TREE
;
389 se
->expr
= gfc_get_symbol_decl (sym
);
391 /* Deal with references to a parent results or entries by storing
392 the current_function_decl and moving to the parent_decl. */
393 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
394 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
395 && sym
->result
== sym
;
396 entry_master
= sym
->attr
.result
397 && sym
->ns
->proc_name
->attr
.entry_master
398 && !gfc_return_by_reference (sym
->ns
->proc_name
);
399 parent_decl
= DECL_CONTEXT (current_function_decl
);
401 if ((se
->expr
== parent_decl
&& return_value
)
402 || (sym
->ns
&& sym
->ns
->proc_name
404 && sym
->ns
->proc_name
->backend_decl
== parent_decl
405 && (alternate_entry
|| entry_master
)))
410 /* Special case for assigning the return value of a function.
411 Self recursive functions must have an explicit return value. */
412 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
413 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
415 /* Similarly for alternate entry points. */
416 else if (alternate_entry
417 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
420 gfc_entry_list
*el
= NULL
;
422 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
425 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
430 else if (entry_master
431 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
433 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
438 /* Procedure actual arguments. */
439 else if (sym
->attr
.flavor
== FL_PROCEDURE
440 && se
->expr
!= current_function_decl
)
442 gcc_assert (se
->want_pointer
);
443 if (!sym
->attr
.dummy
)
445 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
446 se
->expr
= build_fold_addr_expr (se
->expr
);
452 /* Dereference the expression, where needed. Since characters
453 are entirely different from other types, they are treated
455 if (sym
->ts
.type
== BT_CHARACTER
)
457 /* Dereference character pointer dummy arguments
459 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
461 || sym
->attr
.function
462 || sym
->attr
.result
))
463 se
->expr
= build_fold_indirect_ref (se
->expr
);
465 /* A character with VALUE attribute needs an address
468 se
->expr
= build_fold_addr_expr (se
->expr
);
471 else if (!sym
->attr
.value
)
473 /* Dereference non-character scalar dummy arguments. */
474 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
475 se
->expr
= build_fold_indirect_ref (se
->expr
);
477 /* Dereference scalar hidden result. */
478 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
479 && (sym
->attr
.function
|| sym
->attr
.result
)
480 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
481 se
->expr
= build_fold_indirect_ref (se
->expr
);
483 /* Dereference non-character pointer variables.
484 These must be dummies, results, or scalars. */
485 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
487 || sym
->attr
.function
489 || !sym
->attr
.dimension
))
490 se
->expr
= build_fold_indirect_ref (se
->expr
);
496 /* For character variables, also get the length. */
497 if (sym
->ts
.type
== BT_CHARACTER
)
499 /* If the character length of an entry isn't set, get the length from
500 the master function instead. */
501 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
502 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
504 se
->string_length
= sym
->ts
.cl
->backend_decl
;
505 gcc_assert (se
->string_length
);
513 /* Return the descriptor if that's what we want and this is an array
514 section reference. */
515 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
517 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
518 /* Return the descriptor for array pointers and allocations. */
520 && ref
->next
== NULL
&& (se
->descriptor_only
))
523 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
524 /* Return a pointer to an element. */
528 gfc_conv_component_ref (se
, ref
);
532 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
533 expr
->symtree
->name
, &expr
->where
);
542 /* Pointer assignment, allocation or pass by reference. Arrays are handled
544 if (se
->want_pointer
)
546 if (expr
->ts
.type
== BT_CHARACTER
)
547 gfc_conv_string_parameter (se
);
549 se
->expr
= build_fold_addr_expr (se
->expr
);
554 /* Unary ops are easy... Or they would be if ! was a valid op. */
557 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
562 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
563 /* Initialize the operand. */
564 gfc_init_se (&operand
, se
);
565 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
566 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
568 type
= gfc_typenode_for_spec (&expr
->ts
);
570 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
571 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
572 All other unary operators have an equivalent GIMPLE unary operator. */
573 if (code
== TRUTH_NOT_EXPR
)
574 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
575 build_int_cst (type
, 0));
577 se
->expr
= build1 (code
, type
, operand
.expr
);
581 /* Expand power operator to optimal multiplications when a value is raised
582 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
583 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
584 Programming", 3rd Edition, 1998. */
586 /* This code is mostly duplicated from expand_powi in the backend.
587 We establish the "optimal power tree" lookup table with the defined size.
588 The items in the table are the exponents used to calculate the index
589 exponents. Any integer n less than the value can get an "addition chain",
590 with the first node being one. */
591 #define POWI_TABLE_SIZE 256
593 /* The table is from builtins.c. */
594 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
596 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
597 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
598 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
599 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
600 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
601 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
602 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
603 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
604 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
605 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
606 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
607 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
608 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
609 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
610 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
611 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
612 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
613 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
614 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
615 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
616 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
617 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
618 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
619 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
620 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
621 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
622 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
623 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
624 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
625 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
626 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
627 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
630 /* If n is larger than lookup table's max index, we use the "window
632 #define POWI_WINDOW_SIZE 3
634 /* Recursive function to expand the power operator. The temporary
635 values are put in tmpvar. The function returns tmpvar[1] ** n. */
637 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
644 if (n
< POWI_TABLE_SIZE
)
649 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
650 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
654 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
655 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
656 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
660 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
664 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
665 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
667 if (n
< POWI_TABLE_SIZE
)
674 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
675 return 1. Else return 0 and a call to runtime library functions
676 will have to be built. */
678 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
683 tree vartmp
[POWI_TABLE_SIZE
];
687 type
= TREE_TYPE (lhs
);
688 n
= abs (TREE_INT_CST_LOW (rhs
));
689 sgn
= tree_int_cst_sgn (rhs
);
691 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
692 && (n
> 2 || n
< -1))
698 se
->expr
= gfc_build_const (type
, integer_one_node
);
701 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
702 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
704 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
705 build_int_cst (TREE_TYPE (lhs
), -1));
706 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
707 build_int_cst (TREE_TYPE (lhs
), 1));
710 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
713 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
714 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
715 build_int_cst (type
, 0));
719 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
720 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
721 build_int_cst (type
, 0));
722 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
726 memset (vartmp
, 0, sizeof (vartmp
));
730 tmp
= gfc_build_const (type
, integer_one_node
);
731 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
734 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
740 /* Power op (**). Constant integer exponent has special handling. */
743 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
745 tree gfc_int4_type_node
;
753 gfc_init_se (&lse
, se
);
754 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
755 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
756 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
758 gfc_init_se (&rse
, se
);
759 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
760 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
762 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
763 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
764 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
767 gfc_int4_type_node
= gfc_get_int_type (4);
769 kind
= expr
->value
.op
.op1
->ts
.kind
;
770 switch (expr
->value
.op
.op2
->ts
.type
)
773 ikind
= expr
->value
.op
.op2
->ts
.kind
;
778 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
800 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
801 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
826 switch (expr
->value
.op
.op1
->ts
.type
)
829 if (kind
== 3) /* Case 16 was not handled properly above. */
831 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
835 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
839 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
851 fndecl
= built_in_decls
[BUILT_IN_POWF
];
854 fndecl
= built_in_decls
[BUILT_IN_POW
];
858 fndecl
= built_in_decls
[BUILT_IN_POWL
];
869 fndecl
= gfor_fndecl_math_cpowf
;
872 fndecl
= gfor_fndecl_math_cpow
;
875 fndecl
= gfor_fndecl_math_cpowl10
;
878 fndecl
= gfor_fndecl_math_cpowl16
;
890 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
891 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
892 se
->expr
= build_function_call_expr (fndecl
, tmp
);
896 /* Generate code to allocate a string temporary. */
899 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
905 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
907 if (gfc_can_put_var_on_stack (len
))
909 /* Create a temporary variable to hold the result. */
910 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
911 build_int_cst (gfc_charlen_type_node
, 1));
912 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
913 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
914 var
= gfc_create_var (tmp
, "str");
915 var
= gfc_build_addr_expr (type
, var
);
919 /* Allocate a temporary to hold the result. */
920 var
= gfc_create_var (type
, "pstr");
921 args
= gfc_chainon_list (NULL_TREE
, len
);
922 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, args
);
923 tmp
= convert (type
, tmp
);
924 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
926 /* Free the temporary afterwards. */
927 tmp
= convert (pvoid_type_node
, var
);
928 args
= gfc_chainon_list (NULL_TREE
, tmp
);
929 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
930 gfc_add_expr_to_block (&se
->post
, tmp
);
937 /* Handle a string concatenation operation. A temporary will be allocated to
941 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
951 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
952 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
954 gfc_init_se (&lse
, se
);
955 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
956 gfc_conv_string_parameter (&lse
);
957 gfc_init_se (&rse
, se
);
958 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
959 gfc_conv_string_parameter (&rse
);
961 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
962 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
964 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
965 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
966 if (len
== NULL_TREE
)
968 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
969 lse
.string_length
, rse
.string_length
);
972 type
= build_pointer_type (type
);
974 var
= gfc_conv_string_tmp (se
, type
, len
);
976 /* Do the actual concatenation. */
978 args
= gfc_chainon_list (args
, len
);
979 args
= gfc_chainon_list (args
, var
);
980 args
= gfc_chainon_list (args
, lse
.string_length
);
981 args
= gfc_chainon_list (args
, lse
.expr
);
982 args
= gfc_chainon_list (args
, rse
.string_length
);
983 args
= gfc_chainon_list (args
, rse
.expr
);
984 tmp
= build_function_call_expr (gfor_fndecl_concat_string
, args
);
985 gfc_add_expr_to_block (&se
->pre
, tmp
);
987 /* Add the cleanup for the operands. */
988 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
989 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
992 se
->string_length
= len
;
995 /* Translates an op expression. Common (binary) cases are handled by this
996 function, others are passed on. Recursion is used in either case.
997 We use the fact that (op1.ts == op2.ts) (except for the power
999 Operators need no special handling for scalarized expressions as long as
1000 they call gfc_conv_simple_val to get their operands.
1001 Character strings get special handling. */
1004 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1006 enum tree_code code
;
1016 switch (expr
->value
.op
.operator)
1018 case INTRINSIC_UPLUS
:
1019 case INTRINSIC_PARENTHESES
:
1020 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1023 case INTRINSIC_UMINUS
:
1024 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1028 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1031 case INTRINSIC_PLUS
:
1035 case INTRINSIC_MINUS
:
1039 case INTRINSIC_TIMES
:
1043 case INTRINSIC_DIVIDE
:
1044 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1045 an integer, we must round towards zero, so we use a
1047 if (expr
->ts
.type
== BT_INTEGER
)
1048 code
= TRUNC_DIV_EXPR
;
1053 case INTRINSIC_POWER
:
1054 gfc_conv_power_op (se
, expr
);
1057 case INTRINSIC_CONCAT
:
1058 gfc_conv_concat_op (se
, expr
);
1062 code
= TRUTH_ANDIF_EXPR
;
1067 code
= TRUTH_ORIF_EXPR
;
1071 /* EQV and NEQV only work on logicals, but since we represent them
1072 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1081 case INTRINSIC_NEQV
:
1111 case INTRINSIC_USER
:
1112 case INTRINSIC_ASSIGN
:
1113 /* These should be converted into function calls by the frontend. */
1117 fatal_error ("Unknown intrinsic op");
1121 /* The only exception to this is **, which is handled separately anyway. */
1122 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1124 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1128 gfc_init_se (&lse
, se
);
1129 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1130 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1133 gfc_init_se (&rse
, se
);
1134 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1135 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1139 gfc_conv_string_parameter (&lse
);
1140 gfc_conv_string_parameter (&rse
);
1142 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1143 rse
.string_length
, rse
.expr
);
1144 rse
.expr
= integer_zero_node
;
1145 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1148 type
= gfc_typenode_for_spec (&expr
->ts
);
1152 /* The result of logical ops is always boolean_type_node. */
1153 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1154 se
->expr
= convert (type
, tmp
);
1157 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1159 /* Add the post blocks. */
1160 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1161 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1164 /* If a string's length is one, we convert it to a single character. */
1167 gfc_to_single_character (tree len
, tree str
)
1169 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1171 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1172 && TREE_INT_CST_HIGH (len
) == 0)
1174 str
= fold_convert (pchar_type_node
, str
);
1175 return build_fold_indirect_ref (str
);
1181 /* Compare two strings. If they are all single characters, the result is the
1182 subtraction of them. Otherwise, we build a library call. */
1185 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1192 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1193 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1195 type
= gfc_get_int_type (gfc_default_integer_kind
);
1197 sc1
= gfc_to_single_character (len1
, str1
);
1198 sc2
= gfc_to_single_character (len2
, str2
);
1200 /* Deal with single character specially. */
1201 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1203 sc1
= fold_convert (type
, sc1
);
1204 sc2
= fold_convert (type
, sc2
);
1205 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1210 tmp
= gfc_chainon_list (tmp
, len1
);
1211 tmp
= gfc_chainon_list (tmp
, str1
);
1212 tmp
= gfc_chainon_list (tmp
, len2
);
1213 tmp
= gfc_chainon_list (tmp
, str2
);
1215 /* Build a call for the comparison. */
1216 tmp
= build_function_call_expr (gfor_fndecl_compare_string
, tmp
);
1223 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1227 if (sym
->attr
.dummy
)
1229 tmp
= gfc_get_symbol_decl (sym
);
1230 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1231 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1235 if (!sym
->backend_decl
)
1236 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1238 tmp
= sym
->backend_decl
;
1239 if (sym
->attr
.cray_pointee
)
1240 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1241 gfc_get_symbol_decl (sym
->cp_pointer
));
1242 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1244 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1245 tmp
= build_fold_addr_expr (tmp
);
1252 /* Translate the call for an elemental subroutine call used in an operator
1253 assignment. This is a simplified version of gfc_conv_function_call. */
1256 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1263 /* Only elemental subroutines with two arguments. */
1264 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1265 gcc_assert (sym
->formal
->next
->next
== NULL
);
1267 gfc_init_block (&block
);
1269 gfc_add_block_to_block (&block
, &lse
->pre
);
1270 gfc_add_block_to_block (&block
, &rse
->pre
);
1272 /* Build the argument list for the call, including hidden string lengths. */
1273 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1274 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1275 if (lse
->string_length
!= NULL_TREE
)
1276 args
= gfc_chainon_list (args
, lse
->string_length
);
1277 if (rse
->string_length
!= NULL_TREE
)
1278 args
= gfc_chainon_list (args
, rse
->string_length
);
1280 /* Build the function call. */
1281 gfc_init_se (&se
, NULL
);
1282 gfc_conv_function_val (&se
, sym
);
1283 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1284 tmp
= build3 (CALL_EXPR
, tmp
, se
.expr
, args
, NULL_TREE
);
1285 gfc_add_expr_to_block (&block
, tmp
);
1287 gfc_add_block_to_block (&block
, &lse
->post
);
1288 gfc_add_block_to_block (&block
, &rse
->post
);
1290 return gfc_finish_block (&block
);
1294 /* Initialize MAPPING. */
1297 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1299 mapping
->syms
= NULL
;
1300 mapping
->charlens
= NULL
;
1304 /* Free all memory held by MAPPING (but not MAPPING itself). */
1307 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1309 gfc_interface_sym_mapping
*sym
;
1310 gfc_interface_sym_mapping
*nextsym
;
1312 gfc_charlen
*nextcl
;
1314 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1316 nextsym
= sym
->next
;
1317 gfc_free_symbol (sym
->new->n
.sym
);
1318 gfc_free (sym
->new);
1321 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1324 gfc_free_expr (cl
->length
);
1330 /* Return a copy of gfc_charlen CL. Add the returned structure to
1331 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1333 static gfc_charlen
*
1334 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1339 new = gfc_get_charlen ();
1340 new->next
= mapping
->charlens
;
1341 new->length
= gfc_copy_expr (cl
->length
);
1343 mapping
->charlens
= new;
1348 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1349 array variable that can be used as the actual argument for dummy
1350 argument SYM. Add any initialization code to BLOCK. PACKED is as
1351 for gfc_get_nodesc_array_type and DATA points to the first element
1352 in the passed array. */
1355 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1356 int packed
, tree data
)
1361 type
= gfc_typenode_for_spec (&sym
->ts
);
1362 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1364 var
= gfc_create_var (type
, "ifm");
1365 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1371 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1372 and offset of descriptorless array type TYPE given that it has the same
1373 size as DESC. Add any set-up code to BLOCK. */
1376 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1383 offset
= gfc_index_zero_node
;
1384 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1386 dim
= gfc_rank_cst
[n
];
1387 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1388 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1390 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1391 = gfc_conv_descriptor_lbound (desc
, dim
);
1392 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1393 = gfc_conv_descriptor_ubound (desc
, dim
);
1395 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1397 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1398 gfc_conv_descriptor_ubound (desc
, dim
),
1399 gfc_conv_descriptor_lbound (desc
, dim
));
1400 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1401 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1403 tmp
= gfc_evaluate_now (tmp
, block
);
1404 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1406 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1407 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1408 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1409 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1411 offset
= gfc_evaluate_now (offset
, block
);
1412 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1416 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1417 in SE. The caller may still use se->expr and se->string_length after
1418 calling this function. */
1421 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1422 gfc_symbol
* sym
, gfc_se
* se
)
1424 gfc_interface_sym_mapping
*sm
;
1428 gfc_symbol
*new_sym
;
1430 gfc_symtree
*new_symtree
;
1432 /* Create a new symbol to represent the actual argument. */
1433 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1434 new_sym
->ts
= sym
->ts
;
1435 new_sym
->attr
.referenced
= 1;
1436 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1437 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1438 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1439 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1441 /* Create a fake symtree for it. */
1443 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1444 new_symtree
->n
.sym
= new_sym
;
1445 gcc_assert (new_symtree
== root
);
1447 /* Create a dummy->actual mapping. */
1448 sm
= gfc_getmem (sizeof (*sm
));
1449 sm
->next
= mapping
->syms
;
1451 sm
->new = new_symtree
;
1454 /* Stabilize the argument's value. */
1455 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1457 if (sym
->ts
.type
== BT_CHARACTER
)
1459 /* Create a copy of the dummy argument's length. */
1460 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1462 /* If the length is specified as "*", record the length that
1463 the caller is passing. We should use the callee's length
1464 in all other cases. */
1465 if (!new_sym
->ts
.cl
->length
)
1467 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1468 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1472 /* Use the passed value as-is if the argument is a function. */
1473 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1476 /* If the argument is either a string or a pointer to a string,
1477 convert it to a boundless character type. */
1478 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1480 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1481 tmp
= build_pointer_type (tmp
);
1482 if (sym
->attr
.pointer
)
1483 value
= build_fold_indirect_ref (se
->expr
);
1486 value
= fold_convert (tmp
, value
);
1489 /* If the argument is a scalar, a pointer to an array or an allocatable,
1491 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1492 value
= build_fold_indirect_ref (se
->expr
);
1494 /* For character(*), use the actual argument's descriptor. */
1495 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1496 value
= build_fold_indirect_ref (se
->expr
);
1498 /* If the argument is an array descriptor, use it to determine
1499 information about the actual argument's shape. */
1500 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1501 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1503 /* Get the actual argument's descriptor. */
1504 desc
= build_fold_indirect_ref (se
->expr
);
1506 /* Create the replacement variable. */
1507 tmp
= gfc_conv_descriptor_data_get (desc
);
1508 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1510 /* Use DESC to work out the upper bounds, strides and offset. */
1511 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1514 /* Otherwise we have a packed array. */
1515 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1517 new_sym
->backend_decl
= value
;
1521 /* Called once all dummy argument mappings have been added to MAPPING,
1522 but before the mapping is used to evaluate expressions. Pre-evaluate
1523 the length of each argument, adding any initialization code to PRE and
1524 any finalization code to POST. */
1527 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1528 stmtblock_t
* pre
, stmtblock_t
* post
)
1530 gfc_interface_sym_mapping
*sym
;
1534 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1535 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1536 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1538 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1539 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1540 gfc_init_se (&se
, NULL
);
1541 gfc_conv_expr (&se
, expr
);
1543 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1544 gfc_add_block_to_block (pre
, &se
.pre
);
1545 gfc_add_block_to_block (post
, &se
.post
);
1547 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1552 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1556 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1557 gfc_constructor
* c
)
1559 for (; c
; c
= c
->next
)
1561 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1564 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1565 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1566 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1572 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1576 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1581 for (; ref
; ref
= ref
->next
)
1585 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1587 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1588 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1589 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1591 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1598 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1599 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1605 /* EXPR is a copy of an expression that appeared in the interface
1606 associated with MAPPING. Walk it recursively looking for references to
1607 dummy arguments that MAPPING maps to actual arguments. Replace each such
1608 reference with a reference to the associated actual argument. */
1611 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1614 gfc_interface_sym_mapping
*sym
;
1615 gfc_actual_arglist
*actual
;
1620 /* Copying an expression does not copy its length, so do that here. */
1621 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1623 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1624 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1627 /* Apply the mapping to any references. */
1628 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1630 /* ...and to the expression's symbol, if it has one. */
1632 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1633 if (sym
->old
== expr
->symtree
->n
.sym
)
1634 expr
->symtree
= sym
->new;
1636 /* ...and to subexpressions in expr->value. */
1637 switch (expr
->expr_type
)
1642 case EXPR_SUBSTRING
:
1646 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1647 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1651 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1652 if (sym
->old
== expr
->value
.function
.esym
)
1653 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1655 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1656 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1660 case EXPR_STRUCTURE
:
1661 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1667 /* Evaluate interface expression EXPR using MAPPING. Store the result
1671 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1672 gfc_se
* se
, gfc_expr
* expr
)
1674 expr
= gfc_copy_expr (expr
);
1675 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1676 gfc_conv_expr (se
, expr
);
1677 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1678 gfc_free_expr (expr
);
1681 /* Returns a reference to a temporary array into which a component of
1682 an actual argument derived type array is copied and then returned
1683 after the function call.
1684 TODO Get rid of this kludge, when array descriptors are capable of
1685 handling arrays with a bigger stride in bytes than size. */
1688 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1689 int g77
, sym_intent intent
)
1705 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1707 gfc_init_se (&lse
, NULL
);
1708 gfc_init_se (&rse
, NULL
);
1710 /* Walk the argument expression. */
1711 rss
= gfc_walk_expr (expr
);
1713 gcc_assert (rss
!= gfc_ss_terminator
);
1715 /* Initialize the scalarizer. */
1716 gfc_init_loopinfo (&loop
);
1717 gfc_add_ss_to_loop (&loop
, rss
);
1719 /* Calculate the bounds of the scalarization. */
1720 gfc_conv_ss_startstride (&loop
);
1722 /* Build an ss for the temporary. */
1723 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1724 if (GFC_ARRAY_TYPE_P (base_type
)
1725 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1726 base_type
= gfc_get_element_type (base_type
);
1728 loop
.temp_ss
= gfc_get_ss ();;
1729 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1730 loop
.temp_ss
->data
.temp
.type
= base_type
;
1732 if (expr
->ts
.type
== BT_CHARACTER
)
1734 gfc_ref
*char_ref
= expr
->ref
;
1736 for (; char_ref
; char_ref
= char_ref
->next
)
1737 if (char_ref
->type
== REF_SUBSTRING
)
1741 expr
->ts
.cl
= gfc_get_charlen ();
1742 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1743 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1745 gfc_init_se (&tmp_se
, NULL
);
1746 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1747 gfc_array_index_type
);
1748 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1749 tmp_se
.expr
, gfc_index_one_node
);
1750 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1751 gfc_init_se (&tmp_se
, NULL
);
1752 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1753 gfc_array_index_type
);
1754 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1756 expr
->ts
.cl
->backend_decl
= tmp
;
1760 loop
.temp_ss
->data
.temp
.type
1761 = gfc_typenode_for_spec (&expr
->ts
);
1762 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1765 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1766 loop
.temp_ss
->next
= gfc_ss_terminator
;
1768 /* Associate the SS with the loop. */
1769 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1771 /* Setup the scalarizing loops. */
1772 gfc_conv_loop_setup (&loop
);
1774 /* Pass the temporary descriptor back to the caller. */
1775 info
= &loop
.temp_ss
->data
.info
;
1776 parmse
->expr
= info
->descriptor
;
1778 /* Setup the gfc_se structures. */
1779 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1780 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1783 lse
.ss
= loop
.temp_ss
;
1784 gfc_mark_ss_chain_used (rss
, 1);
1785 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1787 /* Start the scalarized loop body. */
1788 gfc_start_scalarized_body (&loop
, &body
);
1790 /* Translate the expression. */
1791 gfc_conv_expr (&rse
, expr
);
1793 gfc_conv_tmp_array_ref (&lse
);
1794 gfc_advance_se_ss_chain (&lse
);
1796 if (intent
!= INTENT_OUT
)
1798 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1799 gfc_add_expr_to_block (&body
, tmp
);
1800 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1801 gfc_trans_scalarizing_loops (&loop
, &body
);
1805 /* Make sure that the temporary declaration survives by merging
1806 all the loop declarations into the current context. */
1807 for (n
= 0; n
< loop
.dimen
; n
++)
1809 gfc_merge_block_scope (&body
);
1810 body
= loop
.code
[loop
.order
[n
]];
1812 gfc_merge_block_scope (&body
);
1815 /* Add the post block after the second loop, so that any
1816 freeing of allocated memory is done at the right time. */
1817 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1819 /**********Copy the temporary back again.*********/
1821 gfc_init_se (&lse
, NULL
);
1822 gfc_init_se (&rse
, NULL
);
1824 /* Walk the argument expression. */
1825 lss
= gfc_walk_expr (expr
);
1826 rse
.ss
= loop
.temp_ss
;
1829 /* Initialize the scalarizer. */
1830 gfc_init_loopinfo (&loop2
);
1831 gfc_add_ss_to_loop (&loop2
, lss
);
1833 /* Calculate the bounds of the scalarization. */
1834 gfc_conv_ss_startstride (&loop2
);
1836 /* Setup the scalarizing loops. */
1837 gfc_conv_loop_setup (&loop2
);
1839 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1840 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1842 gfc_mark_ss_chain_used (lss
, 1);
1843 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1845 /* Declare the variable to hold the temporary offset and start the
1846 scalarized loop body. */
1847 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1848 gfc_start_scalarized_body (&loop2
, &body
);
1850 /* Build the offsets for the temporary from the loop variables. The
1851 temporary array has lbounds of zero and strides of one in all
1852 dimensions, so this is very simple. The offset is only computed
1853 outside the innermost loop, so the overall transfer could be
1854 optimized further. */
1855 info
= &rse
.ss
->data
.info
;
1857 tmp_index
= gfc_index_zero_node
;
1858 for (n
= info
->dimen
- 1; n
> 0; n
--)
1861 tmp
= rse
.loop
->loopvar
[n
];
1862 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1863 tmp
, rse
.loop
->from
[n
]);
1864 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1867 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1868 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1869 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1870 tmp_str
, gfc_index_one_node
);
1872 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1876 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1877 tmp_index
, rse
.loop
->from
[0]);
1878 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1880 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1881 rse
.loop
->loopvar
[0], offset
);
1883 /* Now use the offset for the reference. */
1884 tmp
= build_fold_indirect_ref (info
->data
);
1885 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1887 if (expr
->ts
.type
== BT_CHARACTER
)
1888 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1890 gfc_conv_expr (&lse
, expr
);
1892 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1894 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1895 gfc_add_expr_to_block (&body
, tmp
);
1897 /* Generate the copying loops. */
1898 gfc_trans_scalarizing_loops (&loop2
, &body
);
1900 /* Wrap the whole thing up by adding the second loop to the post-block
1901 and following it by the post-block of the first loop. In this way,
1902 if the temporary needs freeing, it is done after use! */
1903 if (intent
!= INTENT_IN
)
1905 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1906 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1909 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1911 gfc_cleanup_loop (&loop
);
1912 gfc_cleanup_loop (&loop2
);
1914 /* Pass the string length to the argument expression. */
1915 if (expr
->ts
.type
== BT_CHARACTER
)
1916 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1918 /* We want either the address for the data or the address of the descriptor,
1919 depending on the mode of passing array arguments. */
1921 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1923 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1928 /* Is true if an array reference is followed by a component or substring
1932 is_aliased_array (gfc_expr
* e
)
1938 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1940 if (ref
->type
== REF_ARRAY
1941 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1945 && ref
->type
!= REF_ARRAY
)
1951 /* Generate the code for argument list functions. */
1954 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
1956 tree type
= NULL_TREE
;
1957 /* Pass by value for g77 %VAL(arg), pass the address
1958 indirectly for %LOC, else by reference. Thus %REF
1959 is a "do-nothing" and %LOC is the same as an F95
1961 if (strncmp (name
, "%VAL", 4) == 0)
1963 gfc_conv_expr (se
, expr
);
1964 /* %VAL converts argument to default kind. */
1965 switch (expr
->ts
.type
)
1968 type
= gfc_get_real_type (gfc_default_real_kind
);
1969 se
->expr
= fold_convert (type
, se
->expr
);
1972 type
= gfc_get_complex_type (gfc_default_complex_kind
);
1973 se
->expr
= fold_convert (type
, se
->expr
);
1976 type
= gfc_get_int_type (gfc_default_integer_kind
);
1977 se
->expr
= fold_convert (type
, se
->expr
);
1980 type
= gfc_get_logical_type (gfc_default_logical_kind
);
1981 se
->expr
= fold_convert (type
, se
->expr
);
1983 /* This should have been resolved away. */
1984 case BT_UNKNOWN
: case BT_CHARACTER
: case BT_DERIVED
:
1985 case BT_PROCEDURE
: case BT_HOLLERITH
:
1986 gfc_internal_error ("Bad type in conv_arglist_function");
1990 else if (strncmp (name
, "%LOC", 4) == 0)
1992 gfc_conv_expr_reference (se
, expr
);
1993 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
1995 else if (strncmp (name
, "%REF", 4) == 0)
1996 gfc_conv_expr_reference (se
, expr
);
1998 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2002 /* Generate code for a procedure call. Note can return se->post != NULL.
2003 If se->direct_byref is set then se->expr contains the return parameter.
2004 Return nonzero, if the call has alternate specifiers. */
2007 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2008 gfc_actual_arglist
* arg
, tree append_args
)
2010 gfc_interface_mapping mapping
;
2024 gfc_formal_arglist
*formal
;
2025 int has_alternate_specifier
= 0;
2026 bool need_interface_mapping
;
2033 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2035 arglist
= NULL_TREE
;
2036 retargs
= NULL_TREE
;
2037 stringargs
= NULL_TREE
;
2043 if (!sym
->attr
.elemental
)
2045 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2046 if (se
->ss
->useflags
)
2048 gcc_assert (gfc_return_by_reference (sym
)
2049 && sym
->result
->attr
.dimension
);
2050 gcc_assert (se
->loop
!= NULL
);
2052 /* Access the previously obtained result. */
2053 gfc_conv_tmp_array_ref (se
);
2054 gfc_advance_se_ss_chain (se
);
2058 info
= &se
->ss
->data
.info
;
2063 gfc_init_block (&post
);
2064 gfc_init_interface_mapping (&mapping
);
2065 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2066 && sym
->ts
.cl
->length
2067 && sym
->ts
.cl
->length
->expr_type
2069 || sym
->attr
.dimension
);
2070 formal
= sym
->formal
;
2071 /* Evaluate the arguments. */
2072 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2075 fsym
= formal
? formal
->sym
: NULL
;
2076 parm_kind
= MISSING
;
2080 if (se
->ignore_optional
)
2082 /* Some intrinsics have already been resolved to the correct
2086 else if (arg
->label
)
2088 has_alternate_specifier
= 1;
2093 /* Pass a NULL pointer for an absent arg. */
2094 gfc_init_se (&parmse
, NULL
);
2095 parmse
.expr
= null_pointer_node
;
2096 if (arg
->missing_arg_type
== BT_CHARACTER
)
2097 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2100 else if (se
->ss
&& se
->ss
->useflags
)
2102 /* An elemental function inside a scalarized loop. */
2103 gfc_init_se (&parmse
, se
);
2104 gfc_conv_expr_reference (&parmse
, e
);
2105 parm_kind
= ELEMENTAL
;
2109 /* A scalar or transformational function. */
2110 gfc_init_se (&parmse
, NULL
);
2111 argss
= gfc_walk_expr (e
);
2113 if (argss
== gfc_ss_terminator
)
2116 if (fsym
&& fsym
->attr
.value
)
2118 gfc_conv_expr (&parmse
, e
);
2120 else if (arg
->name
&& arg
->name
[0] == '%')
2121 /* Argument list functions %VAL, %LOC and %REF are signalled
2122 through arg->name. */
2123 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2126 gfc_conv_expr_reference (&parmse
, e
);
2127 if (fsym
&& fsym
->attr
.pointer
2128 && e
->expr_type
!= EXPR_NULL
)
2130 /* Scalar pointer dummy args require an extra level of
2131 indirection. The null pointer already contains
2132 this level of indirection. */
2133 parm_kind
= SCALAR_POINTER
;
2134 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2140 /* If the procedure requires an explicit interface, the actual
2141 argument is passed according to the corresponding formal
2142 argument. If the corresponding formal argument is a POINTER,
2143 ALLOCATABLE or assumed shape, we do not use g77's calling
2144 convention, and pass the address of the array descriptor
2145 instead. Otherwise we use g77's calling convention. */
2148 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2149 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2150 f
= f
|| !sym
->attr
.always_explicit
;
2152 if (e
->expr_type
== EXPR_VARIABLE
2153 && is_aliased_array (e
))
2154 /* The actual argument is a component reference to an
2155 array of derived types. In this case, the argument
2156 is converted to a temporary, which is passed and then
2157 written back after the procedure call. */
2158 gfc_conv_aliased_arg (&parmse
, e
, f
,
2159 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2161 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2163 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2164 allocated on entry, it must be deallocated. */
2165 if (fsym
&& fsym
->attr
.allocatable
2166 && fsym
->attr
.intent
== INTENT_OUT
)
2168 tmp
= build_fold_indirect_ref (parmse
.expr
);
2169 tmp
= gfc_trans_dealloc_allocated (tmp
);
2170 gfc_add_expr_to_block (&se
->pre
, tmp
);
2180 /* If an optional argument is itself an optional dummy
2181 argument, check its presence and substitute a null
2183 if (e
->expr_type
== EXPR_VARIABLE
2184 && e
->symtree
->n
.sym
->attr
.optional
2185 && fsym
->attr
.optional
)
2186 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2188 /* If an INTENT(OUT) dummy of derived type has a default
2189 initializer, it must be (re)initialized here. */
2190 if (fsym
->attr
.intent
== INTENT_OUT
2191 && fsym
->ts
.type
== BT_DERIVED
2194 gcc_assert (!fsym
->attr
.allocatable
);
2195 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2196 gfc_add_expr_to_block (&se
->pre
, tmp
);
2199 /* Obtain the character length of an assumed character
2200 length procedure from the typespec. */
2201 if (fsym
->ts
.type
== BT_CHARACTER
2202 && parmse
.string_length
== NULL_TREE
2203 && e
->ts
.type
== BT_PROCEDURE
2204 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2205 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2207 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2208 parmse
.string_length
2209 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2213 if (need_interface_mapping
)
2214 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2217 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2218 gfc_add_block_to_block (&post
, &parmse
.post
);
2220 /* Allocated allocatable components of derived types must be
2221 deallocated for INTENT(OUT) dummy arguments and non-variable
2222 scalars. Non-variable arrays are dealt with in trans-array.c
2223 (gfc_conv_array_parameter). */
2224 if (e
&& e
->ts
.type
== BT_DERIVED
2225 && e
->ts
.derived
->attr
.alloc_comp
2226 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2228 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2231 tmp
= build_fold_indirect_ref (parmse
.expr
);
2232 parm_rank
= e
->rank
;
2240 case (SCALAR_POINTER
):
2241 tmp
= build_fold_indirect_ref (tmp
);
2248 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2249 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2250 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2251 tmp
, build_empty_stmt ());
2253 if (e
->expr_type
!= EXPR_VARIABLE
)
2254 /* Don't deallocate non-variables until they have been used. */
2255 gfc_add_expr_to_block (&se
->post
, tmp
);
2258 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2259 gfc_add_expr_to_block (&se
->pre
, tmp
);
2263 /* Character strings are passed as two parameters, a length and a
2265 if (parmse
.string_length
!= NULL_TREE
)
2266 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2268 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2270 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2273 if (ts
.type
== BT_CHARACTER
)
2275 if (sym
->ts
.cl
->length
== NULL
)
2277 /* Assumed character length results are not allowed by 5.1.1.5 of the
2278 standard and are trapped in resolve.c; except in the case of SPREAD
2279 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2280 we take the character length of the first argument for the result.
2281 For dummies, we have to look through the formal argument list for
2282 this function and use the character length found there.*/
2283 if (!sym
->attr
.dummy
)
2284 cl
.backend_decl
= TREE_VALUE (stringargs
);
2287 formal
= sym
->ns
->proc_name
->formal
;
2288 for (; formal
; formal
= formal
->next
)
2289 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2290 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2295 /* Calculate the length of the returned string. */
2296 gfc_init_se (&parmse
, NULL
);
2297 if (need_interface_mapping
)
2298 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2300 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2301 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2302 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2303 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2306 /* Set up a charlen structure for it. */
2311 len
= cl
.backend_decl
;
2314 byref
= gfc_return_by_reference (sym
);
2317 if (se
->direct_byref
)
2318 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2319 else if (sym
->result
->attr
.dimension
)
2321 gcc_assert (se
->loop
&& info
);
2323 /* Set the type of the array. */
2324 tmp
= gfc_typenode_for_spec (&ts
);
2325 info
->dimen
= se
->loop
->dimen
;
2327 /* Evaluate the bounds of the result, if known. */
2328 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2330 /* Create a temporary to store the result. In case the function
2331 returns a pointer, the temporary will be a shallow copy and
2332 mustn't be deallocated. */
2333 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2334 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2335 false, !sym
->attr
.pointer
, callee_alloc
);
2337 /* Pass the temporary as the first argument. */
2338 tmp
= info
->descriptor
;
2339 tmp
= build_fold_addr_expr (tmp
);
2340 retargs
= gfc_chainon_list (retargs
, tmp
);
2342 else if (ts
.type
== BT_CHARACTER
)
2344 /* Pass the string length. */
2345 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2346 type
= build_pointer_type (type
);
2348 /* Return an address to a char[0:len-1]* temporary for
2349 character pointers. */
2350 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2352 /* Build char[0:len-1] * pstr. */
2353 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2354 build_int_cst (gfc_charlen_type_node
, 1));
2355 tmp
= build_range_type (gfc_array_index_type
,
2356 gfc_index_zero_node
, tmp
);
2357 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2358 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2360 /* Provide an address expression for the function arguments. */
2361 var
= build_fold_addr_expr (var
);
2364 var
= gfc_conv_string_tmp (se
, type
, len
);
2366 retargs
= gfc_chainon_list (retargs
, var
);
2370 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2372 type
= gfc_get_complex_type (ts
.kind
);
2373 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2374 retargs
= gfc_chainon_list (retargs
, var
);
2377 /* Add the string length to the argument list. */
2378 if (ts
.type
== BT_CHARACTER
)
2379 retargs
= gfc_chainon_list (retargs
, len
);
2381 gfc_free_interface_mapping (&mapping
);
2383 /* Add the return arguments. */
2384 arglist
= chainon (retargs
, arglist
);
2386 /* Add the hidden string length parameters to the arguments. */
2387 arglist
= chainon (arglist
, stringargs
);
2389 /* We may want to append extra arguments here. This is used e.g. for
2390 calls to libgfortran_matmul_??, which need extra information. */
2391 if (append_args
!= NULL_TREE
)
2392 arglist
= chainon (arglist
, append_args
);
2394 /* Generate the actual call. */
2395 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. */
2399 if (has_alternate_specifier
2400 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2402 gcc_assert (! sym
->attr
.dummy
);
2403 TREE_TYPE (sym
->backend_decl
)
2404 = build_function_type (integer_type_node
,
2405 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2406 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2409 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2410 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2411 arglist
, NULL_TREE
);
2413 /* If we have a pointer function, but we don't want a pointer, e.g.
2416 where f is pointer valued, we have to dereference the result. */
2417 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2418 se
->expr
= build_fold_indirect_ref (se
->expr
);
2420 /* f2c calling conventions require a scalar default real function to
2421 return a double precision result. Convert this back to default
2422 real. We only care about the cases that can happen in Fortran 77.
2424 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2425 && sym
->ts
.kind
== gfc_default_real_kind
2426 && !sym
->attr
.always_explicit
)
2427 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2429 /* A pure function may still have side-effects - it may modify its
2431 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2433 if (!sym
->attr
.pure
)
2434 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2439 /* Add the function call to the pre chain. There is no expression. */
2440 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2441 se
->expr
= NULL_TREE
;
2443 if (!se
->direct_byref
)
2445 if (sym
->attr
.dimension
)
2447 if (flag_bounds_check
)
2449 /* Check the data pointer hasn't been modified. This would
2450 happen in a function returning a pointer. */
2451 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2452 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2454 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2456 se
->expr
= info
->descriptor
;
2457 /* Bundle in the string length. */
2458 se
->string_length
= len
;
2460 else if (sym
->ts
.type
== BT_CHARACTER
)
2462 /* Dereference for character pointer results. */
2463 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2464 se
->expr
= build_fold_indirect_ref (var
);
2468 se
->string_length
= len
;
2472 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2473 se
->expr
= build_fold_indirect_ref (var
);
2478 /* Follow the function call with the argument post block. */
2480 gfc_add_block_to_block (&se
->pre
, &post
);
2482 gfc_add_block_to_block (&se
->post
, &post
);
2484 return has_alternate_specifier
;
2488 /* Generate code to copy a string. */
2491 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2492 tree slength
, tree src
)
2494 tree tmp
, dlen
, slen
;
2502 stmtblock_t tempblock
;
2504 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2505 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2507 /* Deal with single character specially. */
2508 dsc
= gfc_to_single_character (dlen
, dest
);
2509 ssc
= gfc_to_single_character (slen
, src
);
2510 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2512 gfc_add_modify_expr (block
, dsc
, ssc
);
2516 /* Do nothing if the destination length is zero. */
2517 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2518 build_int_cst (gfc_charlen_type_node
, 0));
2520 /* The following code was previously in _gfortran_copy_string:
2522 // The two strings may overlap so we use memmove.
2524 copy_string (GFC_INTEGER_4 destlen, char * dest,
2525 GFC_INTEGER_4 srclen, const char * src)
2527 if (srclen >= destlen)
2529 // This will truncate if too long.
2530 memmove (dest, src, destlen);
2534 memmove (dest, src, srclen);
2536 memset (&dest[srclen], ' ', destlen - srclen);
2540 We're now doing it here for better optimization, but the logic
2543 /* Truncate string if source is too long. */
2544 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2545 tmp2
= gfc_chainon_list (NULL_TREE
, dest
);
2546 tmp2
= gfc_chainon_list (tmp2
, src
);
2547 tmp2
= gfc_chainon_list (tmp2
, dlen
);
2548 tmp2
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp2
);
2550 /* Else copy and pad with spaces. */
2551 tmp3
= gfc_chainon_list (NULL_TREE
, dest
);
2552 tmp3
= gfc_chainon_list (tmp3
, src
);
2553 tmp3
= gfc_chainon_list (tmp3
, slen
);
2554 tmp3
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp3
);
2556 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2557 fold_convert (pchar_type_node
, slen
));
2558 tmp4
= gfc_chainon_list (NULL_TREE
, tmp4
);
2559 tmp4
= gfc_chainon_list (tmp4
, build_int_cst
2560 (gfc_get_int_type (gfc_c_int_kind
),
2561 lang_hooks
.to_target_charset (' ')));
2562 tmp4
= gfc_chainon_list (tmp4
, fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2564 tmp4
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], tmp4
);
2566 gfc_init_block (&tempblock
);
2567 gfc_add_expr_to_block (&tempblock
, tmp3
);
2568 gfc_add_expr_to_block (&tempblock
, tmp4
);
2569 tmp3
= gfc_finish_block (&tempblock
);
2571 /* The whole copy_string function is there. */
2572 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2573 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2574 gfc_add_expr_to_block (block
, tmp
);
2578 /* Translate a statement function.
2579 The value of a statement function reference is obtained by evaluating the
2580 expression using the values of the actual arguments for the values of the
2581 corresponding dummy arguments. */
2584 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2588 gfc_formal_arglist
*fargs
;
2589 gfc_actual_arglist
*args
;
2592 gfc_saved_var
*saved_vars
;
2598 sym
= expr
->symtree
->n
.sym
;
2599 args
= expr
->value
.function
.actual
;
2600 gfc_init_se (&lse
, NULL
);
2601 gfc_init_se (&rse
, NULL
);
2604 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2606 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2607 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2609 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2611 /* Each dummy shall be specified, explicitly or implicitly, to be
2613 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2616 /* Create a temporary to hold the value. */
2617 type
= gfc_typenode_for_spec (&fsym
->ts
);
2618 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2620 if (fsym
->ts
.type
== BT_CHARACTER
)
2622 /* Copy string arguments. */
2625 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2626 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2628 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2629 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2632 gfc_conv_expr (&rse
, args
->expr
);
2633 gfc_conv_string_parameter (&rse
);
2634 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2635 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2637 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2639 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2640 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2644 /* For everything else, just evaluate the expression. */
2645 gfc_conv_expr (&lse
, args
->expr
);
2647 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2648 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2649 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2655 /* Use the temporary variables in place of the real ones. */
2656 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2657 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2659 gfc_conv_expr (se
, sym
->value
);
2661 if (sym
->ts
.type
== BT_CHARACTER
)
2663 gfc_conv_const_charlen (sym
->ts
.cl
);
2665 /* Force the expression to the correct length. */
2666 if (!INTEGER_CST_P (se
->string_length
)
2667 || tree_int_cst_lt (se
->string_length
,
2668 sym
->ts
.cl
->backend_decl
))
2670 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2671 tmp
= gfc_create_var (type
, sym
->name
);
2672 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2673 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2674 se
->string_length
, se
->expr
);
2677 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2680 /* Restore the original variables. */
2681 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2682 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2683 gfc_free (saved_vars
);
2687 /* Translate a function expression. */
2690 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2694 if (expr
->value
.function
.isym
)
2696 gfc_conv_intrinsic_function (se
, expr
);
2700 /* We distinguish statement functions from general functions to improve
2701 runtime performance. */
2702 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2704 gfc_conv_statement_function (se
, expr
);
2708 /* expr.value.function.esym is the resolved (specific) function symbol for
2709 most functions. However this isn't set for dummy procedures. */
2710 sym
= expr
->value
.function
.esym
;
2712 sym
= expr
->symtree
->n
.sym
;
2713 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2718 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2720 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2721 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2723 gfc_conv_tmp_array_ref (se
);
2724 gfc_advance_se_ss_chain (se
);
2728 /* Build a static initializer. EXPR is the expression for the initial value.
2729 The other parameters describe the variable of the component being
2730 initialized. EXPR may be null. */
2733 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2734 bool array
, bool pointer
)
2738 if (!(expr
|| pointer
))
2743 /* Arrays need special handling. */
2745 return gfc_build_null_descriptor (type
);
2747 return gfc_conv_array_initializer (type
, expr
);
2750 return fold_convert (type
, null_pointer_node
);
2756 gfc_init_se (&se
, NULL
);
2757 gfc_conv_structure (&se
, expr
, 1);
2761 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2764 gfc_init_se (&se
, NULL
);
2765 gfc_conv_constant (&se
, expr
);
2772 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2784 gfc_start_block (&block
);
2786 /* Initialize the scalarizer. */
2787 gfc_init_loopinfo (&loop
);
2789 gfc_init_se (&lse
, NULL
);
2790 gfc_init_se (&rse
, NULL
);
2793 rss
= gfc_walk_expr (expr
);
2794 if (rss
== gfc_ss_terminator
)
2796 /* The rhs is scalar. Add a ss for the expression. */
2797 rss
= gfc_get_ss ();
2798 rss
->next
= gfc_ss_terminator
;
2799 rss
->type
= GFC_SS_SCALAR
;
2803 /* Create a SS for the destination. */
2804 lss
= gfc_get_ss ();
2805 lss
->type
= GFC_SS_COMPONENT
;
2807 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2808 lss
->next
= gfc_ss_terminator
;
2809 lss
->data
.info
.dimen
= cm
->as
->rank
;
2810 lss
->data
.info
.descriptor
= dest
;
2811 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2812 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2813 for (n
= 0; n
< cm
->as
->rank
; n
++)
2815 lss
->data
.info
.dim
[n
] = n
;
2816 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2817 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2819 mpz_init (lss
->shape
[n
]);
2820 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2821 cm
->as
->lower
[n
]->value
.integer
);
2822 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2825 /* Associate the SS with the loop. */
2826 gfc_add_ss_to_loop (&loop
, lss
);
2827 gfc_add_ss_to_loop (&loop
, rss
);
2829 /* Calculate the bounds of the scalarization. */
2830 gfc_conv_ss_startstride (&loop
);
2832 /* Setup the scalarizing loops. */
2833 gfc_conv_loop_setup (&loop
);
2835 /* Setup the gfc_se structures. */
2836 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2837 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2840 gfc_mark_ss_chain_used (rss
, 1);
2842 gfc_mark_ss_chain_used (lss
, 1);
2844 /* Start the scalarized loop body. */
2845 gfc_start_scalarized_body (&loop
, &body
);
2847 gfc_conv_tmp_array_ref (&lse
);
2848 if (cm
->ts
.type
== BT_CHARACTER
)
2849 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2851 gfc_conv_expr (&rse
, expr
);
2853 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2854 gfc_add_expr_to_block (&body
, tmp
);
2856 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2858 /* Generate the copying loops. */
2859 gfc_trans_scalarizing_loops (&loop
, &body
);
2861 /* Wrap the whole thing up. */
2862 gfc_add_block_to_block (&block
, &loop
.pre
);
2863 gfc_add_block_to_block (&block
, &loop
.post
);
2865 for (n
= 0; n
< cm
->as
->rank
; n
++)
2866 mpz_clear (lss
->shape
[n
]);
2867 gfc_free (lss
->shape
);
2869 gfc_cleanup_loop (&loop
);
2871 return gfc_finish_block (&block
);
2875 /* Assign a single component of a derived type constructor. */
2878 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2888 gfc_start_block (&block
);
2892 gfc_init_se (&se
, NULL
);
2893 /* Pointer component. */
2896 /* Array pointer. */
2897 if (expr
->expr_type
== EXPR_NULL
)
2898 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2901 rss
= gfc_walk_expr (expr
);
2902 se
.direct_byref
= 1;
2904 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2905 gfc_add_block_to_block (&block
, &se
.pre
);
2906 gfc_add_block_to_block (&block
, &se
.post
);
2911 /* Scalar pointers. */
2912 se
.want_pointer
= 1;
2913 gfc_conv_expr (&se
, expr
);
2914 gfc_add_block_to_block (&block
, &se
.pre
);
2915 gfc_add_modify_expr (&block
, dest
,
2916 fold_convert (TREE_TYPE (dest
), se
.expr
));
2917 gfc_add_block_to_block (&block
, &se
.post
);
2920 else if (cm
->dimension
)
2922 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2923 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2924 else if (cm
->allocatable
)
2928 gfc_init_se (&se
, NULL
);
2930 rss
= gfc_walk_expr (expr
);
2931 se
.want_pointer
= 0;
2932 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2933 gfc_add_block_to_block (&block
, &se
.pre
);
2935 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2936 gfc_add_modify_expr (&block
, dest
, tmp
);
2938 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2939 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2942 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2943 TREE_TYPE(cm
->backend_decl
),
2946 gfc_add_expr_to_block (&block
, tmp
);
2948 gfc_add_block_to_block (&block
, &se
.post
);
2949 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2951 /* Shift the lbound and ubound of temporaries to being unity, rather
2952 than zero, based. Calculate the offset for all cases. */
2953 offset
= gfc_conv_descriptor_offset (dest
);
2954 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2955 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2956 for (n
= 0; n
< expr
->rank
; n
++)
2958 if (expr
->expr_type
!= EXPR_VARIABLE
2959 && expr
->expr_type
!= EXPR_CONSTANT
)
2961 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2962 gfc_add_modify_expr (&block
, tmp
,
2963 fold_build2 (PLUS_EXPR
,
2964 gfc_array_index_type
,
2965 tmp
, gfc_index_one_node
));
2966 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2967 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2969 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2970 gfc_conv_descriptor_lbound (dest
,
2972 gfc_conv_descriptor_stride (dest
,
2974 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2975 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2976 gfc_add_modify_expr (&block
, offset
, tmp
);
2981 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2982 gfc_add_expr_to_block (&block
, tmp
);
2985 else if (expr
->ts
.type
== BT_DERIVED
)
2987 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2989 gfc_init_se (&se
, NULL
);
2990 gfc_conv_expr (&se
, expr
);
2991 gfc_add_modify_expr (&block
, dest
,
2992 fold_convert (TREE_TYPE (dest
), se
.expr
));
2996 /* Nested constructors. */
2997 tmp
= gfc_trans_structure_assign (dest
, expr
);
2998 gfc_add_expr_to_block (&block
, tmp
);
3003 /* Scalar component. */
3004 gfc_init_se (&se
, NULL
);
3005 gfc_init_se (&lse
, NULL
);
3007 gfc_conv_expr (&se
, expr
);
3008 if (cm
->ts
.type
== BT_CHARACTER
)
3009 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3011 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3012 gfc_add_expr_to_block (&block
, tmp
);
3014 return gfc_finish_block (&block
);
3017 /* Assign a derived type constructor to a variable. */
3020 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3028 gfc_start_block (&block
);
3029 cm
= expr
->ts
.derived
->components
;
3030 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3032 /* Skip absent members in default initializers. */
3036 field
= cm
->backend_decl
;
3037 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3038 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3039 gfc_add_expr_to_block (&block
, tmp
);
3041 return gfc_finish_block (&block
);
3044 /* Build an expression for a constructor. If init is nonzero then
3045 this is part of a static variable initializer. */
3048 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3055 VEC(constructor_elt
,gc
) *v
= NULL
;
3057 gcc_assert (se
->ss
== NULL
);
3058 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3059 type
= gfc_typenode_for_spec (&expr
->ts
);
3063 /* Create a temporary variable and fill it in. */
3064 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3065 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3066 gfc_add_expr_to_block (&se
->pre
, tmp
);
3070 cm
= expr
->ts
.derived
->components
;
3072 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3074 /* Skip absent members in default initializers and allocatable
3075 components. Although the latter have a default initializer
3076 of EXPR_NULL,... by default, the static nullify is not needed
3077 since this is done every time we come into scope. */
3078 if (!c
->expr
|| cm
->allocatable
)
3081 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3082 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3084 /* Append it to the constructor list. */
3085 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3087 se
->expr
= build_constructor (type
, v
);
3091 /* Translate a substring expression. */
3094 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3100 gcc_assert (ref
->type
== REF_SUBSTRING
);
3102 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3103 expr
->value
.character
.string
);
3104 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3105 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3107 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3111 /* Entry point for expression translation. Evaluates a scalar quantity.
3112 EXPR is the expression to be translated, and SE is the state structure if
3113 called from within the scalarized. */
3116 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3118 if (se
->ss
&& se
->ss
->expr
== expr
3119 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3121 /* Substitute a scalar expression evaluated outside the scalarization
3123 se
->expr
= se
->ss
->data
.scalar
.expr
;
3124 se
->string_length
= se
->ss
->string_length
;
3125 gfc_advance_se_ss_chain (se
);
3129 switch (expr
->expr_type
)
3132 gfc_conv_expr_op (se
, expr
);
3136 gfc_conv_function_expr (se
, expr
);
3140 gfc_conv_constant (se
, expr
);
3144 gfc_conv_variable (se
, expr
);
3148 se
->expr
= null_pointer_node
;
3151 case EXPR_SUBSTRING
:
3152 gfc_conv_substring_expr (se
, expr
);
3155 case EXPR_STRUCTURE
:
3156 gfc_conv_structure (se
, expr
, 0);
3160 gfc_conv_array_constructor_expr (se
, expr
);
3169 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3170 of an assignment. */
3172 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3174 gfc_conv_expr (se
, expr
);
3175 /* All numeric lvalues should have empty post chains. If not we need to
3176 figure out a way of rewriting an lvalue so that it has no post chain. */
3177 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3180 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3181 numeric expressions. Used for scalar values where inserting cleanup code
3184 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3188 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3189 gfc_conv_expr (se
, expr
);
3192 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3193 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3195 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3199 /* Helper to translate and expression and convert it to a particular type. */
3201 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3203 gfc_conv_expr_val (se
, expr
);
3204 se
->expr
= convert (type
, se
->expr
);
3208 /* Converts an expression so that it can be passed by reference. Scalar
3212 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3216 if (se
->ss
&& se
->ss
->expr
== expr
3217 && se
->ss
->type
== GFC_SS_REFERENCE
)
3219 se
->expr
= se
->ss
->data
.scalar
.expr
;
3220 se
->string_length
= se
->ss
->string_length
;
3221 gfc_advance_se_ss_chain (se
);
3225 if (expr
->ts
.type
== BT_CHARACTER
)
3227 gfc_conv_expr (se
, expr
);
3228 gfc_conv_string_parameter (se
);
3232 if (expr
->expr_type
== EXPR_VARIABLE
)
3234 se
->want_pointer
= 1;
3235 gfc_conv_expr (se
, expr
);
3238 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3239 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3240 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3246 gfc_conv_expr (se
, expr
);
3248 /* Create a temporary var to hold the value. */
3249 if (TREE_CONSTANT (se
->expr
))
3251 tree tmp
= se
->expr
;
3252 STRIP_TYPE_NOPS (tmp
);
3253 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3254 DECL_INITIAL (var
) = tmp
;
3255 TREE_STATIC (var
) = 1;
3260 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3261 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3263 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3265 /* Take the address of that value. */
3266 se
->expr
= build_fold_addr_expr (var
);
3271 gfc_trans_pointer_assign (gfc_code
* code
)
3273 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3277 /* Generate code for a pointer assignment. */
3280 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3290 gfc_start_block (&block
);
3292 gfc_init_se (&lse
, NULL
);
3294 lss
= gfc_walk_expr (expr1
);
3295 rss
= gfc_walk_expr (expr2
);
3296 if (lss
== gfc_ss_terminator
)
3298 /* Scalar pointers. */
3299 lse
.want_pointer
= 1;
3300 gfc_conv_expr (&lse
, expr1
);
3301 gcc_assert (rss
== gfc_ss_terminator
);
3302 gfc_init_se (&rse
, NULL
);
3303 rse
.want_pointer
= 1;
3304 gfc_conv_expr (&rse
, expr2
);
3305 gfc_add_block_to_block (&block
, &lse
.pre
);
3306 gfc_add_block_to_block (&block
, &rse
.pre
);
3307 gfc_add_modify_expr (&block
, lse
.expr
,
3308 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3309 gfc_add_block_to_block (&block
, &rse
.post
);
3310 gfc_add_block_to_block (&block
, &lse
.post
);
3314 /* Array pointer. */
3315 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3316 switch (expr2
->expr_type
)
3319 /* Just set the data pointer to null. */
3320 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3324 /* Assign directly to the pointer's descriptor. */
3325 lse
.direct_byref
= 1;
3326 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3330 /* Assign to a temporary descriptor and then copy that
3331 temporary to the pointer. */
3333 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3336 lse
.direct_byref
= 1;
3337 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3338 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3341 gfc_add_block_to_block (&block
, &lse
.pre
);
3342 gfc_add_block_to_block (&block
, &lse
.post
);
3344 return gfc_finish_block (&block
);
3348 /* Makes sure se is suitable for passing as a function string parameter. */
3349 /* TODO: Need to check all callers fo this function. It may be abused. */
3352 gfc_conv_string_parameter (gfc_se
* se
)
3356 if (TREE_CODE (se
->expr
) == STRING_CST
)
3358 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3362 type
= TREE_TYPE (se
->expr
);
3363 if (TYPE_STRING_FLAG (type
))
3365 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3366 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3369 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3370 gcc_assert (se
->string_length
3371 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3375 /* Generate code for assignment of scalar variables. Includes character
3376 strings and derived types with allocatable components. */
3379 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3380 bool l_is_temp
, bool r_is_var
)
3386 gfc_init_block (&block
);
3388 if (ts
.type
== BT_CHARACTER
)
3390 gcc_assert (lse
->string_length
!= NULL_TREE
3391 && rse
->string_length
!= NULL_TREE
);
3393 gfc_conv_string_parameter (lse
);
3394 gfc_conv_string_parameter (rse
);
3396 gfc_add_block_to_block (&block
, &lse
->pre
);
3397 gfc_add_block_to_block (&block
, &rse
->pre
);
3399 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3400 rse
->string_length
, rse
->expr
);
3402 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3406 /* Are the rhs and the lhs the same? */
3409 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3410 build_fold_addr_expr (lse
->expr
),
3411 build_fold_addr_expr (rse
->expr
));
3412 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3415 /* Deallocate the lhs allocated components as long as it is not
3416 the same as the rhs. */
3419 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3421 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3422 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3425 gfc_add_block_to_block (&block
, &lse
->pre
);
3426 gfc_add_block_to_block (&block
, &rse
->pre
);
3428 gfc_add_modify_expr (&block
, lse
->expr
,
3429 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3431 /* Do a deep copy if the rhs is a variable, if it is not the
3435 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3436 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3437 gfc_add_expr_to_block (&block
, tmp
);
3442 gfc_add_block_to_block (&block
, &lse
->pre
);
3443 gfc_add_block_to_block (&block
, &rse
->pre
);
3445 gfc_add_modify_expr (&block
, lse
->expr
,
3446 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3449 gfc_add_block_to_block (&block
, &lse
->post
);
3450 gfc_add_block_to_block (&block
, &rse
->post
);
3452 return gfc_finish_block (&block
);
3456 /* Try to translate array(:) = func (...), where func is a transformational
3457 array function, without using a temporary. Returns NULL is this isn't the
3461 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3466 bool seen_array_ref
;
3468 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3469 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3472 /* Elemental functions don't need a temporary anyway. */
3473 if (expr2
->value
.function
.esym
!= NULL
3474 && expr2
->value
.function
.esym
->attr
.elemental
)
3477 /* Fail if EXPR1 can't be expressed as a descriptor. */
3478 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3481 /* Functions returning pointers need temporaries. */
3482 if (expr2
->symtree
->n
.sym
->attr
.pointer
3483 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3486 /* Character array functions need temporaries unless the
3487 character lengths are the same. */
3488 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3490 if (expr1
->ts
.cl
->length
== NULL
3491 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3494 if (expr2
->ts
.cl
->length
== NULL
3495 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3498 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3499 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3503 /* Check that no LHS component references appear during an array
3504 reference. This is needed because we do not have the means to
3505 span any arbitrary stride with an array descriptor. This check
3506 is not needed for the rhs because the function result has to be
3508 seen_array_ref
= false;
3509 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3511 if (ref
->type
== REF_ARRAY
)
3512 seen_array_ref
= true;
3513 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3517 /* Check for a dependency. */
3518 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3519 expr2
->value
.function
.esym
,
3520 expr2
->value
.function
.actual
))
3523 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3525 gcc_assert (expr2
->value
.function
.isym
3526 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3527 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3529 ss
= gfc_walk_expr (expr1
);
3530 gcc_assert (ss
!= gfc_ss_terminator
);
3531 gfc_init_se (&se
, NULL
);
3532 gfc_start_block (&se
.pre
);
3533 se
.want_pointer
= 1;
3535 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3537 se
.direct_byref
= 1;
3538 se
.ss
= gfc_walk_expr (expr2
);
3539 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3540 gfc_conv_function_expr (&se
, expr2
);
3541 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3543 return gfc_finish_block (&se
.pre
);
3546 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3549 is_zero_initializer_p (gfc_expr
* expr
)
3551 if (expr
->expr_type
!= EXPR_CONSTANT
)
3553 /* We ignore Hollerith constants for the time being. */
3557 switch (expr
->ts
.type
)
3560 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3563 return mpfr_zero_p (expr
->value
.real
)
3564 && MPFR_SIGN (expr
->value
.real
) >= 0;
3567 return expr
->value
.logical
== 0;
3570 return mpfr_zero_p (expr
->value
.complex.r
)
3571 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3572 && mpfr_zero_p (expr
->value
.complex.i
)
3573 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3581 /* Try to efficiently translate array(:) = 0. Return NULL if this
3585 gfc_trans_zero_assign (gfc_expr
* expr
)
3587 tree dest
, len
, type
;
3591 sym
= expr
->symtree
->n
.sym
;
3592 dest
= gfc_get_symbol_decl (sym
);
3594 type
= TREE_TYPE (dest
);
3595 if (POINTER_TYPE_P (type
))
3596 type
= TREE_TYPE (type
);
3597 if (!GFC_ARRAY_TYPE_P (type
))
3600 /* Determine the length of the array. */
3601 len
= GFC_TYPE_ARRAY_SIZE (type
);
3602 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3605 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3606 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
3608 /* Convert arguments to the correct types. */
3609 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3610 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3612 dest
= fold_convert (pvoid_type_node
, dest
);
3613 len
= fold_convert (size_type_node
, len
);
3615 /* Construct call to __builtin_memset. */
3616 args
= build_tree_list (NULL_TREE
, len
);
3617 args
= tree_cons (NULL_TREE
, integer_zero_node
, args
);
3618 args
= tree_cons (NULL_TREE
, dest
, args
);
3619 tmp
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], args
);
3620 return fold_convert (void_type_node
, tmp
);
3624 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3625 that constructs the call to __builtin_memcpy. */
3628 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3632 /* Convert arguments to the correct types. */
3633 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3634 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3636 dst
= fold_convert (pvoid_type_node
, dst
);
3638 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3639 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3641 src
= fold_convert (pvoid_type_node
, src
);
3643 len
= fold_convert (size_type_node
, len
);
3645 /* Construct call to __builtin_memcpy. */
3646 args
= build_tree_list (NULL_TREE
, len
);
3647 args
= tree_cons (NULL_TREE
, src
, args
);
3648 args
= tree_cons (NULL_TREE
, dst
, args
);
3649 tmp
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], args
);
3650 return fold_convert (void_type_node
, tmp
);
3654 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3655 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3656 source/rhs, both are gfc_full_array_ref_p which have been checked for
3660 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3662 tree dst
, dlen
, dtype
;
3663 tree src
, slen
, stype
;
3665 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3666 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3668 dtype
= TREE_TYPE (dst
);
3669 if (POINTER_TYPE_P (dtype
))
3670 dtype
= TREE_TYPE (dtype
);
3671 stype
= TREE_TYPE (src
);
3672 if (POINTER_TYPE_P (stype
))
3673 stype
= TREE_TYPE (stype
);
3675 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3678 /* Determine the lengths of the arrays. */
3679 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3680 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3682 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3683 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3685 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3686 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3688 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3689 TYPE_SIZE_UNIT (gfc_get_element_type (stype
)));
3691 /* Sanity check that they are the same. This should always be
3692 the case, as we should already have checked for conformance. */
3693 if (!tree_int_cst_equal (slen
, dlen
))
3696 return gfc_build_memcpy_call (dst
, src
, dlen
);
3700 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3701 this can't be done. EXPR1 is the destination/lhs for which
3702 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3705 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3707 unsigned HOST_WIDE_INT nelem
;
3712 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3716 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3717 dtype
= TREE_TYPE (dst
);
3718 if (POINTER_TYPE_P (dtype
))
3719 dtype
= TREE_TYPE (dtype
);
3720 if (!GFC_ARRAY_TYPE_P (dtype
))
3723 /* Determine the lengths of the array. */
3724 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3725 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3728 /* Confirm that the constructor is the same size. */
3729 if (compare_tree_int (len
, nelem
) != 0)
3732 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3733 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3735 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3736 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3738 stype
= TREE_TYPE (src
);
3739 if (POINTER_TYPE_P (stype
))
3740 stype
= TREE_TYPE (stype
);
3742 return gfc_build_memcpy_call (dst
, src
, len
);
3746 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3747 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3750 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3755 gfc_ss
*lss_section
;
3763 /* Assignment of the form lhs = rhs. */
3764 gfc_start_block (&block
);
3766 gfc_init_se (&lse
, NULL
);
3767 gfc_init_se (&rse
, NULL
);
3770 lss
= gfc_walk_expr (expr1
);
3772 if (lss
!= gfc_ss_terminator
)
3774 /* The assignment needs scalarization. */
3777 /* Find a non-scalar SS from the lhs. */
3778 while (lss_section
!= gfc_ss_terminator
3779 && lss_section
->type
!= GFC_SS_SECTION
)
3780 lss_section
= lss_section
->next
;
3782 gcc_assert (lss_section
!= gfc_ss_terminator
);
3784 /* Initialize the scalarizer. */
3785 gfc_init_loopinfo (&loop
);
3788 rss
= gfc_walk_expr (expr2
);
3789 if (rss
== gfc_ss_terminator
)
3791 /* The rhs is scalar. Add a ss for the expression. */
3792 rss
= gfc_get_ss ();
3793 rss
->next
= gfc_ss_terminator
;
3794 rss
->type
= GFC_SS_SCALAR
;
3797 /* Associate the SS with the loop. */
3798 gfc_add_ss_to_loop (&loop
, lss
);
3799 gfc_add_ss_to_loop (&loop
, rss
);
3801 /* Calculate the bounds of the scalarization. */
3802 gfc_conv_ss_startstride (&loop
);
3803 /* Resolve any data dependencies in the statement. */
3804 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3805 /* Setup the scalarizing loops. */
3806 gfc_conv_loop_setup (&loop
);
3808 /* Setup the gfc_se structures. */
3809 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3810 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3813 gfc_mark_ss_chain_used (rss
, 1);
3814 if (loop
.temp_ss
== NULL
)
3817 gfc_mark_ss_chain_used (lss
, 1);
3821 lse
.ss
= loop
.temp_ss
;
3822 gfc_mark_ss_chain_used (lss
, 3);
3823 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3826 /* Start the scalarized loop body. */
3827 gfc_start_scalarized_body (&loop
, &body
);
3830 gfc_init_block (&body
);
3832 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3834 /* Translate the expression. */
3835 gfc_conv_expr (&rse
, expr2
);
3839 gfc_conv_tmp_array_ref (&lse
);
3840 gfc_advance_se_ss_chain (&lse
);
3843 gfc_conv_expr (&lse
, expr1
);
3845 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3846 l_is_temp
|| init_flag
,
3847 expr2
->expr_type
== EXPR_VARIABLE
);
3848 gfc_add_expr_to_block (&body
, tmp
);
3850 if (lss
== gfc_ss_terminator
)
3852 /* Use the scalar assignment as is. */
3853 gfc_add_block_to_block (&block
, &body
);
3857 gcc_assert (lse
.ss
== gfc_ss_terminator
3858 && rse
.ss
== gfc_ss_terminator
);
3862 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3864 /* We need to copy the temporary to the actual lhs. */
3865 gfc_init_se (&lse
, NULL
);
3866 gfc_init_se (&rse
, NULL
);
3867 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3868 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3870 rse
.ss
= loop
.temp_ss
;
3873 gfc_conv_tmp_array_ref (&rse
);
3874 gfc_advance_se_ss_chain (&rse
);
3875 gfc_conv_expr (&lse
, expr1
);
3877 gcc_assert (lse
.ss
== gfc_ss_terminator
3878 && rse
.ss
== gfc_ss_terminator
);
3880 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3882 gfc_add_expr_to_block (&body
, tmp
);
3885 /* Generate the copying loops. */
3886 gfc_trans_scalarizing_loops (&loop
, &body
);
3888 /* Wrap the whole thing up. */
3889 gfc_add_block_to_block (&block
, &loop
.pre
);
3890 gfc_add_block_to_block (&block
, &loop
.post
);
3892 gfc_cleanup_loop (&loop
);
3895 return gfc_finish_block (&block
);
3899 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3902 copyable_array_p (gfc_expr
* expr
)
3904 /* First check it's an array. */
3905 if (expr
->rank
< 1 || !expr
->ref
)
3908 /* Next check that it's of a simple enough type. */
3909 switch (expr
->ts
.type
)
3921 return !expr
->ts
.derived
->attr
.alloc_comp
;
3930 /* Translate an assignment. */
3933 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3937 /* Special case a single function returning an array. */
3938 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3940 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3945 /* Special case assigning an array to zero. */
3946 if (expr1
->expr_type
== EXPR_VARIABLE
3949 && gfc_full_array_ref_p (expr1
->ref
)
3950 && is_zero_initializer_p (expr2
))
3952 tmp
= gfc_trans_zero_assign (expr1
);
3957 /* Special case copying one array to another. */
3958 if (expr1
->expr_type
== EXPR_VARIABLE
3959 && copyable_array_p (expr1
)
3960 && gfc_full_array_ref_p (expr1
->ref
)
3961 && expr2
->expr_type
== EXPR_VARIABLE
3962 && copyable_array_p (expr2
)
3963 && gfc_full_array_ref_p (expr2
->ref
)
3964 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
3965 && !gfc_check_dependency (expr1
, expr2
, 0))
3967 tmp
= gfc_trans_array_copy (expr1
, expr2
);
3972 /* Special case initializing an array from a constant array constructor. */
3973 if (expr1
->expr_type
== EXPR_VARIABLE
3974 && copyable_array_p (expr1
)
3975 && gfc_full_array_ref_p (expr1
->ref
)
3976 && expr2
->expr_type
== EXPR_ARRAY
3977 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
3979 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
3984 /* Fallback to the scalarizer to generate explicit loops. */
3985 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
3989 gfc_trans_init_assign (gfc_code
* code
)
3991 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3995 gfc_trans_assign (gfc_code
* code
)
3997 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);