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 /* Initialize MAPPING. */
1255 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1257 mapping
->syms
= NULL
;
1258 mapping
->charlens
= NULL
;
1262 /* Free all memory held by MAPPING (but not MAPPING itself). */
1265 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1267 gfc_interface_sym_mapping
*sym
;
1268 gfc_interface_sym_mapping
*nextsym
;
1270 gfc_charlen
*nextcl
;
1272 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1274 nextsym
= sym
->next
;
1275 gfc_free_symbol (sym
->new->n
.sym
);
1276 gfc_free (sym
->new);
1279 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1282 gfc_free_expr (cl
->length
);
1288 /* Return a copy of gfc_charlen CL. Add the returned structure to
1289 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1291 static gfc_charlen
*
1292 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1297 new = gfc_get_charlen ();
1298 new->next
= mapping
->charlens
;
1299 new->length
= gfc_copy_expr (cl
->length
);
1301 mapping
->charlens
= new;
1306 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1307 array variable that can be used as the actual argument for dummy
1308 argument SYM. Add any initialization code to BLOCK. PACKED is as
1309 for gfc_get_nodesc_array_type and DATA points to the first element
1310 in the passed array. */
1313 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1314 int packed
, tree data
)
1319 type
= gfc_typenode_for_spec (&sym
->ts
);
1320 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1322 var
= gfc_create_var (type
, "ifm");
1323 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1329 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1330 and offset of descriptorless array type TYPE given that it has the same
1331 size as DESC. Add any set-up code to BLOCK. */
1334 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1341 offset
= gfc_index_zero_node
;
1342 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1344 dim
= gfc_rank_cst
[n
];
1345 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1346 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1348 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1349 = gfc_conv_descriptor_lbound (desc
, dim
);
1350 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1351 = gfc_conv_descriptor_ubound (desc
, dim
);
1353 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1355 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1356 gfc_conv_descriptor_ubound (desc
, dim
),
1357 gfc_conv_descriptor_lbound (desc
, dim
));
1358 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1359 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1361 tmp
= gfc_evaluate_now (tmp
, block
);
1362 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1364 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1365 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1366 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1367 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1369 offset
= gfc_evaluate_now (offset
, block
);
1370 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1374 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1375 in SE. The caller may still use se->expr and se->string_length after
1376 calling this function. */
1379 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1380 gfc_symbol
* sym
, gfc_se
* se
)
1382 gfc_interface_sym_mapping
*sm
;
1386 gfc_symbol
*new_sym
;
1388 gfc_symtree
*new_symtree
;
1390 /* Create a new symbol to represent the actual argument. */
1391 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1392 new_sym
->ts
= sym
->ts
;
1393 new_sym
->attr
.referenced
= 1;
1394 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1395 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1396 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1397 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1399 /* Create a fake symtree for it. */
1401 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1402 new_symtree
->n
.sym
= new_sym
;
1403 gcc_assert (new_symtree
== root
);
1405 /* Create a dummy->actual mapping. */
1406 sm
= gfc_getmem (sizeof (*sm
));
1407 sm
->next
= mapping
->syms
;
1409 sm
->new = new_symtree
;
1412 /* Stabilize the argument's value. */
1413 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1415 if (sym
->ts
.type
== BT_CHARACTER
)
1417 /* Create a copy of the dummy argument's length. */
1418 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1420 /* If the length is specified as "*", record the length that
1421 the caller is passing. We should use the callee's length
1422 in all other cases. */
1423 if (!new_sym
->ts
.cl
->length
)
1425 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1426 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1430 /* Use the passed value as-is if the argument is a function. */
1431 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1434 /* If the argument is either a string or a pointer to a string,
1435 convert it to a boundless character type. */
1436 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1438 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1439 tmp
= build_pointer_type (tmp
);
1440 if (sym
->attr
.pointer
)
1441 value
= build_fold_indirect_ref (se
->expr
);
1444 value
= fold_convert (tmp
, value
);
1447 /* If the argument is a scalar, a pointer to an array or an allocatable,
1449 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1450 value
= build_fold_indirect_ref (se
->expr
);
1452 /* For character(*), use the actual argument's descriptor. */
1453 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1454 value
= build_fold_indirect_ref (se
->expr
);
1456 /* If the argument is an array descriptor, use it to determine
1457 information about the actual argument's shape. */
1458 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1459 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1461 /* Get the actual argument's descriptor. */
1462 desc
= build_fold_indirect_ref (se
->expr
);
1464 /* Create the replacement variable. */
1465 tmp
= gfc_conv_descriptor_data_get (desc
);
1466 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1468 /* Use DESC to work out the upper bounds, strides and offset. */
1469 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1472 /* Otherwise we have a packed array. */
1473 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1475 new_sym
->backend_decl
= value
;
1479 /* Called once all dummy argument mappings have been added to MAPPING,
1480 but before the mapping is used to evaluate expressions. Pre-evaluate
1481 the length of each argument, adding any initialization code to PRE and
1482 any finalization code to POST. */
1485 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1486 stmtblock_t
* pre
, stmtblock_t
* post
)
1488 gfc_interface_sym_mapping
*sym
;
1492 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1493 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1494 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1496 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1497 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1498 gfc_init_se (&se
, NULL
);
1499 gfc_conv_expr (&se
, expr
);
1501 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1502 gfc_add_block_to_block (pre
, &se
.pre
);
1503 gfc_add_block_to_block (post
, &se
.post
);
1505 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1510 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1514 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1515 gfc_constructor
* c
)
1517 for (; c
; c
= c
->next
)
1519 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1522 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1523 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1524 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1530 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1534 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1539 for (; ref
; ref
= ref
->next
)
1543 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1545 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1546 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1547 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1549 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1556 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1557 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1563 /* EXPR is a copy of an expression that appeared in the interface
1564 associated with MAPPING. Walk it recursively looking for references to
1565 dummy arguments that MAPPING maps to actual arguments. Replace each such
1566 reference with a reference to the associated actual argument. */
1569 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1572 gfc_interface_sym_mapping
*sym
;
1573 gfc_actual_arglist
*actual
;
1578 /* Copying an expression does not copy its length, so do that here. */
1579 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1581 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1582 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1585 /* Apply the mapping to any references. */
1586 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1588 /* ...and to the expression's symbol, if it has one. */
1590 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1591 if (sym
->old
== expr
->symtree
->n
.sym
)
1592 expr
->symtree
= sym
->new;
1594 /* ...and to subexpressions in expr->value. */
1595 switch (expr
->expr_type
)
1600 case EXPR_SUBSTRING
:
1604 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1605 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1609 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1610 if (sym
->old
== expr
->value
.function
.esym
)
1611 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1613 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1614 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1618 case EXPR_STRUCTURE
:
1619 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1625 /* Evaluate interface expression EXPR using MAPPING. Store the result
1629 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1630 gfc_se
* se
, gfc_expr
* expr
)
1632 expr
= gfc_copy_expr (expr
);
1633 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1634 gfc_conv_expr (se
, expr
);
1635 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1636 gfc_free_expr (expr
);
1639 /* Returns a reference to a temporary array into which a component of
1640 an actual argument derived type array is copied and then returned
1641 after the function call.
1642 TODO Get rid of this kludge, when array descriptors are capable of
1643 handling aliased arrays. */
1646 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1647 int g77
, sym_intent intent
)
1663 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1665 gfc_init_se (&lse
, NULL
);
1666 gfc_init_se (&rse
, NULL
);
1668 /* Walk the argument expression. */
1669 rss
= gfc_walk_expr (expr
);
1671 gcc_assert (rss
!= gfc_ss_terminator
);
1673 /* Initialize the scalarizer. */
1674 gfc_init_loopinfo (&loop
);
1675 gfc_add_ss_to_loop (&loop
, rss
);
1677 /* Calculate the bounds of the scalarization. */
1678 gfc_conv_ss_startstride (&loop
);
1680 /* Build an ss for the temporary. */
1681 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1682 if (GFC_ARRAY_TYPE_P (base_type
)
1683 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1684 base_type
= gfc_get_element_type (base_type
);
1686 loop
.temp_ss
= gfc_get_ss ();;
1687 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1688 loop
.temp_ss
->data
.temp
.type
= base_type
;
1690 if (expr
->ts
.type
== BT_CHARACTER
)
1692 gfc_ref
*char_ref
= expr
->ref
;
1694 for (; expr
->ts
.cl
== NULL
&& char_ref
; char_ref
= char_ref
->next
)
1695 if (char_ref
->type
== REF_SUBSTRING
)
1699 expr
->ts
.cl
= gfc_get_charlen ();
1700 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1701 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1703 gfc_init_se (&tmp_se
, NULL
);
1704 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1705 gfc_array_index_type
);
1706 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1707 tmp_se
.expr
, gfc_index_one_node
);
1708 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1709 gfc_init_se (&tmp_se
, NULL
);
1710 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1711 gfc_array_index_type
);
1712 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1714 expr
->ts
.cl
->backend_decl
= tmp
;
1718 loop
.temp_ss
->data
.temp
.type
1719 = gfc_typenode_for_spec (&expr
->ts
);
1720 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1723 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1724 loop
.temp_ss
->next
= gfc_ss_terminator
;
1726 /* Associate the SS with the loop. */
1727 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1729 /* Setup the scalarizing loops. */
1730 gfc_conv_loop_setup (&loop
);
1732 /* Pass the temporary descriptor back to the caller. */
1733 info
= &loop
.temp_ss
->data
.info
;
1734 parmse
->expr
= info
->descriptor
;
1736 /* Setup the gfc_se structures. */
1737 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1738 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1741 lse
.ss
= loop
.temp_ss
;
1742 gfc_mark_ss_chain_used (rss
, 1);
1743 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1745 /* Start the scalarized loop body. */
1746 gfc_start_scalarized_body (&loop
, &body
);
1748 /* Translate the expression. */
1749 gfc_conv_expr (&rse
, expr
);
1751 gfc_conv_tmp_array_ref (&lse
);
1752 gfc_advance_se_ss_chain (&lse
);
1754 if (intent
!= INTENT_OUT
)
1756 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1757 gfc_add_expr_to_block (&body
, tmp
);
1758 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1759 gfc_trans_scalarizing_loops (&loop
, &body
);
1763 /* Make sure that the temporary declaration survives by merging
1764 all the loop declarations into the current context. */
1765 for (n
= 0; n
< loop
.dimen
; n
++)
1767 gfc_merge_block_scope (&body
);
1768 body
= loop
.code
[loop
.order
[n
]];
1770 gfc_merge_block_scope (&body
);
1773 /* Add the post block after the second loop, so that any
1774 freeing of allocated memory is done at the right time. */
1775 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1777 /**********Copy the temporary back again.*********/
1779 gfc_init_se (&lse
, NULL
);
1780 gfc_init_se (&rse
, NULL
);
1782 /* Walk the argument expression. */
1783 lss
= gfc_walk_expr (expr
);
1784 rse
.ss
= loop
.temp_ss
;
1787 /* Initialize the scalarizer. */
1788 gfc_init_loopinfo (&loop2
);
1789 gfc_add_ss_to_loop (&loop2
, lss
);
1791 /* Calculate the bounds of the scalarization. */
1792 gfc_conv_ss_startstride (&loop2
);
1794 /* Setup the scalarizing loops. */
1795 gfc_conv_loop_setup (&loop2
);
1797 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1798 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1800 gfc_mark_ss_chain_used (lss
, 1);
1801 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1803 /* Declare the variable to hold the temporary offset and start the
1804 scalarized loop body. */
1805 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1806 gfc_start_scalarized_body (&loop2
, &body
);
1808 /* Build the offsets for the temporary from the loop variables. The
1809 temporary array has lbounds of zero and strides of one in all
1810 dimensions, so this is very simple. The offset is only computed
1811 outside the innermost loop, so the overall transfer could be
1812 optimized further. */
1813 info
= &rse
.ss
->data
.info
;
1815 tmp_index
= gfc_index_zero_node
;
1816 for (n
= info
->dimen
- 1; n
> 0; n
--)
1819 tmp
= rse
.loop
->loopvar
[n
];
1820 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1821 tmp
, rse
.loop
->from
[n
]);
1822 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1825 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1826 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1827 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1828 tmp_str
, gfc_index_one_node
);
1830 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1834 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1835 tmp_index
, rse
.loop
->from
[0]);
1836 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1838 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1839 rse
.loop
->loopvar
[0], offset
);
1841 /* Now use the offset for the reference. */
1842 tmp
= build_fold_indirect_ref (info
->data
);
1843 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1845 if (expr
->ts
.type
== BT_CHARACTER
)
1846 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1848 gfc_conv_expr (&lse
, expr
);
1850 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1852 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1853 gfc_add_expr_to_block (&body
, tmp
);
1855 /* Generate the copying loops. */
1856 gfc_trans_scalarizing_loops (&loop2
, &body
);
1858 /* Wrap the whole thing up by adding the second loop to the post-block
1859 and following it by the post-block of the first loop. In this way,
1860 if the temporary needs freeing, it is done after use! */
1861 if (intent
!= INTENT_IN
)
1863 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1864 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1867 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1869 gfc_cleanup_loop (&loop
);
1870 gfc_cleanup_loop (&loop2
);
1872 /* Pass the string length to the argument expression. */
1873 if (expr
->ts
.type
== BT_CHARACTER
)
1874 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1876 /* We want either the address for the data or the address of the descriptor,
1877 depending on the mode of passing array arguments. */
1879 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1881 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1886 /* Is true if an array reference is followed by a component or substring
1890 is_aliased_array (gfc_expr
* e
)
1896 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1898 if (ref
->type
== REF_ARRAY
1899 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1903 && ref
->type
!= REF_ARRAY
)
1909 /* Generate code for a procedure call. Note can return se->post != NULL.
1910 If se->direct_byref is set then se->expr contains the return parameter.
1911 Return nonzero, if the call has alternate specifiers. */
1914 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1915 gfc_actual_arglist
* arg
, tree append_args
)
1917 gfc_interface_mapping mapping
;
1931 gfc_formal_arglist
*formal
;
1932 int has_alternate_specifier
= 0;
1933 bool need_interface_mapping
;
1940 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
1942 arglist
= NULL_TREE
;
1943 retargs
= NULL_TREE
;
1944 stringargs
= NULL_TREE
;
1950 if (!sym
->attr
.elemental
)
1952 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1953 if (se
->ss
->useflags
)
1955 gcc_assert (gfc_return_by_reference (sym
)
1956 && sym
->result
->attr
.dimension
);
1957 gcc_assert (se
->loop
!= NULL
);
1959 /* Access the previously obtained result. */
1960 gfc_conv_tmp_array_ref (se
);
1961 gfc_advance_se_ss_chain (se
);
1965 info
= &se
->ss
->data
.info
;
1970 gfc_init_block (&post
);
1971 gfc_init_interface_mapping (&mapping
);
1972 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
1973 && sym
->ts
.cl
->length
1974 && sym
->ts
.cl
->length
->expr_type
1976 || sym
->attr
.dimension
);
1977 formal
= sym
->formal
;
1978 /* Evaluate the arguments. */
1979 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1982 fsym
= formal
? formal
->sym
: NULL
;
1983 parm_kind
= MISSING
;
1987 if (se
->ignore_optional
)
1989 /* Some intrinsics have already been resolved to the correct
1993 else if (arg
->label
)
1995 has_alternate_specifier
= 1;
2000 /* Pass a NULL pointer for an absent arg. */
2001 gfc_init_se (&parmse
, NULL
);
2002 parmse
.expr
= null_pointer_node
;
2003 if (arg
->missing_arg_type
== BT_CHARACTER
)
2004 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2007 else if (se
->ss
&& se
->ss
->useflags
)
2009 /* An elemental function inside a scalarized loop. */
2010 gfc_init_se (&parmse
, se
);
2011 gfc_conv_expr_reference (&parmse
, e
);
2012 parm_kind
= ELEMENTAL
;
2016 /* A scalar or transformational function. */
2017 gfc_init_se (&parmse
, NULL
);
2018 argss
= gfc_walk_expr (e
);
2020 if (argss
== gfc_ss_terminator
)
2023 if (fsym
&& fsym
->attr
.value
)
2025 gfc_conv_expr (&parmse
, e
);
2029 gfc_conv_expr_reference (&parmse
, e
);
2030 if (fsym
&& fsym
->attr
.pointer
2031 && e
->expr_type
!= EXPR_NULL
)
2033 /* Scalar pointer dummy args require an extra level of
2034 indirection. The null pointer already contains
2035 this level of indirection. */
2036 parm_kind
= SCALAR_POINTER
;
2037 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2043 /* If the procedure requires an explicit interface, the actual
2044 argument is passed according to the corresponding formal
2045 argument. If the corresponding formal argument is a POINTER,
2046 ALLOCATABLE or assumed shape, we do not use g77's calling
2047 convention, and pass the address of the array descriptor
2048 instead. Otherwise we use g77's calling convention. */
2051 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2052 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2053 f
= f
|| !sym
->attr
.always_explicit
;
2055 if (e
->expr_type
== EXPR_VARIABLE
2056 && is_aliased_array (e
))
2057 /* The actual argument is a component reference to an
2058 array of derived types. In this case, the argument
2059 is converted to a temporary, which is passed and then
2060 written back after the procedure call. */
2061 gfc_conv_aliased_arg (&parmse
, e
, f
,
2062 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2064 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2066 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2067 allocated on entry, it must be deallocated. */
2068 if (fsym
&& fsym
->attr
.allocatable
2069 && fsym
->attr
.intent
== INTENT_OUT
)
2071 tmp
= build_fold_indirect_ref (parmse
.expr
);
2072 tmp
= gfc_trans_dealloc_allocated (tmp
);
2073 gfc_add_expr_to_block (&se
->pre
, tmp
);
2083 /* If an optional argument is itself an optional dummy
2084 argument, check its presence and substitute a null
2086 if (e
->expr_type
== EXPR_VARIABLE
2087 && e
->symtree
->n
.sym
->attr
.optional
2088 && fsym
->attr
.optional
)
2089 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2091 /* If an INTENT(OUT) dummy of derived type has a default
2092 initializer, it must be (re)initialized here. */
2093 if (fsym
->attr
.intent
== INTENT_OUT
2094 && fsym
->ts
.type
== BT_DERIVED
2097 gcc_assert (!fsym
->attr
.allocatable
);
2098 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2099 gfc_add_expr_to_block (&se
->pre
, tmp
);
2102 /* Obtain the character length of an assumed character
2103 length procedure from the typespec. */
2104 if (fsym
->ts
.type
== BT_CHARACTER
2105 && parmse
.string_length
== NULL_TREE
2106 && e
->ts
.type
== BT_PROCEDURE
2107 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2108 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2110 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2111 parmse
.string_length
2112 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2116 if (need_interface_mapping
)
2117 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2120 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2121 gfc_add_block_to_block (&post
, &parmse
.post
);
2123 /* Allocated allocatable components of derived types must be
2124 deallocated for INTENT(OUT) dummy arguments and non-variable
2125 scalars. Non-variable arrays are dealt with in trans-array.c
2126 (gfc_conv_array_parameter). */
2127 if (e
&& e
->ts
.type
== BT_DERIVED
2128 && e
->ts
.derived
->attr
.alloc_comp
2129 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2131 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2134 tmp
= build_fold_indirect_ref (parmse
.expr
);
2135 parm_rank
= e
->rank
;
2143 case (SCALAR_POINTER
):
2144 tmp
= build_fold_indirect_ref (tmp
);
2151 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2152 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2153 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2154 tmp
, build_empty_stmt ());
2156 if (e
->expr_type
!= EXPR_VARIABLE
)
2157 /* Don't deallocate non-variables until they have been used. */
2158 gfc_add_expr_to_block (&se
->post
, tmp
);
2161 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2162 gfc_add_expr_to_block (&se
->pre
, tmp
);
2166 /* Character strings are passed as two parameters, a length and a
2168 if (parmse
.string_length
!= NULL_TREE
)
2169 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2171 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2173 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2176 if (ts
.type
== BT_CHARACTER
)
2178 if (sym
->ts
.cl
->length
== NULL
)
2180 /* Assumed character length results are not allowed by 5.1.1.5 of the
2181 standard and are trapped in resolve.c; except in the case of SPREAD
2182 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2183 we take the character length of the first argument for the result.
2184 For dummies, we have to look through the formal argument list for
2185 this function and use the character length found there.*/
2186 if (!sym
->attr
.dummy
)
2187 cl
.backend_decl
= TREE_VALUE (stringargs
);
2190 formal
= sym
->ns
->proc_name
->formal
;
2191 for (; formal
; formal
= formal
->next
)
2192 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2193 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2198 /* Calculate the length of the returned string. */
2199 gfc_init_se (&parmse
, NULL
);
2200 if (need_interface_mapping
)
2201 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2203 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2204 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2205 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2206 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2209 /* Set up a charlen structure for it. */
2214 len
= cl
.backend_decl
;
2217 byref
= gfc_return_by_reference (sym
);
2220 if (se
->direct_byref
)
2221 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2222 else if (sym
->result
->attr
.dimension
)
2224 gcc_assert (se
->loop
&& info
);
2226 /* Set the type of the array. */
2227 tmp
= gfc_typenode_for_spec (&ts
);
2228 info
->dimen
= se
->loop
->dimen
;
2230 /* Evaluate the bounds of the result, if known. */
2231 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2233 /* Create a temporary to store the result. In case the function
2234 returns a pointer, the temporary will be a shallow copy and
2235 mustn't be deallocated. */
2236 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2237 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2238 false, !sym
->attr
.pointer
, callee_alloc
,
2241 /* Pass the temporary as the first argument. */
2242 tmp
= info
->descriptor
;
2243 tmp
= build_fold_addr_expr (tmp
);
2244 retargs
= gfc_chainon_list (retargs
, tmp
);
2246 else if (ts
.type
== BT_CHARACTER
)
2248 /* Pass the string length. */
2249 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2250 type
= build_pointer_type (type
);
2252 /* Return an address to a char[0:len-1]* temporary for
2253 character pointers. */
2254 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2256 /* Build char[0:len-1] * pstr. */
2257 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2258 build_int_cst (gfc_charlen_type_node
, 1));
2259 tmp
= build_range_type (gfc_array_index_type
,
2260 gfc_index_zero_node
, tmp
);
2261 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2262 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2264 /* Provide an address expression for the function arguments. */
2265 var
= build_fold_addr_expr (var
);
2268 var
= gfc_conv_string_tmp (se
, type
, len
);
2270 retargs
= gfc_chainon_list (retargs
, var
);
2274 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2276 type
= gfc_get_complex_type (ts
.kind
);
2277 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2278 retargs
= gfc_chainon_list (retargs
, var
);
2281 /* Add the string length to the argument list. */
2282 if (ts
.type
== BT_CHARACTER
)
2283 retargs
= gfc_chainon_list (retargs
, len
);
2285 gfc_free_interface_mapping (&mapping
);
2287 /* Add the return arguments. */
2288 arglist
= chainon (retargs
, arglist
);
2290 /* Add the hidden string length parameters to the arguments. */
2291 arglist
= chainon (arglist
, stringargs
);
2293 /* We may want to append extra arguments here. This is used e.g. for
2294 calls to libgfortran_matmul_??, which need extra information. */
2295 if (append_args
!= NULL_TREE
)
2296 arglist
= chainon (arglist
, append_args
);
2298 /* Generate the actual call. */
2299 gfc_conv_function_val (se
, sym
);
2300 /* If there are alternate return labels, function type should be
2301 integer. Can't modify the type in place though, since it can be shared
2302 with other functions. */
2303 if (has_alternate_specifier
2304 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2306 gcc_assert (! sym
->attr
.dummy
);
2307 TREE_TYPE (sym
->backend_decl
)
2308 = build_function_type (integer_type_node
,
2309 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2310 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2313 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2314 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2315 arglist
, NULL_TREE
);
2317 /* If we have a pointer function, but we don't want a pointer, e.g.
2320 where f is pointer valued, we have to dereference the result. */
2321 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2322 se
->expr
= build_fold_indirect_ref (se
->expr
);
2324 /* f2c calling conventions require a scalar default real function to
2325 return a double precision result. Convert this back to default
2326 real. We only care about the cases that can happen in Fortran 77.
2328 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2329 && sym
->ts
.kind
== gfc_default_real_kind
2330 && !sym
->attr
.always_explicit
)
2331 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2333 /* A pure function may still have side-effects - it may modify its
2335 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2337 if (!sym
->attr
.pure
)
2338 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2343 /* Add the function call to the pre chain. There is no expression. */
2344 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2345 se
->expr
= NULL_TREE
;
2347 if (!se
->direct_byref
)
2349 if (sym
->attr
.dimension
)
2351 if (flag_bounds_check
)
2353 /* Check the data pointer hasn't been modified. This would
2354 happen in a function returning a pointer. */
2355 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2356 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2358 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2360 se
->expr
= info
->descriptor
;
2361 /* Bundle in the string length. */
2362 se
->string_length
= len
;
2364 else if (sym
->ts
.type
== BT_CHARACTER
)
2366 /* Dereference for character pointer results. */
2367 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2368 se
->expr
= build_fold_indirect_ref (var
);
2372 se
->string_length
= len
;
2376 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2377 se
->expr
= build_fold_indirect_ref (var
);
2382 /* Follow the function call with the argument post block. */
2384 gfc_add_block_to_block (&se
->pre
, &post
);
2386 gfc_add_block_to_block (&se
->post
, &post
);
2388 return has_alternate_specifier
;
2392 /* Generate code to copy a string. */
2395 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2396 tree slength
, tree src
)
2398 tree tmp
, dlen
, slen
;
2406 stmtblock_t tempblock
;
2408 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2409 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2411 /* Deal with single character specially. */
2412 dsc
= gfc_to_single_character (dlen
, dest
);
2413 ssc
= gfc_to_single_character (slen
, src
);
2414 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2416 gfc_add_modify_expr (block
, dsc
, ssc
);
2420 /* Do nothing if the destination length is zero. */
2421 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2422 build_int_cst (gfc_charlen_type_node
, 0));
2424 /* The following code was previously in _gfortran_copy_string:
2426 // The two strings may overlap so we use memmove.
2428 copy_string (GFC_INTEGER_4 destlen, char * dest,
2429 GFC_INTEGER_4 srclen, const char * src)
2431 if (srclen >= destlen)
2433 // This will truncate if too long.
2434 memmove (dest, src, destlen);
2438 memmove (dest, src, srclen);
2440 memset (&dest[srclen], ' ', destlen - srclen);
2444 We're now doing it here for better optimization, but the logic
2447 /* Truncate string if source is too long. */
2448 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2449 tmp2
= gfc_chainon_list (NULL_TREE
, dest
);
2450 tmp2
= gfc_chainon_list (tmp2
, src
);
2451 tmp2
= gfc_chainon_list (tmp2
, dlen
);
2452 tmp2
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp2
);
2454 /* Else copy and pad with spaces. */
2455 tmp3
= gfc_chainon_list (NULL_TREE
, dest
);
2456 tmp3
= gfc_chainon_list (tmp3
, src
);
2457 tmp3
= gfc_chainon_list (tmp3
, slen
);
2458 tmp3
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp3
);
2460 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2461 fold_convert (pchar_type_node
, slen
));
2462 tmp4
= gfc_chainon_list (NULL_TREE
, tmp4
);
2463 tmp4
= gfc_chainon_list (tmp4
, build_int_cst
2464 (gfc_get_int_type (gfc_c_int_kind
),
2465 lang_hooks
.to_target_charset (' ')));
2466 tmp4
= gfc_chainon_list (tmp4
, fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2468 tmp4
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], tmp4
);
2470 gfc_init_block (&tempblock
);
2471 gfc_add_expr_to_block (&tempblock
, tmp3
);
2472 gfc_add_expr_to_block (&tempblock
, tmp4
);
2473 tmp3
= gfc_finish_block (&tempblock
);
2475 /* The whole copy_string function is there. */
2476 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2477 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2478 gfc_add_expr_to_block (block
, tmp
);
2482 /* Translate a statement function.
2483 The value of a statement function reference is obtained by evaluating the
2484 expression using the values of the actual arguments for the values of the
2485 corresponding dummy arguments. */
2488 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2492 gfc_formal_arglist
*fargs
;
2493 gfc_actual_arglist
*args
;
2496 gfc_saved_var
*saved_vars
;
2502 sym
= expr
->symtree
->n
.sym
;
2503 args
= expr
->value
.function
.actual
;
2504 gfc_init_se (&lse
, NULL
);
2505 gfc_init_se (&rse
, NULL
);
2508 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2510 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2511 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2513 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2515 /* Each dummy shall be specified, explicitly or implicitly, to be
2517 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2520 /* Create a temporary to hold the value. */
2521 type
= gfc_typenode_for_spec (&fsym
->ts
);
2522 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2524 if (fsym
->ts
.type
== BT_CHARACTER
)
2526 /* Copy string arguments. */
2529 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2530 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2532 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2533 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2536 gfc_conv_expr (&rse
, args
->expr
);
2537 gfc_conv_string_parameter (&rse
);
2538 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2539 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2541 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2543 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2544 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2548 /* For everything else, just evaluate the expression. */
2549 gfc_conv_expr (&lse
, args
->expr
);
2551 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2552 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2553 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2559 /* Use the temporary variables in place of the real ones. */
2560 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2561 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2563 gfc_conv_expr (se
, sym
->value
);
2565 if (sym
->ts
.type
== BT_CHARACTER
)
2567 gfc_conv_const_charlen (sym
->ts
.cl
);
2569 /* Force the expression to the correct length. */
2570 if (!INTEGER_CST_P (se
->string_length
)
2571 || tree_int_cst_lt (se
->string_length
,
2572 sym
->ts
.cl
->backend_decl
))
2574 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2575 tmp
= gfc_create_var (type
, sym
->name
);
2576 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2577 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2578 se
->string_length
, se
->expr
);
2581 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2584 /* Restore the original variables. */
2585 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2586 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2587 gfc_free (saved_vars
);
2591 /* Translate a function expression. */
2594 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2598 if (expr
->value
.function
.isym
)
2600 gfc_conv_intrinsic_function (se
, expr
);
2604 /* We distinguish statement functions from general functions to improve
2605 runtime performance. */
2606 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2608 gfc_conv_statement_function (se
, expr
);
2612 /* expr.value.function.esym is the resolved (specific) function symbol for
2613 most functions. However this isn't set for dummy procedures. */
2614 sym
= expr
->value
.function
.esym
;
2616 sym
= expr
->symtree
->n
.sym
;
2617 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2622 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2624 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2625 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2627 gfc_conv_tmp_array_ref (se
);
2628 gfc_advance_se_ss_chain (se
);
2632 /* Build a static initializer. EXPR is the expression for the initial value.
2633 The other parameters describe the variable of the component being
2634 initialized. EXPR may be null. */
2637 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2638 bool array
, bool pointer
)
2642 if (!(expr
|| pointer
))
2647 /* Arrays need special handling. */
2649 return gfc_build_null_descriptor (type
);
2651 return gfc_conv_array_initializer (type
, expr
);
2654 return fold_convert (type
, null_pointer_node
);
2660 gfc_init_se (&se
, NULL
);
2661 gfc_conv_structure (&se
, expr
, 1);
2665 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2668 gfc_init_se (&se
, NULL
);
2669 gfc_conv_constant (&se
, expr
);
2676 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2688 gfc_start_block (&block
);
2690 /* Initialize the scalarizer. */
2691 gfc_init_loopinfo (&loop
);
2693 gfc_init_se (&lse
, NULL
);
2694 gfc_init_se (&rse
, NULL
);
2697 rss
= gfc_walk_expr (expr
);
2698 if (rss
== gfc_ss_terminator
)
2700 /* The rhs is scalar. Add a ss for the expression. */
2701 rss
= gfc_get_ss ();
2702 rss
->next
= gfc_ss_terminator
;
2703 rss
->type
= GFC_SS_SCALAR
;
2707 /* Create a SS for the destination. */
2708 lss
= gfc_get_ss ();
2709 lss
->type
= GFC_SS_COMPONENT
;
2711 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2712 lss
->next
= gfc_ss_terminator
;
2713 lss
->data
.info
.dimen
= cm
->as
->rank
;
2714 lss
->data
.info
.descriptor
= dest
;
2715 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2716 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2717 for (n
= 0; n
< cm
->as
->rank
; n
++)
2719 lss
->data
.info
.dim
[n
] = n
;
2720 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2721 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2723 mpz_init (lss
->shape
[n
]);
2724 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2725 cm
->as
->lower
[n
]->value
.integer
);
2726 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2729 /* Associate the SS with the loop. */
2730 gfc_add_ss_to_loop (&loop
, lss
);
2731 gfc_add_ss_to_loop (&loop
, rss
);
2733 /* Calculate the bounds of the scalarization. */
2734 gfc_conv_ss_startstride (&loop
);
2736 /* Setup the scalarizing loops. */
2737 gfc_conv_loop_setup (&loop
);
2739 /* Setup the gfc_se structures. */
2740 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2741 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2744 gfc_mark_ss_chain_used (rss
, 1);
2746 gfc_mark_ss_chain_used (lss
, 1);
2748 /* Start the scalarized loop body. */
2749 gfc_start_scalarized_body (&loop
, &body
);
2751 gfc_conv_tmp_array_ref (&lse
);
2752 if (cm
->ts
.type
== BT_CHARACTER
)
2753 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2755 gfc_conv_expr (&rse
, expr
);
2757 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2758 gfc_add_expr_to_block (&body
, tmp
);
2760 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2762 /* Generate the copying loops. */
2763 gfc_trans_scalarizing_loops (&loop
, &body
);
2765 /* Wrap the whole thing up. */
2766 gfc_add_block_to_block (&block
, &loop
.pre
);
2767 gfc_add_block_to_block (&block
, &loop
.post
);
2769 for (n
= 0; n
< cm
->as
->rank
; n
++)
2770 mpz_clear (lss
->shape
[n
]);
2771 gfc_free (lss
->shape
);
2773 gfc_cleanup_loop (&loop
);
2775 return gfc_finish_block (&block
);
2779 /* Assign a single component of a derived type constructor. */
2782 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2792 gfc_start_block (&block
);
2796 gfc_init_se (&se
, NULL
);
2797 /* Pointer component. */
2800 /* Array pointer. */
2801 if (expr
->expr_type
== EXPR_NULL
)
2802 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2805 rss
= gfc_walk_expr (expr
);
2806 se
.direct_byref
= 1;
2808 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2809 gfc_add_block_to_block (&block
, &se
.pre
);
2810 gfc_add_block_to_block (&block
, &se
.post
);
2815 /* Scalar pointers. */
2816 se
.want_pointer
= 1;
2817 gfc_conv_expr (&se
, expr
);
2818 gfc_add_block_to_block (&block
, &se
.pre
);
2819 gfc_add_modify_expr (&block
, dest
,
2820 fold_convert (TREE_TYPE (dest
), se
.expr
));
2821 gfc_add_block_to_block (&block
, &se
.post
);
2824 else if (cm
->dimension
)
2826 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2827 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2828 else if (cm
->allocatable
)
2832 gfc_init_se (&se
, NULL
);
2834 rss
= gfc_walk_expr (expr
);
2835 se
.want_pointer
= 0;
2836 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2837 gfc_add_block_to_block (&block
, &se
.pre
);
2839 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2840 gfc_add_modify_expr (&block
, dest
, tmp
);
2842 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2843 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2846 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2847 TREE_TYPE(cm
->backend_decl
),
2850 gfc_add_expr_to_block (&block
, tmp
);
2852 gfc_add_block_to_block (&block
, &se
.post
);
2853 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2855 /* Shift the lbound and ubound of temporaries to being unity, rather
2856 than zero, based. Calculate the offset for all cases. */
2857 offset
= gfc_conv_descriptor_offset (dest
);
2858 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2859 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2860 for (n
= 0; n
< expr
->rank
; n
++)
2862 if (expr
->expr_type
!= EXPR_VARIABLE
2863 && expr
->expr_type
!= EXPR_CONSTANT
)
2865 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2866 gfc_add_modify_expr (&block
, tmp
,
2867 fold_build2 (PLUS_EXPR
,
2868 gfc_array_index_type
,
2869 tmp
, gfc_index_one_node
));
2870 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2871 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2873 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2874 gfc_conv_descriptor_lbound (dest
,
2876 gfc_conv_descriptor_stride (dest
,
2878 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2879 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2880 gfc_add_modify_expr (&block
, offset
, tmp
);
2885 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2886 gfc_add_expr_to_block (&block
, tmp
);
2889 else if (expr
->ts
.type
== BT_DERIVED
)
2891 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2893 gfc_init_se (&se
, NULL
);
2894 gfc_conv_expr (&se
, expr
);
2895 gfc_add_modify_expr (&block
, dest
,
2896 fold_convert (TREE_TYPE (dest
), se
.expr
));
2900 /* Nested constructors. */
2901 tmp
= gfc_trans_structure_assign (dest
, expr
);
2902 gfc_add_expr_to_block (&block
, tmp
);
2907 /* Scalar component. */
2908 gfc_init_se (&se
, NULL
);
2909 gfc_init_se (&lse
, NULL
);
2911 gfc_conv_expr (&se
, expr
);
2912 if (cm
->ts
.type
== BT_CHARACTER
)
2913 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2915 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
2916 gfc_add_expr_to_block (&block
, tmp
);
2918 return gfc_finish_block (&block
);
2921 /* Assign a derived type constructor to a variable. */
2924 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2932 gfc_start_block (&block
);
2933 cm
= expr
->ts
.derived
->components
;
2934 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2936 /* Skip absent members in default initializers. */
2940 field
= cm
->backend_decl
;
2941 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
2942 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
2943 gfc_add_expr_to_block (&block
, tmp
);
2945 return gfc_finish_block (&block
);
2948 /* Build an expression for a constructor. If init is nonzero then
2949 this is part of a static variable initializer. */
2952 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
2959 VEC(constructor_elt
,gc
) *v
= NULL
;
2961 gcc_assert (se
->ss
== NULL
);
2962 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
2963 type
= gfc_typenode_for_spec (&expr
->ts
);
2967 /* Create a temporary variable and fill it in. */
2968 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
2969 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
2970 gfc_add_expr_to_block (&se
->pre
, tmp
);
2974 cm
= expr
->ts
.derived
->components
;
2976 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2978 /* Skip absent members in default initializers and allocatable
2979 components. Although the latter have a default initializer
2980 of EXPR_NULL,... by default, the static nullify is not needed
2981 since this is done every time we come into scope. */
2982 if (!c
->expr
|| cm
->allocatable
)
2985 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
2986 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
2988 /* Append it to the constructor list. */
2989 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
2991 se
->expr
= build_constructor (type
, v
);
2995 /* Translate a substring expression. */
2998 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3004 gcc_assert (ref
->type
== REF_SUBSTRING
);
3006 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3007 expr
->value
.character
.string
);
3008 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3009 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3011 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3015 /* Entry point for expression translation. Evaluates a scalar quantity.
3016 EXPR is the expression to be translated, and SE is the state structure if
3017 called from within the scalarized. */
3020 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3022 if (se
->ss
&& se
->ss
->expr
== expr
3023 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3025 /* Substitute a scalar expression evaluated outside the scalarization
3027 se
->expr
= se
->ss
->data
.scalar
.expr
;
3028 se
->string_length
= se
->ss
->string_length
;
3029 gfc_advance_se_ss_chain (se
);
3033 switch (expr
->expr_type
)
3036 gfc_conv_expr_op (se
, expr
);
3040 gfc_conv_function_expr (se
, expr
);
3044 gfc_conv_constant (se
, expr
);
3048 gfc_conv_variable (se
, expr
);
3052 se
->expr
= null_pointer_node
;
3055 case EXPR_SUBSTRING
:
3056 gfc_conv_substring_expr (se
, expr
);
3059 case EXPR_STRUCTURE
:
3060 gfc_conv_structure (se
, expr
, 0);
3064 gfc_conv_array_constructor_expr (se
, expr
);
3073 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3074 of an assignment. */
3076 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3078 gfc_conv_expr (se
, expr
);
3079 /* All numeric lvalues should have empty post chains. If not we need to
3080 figure out a way of rewriting an lvalue so that it has no post chain. */
3081 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3084 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3085 numeric expressions. Used for scalar values where inserting cleanup code
3088 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3092 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3093 gfc_conv_expr (se
, expr
);
3096 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3097 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3099 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3103 /* Helper to translate and expression and convert it to a particular type. */
3105 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3107 gfc_conv_expr_val (se
, expr
);
3108 se
->expr
= convert (type
, se
->expr
);
3112 /* Converts an expression so that it can be passed by reference. Scalar
3116 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3120 if (se
->ss
&& se
->ss
->expr
== expr
3121 && se
->ss
->type
== GFC_SS_REFERENCE
)
3123 se
->expr
= se
->ss
->data
.scalar
.expr
;
3124 se
->string_length
= se
->ss
->string_length
;
3125 gfc_advance_se_ss_chain (se
);
3129 if (expr
->ts
.type
== BT_CHARACTER
)
3131 gfc_conv_expr (se
, expr
);
3132 gfc_conv_string_parameter (se
);
3136 if (expr
->expr_type
== EXPR_VARIABLE
)
3138 se
->want_pointer
= 1;
3139 gfc_conv_expr (se
, expr
);
3142 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3143 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3144 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3150 gfc_conv_expr (se
, expr
);
3152 /* Create a temporary var to hold the value. */
3153 if (TREE_CONSTANT (se
->expr
))
3155 tree tmp
= se
->expr
;
3156 STRIP_TYPE_NOPS (tmp
);
3157 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3158 DECL_INITIAL (var
) = tmp
;
3159 TREE_STATIC (var
) = 1;
3164 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3165 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3167 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3169 /* Take the address of that value. */
3170 se
->expr
= build_fold_addr_expr (var
);
3175 gfc_trans_pointer_assign (gfc_code
* code
)
3177 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3181 /* Generate code for a pointer assignment. */
3184 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3194 gfc_start_block (&block
);
3196 gfc_init_se (&lse
, NULL
);
3198 lss
= gfc_walk_expr (expr1
);
3199 rss
= gfc_walk_expr (expr2
);
3200 if (lss
== gfc_ss_terminator
)
3202 /* Scalar pointers. */
3203 lse
.want_pointer
= 1;
3204 gfc_conv_expr (&lse
, expr1
);
3205 gcc_assert (rss
== gfc_ss_terminator
);
3206 gfc_init_se (&rse
, NULL
);
3207 rse
.want_pointer
= 1;
3208 gfc_conv_expr (&rse
, expr2
);
3209 gfc_add_block_to_block (&block
, &lse
.pre
);
3210 gfc_add_block_to_block (&block
, &rse
.pre
);
3211 gfc_add_modify_expr (&block
, lse
.expr
,
3212 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3213 gfc_add_block_to_block (&block
, &rse
.post
);
3214 gfc_add_block_to_block (&block
, &lse
.post
);
3218 /* Array pointer. */
3219 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3220 switch (expr2
->expr_type
)
3223 /* Just set the data pointer to null. */
3224 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3228 /* Assign directly to the pointer's descriptor. */
3229 lse
.direct_byref
= 1;
3230 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3234 /* Assign to a temporary descriptor and then copy that
3235 temporary to the pointer. */
3237 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3240 lse
.direct_byref
= 1;
3241 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3242 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3245 gfc_add_block_to_block (&block
, &lse
.pre
);
3246 gfc_add_block_to_block (&block
, &lse
.post
);
3248 return gfc_finish_block (&block
);
3252 /* Makes sure se is suitable for passing as a function string parameter. */
3253 /* TODO: Need to check all callers fo this function. It may be abused. */
3256 gfc_conv_string_parameter (gfc_se
* se
)
3260 if (TREE_CODE (se
->expr
) == STRING_CST
)
3262 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3266 type
= TREE_TYPE (se
->expr
);
3267 if (TYPE_STRING_FLAG (type
))
3269 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3270 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3273 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3274 gcc_assert (se
->string_length
3275 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3279 /* Generate code for assignment of scalar variables. Includes character
3280 strings and derived types with allocatable components. */
3283 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3284 bool l_is_temp
, bool r_is_var
)
3290 gfc_init_block (&block
);
3292 if (ts
.type
== BT_CHARACTER
)
3294 gcc_assert (lse
->string_length
!= NULL_TREE
3295 && rse
->string_length
!= NULL_TREE
);
3297 gfc_conv_string_parameter (lse
);
3298 gfc_conv_string_parameter (rse
);
3300 gfc_add_block_to_block (&block
, &lse
->pre
);
3301 gfc_add_block_to_block (&block
, &rse
->pre
);
3303 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3304 rse
->string_length
, rse
->expr
);
3306 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3310 /* Are the rhs and the lhs the same? */
3313 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3314 build_fold_addr_expr (lse
->expr
),
3315 build_fold_addr_expr (rse
->expr
));
3316 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3319 /* Deallocate the lhs allocated components as long as it is not
3320 the same as the rhs. */
3323 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3325 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3326 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3329 gfc_add_block_to_block (&block
, &lse
->pre
);
3330 gfc_add_block_to_block (&block
, &rse
->pre
);
3332 gfc_add_modify_expr (&block
, lse
->expr
,
3333 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3335 /* Do a deep copy if the rhs is a variable, if it is not the
3339 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3340 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3341 gfc_add_expr_to_block (&block
, tmp
);
3346 gfc_add_block_to_block (&block
, &lse
->pre
);
3347 gfc_add_block_to_block (&block
, &rse
->pre
);
3349 gfc_add_modify_expr (&block
, lse
->expr
,
3350 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3353 gfc_add_block_to_block (&block
, &lse
->post
);
3354 gfc_add_block_to_block (&block
, &rse
->post
);
3356 return gfc_finish_block (&block
);
3360 /* Try to translate array(:) = func (...), where func is a transformational
3361 array function, without using a temporary. Returns NULL is this isn't the
3365 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3370 bool seen_array_ref
;
3372 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3373 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3376 /* Elemental functions don't need a temporary anyway. */
3377 if (expr2
->value
.function
.esym
!= NULL
3378 && expr2
->value
.function
.esym
->attr
.elemental
)
3381 /* Fail if EXPR1 can't be expressed as a descriptor. */
3382 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3385 /* Functions returning pointers need temporaries. */
3386 if (expr2
->symtree
->n
.sym
->attr
.pointer
3387 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3390 /* Character array functions need temporaries unless the
3391 character lengths are the same. */
3392 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3394 if (expr1
->ts
.cl
->length
== NULL
3395 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3398 if (expr2
->ts
.cl
->length
== NULL
3399 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3402 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3403 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3407 /* Check that no LHS component references appear during an array
3408 reference. This is needed because we do not have the means to
3409 span any arbitrary stride with an array descriptor. This check
3410 is not needed for the rhs because the function result has to be
3412 seen_array_ref
= false;
3413 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3415 if (ref
->type
== REF_ARRAY
)
3416 seen_array_ref
= true;
3417 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3421 /* Check for a dependency. */
3422 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3423 expr2
->value
.function
.esym
,
3424 expr2
->value
.function
.actual
))
3427 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3429 gcc_assert (expr2
->value
.function
.isym
3430 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3431 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3433 ss
= gfc_walk_expr (expr1
);
3434 gcc_assert (ss
!= gfc_ss_terminator
);
3435 gfc_init_se (&se
, NULL
);
3436 gfc_start_block (&se
.pre
);
3437 se
.want_pointer
= 1;
3439 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3441 se
.direct_byref
= 1;
3442 se
.ss
= gfc_walk_expr (expr2
);
3443 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3444 gfc_conv_function_expr (&se
, expr2
);
3445 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3447 return gfc_finish_block (&se
.pre
);
3450 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3453 is_zero_initializer_p (gfc_expr
* expr
)
3455 if (expr
->expr_type
!= EXPR_CONSTANT
)
3457 /* We ignore Hollerith constants for the time being. */
3461 switch (expr
->ts
.type
)
3464 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3467 return mpfr_zero_p (expr
->value
.real
)
3468 && MPFR_SIGN (expr
->value
.real
) >= 0;
3471 return expr
->value
.logical
== 0;
3474 return mpfr_zero_p (expr
->value
.complex.r
)
3475 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3476 && mpfr_zero_p (expr
->value
.complex.i
)
3477 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3485 /* Try to efficiently translate array(:) = 0. Return NULL if this
3489 gfc_trans_zero_assign (gfc_expr
* expr
)
3491 tree dest
, len
, type
;
3495 sym
= expr
->symtree
->n
.sym
;
3496 dest
= gfc_get_symbol_decl (sym
);
3498 type
= TREE_TYPE (dest
);
3499 if (POINTER_TYPE_P (type
))
3500 type
= TREE_TYPE (type
);
3501 if (!GFC_ARRAY_TYPE_P (type
))
3504 /* Determine the length of the array. */
3505 len
= GFC_TYPE_ARRAY_SIZE (type
);
3506 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3509 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3510 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
3512 /* Convert arguments to the correct types. */
3513 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3514 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3516 dest
= fold_convert (pvoid_type_node
, dest
);
3517 len
= fold_convert (size_type_node
, len
);
3519 /* Construct call to __builtin_memset. */
3520 args
= build_tree_list (NULL_TREE
, len
);
3521 args
= tree_cons (NULL_TREE
, integer_zero_node
, args
);
3522 args
= tree_cons (NULL_TREE
, dest
, args
);
3523 tmp
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], args
);
3524 return fold_convert (void_type_node
, tmp
);
3527 /* Translate an assignment. Most of the code is concerned with
3528 setting up the scalarizer. */
3531 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3536 gfc_ss
*lss_section
;
3544 /* Special case a single function returning an array. */
3545 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3547 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3552 /* Special case assigning an array to zero. */
3553 if (expr1
->expr_type
== EXPR_VARIABLE
3556 && gfc_full_array_ref_p (expr1
->ref
)
3557 && is_zero_initializer_p (expr2
))
3559 tmp
= gfc_trans_zero_assign (expr1
);
3564 /* Assignment of the form lhs = rhs. */
3565 gfc_start_block (&block
);
3567 gfc_init_se (&lse
, NULL
);
3568 gfc_init_se (&rse
, NULL
);
3571 lss
= gfc_walk_expr (expr1
);
3573 if (lss
!= gfc_ss_terminator
)
3575 /* The assignment needs scalarization. */
3578 /* Find a non-scalar SS from the lhs. */
3579 while (lss_section
!= gfc_ss_terminator
3580 && lss_section
->type
!= GFC_SS_SECTION
)
3581 lss_section
= lss_section
->next
;
3583 gcc_assert (lss_section
!= gfc_ss_terminator
);
3585 /* Initialize the scalarizer. */
3586 gfc_init_loopinfo (&loop
);
3589 rss
= gfc_walk_expr (expr2
);
3590 if (rss
== gfc_ss_terminator
)
3592 /* The rhs is scalar. Add a ss for the expression. */
3593 rss
= gfc_get_ss ();
3594 rss
->next
= gfc_ss_terminator
;
3595 rss
->type
= GFC_SS_SCALAR
;
3598 /* Associate the SS with the loop. */
3599 gfc_add_ss_to_loop (&loop
, lss
);
3600 gfc_add_ss_to_loop (&loop
, rss
);
3602 /* Calculate the bounds of the scalarization. */
3603 gfc_conv_ss_startstride (&loop
);
3604 /* Resolve any data dependencies in the statement. */
3605 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3606 /* Setup the scalarizing loops. */
3607 gfc_conv_loop_setup (&loop
);
3609 /* Setup the gfc_se structures. */
3610 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3611 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3614 gfc_mark_ss_chain_used (rss
, 1);
3615 if (loop
.temp_ss
== NULL
)
3618 gfc_mark_ss_chain_used (lss
, 1);
3622 lse
.ss
= loop
.temp_ss
;
3623 gfc_mark_ss_chain_used (lss
, 3);
3624 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3627 /* Start the scalarized loop body. */
3628 gfc_start_scalarized_body (&loop
, &body
);
3631 gfc_init_block (&body
);
3633 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3635 /* Translate the expression. */
3636 gfc_conv_expr (&rse
, expr2
);
3640 gfc_conv_tmp_array_ref (&lse
);
3641 gfc_advance_se_ss_chain (&lse
);
3644 gfc_conv_expr (&lse
, expr1
);
3646 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3647 l_is_temp
|| init_flag
,
3648 expr2
->expr_type
== EXPR_VARIABLE
);
3649 gfc_add_expr_to_block (&body
, tmp
);
3651 if (lss
== gfc_ss_terminator
)
3653 /* Use the scalar assignment as is. */
3654 gfc_add_block_to_block (&block
, &body
);
3658 gcc_assert (lse
.ss
== gfc_ss_terminator
3659 && rse
.ss
== gfc_ss_terminator
);
3663 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3665 /* We need to copy the temporary to the actual lhs. */
3666 gfc_init_se (&lse
, NULL
);
3667 gfc_init_se (&rse
, NULL
);
3668 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3669 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3671 rse
.ss
= loop
.temp_ss
;
3674 gfc_conv_tmp_array_ref (&rse
);
3675 gfc_advance_se_ss_chain (&rse
);
3676 gfc_conv_expr (&lse
, expr1
);
3678 gcc_assert (lse
.ss
== gfc_ss_terminator
3679 && rse
.ss
== gfc_ss_terminator
);
3681 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3683 gfc_add_expr_to_block (&body
, tmp
);
3686 /* Generate the copying loops. */
3687 gfc_trans_scalarizing_loops (&loop
, &body
);
3689 /* Wrap the whole thing up. */
3690 gfc_add_block_to_block (&block
, &loop
.pre
);
3691 gfc_add_block_to_block (&block
, &loop
.post
);
3693 gfc_cleanup_loop (&loop
);
3696 return gfc_finish_block (&block
);
3700 gfc_trans_init_assign (gfc_code
* code
)
3702 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3706 gfc_trans_assign (gfc_code
* code
)
3708 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);