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 /* Check lower bound. */
282 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
283 build_int_cst (gfc_charlen_type_node
, 1));
285 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
286 "is less than one", name
);
288 asprintf (&msg
, "Substring out of bounds: lower bound "
290 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
293 /* Check upper bound. */
294 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
297 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
298 "exceeds string length", name
);
300 asprintf (&msg
, "Substring out of bounds: upper bound "
301 "exceeds string length");
302 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
306 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
307 build_int_cst (gfc_charlen_type_node
, 1),
309 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
310 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
311 build_int_cst (gfc_charlen_type_node
, 0));
312 se
->string_length
= tmp
;
316 /* Convert a derived type component reference. */
319 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
326 c
= ref
->u
.c
.component
;
328 gcc_assert (c
->backend_decl
);
330 field
= c
->backend_decl
;
331 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
333 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
337 if (c
->ts
.type
== BT_CHARACTER
)
339 tmp
= c
->ts
.cl
->backend_decl
;
340 /* Components must always be constant length. */
341 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
342 se
->string_length
= tmp
;
345 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
346 se
->expr
= build_fold_indirect_ref (se
->expr
);
350 /* Return the contents of a variable. Also handles reference/pointer
351 variables (all Fortran pointer references are implicit). */
354 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
361 bool alternate_entry
;
364 sym
= expr
->symtree
->n
.sym
;
367 /* Check that something hasn't gone horribly wrong. */
368 gcc_assert (se
->ss
!= gfc_ss_terminator
);
369 gcc_assert (se
->ss
->expr
== expr
);
371 /* A scalarized term. We already know the descriptor. */
372 se
->expr
= se
->ss
->data
.info
.descriptor
;
373 se
->string_length
= se
->ss
->string_length
;
374 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
375 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
380 tree se_expr
= NULL_TREE
;
382 se
->expr
= gfc_get_symbol_decl (sym
);
384 /* Deal with references to a parent results or entries by storing
385 the current_function_decl and moving to the parent_decl. */
386 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
387 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
388 && sym
->result
== sym
;
389 entry_master
= sym
->attr
.result
390 && sym
->ns
->proc_name
->attr
.entry_master
391 && !gfc_return_by_reference (sym
->ns
->proc_name
);
392 parent_decl
= DECL_CONTEXT (current_function_decl
);
394 if ((se
->expr
== parent_decl
&& return_value
)
395 || (sym
->ns
&& sym
->ns
->proc_name
397 && sym
->ns
->proc_name
->backend_decl
== parent_decl
398 && (alternate_entry
|| entry_master
)))
403 /* Special case for assigning the return value of a function.
404 Self recursive functions must have an explicit return value. */
405 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
406 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
408 /* Similarly for alternate entry points. */
409 else if (alternate_entry
410 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
413 gfc_entry_list
*el
= NULL
;
415 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
418 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
423 else if (entry_master
424 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
426 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
431 /* Procedure actual arguments. */
432 else if (sym
->attr
.flavor
== FL_PROCEDURE
433 && se
->expr
!= current_function_decl
)
435 gcc_assert (se
->want_pointer
);
436 if (!sym
->attr
.dummy
)
438 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
439 se
->expr
= build_fold_addr_expr (se
->expr
);
445 /* Dereference the expression, where needed. Since characters
446 are entirely different from other types, they are treated
448 if (sym
->ts
.type
== BT_CHARACTER
)
450 /* Dereference character pointer dummy arguments
452 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
454 || sym
->attr
.function
455 || sym
->attr
.result
))
456 se
->expr
= build_fold_indirect_ref (se
->expr
);
458 /* A character with VALUE attribute needs an address
461 se
->expr
= build_fold_addr_expr (se
->expr
);
464 else if (!sym
->attr
.value
)
466 /* Dereference non-character scalar dummy arguments. */
467 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
468 se
->expr
= build_fold_indirect_ref (se
->expr
);
470 /* Dereference scalar hidden result. */
471 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
472 && (sym
->attr
.function
|| sym
->attr
.result
)
473 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
474 se
->expr
= build_fold_indirect_ref (se
->expr
);
476 /* Dereference non-character pointer variables.
477 These must be dummies, results, or scalars. */
478 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
480 || sym
->attr
.function
482 || !sym
->attr
.dimension
))
483 se
->expr
= build_fold_indirect_ref (se
->expr
);
489 /* For character variables, also get the length. */
490 if (sym
->ts
.type
== BT_CHARACTER
)
492 /* If the character length of an entry isn't set, get the length from
493 the master function instead. */
494 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
495 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
497 se
->string_length
= sym
->ts
.cl
->backend_decl
;
498 gcc_assert (se
->string_length
);
506 /* Return the descriptor if that's what we want and this is an array
507 section reference. */
508 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
510 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
511 /* Return the descriptor for array pointers and allocations. */
513 && ref
->next
== NULL
&& (se
->descriptor_only
))
516 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
517 /* Return a pointer to an element. */
521 gfc_conv_component_ref (se
, ref
);
525 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
526 expr
->symtree
->name
, &expr
->where
);
535 /* Pointer assignment, allocation or pass by reference. Arrays are handled
537 if (se
->want_pointer
)
539 if (expr
->ts
.type
== BT_CHARACTER
)
540 gfc_conv_string_parameter (se
);
542 se
->expr
= build_fold_addr_expr (se
->expr
);
547 /* Unary ops are easy... Or they would be if ! was a valid op. */
550 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
555 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
556 /* Initialize the operand. */
557 gfc_init_se (&operand
, se
);
558 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
559 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
561 type
= gfc_typenode_for_spec (&expr
->ts
);
563 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
564 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
565 All other unary operators have an equivalent GIMPLE unary operator. */
566 if (code
== TRUTH_NOT_EXPR
)
567 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
568 build_int_cst (type
, 0));
570 se
->expr
= build1 (code
, type
, operand
.expr
);
574 /* Expand power operator to optimal multiplications when a value is raised
575 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
576 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
577 Programming", 3rd Edition, 1998. */
579 /* This code is mostly duplicated from expand_powi in the backend.
580 We establish the "optimal power tree" lookup table with the defined size.
581 The items in the table are the exponents used to calculate the index
582 exponents. Any integer n less than the value can get an "addition chain",
583 with the first node being one. */
584 #define POWI_TABLE_SIZE 256
586 /* The table is from builtins.c. */
587 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
589 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
590 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
591 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
592 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
593 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
594 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
595 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
596 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
597 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
598 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
599 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
600 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
601 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
602 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
603 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
604 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
605 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
606 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
607 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
608 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
609 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
610 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
611 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
612 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
613 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
614 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
615 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
616 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
617 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
618 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
619 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
620 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
623 /* If n is larger than lookup table's max index, we use the "window
625 #define POWI_WINDOW_SIZE 3
627 /* Recursive function to expand the power operator. The temporary
628 values are put in tmpvar. The function returns tmpvar[1] ** n. */
630 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
637 if (n
< POWI_TABLE_SIZE
)
642 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
643 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
647 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
648 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
649 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
653 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
657 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
658 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
660 if (n
< POWI_TABLE_SIZE
)
667 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
668 return 1. Else return 0 and a call to runtime library functions
669 will have to be built. */
671 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
676 tree vartmp
[POWI_TABLE_SIZE
];
680 type
= TREE_TYPE (lhs
);
681 n
= abs (TREE_INT_CST_LOW (rhs
));
682 sgn
= tree_int_cst_sgn (rhs
);
684 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
685 && (n
> 2 || n
< -1))
691 se
->expr
= gfc_build_const (type
, integer_one_node
);
694 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
695 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
697 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
698 build_int_cst (TREE_TYPE (lhs
), -1));
699 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
700 build_int_cst (TREE_TYPE (lhs
), 1));
703 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
706 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
707 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
708 build_int_cst (type
, 0));
712 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
713 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
714 build_int_cst (type
, 0));
715 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
719 memset (vartmp
, 0, sizeof (vartmp
));
723 tmp
= gfc_build_const (type
, integer_one_node
);
724 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
727 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
733 /* Power op (**). Constant integer exponent has special handling. */
736 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
738 tree gfc_int4_type_node
;
746 gfc_init_se (&lse
, se
);
747 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
748 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
749 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
751 gfc_init_se (&rse
, se
);
752 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
753 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
755 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
756 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
757 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
760 gfc_int4_type_node
= gfc_get_int_type (4);
762 kind
= expr
->value
.op
.op1
->ts
.kind
;
763 switch (expr
->value
.op
.op2
->ts
.type
)
766 ikind
= expr
->value
.op
.op2
->ts
.kind
;
771 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
793 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
794 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
819 switch (expr
->value
.op
.op1
->ts
.type
)
822 if (kind
== 3) /* Case 16 was not handled properly above. */
824 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
828 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
832 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
844 fndecl
= built_in_decls
[BUILT_IN_POWF
];
847 fndecl
= built_in_decls
[BUILT_IN_POW
];
851 fndecl
= built_in_decls
[BUILT_IN_POWL
];
862 fndecl
= gfor_fndecl_math_cpowf
;
865 fndecl
= gfor_fndecl_math_cpow
;
868 fndecl
= gfor_fndecl_math_cpowl10
;
871 fndecl
= gfor_fndecl_math_cpowl16
;
883 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
884 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
885 se
->expr
= build_function_call_expr (fndecl
, tmp
);
889 /* Generate code to allocate a string temporary. */
892 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
898 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
900 if (gfc_can_put_var_on_stack (len
))
902 /* Create a temporary variable to hold the result. */
903 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
904 build_int_cst (gfc_charlen_type_node
, 1));
905 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
906 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
907 var
= gfc_create_var (tmp
, "str");
908 var
= gfc_build_addr_expr (type
, var
);
912 /* Allocate a temporary to hold the result. */
913 var
= gfc_create_var (type
, "pstr");
914 args
= gfc_chainon_list (NULL_TREE
, len
);
915 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, args
);
916 tmp
= convert (type
, tmp
);
917 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
919 /* Free the temporary afterwards. */
920 tmp
= convert (pvoid_type_node
, var
);
921 args
= gfc_chainon_list (NULL_TREE
, tmp
);
922 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
923 gfc_add_expr_to_block (&se
->post
, tmp
);
930 /* Handle a string concatenation operation. A temporary will be allocated to
934 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
944 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
945 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
947 gfc_init_se (&lse
, se
);
948 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
949 gfc_conv_string_parameter (&lse
);
950 gfc_init_se (&rse
, se
);
951 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
952 gfc_conv_string_parameter (&rse
);
954 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
955 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
957 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
958 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
959 if (len
== NULL_TREE
)
961 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
962 lse
.string_length
, rse
.string_length
);
965 type
= build_pointer_type (type
);
967 var
= gfc_conv_string_tmp (se
, type
, len
);
969 /* Do the actual concatenation. */
971 args
= gfc_chainon_list (args
, len
);
972 args
= gfc_chainon_list (args
, var
);
973 args
= gfc_chainon_list (args
, lse
.string_length
);
974 args
= gfc_chainon_list (args
, lse
.expr
);
975 args
= gfc_chainon_list (args
, rse
.string_length
);
976 args
= gfc_chainon_list (args
, rse
.expr
);
977 tmp
= build_function_call_expr (gfor_fndecl_concat_string
, args
);
978 gfc_add_expr_to_block (&se
->pre
, tmp
);
980 /* Add the cleanup for the operands. */
981 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
982 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
985 se
->string_length
= len
;
988 /* Translates an op expression. Common (binary) cases are handled by this
989 function, others are passed on. Recursion is used in either case.
990 We use the fact that (op1.ts == op2.ts) (except for the power
992 Operators need no special handling for scalarized expressions as long as
993 they call gfc_conv_simple_val to get their operands.
994 Character strings get special handling. */
997 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1009 switch (expr
->value
.op
.operator)
1011 case INTRINSIC_UPLUS
:
1012 case INTRINSIC_PARENTHESES
:
1013 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1016 case INTRINSIC_UMINUS
:
1017 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1021 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1024 case INTRINSIC_PLUS
:
1028 case INTRINSIC_MINUS
:
1032 case INTRINSIC_TIMES
:
1036 case INTRINSIC_DIVIDE
:
1037 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1038 an integer, we must round towards zero, so we use a
1040 if (expr
->ts
.type
== BT_INTEGER
)
1041 code
= TRUNC_DIV_EXPR
;
1046 case INTRINSIC_POWER
:
1047 gfc_conv_power_op (se
, expr
);
1050 case INTRINSIC_CONCAT
:
1051 gfc_conv_concat_op (se
, expr
);
1055 code
= TRUTH_ANDIF_EXPR
;
1060 code
= TRUTH_ORIF_EXPR
;
1064 /* EQV and NEQV only work on logicals, but since we represent them
1065 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1074 case INTRINSIC_NEQV
:
1104 case INTRINSIC_USER
:
1105 case INTRINSIC_ASSIGN
:
1106 /* These should be converted into function calls by the frontend. */
1110 fatal_error ("Unknown intrinsic op");
1114 /* The only exception to this is **, which is handled separately anyway. */
1115 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1117 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1121 gfc_init_se (&lse
, se
);
1122 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1123 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1126 gfc_init_se (&rse
, se
);
1127 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1128 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1132 gfc_conv_string_parameter (&lse
);
1133 gfc_conv_string_parameter (&rse
);
1135 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1136 rse
.string_length
, rse
.expr
);
1137 rse
.expr
= integer_zero_node
;
1138 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1141 type
= gfc_typenode_for_spec (&expr
->ts
);
1145 /* The result of logical ops is always boolean_type_node. */
1146 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1147 se
->expr
= convert (type
, tmp
);
1150 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1152 /* Add the post blocks. */
1153 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1154 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1157 /* If a string's length is one, we convert it to a single character. */
1160 gfc_to_single_character (tree len
, tree str
)
1162 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1164 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1165 && TREE_INT_CST_HIGH (len
) == 0)
1167 str
= fold_convert (pchar_type_node
, str
);
1168 return build_fold_indirect_ref (str
);
1174 /* Compare two strings. If they are all single characters, the result is the
1175 subtraction of them. Otherwise, we build a library call. */
1178 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1185 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1186 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1188 type
= gfc_get_int_type (gfc_default_integer_kind
);
1190 sc1
= gfc_to_single_character (len1
, str1
);
1191 sc2
= gfc_to_single_character (len2
, str2
);
1193 /* Deal with single character specially. */
1194 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1196 sc1
= fold_convert (type
, sc1
);
1197 sc2
= fold_convert (type
, sc2
);
1198 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1203 tmp
= gfc_chainon_list (tmp
, len1
);
1204 tmp
= gfc_chainon_list (tmp
, str1
);
1205 tmp
= gfc_chainon_list (tmp
, len2
);
1206 tmp
= gfc_chainon_list (tmp
, str2
);
1208 /* Build a call for the comparison. */
1209 tmp
= build_function_call_expr (gfor_fndecl_compare_string
, tmp
);
1216 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1220 if (sym
->attr
.dummy
)
1222 tmp
= gfc_get_symbol_decl (sym
);
1223 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1224 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1228 if (!sym
->backend_decl
)
1229 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1231 tmp
= sym
->backend_decl
;
1232 if (sym
->attr
.cray_pointee
)
1233 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1234 gfc_get_symbol_decl (sym
->cp_pointer
));
1235 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1237 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1238 tmp
= build_fold_addr_expr (tmp
);
1245 /* Initialize MAPPING. */
1248 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1250 mapping
->syms
= NULL
;
1251 mapping
->charlens
= NULL
;
1255 /* Free all memory held by MAPPING (but not MAPPING itself). */
1258 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1260 gfc_interface_sym_mapping
*sym
;
1261 gfc_interface_sym_mapping
*nextsym
;
1263 gfc_charlen
*nextcl
;
1265 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1267 nextsym
= sym
->next
;
1268 gfc_free_symbol (sym
->new->n
.sym
);
1269 gfc_free (sym
->new);
1272 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1275 gfc_free_expr (cl
->length
);
1281 /* Return a copy of gfc_charlen CL. Add the returned structure to
1282 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1284 static gfc_charlen
*
1285 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1290 new = gfc_get_charlen ();
1291 new->next
= mapping
->charlens
;
1292 new->length
= gfc_copy_expr (cl
->length
);
1294 mapping
->charlens
= new;
1299 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1300 array variable that can be used as the actual argument for dummy
1301 argument SYM. Add any initialization code to BLOCK. PACKED is as
1302 for gfc_get_nodesc_array_type and DATA points to the first element
1303 in the passed array. */
1306 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1307 int packed
, tree data
)
1312 type
= gfc_typenode_for_spec (&sym
->ts
);
1313 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1315 var
= gfc_create_var (type
, "ifm");
1316 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1322 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1323 and offset of descriptorless array type TYPE given that it has the same
1324 size as DESC. Add any set-up code to BLOCK. */
1327 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1334 offset
= gfc_index_zero_node
;
1335 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1337 dim
= gfc_rank_cst
[n
];
1338 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1339 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1341 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1342 = gfc_conv_descriptor_lbound (desc
, dim
);
1343 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1344 = gfc_conv_descriptor_ubound (desc
, dim
);
1346 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1348 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1349 gfc_conv_descriptor_ubound (desc
, dim
),
1350 gfc_conv_descriptor_lbound (desc
, dim
));
1351 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1352 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1354 tmp
= gfc_evaluate_now (tmp
, block
);
1355 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1357 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1358 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1359 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1360 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1362 offset
= gfc_evaluate_now (offset
, block
);
1363 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1367 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1368 in SE. The caller may still use se->expr and se->string_length after
1369 calling this function. */
1372 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1373 gfc_symbol
* sym
, gfc_se
* se
)
1375 gfc_interface_sym_mapping
*sm
;
1379 gfc_symbol
*new_sym
;
1381 gfc_symtree
*new_symtree
;
1383 /* Create a new symbol to represent the actual argument. */
1384 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1385 new_sym
->ts
= sym
->ts
;
1386 new_sym
->attr
.referenced
= 1;
1387 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1388 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1389 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1390 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1392 /* Create a fake symtree for it. */
1394 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1395 new_symtree
->n
.sym
= new_sym
;
1396 gcc_assert (new_symtree
== root
);
1398 /* Create a dummy->actual mapping. */
1399 sm
= gfc_getmem (sizeof (*sm
));
1400 sm
->next
= mapping
->syms
;
1402 sm
->new = new_symtree
;
1405 /* Stabilize the argument's value. */
1406 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1408 if (sym
->ts
.type
== BT_CHARACTER
)
1410 /* Create a copy of the dummy argument's length. */
1411 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1413 /* If the length is specified as "*", record the length that
1414 the caller is passing. We should use the callee's length
1415 in all other cases. */
1416 if (!new_sym
->ts
.cl
->length
)
1418 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1419 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1423 /* Use the passed value as-is if the argument is a function. */
1424 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1427 /* If the argument is either a string or a pointer to a string,
1428 convert it to a boundless character type. */
1429 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1431 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1432 tmp
= build_pointer_type (tmp
);
1433 if (sym
->attr
.pointer
)
1434 value
= build_fold_indirect_ref (se
->expr
);
1437 value
= fold_convert (tmp
, value
);
1440 /* If the argument is a scalar, a pointer to an array or an allocatable,
1442 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1443 value
= build_fold_indirect_ref (se
->expr
);
1445 /* For character(*), use the actual argument's descriptor. */
1446 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1447 value
= build_fold_indirect_ref (se
->expr
);
1449 /* If the argument is an array descriptor, use it to determine
1450 information about the actual argument's shape. */
1451 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1452 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1454 /* Get the actual argument's descriptor. */
1455 desc
= build_fold_indirect_ref (se
->expr
);
1457 /* Create the replacement variable. */
1458 tmp
= gfc_conv_descriptor_data_get (desc
);
1459 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1461 /* Use DESC to work out the upper bounds, strides and offset. */
1462 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1465 /* Otherwise we have a packed array. */
1466 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1468 new_sym
->backend_decl
= value
;
1472 /* Called once all dummy argument mappings have been added to MAPPING,
1473 but before the mapping is used to evaluate expressions. Pre-evaluate
1474 the length of each argument, adding any initialization code to PRE and
1475 any finalization code to POST. */
1478 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1479 stmtblock_t
* pre
, stmtblock_t
* post
)
1481 gfc_interface_sym_mapping
*sym
;
1485 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1486 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1487 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1489 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1490 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1491 gfc_init_se (&se
, NULL
);
1492 gfc_conv_expr (&se
, expr
);
1494 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1495 gfc_add_block_to_block (pre
, &se
.pre
);
1496 gfc_add_block_to_block (post
, &se
.post
);
1498 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1503 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1507 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1508 gfc_constructor
* c
)
1510 for (; c
; c
= c
->next
)
1512 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1515 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1516 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1517 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1523 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1527 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1532 for (; ref
; ref
= ref
->next
)
1536 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1538 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1539 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1540 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1542 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1549 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1550 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1556 /* EXPR is a copy of an expression that appeared in the interface
1557 associated with MAPPING. Walk it recursively looking for references to
1558 dummy arguments that MAPPING maps to actual arguments. Replace each such
1559 reference with a reference to the associated actual argument. */
1562 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1565 gfc_interface_sym_mapping
*sym
;
1566 gfc_actual_arglist
*actual
;
1571 /* Copying an expression does not copy its length, so do that here. */
1572 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1574 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1575 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1578 /* Apply the mapping to any references. */
1579 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1581 /* ...and to the expression's symbol, if it has one. */
1583 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1584 if (sym
->old
== expr
->symtree
->n
.sym
)
1585 expr
->symtree
= sym
->new;
1587 /* ...and to subexpressions in expr->value. */
1588 switch (expr
->expr_type
)
1593 case EXPR_SUBSTRING
:
1597 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1598 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1602 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1603 if (sym
->old
== expr
->value
.function
.esym
)
1604 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1606 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1607 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1611 case EXPR_STRUCTURE
:
1612 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1618 /* Evaluate interface expression EXPR using MAPPING. Store the result
1622 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1623 gfc_se
* se
, gfc_expr
* expr
)
1625 expr
= gfc_copy_expr (expr
);
1626 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1627 gfc_conv_expr (se
, expr
);
1628 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1629 gfc_free_expr (expr
);
1632 /* Returns a reference to a temporary array into which a component of
1633 an actual argument derived type array is copied and then returned
1634 after the function call.
1635 TODO Get rid of this kludge, when array descriptors are capable of
1636 handling aliased arrays. */
1639 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1640 int g77
, sym_intent intent
)
1656 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1658 gfc_init_se (&lse
, NULL
);
1659 gfc_init_se (&rse
, NULL
);
1661 /* Walk the argument expression. */
1662 rss
= gfc_walk_expr (expr
);
1664 gcc_assert (rss
!= gfc_ss_terminator
);
1666 /* Initialize the scalarizer. */
1667 gfc_init_loopinfo (&loop
);
1668 gfc_add_ss_to_loop (&loop
, rss
);
1670 /* Calculate the bounds of the scalarization. */
1671 gfc_conv_ss_startstride (&loop
);
1673 /* Build an ss for the temporary. */
1674 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1675 if (GFC_ARRAY_TYPE_P (base_type
)
1676 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1677 base_type
= gfc_get_element_type (base_type
);
1679 loop
.temp_ss
= gfc_get_ss ();;
1680 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1681 loop
.temp_ss
->data
.temp
.type
= base_type
;
1683 if (expr
->ts
.type
== BT_CHARACTER
)
1685 gfc_ref
*char_ref
= expr
->ref
;
1687 for (; expr
->ts
.cl
== NULL
&& char_ref
; char_ref
= char_ref
->next
)
1688 if (char_ref
->type
== REF_SUBSTRING
)
1692 expr
->ts
.cl
= gfc_get_charlen ();
1693 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1694 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1696 gfc_init_se (&tmp_se
, NULL
);
1697 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1698 gfc_array_index_type
);
1699 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1700 tmp_se
.expr
, gfc_index_one_node
);
1701 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1702 gfc_init_se (&tmp_se
, NULL
);
1703 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1704 gfc_array_index_type
);
1705 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1707 expr
->ts
.cl
->backend_decl
= tmp
;
1711 loop
.temp_ss
->data
.temp
.type
1712 = gfc_typenode_for_spec (&expr
->ts
);
1713 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1716 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1717 loop
.temp_ss
->next
= gfc_ss_terminator
;
1719 /* Associate the SS with the loop. */
1720 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1722 /* Setup the scalarizing loops. */
1723 gfc_conv_loop_setup (&loop
);
1725 /* Pass the temporary descriptor back to the caller. */
1726 info
= &loop
.temp_ss
->data
.info
;
1727 parmse
->expr
= info
->descriptor
;
1729 /* Setup the gfc_se structures. */
1730 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1731 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1734 lse
.ss
= loop
.temp_ss
;
1735 gfc_mark_ss_chain_used (rss
, 1);
1736 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1738 /* Start the scalarized loop body. */
1739 gfc_start_scalarized_body (&loop
, &body
);
1741 /* Translate the expression. */
1742 gfc_conv_expr (&rse
, expr
);
1744 gfc_conv_tmp_array_ref (&lse
);
1745 gfc_advance_se_ss_chain (&lse
);
1747 if (intent
!= INTENT_OUT
)
1749 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1750 gfc_add_expr_to_block (&body
, tmp
);
1751 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1752 gfc_trans_scalarizing_loops (&loop
, &body
);
1756 /* Make sure that the temporary declaration survives by merging
1757 all the loop declarations into the current context. */
1758 for (n
= 0; n
< loop
.dimen
; n
++)
1760 gfc_merge_block_scope (&body
);
1761 body
= loop
.code
[loop
.order
[n
]];
1763 gfc_merge_block_scope (&body
);
1766 /* Add the post block after the second loop, so that any
1767 freeing of allocated memory is done at the right time. */
1768 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1770 /**********Copy the temporary back again.*********/
1772 gfc_init_se (&lse
, NULL
);
1773 gfc_init_se (&rse
, NULL
);
1775 /* Walk the argument expression. */
1776 lss
= gfc_walk_expr (expr
);
1777 rse
.ss
= loop
.temp_ss
;
1780 /* Initialize the scalarizer. */
1781 gfc_init_loopinfo (&loop2
);
1782 gfc_add_ss_to_loop (&loop2
, lss
);
1784 /* Calculate the bounds of the scalarization. */
1785 gfc_conv_ss_startstride (&loop2
);
1787 /* Setup the scalarizing loops. */
1788 gfc_conv_loop_setup (&loop2
);
1790 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1791 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1793 gfc_mark_ss_chain_used (lss
, 1);
1794 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1796 /* Declare the variable to hold the temporary offset and start the
1797 scalarized loop body. */
1798 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1799 gfc_start_scalarized_body (&loop2
, &body
);
1801 /* Build the offsets for the temporary from the loop variables. The
1802 temporary array has lbounds of zero and strides of one in all
1803 dimensions, so this is very simple. The offset is only computed
1804 outside the innermost loop, so the overall transfer could be
1805 optimized further. */
1806 info
= &rse
.ss
->data
.info
;
1808 tmp_index
= gfc_index_zero_node
;
1809 for (n
= info
->dimen
- 1; n
> 0; n
--)
1812 tmp
= rse
.loop
->loopvar
[n
];
1813 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1814 tmp
, rse
.loop
->from
[n
]);
1815 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1818 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1819 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1820 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1821 tmp_str
, gfc_index_one_node
);
1823 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1827 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1828 tmp_index
, rse
.loop
->from
[0]);
1829 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1831 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1832 rse
.loop
->loopvar
[0], offset
);
1834 /* Now use the offset for the reference. */
1835 tmp
= build_fold_indirect_ref (info
->data
);
1836 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1838 if (expr
->ts
.type
== BT_CHARACTER
)
1839 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1841 gfc_conv_expr (&lse
, expr
);
1843 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1845 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1846 gfc_add_expr_to_block (&body
, tmp
);
1848 /* Generate the copying loops. */
1849 gfc_trans_scalarizing_loops (&loop2
, &body
);
1851 /* Wrap the whole thing up by adding the second loop to the post-block
1852 and following it by the post-block of the first loop. In this way,
1853 if the temporary needs freeing, it is done after use! */
1854 if (intent
!= INTENT_IN
)
1856 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1857 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1860 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1862 gfc_cleanup_loop (&loop
);
1863 gfc_cleanup_loop (&loop2
);
1865 /* Pass the string length to the argument expression. */
1866 if (expr
->ts
.type
== BT_CHARACTER
)
1867 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1869 /* We want either the address for the data or the address of the descriptor,
1870 depending on the mode of passing array arguments. */
1872 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1874 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1879 /* Is true if an array reference is followed by a component or substring
1883 is_aliased_array (gfc_expr
* e
)
1889 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1891 if (ref
->type
== REF_ARRAY
1892 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1896 && ref
->type
!= REF_ARRAY
)
1902 /* Generate code for a procedure call. Note can return se->post != NULL.
1903 If se->direct_byref is set then se->expr contains the return parameter.
1904 Return nonzero, if the call has alternate specifiers. */
1907 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1908 gfc_actual_arglist
* arg
, tree append_args
)
1910 gfc_interface_mapping mapping
;
1924 gfc_formal_arglist
*formal
;
1925 int has_alternate_specifier
= 0;
1926 bool need_interface_mapping
;
1933 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
1935 arglist
= NULL_TREE
;
1936 retargs
= NULL_TREE
;
1937 stringargs
= NULL_TREE
;
1943 if (!sym
->attr
.elemental
)
1945 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1946 if (se
->ss
->useflags
)
1948 gcc_assert (gfc_return_by_reference (sym
)
1949 && sym
->result
->attr
.dimension
);
1950 gcc_assert (se
->loop
!= NULL
);
1952 /* Access the previously obtained result. */
1953 gfc_conv_tmp_array_ref (se
);
1954 gfc_advance_se_ss_chain (se
);
1958 info
= &se
->ss
->data
.info
;
1963 gfc_init_block (&post
);
1964 gfc_init_interface_mapping (&mapping
);
1965 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
1966 && sym
->ts
.cl
->length
1967 && sym
->ts
.cl
->length
->expr_type
1969 || sym
->attr
.dimension
);
1970 formal
= sym
->formal
;
1971 /* Evaluate the arguments. */
1972 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1975 fsym
= formal
? formal
->sym
: NULL
;
1976 parm_kind
= MISSING
;
1980 if (se
->ignore_optional
)
1982 /* Some intrinsics have already been resolved to the correct
1986 else if (arg
->label
)
1988 has_alternate_specifier
= 1;
1993 /* Pass a NULL pointer for an absent arg. */
1994 gfc_init_se (&parmse
, NULL
);
1995 parmse
.expr
= null_pointer_node
;
1996 if (arg
->missing_arg_type
== BT_CHARACTER
)
1997 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2000 else if (se
->ss
&& se
->ss
->useflags
)
2002 /* An elemental function inside a scalarized loop. */
2003 gfc_init_se (&parmse
, se
);
2004 gfc_conv_expr_reference (&parmse
, e
);
2005 parm_kind
= ELEMENTAL
;
2009 /* A scalar or transformational function. */
2010 gfc_init_se (&parmse
, NULL
);
2011 argss
= gfc_walk_expr (e
);
2013 if (argss
== gfc_ss_terminator
)
2016 if (fsym
&& fsym
->attr
.value
)
2018 gfc_conv_expr (&parmse
, e
);
2022 gfc_conv_expr_reference (&parmse
, e
);
2023 if (fsym
&& fsym
->attr
.pointer
2024 && e
->expr_type
!= EXPR_NULL
)
2026 /* Scalar pointer dummy args require an extra level of
2027 indirection. The null pointer already contains
2028 this level of indirection. */
2029 parm_kind
= SCALAR_POINTER
;
2030 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2036 /* If the procedure requires an explicit interface, the actual
2037 argument is passed according to the corresponding formal
2038 argument. If the corresponding formal argument is a POINTER,
2039 ALLOCATABLE or assumed shape, we do not use g77's calling
2040 convention, and pass the address of the array descriptor
2041 instead. Otherwise we use g77's calling convention. */
2044 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2045 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2046 f
= f
|| !sym
->attr
.always_explicit
;
2048 if (e
->expr_type
== EXPR_VARIABLE
2049 && is_aliased_array (e
))
2050 /* The actual argument is a component reference to an
2051 array of derived types. In this case, the argument
2052 is converted to a temporary, which is passed and then
2053 written back after the procedure call. */
2054 gfc_conv_aliased_arg (&parmse
, e
, f
,
2055 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2057 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2059 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2060 allocated on entry, it must be deallocated. */
2061 if (fsym
&& fsym
->attr
.allocatable
2062 && fsym
->attr
.intent
== INTENT_OUT
)
2064 tmp
= e
->symtree
->n
.sym
->backend_decl
;
2065 if (e
->symtree
->n
.sym
->attr
.dummy
)
2066 tmp
= build_fold_indirect_ref (tmp
);
2067 tmp
= gfc_trans_dealloc_allocated (tmp
);
2068 gfc_add_expr_to_block (&se
->pre
, tmp
);
2078 /* If an optional argument is itself an optional dummy
2079 argument, check its presence and substitute a null
2081 if (e
->expr_type
== EXPR_VARIABLE
2082 && e
->symtree
->n
.sym
->attr
.optional
2083 && fsym
->attr
.optional
)
2084 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2086 /* If an INTENT(OUT) dummy of derived type has a default
2087 initializer, it must be (re)initialized here. */
2088 if (fsym
->attr
.intent
== INTENT_OUT
2089 && fsym
->ts
.type
== BT_DERIVED
2092 gcc_assert (!fsym
->attr
.allocatable
);
2093 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2094 gfc_add_expr_to_block (&se
->pre
, tmp
);
2097 /* Obtain the character length of an assumed character
2098 length procedure from the typespec. */
2099 if (fsym
->ts
.type
== BT_CHARACTER
2100 && parmse
.string_length
== NULL_TREE
2101 && e
->ts
.type
== BT_PROCEDURE
2102 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2103 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2105 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2106 parmse
.string_length
2107 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2111 if (need_interface_mapping
)
2112 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2115 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2116 gfc_add_block_to_block (&post
, &parmse
.post
);
2118 /* Allocated allocatable components of derived types must be
2119 deallocated for INTENT(OUT) dummy arguments and non-variable
2120 scalars. Non-variable arrays are dealt with in trans-array.c
2121 (gfc_conv_array_parameter). */
2122 if (e
&& e
->ts
.type
== BT_DERIVED
2123 && e
->ts
.derived
->attr
.alloc_comp
2124 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2126 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2129 tmp
= build_fold_indirect_ref (parmse
.expr
);
2130 parm_rank
= e
->rank
;
2138 case (SCALAR_POINTER
):
2139 tmp
= build_fold_indirect_ref (tmp
);
2146 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2147 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2148 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2149 tmp
, build_empty_stmt ());
2151 if (e
->expr_type
!= EXPR_VARIABLE
)
2152 /* Don't deallocate non-variables until they have been used. */
2153 gfc_add_expr_to_block (&se
->post
, tmp
);
2156 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2157 gfc_add_expr_to_block (&se
->pre
, tmp
);
2161 /* Character strings are passed as two parameters, a length and a
2163 if (parmse
.string_length
!= NULL_TREE
)
2164 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2166 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2168 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2171 if (ts
.type
== BT_CHARACTER
)
2173 if (sym
->ts
.cl
->length
== NULL
)
2175 /* Assumed character length results are not allowed by 5.1.1.5 of the
2176 standard and are trapped in resolve.c; except in the case of SPREAD
2177 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2178 we take the character length of the first argument for the result.
2179 For dummies, we have to look through the formal argument list for
2180 this function and use the character length found there.*/
2181 if (!sym
->attr
.dummy
)
2182 cl
.backend_decl
= TREE_VALUE (stringargs
);
2185 formal
= sym
->ns
->proc_name
->formal
;
2186 for (; formal
; formal
= formal
->next
)
2187 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2188 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2193 /* Calculate the length of the returned string. */
2194 gfc_init_se (&parmse
, NULL
);
2195 if (need_interface_mapping
)
2196 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2198 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2199 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2200 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2201 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2204 /* Set up a charlen structure for it. */
2209 len
= cl
.backend_decl
;
2212 byref
= gfc_return_by_reference (sym
);
2215 if (se
->direct_byref
)
2216 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2217 else if (sym
->result
->attr
.dimension
)
2219 gcc_assert (se
->loop
&& info
);
2221 /* Set the type of the array. */
2222 tmp
= gfc_typenode_for_spec (&ts
);
2223 info
->dimen
= se
->loop
->dimen
;
2225 /* Evaluate the bounds of the result, if known. */
2226 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2228 /* Create a temporary to store the result. In case the function
2229 returns a pointer, the temporary will be a shallow copy and
2230 mustn't be deallocated. */
2231 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2232 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2233 false, !sym
->attr
.pointer
, callee_alloc
,
2236 /* Pass the temporary as the first argument. */
2237 tmp
= info
->descriptor
;
2238 tmp
= build_fold_addr_expr (tmp
);
2239 retargs
= gfc_chainon_list (retargs
, tmp
);
2241 else if (ts
.type
== BT_CHARACTER
)
2243 /* Pass the string length. */
2244 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2245 type
= build_pointer_type (type
);
2247 /* Return an address to a char[0:len-1]* temporary for
2248 character pointers. */
2249 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2251 /* Build char[0:len-1] * pstr. */
2252 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2253 build_int_cst (gfc_charlen_type_node
, 1));
2254 tmp
= build_range_type (gfc_array_index_type
,
2255 gfc_index_zero_node
, tmp
);
2256 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2257 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2259 /* Provide an address expression for the function arguments. */
2260 var
= build_fold_addr_expr (var
);
2263 var
= gfc_conv_string_tmp (se
, type
, len
);
2265 retargs
= gfc_chainon_list (retargs
, var
);
2269 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2271 type
= gfc_get_complex_type (ts
.kind
);
2272 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2273 retargs
= gfc_chainon_list (retargs
, var
);
2276 /* Add the string length to the argument list. */
2277 if (ts
.type
== BT_CHARACTER
)
2278 retargs
= gfc_chainon_list (retargs
, len
);
2280 gfc_free_interface_mapping (&mapping
);
2282 /* Add the return arguments. */
2283 arglist
= chainon (retargs
, arglist
);
2285 /* Add the hidden string length parameters to the arguments. */
2286 arglist
= chainon (arglist
, stringargs
);
2288 /* We may want to append extra arguments here. This is used e.g. for
2289 calls to libgfortran_matmul_??, which need extra information. */
2290 if (append_args
!= NULL_TREE
)
2291 arglist
= chainon (arglist
, append_args
);
2293 /* Generate the actual call. */
2294 gfc_conv_function_val (se
, sym
);
2295 /* If there are alternate return labels, function type should be
2296 integer. Can't modify the type in place though, since it can be shared
2297 with other functions. */
2298 if (has_alternate_specifier
2299 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2301 gcc_assert (! sym
->attr
.dummy
);
2302 TREE_TYPE (sym
->backend_decl
)
2303 = build_function_type (integer_type_node
,
2304 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2305 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2308 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2309 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2310 arglist
, NULL_TREE
);
2312 /* If we have a pointer function, but we don't want a pointer, e.g.
2315 where f is pointer valued, we have to dereference the result. */
2316 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2317 se
->expr
= build_fold_indirect_ref (se
->expr
);
2319 /* f2c calling conventions require a scalar default real function to
2320 return a double precision result. Convert this back to default
2321 real. We only care about the cases that can happen in Fortran 77.
2323 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2324 && sym
->ts
.kind
== gfc_default_real_kind
2325 && !sym
->attr
.always_explicit
)
2326 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2328 /* A pure function may still have side-effects - it may modify its
2330 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2332 if (!sym
->attr
.pure
)
2333 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2338 /* Add the function call to the pre chain. There is no expression. */
2339 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2340 se
->expr
= NULL_TREE
;
2342 if (!se
->direct_byref
)
2344 if (sym
->attr
.dimension
)
2346 if (flag_bounds_check
)
2348 /* Check the data pointer hasn't been modified. This would
2349 happen in a function returning a pointer. */
2350 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2351 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2353 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2355 se
->expr
= info
->descriptor
;
2356 /* Bundle in the string length. */
2357 se
->string_length
= len
;
2359 else if (sym
->ts
.type
== BT_CHARACTER
)
2361 /* Dereference for character pointer results. */
2362 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2363 se
->expr
= build_fold_indirect_ref (var
);
2367 se
->string_length
= len
;
2371 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2372 se
->expr
= build_fold_indirect_ref (var
);
2377 /* Follow the function call with the argument post block. */
2379 gfc_add_block_to_block (&se
->pre
, &post
);
2381 gfc_add_block_to_block (&se
->post
, &post
);
2383 return has_alternate_specifier
;
2387 /* Generate code to copy a string. */
2390 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2391 tree slength
, tree src
)
2393 tree tmp
, dlen
, slen
;
2401 stmtblock_t tempblock
;
2403 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2404 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2406 /* Deal with single character specially. */
2407 dsc
= gfc_to_single_character (dlen
, dest
);
2408 ssc
= gfc_to_single_character (slen
, src
);
2409 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2411 gfc_add_modify_expr (block
, dsc
, ssc
);
2415 /* Do nothing if the destination length is zero. */
2416 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2417 build_int_cst (gfc_charlen_type_node
, 0));
2419 /* The following code was previously in _gfortran_copy_string:
2421 // The two strings may overlap so we use memmove.
2423 copy_string (GFC_INTEGER_4 destlen, char * dest,
2424 GFC_INTEGER_4 srclen, const char * src)
2426 if (srclen >= destlen)
2428 // This will truncate if too long.
2429 memmove (dest, src, destlen);
2433 memmove (dest, src, srclen);
2435 memset (&dest[srclen], ' ', destlen - srclen);
2439 We're now doing it here for better optimization, but the logic
2442 /* Truncate string if source is too long. */
2443 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2444 tmp2
= gfc_chainon_list (NULL_TREE
, dest
);
2445 tmp2
= gfc_chainon_list (tmp2
, src
);
2446 tmp2
= gfc_chainon_list (tmp2
, dlen
);
2447 tmp2
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp2
);
2449 /* Else copy and pad with spaces. */
2450 tmp3
= gfc_chainon_list (NULL_TREE
, dest
);
2451 tmp3
= gfc_chainon_list (tmp3
, src
);
2452 tmp3
= gfc_chainon_list (tmp3
, slen
);
2453 tmp3
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp3
);
2455 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2456 fold_convert (pchar_type_node
, slen
));
2457 tmp4
= gfc_chainon_list (NULL_TREE
, tmp4
);
2458 tmp4
= gfc_chainon_list (tmp4
, build_int_cst
2459 (gfc_get_int_type (gfc_c_int_kind
),
2460 lang_hooks
.to_target_charset (' ')));
2461 tmp4
= gfc_chainon_list (tmp4
, fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2463 tmp4
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], tmp4
);
2465 gfc_init_block (&tempblock
);
2466 gfc_add_expr_to_block (&tempblock
, tmp3
);
2467 gfc_add_expr_to_block (&tempblock
, tmp4
);
2468 tmp3
= gfc_finish_block (&tempblock
);
2470 /* The whole copy_string function is there. */
2471 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2472 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2473 gfc_add_expr_to_block (block
, tmp
);
2477 /* Translate a statement function.
2478 The value of a statement function reference is obtained by evaluating the
2479 expression using the values of the actual arguments for the values of the
2480 corresponding dummy arguments. */
2483 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2487 gfc_formal_arglist
*fargs
;
2488 gfc_actual_arglist
*args
;
2491 gfc_saved_var
*saved_vars
;
2497 sym
= expr
->symtree
->n
.sym
;
2498 args
= expr
->value
.function
.actual
;
2499 gfc_init_se (&lse
, NULL
);
2500 gfc_init_se (&rse
, NULL
);
2503 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2505 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2506 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2508 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2510 /* Each dummy shall be specified, explicitly or implicitly, to be
2512 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2515 /* Create a temporary to hold the value. */
2516 type
= gfc_typenode_for_spec (&fsym
->ts
);
2517 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2519 if (fsym
->ts
.type
== BT_CHARACTER
)
2521 /* Copy string arguments. */
2524 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2525 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2527 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2528 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2531 gfc_conv_expr (&rse
, args
->expr
);
2532 gfc_conv_string_parameter (&rse
);
2533 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2534 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2536 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2538 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2539 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2543 /* For everything else, just evaluate the expression. */
2544 gfc_conv_expr (&lse
, args
->expr
);
2546 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2547 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2548 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2554 /* Use the temporary variables in place of the real ones. */
2555 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2556 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2558 gfc_conv_expr (se
, sym
->value
);
2560 if (sym
->ts
.type
== BT_CHARACTER
)
2562 gfc_conv_const_charlen (sym
->ts
.cl
);
2564 /* Force the expression to the correct length. */
2565 if (!INTEGER_CST_P (se
->string_length
)
2566 || tree_int_cst_lt (se
->string_length
,
2567 sym
->ts
.cl
->backend_decl
))
2569 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2570 tmp
= gfc_create_var (type
, sym
->name
);
2571 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2572 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2573 se
->string_length
, se
->expr
);
2576 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2579 /* Restore the original variables. */
2580 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2581 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2582 gfc_free (saved_vars
);
2586 /* Translate a function expression. */
2589 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2593 if (expr
->value
.function
.isym
)
2595 gfc_conv_intrinsic_function (se
, expr
);
2599 /* We distinguish statement functions from general functions to improve
2600 runtime performance. */
2601 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2603 gfc_conv_statement_function (se
, expr
);
2607 /* expr.value.function.esym is the resolved (specific) function symbol for
2608 most functions. However this isn't set for dummy procedures. */
2609 sym
= expr
->value
.function
.esym
;
2611 sym
= expr
->symtree
->n
.sym
;
2612 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2617 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2619 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2620 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2622 gfc_conv_tmp_array_ref (se
);
2623 gfc_advance_se_ss_chain (se
);
2627 /* Build a static initializer. EXPR is the expression for the initial value.
2628 The other parameters describe the variable of the component being
2629 initialized. EXPR may be null. */
2632 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2633 bool array
, bool pointer
)
2637 if (!(expr
|| pointer
))
2642 /* Arrays need special handling. */
2644 return gfc_build_null_descriptor (type
);
2646 return gfc_conv_array_initializer (type
, expr
);
2649 return fold_convert (type
, null_pointer_node
);
2655 gfc_init_se (&se
, NULL
);
2656 gfc_conv_structure (&se
, expr
, 1);
2660 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2663 gfc_init_se (&se
, NULL
);
2664 gfc_conv_constant (&se
, expr
);
2671 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2683 gfc_start_block (&block
);
2685 /* Initialize the scalarizer. */
2686 gfc_init_loopinfo (&loop
);
2688 gfc_init_se (&lse
, NULL
);
2689 gfc_init_se (&rse
, NULL
);
2692 rss
= gfc_walk_expr (expr
);
2693 if (rss
== gfc_ss_terminator
)
2695 /* The rhs is scalar. Add a ss for the expression. */
2696 rss
= gfc_get_ss ();
2697 rss
->next
= gfc_ss_terminator
;
2698 rss
->type
= GFC_SS_SCALAR
;
2702 /* Create a SS for the destination. */
2703 lss
= gfc_get_ss ();
2704 lss
->type
= GFC_SS_COMPONENT
;
2706 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2707 lss
->next
= gfc_ss_terminator
;
2708 lss
->data
.info
.dimen
= cm
->as
->rank
;
2709 lss
->data
.info
.descriptor
= dest
;
2710 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2711 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2712 for (n
= 0; n
< cm
->as
->rank
; n
++)
2714 lss
->data
.info
.dim
[n
] = n
;
2715 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2716 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2718 mpz_init (lss
->shape
[n
]);
2719 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2720 cm
->as
->lower
[n
]->value
.integer
);
2721 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2724 /* Associate the SS with the loop. */
2725 gfc_add_ss_to_loop (&loop
, lss
);
2726 gfc_add_ss_to_loop (&loop
, rss
);
2728 /* Calculate the bounds of the scalarization. */
2729 gfc_conv_ss_startstride (&loop
);
2731 /* Setup the scalarizing loops. */
2732 gfc_conv_loop_setup (&loop
);
2734 /* Setup the gfc_se structures. */
2735 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2736 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2739 gfc_mark_ss_chain_used (rss
, 1);
2741 gfc_mark_ss_chain_used (lss
, 1);
2743 /* Start the scalarized loop body. */
2744 gfc_start_scalarized_body (&loop
, &body
);
2746 gfc_conv_tmp_array_ref (&lse
);
2747 if (cm
->ts
.type
== BT_CHARACTER
)
2748 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2750 gfc_conv_expr (&rse
, expr
);
2752 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2753 gfc_add_expr_to_block (&body
, tmp
);
2755 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2757 /* Generate the copying loops. */
2758 gfc_trans_scalarizing_loops (&loop
, &body
);
2760 /* Wrap the whole thing up. */
2761 gfc_add_block_to_block (&block
, &loop
.pre
);
2762 gfc_add_block_to_block (&block
, &loop
.post
);
2764 for (n
= 0; n
< cm
->as
->rank
; n
++)
2765 mpz_clear (lss
->shape
[n
]);
2766 gfc_free (lss
->shape
);
2768 gfc_cleanup_loop (&loop
);
2770 return gfc_finish_block (&block
);
2774 /* Assign a single component of a derived type constructor. */
2777 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2787 gfc_start_block (&block
);
2791 gfc_init_se (&se
, NULL
);
2792 /* Pointer component. */
2795 /* Array pointer. */
2796 if (expr
->expr_type
== EXPR_NULL
)
2797 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2800 rss
= gfc_walk_expr (expr
);
2801 se
.direct_byref
= 1;
2803 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2804 gfc_add_block_to_block (&block
, &se
.pre
);
2805 gfc_add_block_to_block (&block
, &se
.post
);
2810 /* Scalar pointers. */
2811 se
.want_pointer
= 1;
2812 gfc_conv_expr (&se
, expr
);
2813 gfc_add_block_to_block (&block
, &se
.pre
);
2814 gfc_add_modify_expr (&block
, dest
,
2815 fold_convert (TREE_TYPE (dest
), se
.expr
));
2816 gfc_add_block_to_block (&block
, &se
.post
);
2819 else if (cm
->dimension
)
2821 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2822 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2823 else if (cm
->allocatable
)
2827 gfc_init_se (&se
, NULL
);
2829 rss
= gfc_walk_expr (expr
);
2830 se
.want_pointer
= 0;
2831 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2832 gfc_add_block_to_block (&block
, &se
.pre
);
2834 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2835 gfc_add_modify_expr (&block
, dest
, tmp
);
2837 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2838 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2841 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2842 TREE_TYPE(cm
->backend_decl
),
2845 gfc_add_expr_to_block (&block
, tmp
);
2847 gfc_add_block_to_block (&block
, &se
.post
);
2848 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2850 /* Shift the lbound and ubound of temporaries to being unity, rather
2851 than zero, based. Calculate the offset for all cases. */
2852 offset
= gfc_conv_descriptor_offset (dest
);
2853 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2854 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2855 for (n
= 0; n
< expr
->rank
; n
++)
2857 if (expr
->expr_type
!= EXPR_VARIABLE
2858 && expr
->expr_type
!= EXPR_CONSTANT
)
2860 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2861 gfc_add_modify_expr (&block
, tmp
,
2862 fold_build2 (PLUS_EXPR
,
2863 gfc_array_index_type
,
2864 tmp
, gfc_index_one_node
));
2865 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2866 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2868 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2869 gfc_conv_descriptor_lbound (dest
,
2871 gfc_conv_descriptor_stride (dest
,
2873 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2874 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2875 gfc_add_modify_expr (&block
, offset
, tmp
);
2880 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2881 gfc_add_expr_to_block (&block
, tmp
);
2884 else if (expr
->ts
.type
== BT_DERIVED
)
2886 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2888 gfc_init_se (&se
, NULL
);
2889 gfc_conv_expr (&se
, expr
);
2890 gfc_add_modify_expr (&block
, dest
,
2891 fold_convert (TREE_TYPE (dest
), se
.expr
));
2895 /* Nested constructors. */
2896 tmp
= gfc_trans_structure_assign (dest
, expr
);
2897 gfc_add_expr_to_block (&block
, tmp
);
2902 /* Scalar component. */
2903 gfc_init_se (&se
, NULL
);
2904 gfc_init_se (&lse
, NULL
);
2906 gfc_conv_expr (&se
, expr
);
2907 if (cm
->ts
.type
== BT_CHARACTER
)
2908 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2910 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
2911 gfc_add_expr_to_block (&block
, tmp
);
2913 return gfc_finish_block (&block
);
2916 /* Assign a derived type constructor to a variable. */
2919 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2927 gfc_start_block (&block
);
2928 cm
= expr
->ts
.derived
->components
;
2929 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2931 /* Skip absent members in default initializers. */
2935 field
= cm
->backend_decl
;
2936 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
2937 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
2938 gfc_add_expr_to_block (&block
, tmp
);
2940 return gfc_finish_block (&block
);
2943 /* Build an expression for a constructor. If init is nonzero then
2944 this is part of a static variable initializer. */
2947 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
2954 VEC(constructor_elt
,gc
) *v
= NULL
;
2956 gcc_assert (se
->ss
== NULL
);
2957 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
2958 type
= gfc_typenode_for_spec (&expr
->ts
);
2962 /* Create a temporary variable and fill it in. */
2963 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
2964 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
2965 gfc_add_expr_to_block (&se
->pre
, tmp
);
2969 cm
= expr
->ts
.derived
->components
;
2971 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2973 /* Skip absent members in default initializers and allocatable
2974 components. Although the latter have a default initializer
2975 of EXPR_NULL,... by default, the static nullify is not needed
2976 since this is done every time we come into scope. */
2977 if (!c
->expr
|| cm
->allocatable
)
2980 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
2981 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
2983 /* Append it to the constructor list. */
2984 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
2986 se
->expr
= build_constructor (type
, v
);
2990 /* Translate a substring expression. */
2993 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
2999 gcc_assert (ref
->type
== REF_SUBSTRING
);
3001 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3002 expr
->value
.character
.string
);
3003 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3004 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3006 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3010 /* Entry point for expression translation. Evaluates a scalar quantity.
3011 EXPR is the expression to be translated, and SE is the state structure if
3012 called from within the scalarized. */
3015 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3017 if (se
->ss
&& se
->ss
->expr
== expr
3018 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3020 /* Substitute a scalar expression evaluated outside the scalarization
3022 se
->expr
= se
->ss
->data
.scalar
.expr
;
3023 se
->string_length
= se
->ss
->string_length
;
3024 gfc_advance_se_ss_chain (se
);
3028 switch (expr
->expr_type
)
3031 gfc_conv_expr_op (se
, expr
);
3035 gfc_conv_function_expr (se
, expr
);
3039 gfc_conv_constant (se
, expr
);
3043 gfc_conv_variable (se
, expr
);
3047 se
->expr
= null_pointer_node
;
3050 case EXPR_SUBSTRING
:
3051 gfc_conv_substring_expr (se
, expr
);
3054 case EXPR_STRUCTURE
:
3055 gfc_conv_structure (se
, expr
, 0);
3059 gfc_conv_array_constructor_expr (se
, expr
);
3068 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3069 of an assignment. */
3071 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3073 gfc_conv_expr (se
, expr
);
3074 /* All numeric lvalues should have empty post chains. If not we need to
3075 figure out a way of rewriting an lvalue so that it has no post chain. */
3076 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3079 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3080 numeric expressions. Used for scalar values where inserting cleanup code
3083 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3087 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3088 gfc_conv_expr (se
, expr
);
3091 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3092 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3094 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3098 /* Helper to translate and expression and convert it to a particular type. */
3100 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3102 gfc_conv_expr_val (se
, expr
);
3103 se
->expr
= convert (type
, se
->expr
);
3107 /* Converts an expression so that it can be passed by reference. Scalar
3111 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3115 if (se
->ss
&& se
->ss
->expr
== expr
3116 && se
->ss
->type
== GFC_SS_REFERENCE
)
3118 se
->expr
= se
->ss
->data
.scalar
.expr
;
3119 se
->string_length
= se
->ss
->string_length
;
3120 gfc_advance_se_ss_chain (se
);
3124 if (expr
->ts
.type
== BT_CHARACTER
)
3126 gfc_conv_expr (se
, expr
);
3127 gfc_conv_string_parameter (se
);
3131 if (expr
->expr_type
== EXPR_VARIABLE
)
3133 se
->want_pointer
= 1;
3134 gfc_conv_expr (se
, expr
);
3137 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3138 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3139 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3145 gfc_conv_expr (se
, expr
);
3147 /* Create a temporary var to hold the value. */
3148 if (TREE_CONSTANT (se
->expr
))
3150 tree tmp
= se
->expr
;
3151 STRIP_TYPE_NOPS (tmp
);
3152 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3153 DECL_INITIAL (var
) = tmp
;
3154 TREE_STATIC (var
) = 1;
3159 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3160 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3162 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3164 /* Take the address of that value. */
3165 se
->expr
= build_fold_addr_expr (var
);
3170 gfc_trans_pointer_assign (gfc_code
* code
)
3172 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3176 /* Generate code for a pointer assignment. */
3179 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3189 gfc_start_block (&block
);
3191 gfc_init_se (&lse
, NULL
);
3193 lss
= gfc_walk_expr (expr1
);
3194 rss
= gfc_walk_expr (expr2
);
3195 if (lss
== gfc_ss_terminator
)
3197 /* Scalar pointers. */
3198 lse
.want_pointer
= 1;
3199 gfc_conv_expr (&lse
, expr1
);
3200 gcc_assert (rss
== gfc_ss_terminator
);
3201 gfc_init_se (&rse
, NULL
);
3202 rse
.want_pointer
= 1;
3203 gfc_conv_expr (&rse
, expr2
);
3204 gfc_add_block_to_block (&block
, &lse
.pre
);
3205 gfc_add_block_to_block (&block
, &rse
.pre
);
3206 gfc_add_modify_expr (&block
, lse
.expr
,
3207 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3208 gfc_add_block_to_block (&block
, &rse
.post
);
3209 gfc_add_block_to_block (&block
, &lse
.post
);
3213 /* Array pointer. */
3214 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3215 switch (expr2
->expr_type
)
3218 /* Just set the data pointer to null. */
3219 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3223 /* Assign directly to the pointer's descriptor. */
3224 lse
.direct_byref
= 1;
3225 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3229 /* Assign to a temporary descriptor and then copy that
3230 temporary to the pointer. */
3232 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3235 lse
.direct_byref
= 1;
3236 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3237 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3240 gfc_add_block_to_block (&block
, &lse
.pre
);
3241 gfc_add_block_to_block (&block
, &lse
.post
);
3243 return gfc_finish_block (&block
);
3247 /* Makes sure se is suitable for passing as a function string parameter. */
3248 /* TODO: Need to check all callers fo this function. It may be abused. */
3251 gfc_conv_string_parameter (gfc_se
* se
)
3255 if (TREE_CODE (se
->expr
) == STRING_CST
)
3257 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3261 type
= TREE_TYPE (se
->expr
);
3262 if (TYPE_STRING_FLAG (type
))
3264 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3265 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3268 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3269 gcc_assert (se
->string_length
3270 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3274 /* Generate code for assignment of scalar variables. Includes character
3275 strings and derived types with allocatable components. */
3278 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3279 bool l_is_temp
, bool r_is_var
)
3285 gfc_init_block (&block
);
3287 if (ts
.type
== BT_CHARACTER
)
3289 gcc_assert (lse
->string_length
!= NULL_TREE
3290 && rse
->string_length
!= NULL_TREE
);
3292 gfc_conv_string_parameter (lse
);
3293 gfc_conv_string_parameter (rse
);
3295 gfc_add_block_to_block (&block
, &lse
->pre
);
3296 gfc_add_block_to_block (&block
, &rse
->pre
);
3298 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3299 rse
->string_length
, rse
->expr
);
3301 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3305 /* Are the rhs and the lhs the same? */
3308 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3309 build_fold_addr_expr (lse
->expr
),
3310 build_fold_addr_expr (rse
->expr
));
3311 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3314 /* Deallocate the lhs allocated components as long as it is not
3315 the same as the rhs. */
3318 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3320 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3321 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3324 gfc_add_block_to_block (&block
, &lse
->pre
);
3325 gfc_add_block_to_block (&block
, &rse
->pre
);
3327 gfc_add_modify_expr (&block
, lse
->expr
,
3328 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3330 /* Do a deep copy if the rhs is a variable, if it is not the
3334 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3335 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3336 gfc_add_expr_to_block (&block
, tmp
);
3341 gfc_add_block_to_block (&block
, &lse
->pre
);
3342 gfc_add_block_to_block (&block
, &rse
->pre
);
3344 gfc_add_modify_expr (&block
, lse
->expr
,
3345 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3348 gfc_add_block_to_block (&block
, &lse
->post
);
3349 gfc_add_block_to_block (&block
, &rse
->post
);
3351 return gfc_finish_block (&block
);
3355 /* Try to translate array(:) = func (...), where func is a transformational
3356 array function, without using a temporary. Returns NULL is this isn't the
3360 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3365 bool seen_array_ref
;
3367 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3368 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3371 /* Elemental functions don't need a temporary anyway. */
3372 if (expr2
->value
.function
.esym
!= NULL
3373 && expr2
->value
.function
.esym
->attr
.elemental
)
3376 /* Fail if EXPR1 can't be expressed as a descriptor. */
3377 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3380 /* Functions returning pointers need temporaries. */
3381 if (expr2
->symtree
->n
.sym
->attr
.pointer
3382 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3385 /* Check that no LHS component references appear during an array
3386 reference. This is needed because we do not have the means to
3387 span any arbitrary stride with an array descriptor. This check
3388 is not needed for the rhs because the function result has to be
3390 seen_array_ref
= false;
3391 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3393 if (ref
->type
== REF_ARRAY
)
3394 seen_array_ref
= true;
3395 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3399 /* Check for a dependency. */
3400 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3401 expr2
->value
.function
.esym
,
3402 expr2
->value
.function
.actual
))
3405 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3407 gcc_assert (expr2
->value
.function
.isym
3408 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3409 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3411 ss
= gfc_walk_expr (expr1
);
3412 gcc_assert (ss
!= gfc_ss_terminator
);
3413 gfc_init_se (&se
, NULL
);
3414 gfc_start_block (&se
.pre
);
3415 se
.want_pointer
= 1;
3417 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3419 se
.direct_byref
= 1;
3420 se
.ss
= gfc_walk_expr (expr2
);
3421 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3422 gfc_conv_function_expr (&se
, expr2
);
3423 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3425 return gfc_finish_block (&se
.pre
);
3429 /* Translate an assignment. Most of the code is concerned with
3430 setting up the scalarizer. */
3433 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3438 gfc_ss
*lss_section
;
3446 /* Special case a single function returning an array. */
3447 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3449 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3454 /* Assignment of the form lhs = rhs. */
3455 gfc_start_block (&block
);
3457 gfc_init_se (&lse
, NULL
);
3458 gfc_init_se (&rse
, NULL
);
3461 lss
= gfc_walk_expr (expr1
);
3463 if (lss
!= gfc_ss_terminator
)
3465 /* The assignment needs scalarization. */
3468 /* Find a non-scalar SS from the lhs. */
3469 while (lss_section
!= gfc_ss_terminator
3470 && lss_section
->type
!= GFC_SS_SECTION
)
3471 lss_section
= lss_section
->next
;
3473 gcc_assert (lss_section
!= gfc_ss_terminator
);
3475 /* Initialize the scalarizer. */
3476 gfc_init_loopinfo (&loop
);
3479 rss
= gfc_walk_expr (expr2
);
3480 if (rss
== gfc_ss_terminator
)
3482 /* The rhs is scalar. Add a ss for the expression. */
3483 rss
= gfc_get_ss ();
3484 rss
->next
= gfc_ss_terminator
;
3485 rss
->type
= GFC_SS_SCALAR
;
3488 /* Associate the SS with the loop. */
3489 gfc_add_ss_to_loop (&loop
, lss
);
3490 gfc_add_ss_to_loop (&loop
, rss
);
3492 /* Calculate the bounds of the scalarization. */
3493 gfc_conv_ss_startstride (&loop
);
3494 /* Resolve any data dependencies in the statement. */
3495 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3496 /* Setup the scalarizing loops. */
3497 gfc_conv_loop_setup (&loop
);
3499 /* Setup the gfc_se structures. */
3500 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3501 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3504 gfc_mark_ss_chain_used (rss
, 1);
3505 if (loop
.temp_ss
== NULL
)
3508 gfc_mark_ss_chain_used (lss
, 1);
3512 lse
.ss
= loop
.temp_ss
;
3513 gfc_mark_ss_chain_used (lss
, 3);
3514 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3517 /* Start the scalarized loop body. */
3518 gfc_start_scalarized_body (&loop
, &body
);
3521 gfc_init_block (&body
);
3523 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3525 /* Translate the expression. */
3526 gfc_conv_expr (&rse
, expr2
);
3530 gfc_conv_tmp_array_ref (&lse
);
3531 gfc_advance_se_ss_chain (&lse
);
3534 gfc_conv_expr (&lse
, expr1
);
3536 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3537 l_is_temp
|| init_flag
,
3538 expr2
->expr_type
== EXPR_VARIABLE
);
3539 gfc_add_expr_to_block (&body
, tmp
);
3541 if (lss
== gfc_ss_terminator
)
3543 /* Use the scalar assignment as is. */
3544 gfc_add_block_to_block (&block
, &body
);
3548 gcc_assert (lse
.ss
== gfc_ss_terminator
3549 && rse
.ss
== gfc_ss_terminator
);
3553 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3555 /* We need to copy the temporary to the actual lhs. */
3556 gfc_init_se (&lse
, NULL
);
3557 gfc_init_se (&rse
, NULL
);
3558 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3559 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3561 rse
.ss
= loop
.temp_ss
;
3564 gfc_conv_tmp_array_ref (&rse
);
3565 gfc_advance_se_ss_chain (&rse
);
3566 gfc_conv_expr (&lse
, expr1
);
3568 gcc_assert (lse
.ss
== gfc_ss_terminator
3569 && rse
.ss
== gfc_ss_terminator
);
3571 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3573 gfc_add_expr_to_block (&body
, tmp
);
3576 /* Generate the copying loops. */
3577 gfc_trans_scalarizing_loops (&loop
, &body
);
3579 /* Wrap the whole thing up. */
3580 gfc_add_block_to_block (&block
, &loop
.pre
);
3581 gfc_add_block_to_block (&block
, &loop
.post
);
3583 gfc_cleanup_loop (&loop
);
3586 return gfc_finish_block (&block
);
3590 gfc_trans_init_assign (gfc_code
* code
)
3592 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3596 gfc_trans_assign (gfc_code
* code
)
3598 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);