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
);
460 /* Dereference non-character scalar dummy arguments. */
461 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
462 se
->expr
= build_fold_indirect_ref (se
->expr
);
464 /* Dereference scalar hidden result. */
465 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
466 && (sym
->attr
.function
|| sym
->attr
.result
)
467 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
468 se
->expr
= build_fold_indirect_ref (se
->expr
);
470 /* Dereference non-character pointer variables.
471 These must be dummies, results, or scalars. */
472 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
474 || sym
->attr
.function
476 || !sym
->attr
.dimension
))
477 se
->expr
= build_fold_indirect_ref (se
->expr
);
483 /* For character variables, also get the length. */
484 if (sym
->ts
.type
== BT_CHARACTER
)
486 /* If the character length of an entry isn't set, get the length from
487 the master function instead. */
488 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
489 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
491 se
->string_length
= sym
->ts
.cl
->backend_decl
;
492 gcc_assert (se
->string_length
);
500 /* Return the descriptor if that's what we want and this is an array
501 section reference. */
502 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
504 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
505 /* Return the descriptor for array pointers and allocations. */
507 && ref
->next
== NULL
&& (se
->descriptor_only
))
510 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
511 /* Return a pointer to an element. */
515 gfc_conv_component_ref (se
, ref
);
519 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
520 expr
->symtree
->name
, &expr
->where
);
529 /* Pointer assignment, allocation or pass by reference. Arrays are handled
531 if (se
->want_pointer
)
533 if (expr
->ts
.type
== BT_CHARACTER
)
534 gfc_conv_string_parameter (se
);
536 se
->expr
= build_fold_addr_expr (se
->expr
);
541 /* Unary ops are easy... Or they would be if ! was a valid op. */
544 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
549 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
550 /* Initialize the operand. */
551 gfc_init_se (&operand
, se
);
552 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
553 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
555 type
= gfc_typenode_for_spec (&expr
->ts
);
557 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
558 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
559 All other unary operators have an equivalent GIMPLE unary operator. */
560 if (code
== TRUTH_NOT_EXPR
)
561 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
562 build_int_cst (type
, 0));
564 se
->expr
= build1 (code
, type
, operand
.expr
);
568 /* Expand power operator to optimal multiplications when a value is raised
569 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
570 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
571 Programming", 3rd Edition, 1998. */
573 /* This code is mostly duplicated from expand_powi in the backend.
574 We establish the "optimal power tree" lookup table with the defined size.
575 The items in the table are the exponents used to calculate the index
576 exponents. Any integer n less than the value can get an "addition chain",
577 with the first node being one. */
578 #define POWI_TABLE_SIZE 256
580 /* The table is from builtins.c. */
581 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
583 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
584 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
585 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
586 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
587 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
588 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
589 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
590 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
591 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
592 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
593 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
594 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
595 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
596 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
597 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
598 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
599 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
600 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
601 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
602 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
603 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
604 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
605 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
606 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
607 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
608 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
609 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
610 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
611 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
612 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
613 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
614 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
617 /* If n is larger than lookup table's max index, we use the "window
619 #define POWI_WINDOW_SIZE 3
621 /* Recursive function to expand the power operator. The temporary
622 values are put in tmpvar. The function returns tmpvar[1] ** n. */
624 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
631 if (n
< POWI_TABLE_SIZE
)
636 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
637 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
641 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
642 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
643 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
647 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
651 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
652 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
654 if (n
< POWI_TABLE_SIZE
)
661 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
662 return 1. Else return 0 and a call to runtime library functions
663 will have to be built. */
665 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
670 tree vartmp
[POWI_TABLE_SIZE
];
674 type
= TREE_TYPE (lhs
);
675 n
= abs (TREE_INT_CST_LOW (rhs
));
676 sgn
= tree_int_cst_sgn (rhs
);
678 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
679 && (n
> 2 || n
< -1))
685 se
->expr
= gfc_build_const (type
, integer_one_node
);
688 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
689 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
691 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
692 build_int_cst (TREE_TYPE (lhs
), -1));
693 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
694 build_int_cst (TREE_TYPE (lhs
), 1));
697 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
700 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
701 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
702 build_int_cst (type
, 0));
706 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
707 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
708 build_int_cst (type
, 0));
709 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
713 memset (vartmp
, 0, sizeof (vartmp
));
717 tmp
= gfc_build_const (type
, integer_one_node
);
718 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
721 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
727 /* Power op (**). Constant integer exponent has special handling. */
730 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
732 tree gfc_int4_type_node
;
740 gfc_init_se (&lse
, se
);
741 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
742 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
743 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
745 gfc_init_se (&rse
, se
);
746 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
747 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
749 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
750 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
751 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
754 gfc_int4_type_node
= gfc_get_int_type (4);
756 kind
= expr
->value
.op
.op1
->ts
.kind
;
757 switch (expr
->value
.op
.op2
->ts
.type
)
760 ikind
= expr
->value
.op
.op2
->ts
.kind
;
765 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
787 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
788 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
813 switch (expr
->value
.op
.op1
->ts
.type
)
816 if (kind
== 3) /* Case 16 was not handled properly above. */
818 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
822 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
826 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
838 fndecl
= built_in_decls
[BUILT_IN_POWF
];
841 fndecl
= built_in_decls
[BUILT_IN_POW
];
845 fndecl
= built_in_decls
[BUILT_IN_POWL
];
856 fndecl
= gfor_fndecl_math_cpowf
;
859 fndecl
= gfor_fndecl_math_cpow
;
862 fndecl
= gfor_fndecl_math_cpowl10
;
865 fndecl
= gfor_fndecl_math_cpowl16
;
877 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
878 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
879 se
->expr
= build_function_call_expr (fndecl
, tmp
);
883 /* Generate code to allocate a string temporary. */
886 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
892 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
894 if (gfc_can_put_var_on_stack (len
))
896 /* Create a temporary variable to hold the result. */
897 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
898 build_int_cst (gfc_charlen_type_node
, 1));
899 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
900 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
901 var
= gfc_create_var (tmp
, "str");
902 var
= gfc_build_addr_expr (type
, var
);
906 /* Allocate a temporary to hold the result. */
907 var
= gfc_create_var (type
, "pstr");
908 args
= gfc_chainon_list (NULL_TREE
, len
);
909 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, args
);
910 tmp
= convert (type
, tmp
);
911 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
913 /* Free the temporary afterwards. */
914 tmp
= convert (pvoid_type_node
, var
);
915 args
= gfc_chainon_list (NULL_TREE
, tmp
);
916 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
917 gfc_add_expr_to_block (&se
->post
, tmp
);
924 /* Handle a string concatenation operation. A temporary will be allocated to
928 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
938 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
939 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
941 gfc_init_se (&lse
, se
);
942 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
943 gfc_conv_string_parameter (&lse
);
944 gfc_init_se (&rse
, se
);
945 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
946 gfc_conv_string_parameter (&rse
);
948 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
949 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
951 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
952 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
953 if (len
== NULL_TREE
)
955 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
956 lse
.string_length
, rse
.string_length
);
959 type
= build_pointer_type (type
);
961 var
= gfc_conv_string_tmp (se
, type
, len
);
963 /* Do the actual concatenation. */
965 args
= gfc_chainon_list (args
, len
);
966 args
= gfc_chainon_list (args
, var
);
967 args
= gfc_chainon_list (args
, lse
.string_length
);
968 args
= gfc_chainon_list (args
, lse
.expr
);
969 args
= gfc_chainon_list (args
, rse
.string_length
);
970 args
= gfc_chainon_list (args
, rse
.expr
);
971 tmp
= build_function_call_expr (gfor_fndecl_concat_string
, args
);
972 gfc_add_expr_to_block (&se
->pre
, tmp
);
974 /* Add the cleanup for the operands. */
975 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
976 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
979 se
->string_length
= len
;
982 /* Translates an op expression. Common (binary) cases are handled by this
983 function, others are passed on. Recursion is used in either case.
984 We use the fact that (op1.ts == op2.ts) (except for the power
986 Operators need no special handling for scalarized expressions as long as
987 they call gfc_conv_simple_val to get their operands.
988 Character strings get special handling. */
991 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1003 switch (expr
->value
.op
.operator)
1005 case INTRINSIC_UPLUS
:
1006 case INTRINSIC_PARENTHESES
:
1007 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1010 case INTRINSIC_UMINUS
:
1011 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1015 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1018 case INTRINSIC_PLUS
:
1022 case INTRINSIC_MINUS
:
1026 case INTRINSIC_TIMES
:
1030 case INTRINSIC_DIVIDE
:
1031 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1032 an integer, we must round towards zero, so we use a
1034 if (expr
->ts
.type
== BT_INTEGER
)
1035 code
= TRUNC_DIV_EXPR
;
1040 case INTRINSIC_POWER
:
1041 gfc_conv_power_op (se
, expr
);
1044 case INTRINSIC_CONCAT
:
1045 gfc_conv_concat_op (se
, expr
);
1049 code
= TRUTH_ANDIF_EXPR
;
1054 code
= TRUTH_ORIF_EXPR
;
1058 /* EQV and NEQV only work on logicals, but since we represent them
1059 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1068 case INTRINSIC_NEQV
:
1098 case INTRINSIC_USER
:
1099 case INTRINSIC_ASSIGN
:
1100 /* These should be converted into function calls by the frontend. */
1104 fatal_error ("Unknown intrinsic op");
1108 /* The only exception to this is **, which is handled separately anyway. */
1109 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1111 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1115 gfc_init_se (&lse
, se
);
1116 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1117 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1120 gfc_init_se (&rse
, se
);
1121 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1122 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1126 gfc_conv_string_parameter (&lse
);
1127 gfc_conv_string_parameter (&rse
);
1129 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1130 rse
.string_length
, rse
.expr
);
1131 rse
.expr
= integer_zero_node
;
1132 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1135 type
= gfc_typenode_for_spec (&expr
->ts
);
1139 /* The result of logical ops is always boolean_type_node. */
1140 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1141 se
->expr
= convert (type
, tmp
);
1144 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1146 /* Add the post blocks. */
1147 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1148 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1151 /* If a string's length is one, we convert it to a single character. */
1154 gfc_to_single_character (tree len
, tree str
)
1156 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1158 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1159 && TREE_INT_CST_HIGH (len
) == 0)
1161 str
= fold_convert (pchar_type_node
, str
);
1162 return build_fold_indirect_ref (str
);
1168 /* Compare two strings. If they are all single characters, the result is the
1169 subtraction of them. Otherwise, we build a library call. */
1172 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1179 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1180 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1182 type
= gfc_get_int_type (gfc_default_integer_kind
);
1184 sc1
= gfc_to_single_character (len1
, str1
);
1185 sc2
= gfc_to_single_character (len2
, str2
);
1187 /* Deal with single character specially. */
1188 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1190 sc1
= fold_convert (type
, sc1
);
1191 sc2
= fold_convert (type
, sc2
);
1192 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1197 tmp
= gfc_chainon_list (tmp
, len1
);
1198 tmp
= gfc_chainon_list (tmp
, str1
);
1199 tmp
= gfc_chainon_list (tmp
, len2
);
1200 tmp
= gfc_chainon_list (tmp
, str2
);
1202 /* Build a call for the comparison. */
1203 tmp
= build_function_call_expr (gfor_fndecl_compare_string
, tmp
);
1210 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1214 if (sym
->attr
.dummy
)
1216 tmp
= gfc_get_symbol_decl (sym
);
1217 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1218 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1222 if (!sym
->backend_decl
)
1223 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1225 tmp
= sym
->backend_decl
;
1226 if (sym
->attr
.cray_pointee
)
1227 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1228 gfc_get_symbol_decl (sym
->cp_pointer
));
1229 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1231 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1232 tmp
= build_fold_addr_expr (tmp
);
1239 /* Initialize MAPPING. */
1242 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1244 mapping
->syms
= NULL
;
1245 mapping
->charlens
= NULL
;
1249 /* Free all memory held by MAPPING (but not MAPPING itself). */
1252 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1254 gfc_interface_sym_mapping
*sym
;
1255 gfc_interface_sym_mapping
*nextsym
;
1257 gfc_charlen
*nextcl
;
1259 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1261 nextsym
= sym
->next
;
1262 gfc_free_symbol (sym
->new->n
.sym
);
1263 gfc_free (sym
->new);
1266 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1269 gfc_free_expr (cl
->length
);
1275 /* Return a copy of gfc_charlen CL. Add the returned structure to
1276 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1278 static gfc_charlen
*
1279 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1284 new = gfc_get_charlen ();
1285 new->next
= mapping
->charlens
;
1286 new->length
= gfc_copy_expr (cl
->length
);
1288 mapping
->charlens
= new;
1293 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1294 array variable that can be used as the actual argument for dummy
1295 argument SYM. Add any initialization code to BLOCK. PACKED is as
1296 for gfc_get_nodesc_array_type and DATA points to the first element
1297 in the passed array. */
1300 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1301 int packed
, tree data
)
1306 type
= gfc_typenode_for_spec (&sym
->ts
);
1307 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1309 var
= gfc_create_var (type
, "ifm");
1310 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1316 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1317 and offset of descriptorless array type TYPE given that it has the same
1318 size as DESC. Add any set-up code to BLOCK. */
1321 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1328 offset
= gfc_index_zero_node
;
1329 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1331 dim
= gfc_rank_cst
[n
];
1332 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1333 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1335 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1336 = gfc_conv_descriptor_lbound (desc
, dim
);
1337 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1338 = gfc_conv_descriptor_ubound (desc
, dim
);
1340 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1342 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1343 gfc_conv_descriptor_ubound (desc
, dim
),
1344 gfc_conv_descriptor_lbound (desc
, dim
));
1345 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1346 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1348 tmp
= gfc_evaluate_now (tmp
, block
);
1349 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1351 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1352 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1353 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1354 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1356 offset
= gfc_evaluate_now (offset
, block
);
1357 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1361 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1362 in SE. The caller may still use se->expr and se->string_length after
1363 calling this function. */
1366 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1367 gfc_symbol
* sym
, gfc_se
* se
)
1369 gfc_interface_sym_mapping
*sm
;
1373 gfc_symbol
*new_sym
;
1375 gfc_symtree
*new_symtree
;
1377 /* Create a new symbol to represent the actual argument. */
1378 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1379 new_sym
->ts
= sym
->ts
;
1380 new_sym
->attr
.referenced
= 1;
1381 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1382 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1383 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1384 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1386 /* Create a fake symtree for it. */
1388 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1389 new_symtree
->n
.sym
= new_sym
;
1390 gcc_assert (new_symtree
== root
);
1392 /* Create a dummy->actual mapping. */
1393 sm
= gfc_getmem (sizeof (*sm
));
1394 sm
->next
= mapping
->syms
;
1396 sm
->new = new_symtree
;
1399 /* Stabilize the argument's value. */
1400 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1402 if (sym
->ts
.type
== BT_CHARACTER
)
1404 /* Create a copy of the dummy argument's length. */
1405 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1407 /* If the length is specified as "*", record the length that
1408 the caller is passing. We should use the callee's length
1409 in all other cases. */
1410 if (!new_sym
->ts
.cl
->length
)
1412 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1413 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1417 /* Use the passed value as-is if the argument is a function. */
1418 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1421 /* If the argument is either a string or a pointer to a string,
1422 convert it to a boundless character type. */
1423 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1425 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1426 tmp
= build_pointer_type (tmp
);
1427 if (sym
->attr
.pointer
)
1428 value
= build_fold_indirect_ref (se
->expr
);
1431 value
= fold_convert (tmp
, value
);
1434 /* If the argument is a scalar, a pointer to an array or an allocatable,
1436 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1437 value
= build_fold_indirect_ref (se
->expr
);
1439 /* For character(*), use the actual argument's descriptor. */
1440 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1441 value
= build_fold_indirect_ref (se
->expr
);
1443 /* If the argument is an array descriptor, use it to determine
1444 information about the actual argument's shape. */
1445 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1446 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1448 /* Get the actual argument's descriptor. */
1449 desc
= build_fold_indirect_ref (se
->expr
);
1451 /* Create the replacement variable. */
1452 tmp
= gfc_conv_descriptor_data_get (desc
);
1453 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1455 /* Use DESC to work out the upper bounds, strides and offset. */
1456 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1459 /* Otherwise we have a packed array. */
1460 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1462 new_sym
->backend_decl
= value
;
1466 /* Called once all dummy argument mappings have been added to MAPPING,
1467 but before the mapping is used to evaluate expressions. Pre-evaluate
1468 the length of each argument, adding any initialization code to PRE and
1469 any finalization code to POST. */
1472 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1473 stmtblock_t
* pre
, stmtblock_t
* post
)
1475 gfc_interface_sym_mapping
*sym
;
1479 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1480 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1481 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1483 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1484 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1485 gfc_init_se (&se
, NULL
);
1486 gfc_conv_expr (&se
, expr
);
1488 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1489 gfc_add_block_to_block (pre
, &se
.pre
);
1490 gfc_add_block_to_block (post
, &se
.post
);
1492 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1497 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1501 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1502 gfc_constructor
* c
)
1504 for (; c
; c
= c
->next
)
1506 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1509 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1510 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1511 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1517 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1521 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1526 for (; ref
; ref
= ref
->next
)
1530 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1532 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1533 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1534 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1536 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1543 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1544 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1550 /* EXPR is a copy of an expression that appeared in the interface
1551 associated with MAPPING. Walk it recursively looking for references to
1552 dummy arguments that MAPPING maps to actual arguments. Replace each such
1553 reference with a reference to the associated actual argument. */
1556 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1559 gfc_interface_sym_mapping
*sym
;
1560 gfc_actual_arglist
*actual
;
1565 /* Copying an expression does not copy its length, so do that here. */
1566 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1568 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1569 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1572 /* Apply the mapping to any references. */
1573 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1575 /* ...and to the expression's symbol, if it has one. */
1577 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1578 if (sym
->old
== expr
->symtree
->n
.sym
)
1579 expr
->symtree
= sym
->new;
1581 /* ...and to subexpressions in expr->value. */
1582 switch (expr
->expr_type
)
1587 case EXPR_SUBSTRING
:
1591 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1592 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1596 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1597 if (sym
->old
== expr
->value
.function
.esym
)
1598 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1600 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1601 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1605 case EXPR_STRUCTURE
:
1606 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1612 /* Evaluate interface expression EXPR using MAPPING. Store the result
1616 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1617 gfc_se
* se
, gfc_expr
* expr
)
1619 expr
= gfc_copy_expr (expr
);
1620 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1621 gfc_conv_expr (se
, expr
);
1622 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1623 gfc_free_expr (expr
);
1626 /* Returns a reference to a temporary array into which a component of
1627 an actual argument derived type array is copied and then returned
1628 after the function call.
1629 TODO Get rid of this kludge, when array descriptors are capable of
1630 handling aliased arrays. */
1633 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1634 int g77
, sym_intent intent
)
1650 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1652 gfc_init_se (&lse
, NULL
);
1653 gfc_init_se (&rse
, NULL
);
1655 /* Walk the argument expression. */
1656 rss
= gfc_walk_expr (expr
);
1658 gcc_assert (rss
!= gfc_ss_terminator
);
1660 /* Initialize the scalarizer. */
1661 gfc_init_loopinfo (&loop
);
1662 gfc_add_ss_to_loop (&loop
, rss
);
1664 /* Calculate the bounds of the scalarization. */
1665 gfc_conv_ss_startstride (&loop
);
1667 /* Build an ss for the temporary. */
1668 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1669 if (GFC_ARRAY_TYPE_P (base_type
)
1670 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1671 base_type
= gfc_get_element_type (base_type
);
1673 loop
.temp_ss
= gfc_get_ss ();;
1674 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1675 loop
.temp_ss
->data
.temp
.type
= base_type
;
1677 if (expr
->ts
.type
== BT_CHARACTER
)
1679 gfc_ref
*char_ref
= expr
->ref
;
1681 for (; expr
->ts
.cl
== NULL
&& char_ref
; char_ref
= char_ref
->next
)
1682 if (char_ref
->type
== REF_SUBSTRING
)
1686 expr
->ts
.cl
= gfc_get_charlen ();
1687 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1688 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1690 gfc_init_se (&tmp_se
, NULL
);
1691 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1692 gfc_array_index_type
);
1693 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1694 tmp_se
.expr
, gfc_index_one_node
);
1695 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1696 gfc_init_se (&tmp_se
, NULL
);
1697 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1698 gfc_array_index_type
);
1699 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1701 expr
->ts
.cl
->backend_decl
= tmp
;
1705 loop
.temp_ss
->data
.temp
.type
1706 = gfc_typenode_for_spec (&expr
->ts
);
1707 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1710 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1711 loop
.temp_ss
->next
= gfc_ss_terminator
;
1713 /* Associate the SS with the loop. */
1714 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1716 /* Setup the scalarizing loops. */
1717 gfc_conv_loop_setup (&loop
);
1719 /* Pass the temporary descriptor back to the caller. */
1720 info
= &loop
.temp_ss
->data
.info
;
1721 parmse
->expr
= info
->descriptor
;
1723 /* Setup the gfc_se structures. */
1724 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1725 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1728 lse
.ss
= loop
.temp_ss
;
1729 gfc_mark_ss_chain_used (rss
, 1);
1730 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1732 /* Start the scalarized loop body. */
1733 gfc_start_scalarized_body (&loop
, &body
);
1735 /* Translate the expression. */
1736 gfc_conv_expr (&rse
, expr
);
1738 gfc_conv_tmp_array_ref (&lse
);
1739 gfc_advance_se_ss_chain (&lse
);
1741 if (intent
!= INTENT_OUT
)
1743 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1744 gfc_add_expr_to_block (&body
, tmp
);
1745 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1746 gfc_trans_scalarizing_loops (&loop
, &body
);
1750 /* Make sure that the temporary declaration survives by merging
1751 all the loop declarations into the current context. */
1752 for (n
= 0; n
< loop
.dimen
; n
++)
1754 gfc_merge_block_scope (&body
);
1755 body
= loop
.code
[loop
.order
[n
]];
1757 gfc_merge_block_scope (&body
);
1760 /* Add the post block after the second loop, so that any
1761 freeing of allocated memory is done at the right time. */
1762 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1764 /**********Copy the temporary back again.*********/
1766 gfc_init_se (&lse
, NULL
);
1767 gfc_init_se (&rse
, NULL
);
1769 /* Walk the argument expression. */
1770 lss
= gfc_walk_expr (expr
);
1771 rse
.ss
= loop
.temp_ss
;
1774 /* Initialize the scalarizer. */
1775 gfc_init_loopinfo (&loop2
);
1776 gfc_add_ss_to_loop (&loop2
, lss
);
1778 /* Calculate the bounds of the scalarization. */
1779 gfc_conv_ss_startstride (&loop2
);
1781 /* Setup the scalarizing loops. */
1782 gfc_conv_loop_setup (&loop2
);
1784 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1785 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1787 gfc_mark_ss_chain_used (lss
, 1);
1788 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1790 /* Declare the variable to hold the temporary offset and start the
1791 scalarized loop body. */
1792 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1793 gfc_start_scalarized_body (&loop2
, &body
);
1795 /* Build the offsets for the temporary from the loop variables. The
1796 temporary array has lbounds of zero and strides of one in all
1797 dimensions, so this is very simple. The offset is only computed
1798 outside the innermost loop, so the overall transfer could be
1799 optimized further. */
1800 info
= &rse
.ss
->data
.info
;
1802 tmp_index
= gfc_index_zero_node
;
1803 for (n
= info
->dimen
- 1; n
> 0; n
--)
1806 tmp
= rse
.loop
->loopvar
[n
];
1807 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1808 tmp
, rse
.loop
->from
[n
]);
1809 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1812 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1813 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1814 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1815 tmp_str
, gfc_index_one_node
);
1817 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1821 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1822 tmp_index
, rse
.loop
->from
[0]);
1823 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1825 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1826 rse
.loop
->loopvar
[0], offset
);
1828 /* Now use the offset for the reference. */
1829 tmp
= build_fold_indirect_ref (info
->data
);
1830 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1832 if (expr
->ts
.type
== BT_CHARACTER
)
1833 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1835 gfc_conv_expr (&lse
, expr
);
1837 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1839 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1840 gfc_add_expr_to_block (&body
, tmp
);
1842 /* Generate the copying loops. */
1843 gfc_trans_scalarizing_loops (&loop2
, &body
);
1845 /* Wrap the whole thing up by adding the second loop to the post-block
1846 and following it by the post-block of the first loop. In this way,
1847 if the temporary needs freeing, it is done after use! */
1848 if (intent
!= INTENT_IN
)
1850 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1851 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1854 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1856 gfc_cleanup_loop (&loop
);
1857 gfc_cleanup_loop (&loop2
);
1859 /* Pass the string length to the argument expression. */
1860 if (expr
->ts
.type
== BT_CHARACTER
)
1861 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1863 /* We want either the address for the data or the address of the descriptor,
1864 depending on the mode of passing array arguments. */
1866 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1868 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1873 /* Is true if an array reference is followed by a component or substring
1877 is_aliased_array (gfc_expr
* e
)
1883 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1885 if (ref
->type
== REF_ARRAY
1886 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1890 && ref
->type
!= REF_ARRAY
)
1896 /* Generate code for a procedure call. Note can return se->post != NULL.
1897 If se->direct_byref is set then se->expr contains the return parameter.
1898 Return nonzero, if the call has alternate specifiers. */
1901 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1902 gfc_actual_arglist
* arg
, tree append_args
)
1904 gfc_interface_mapping mapping
;
1918 gfc_formal_arglist
*formal
;
1919 int has_alternate_specifier
= 0;
1920 bool need_interface_mapping
;
1927 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
1929 arglist
= NULL_TREE
;
1930 retargs
= NULL_TREE
;
1931 stringargs
= NULL_TREE
;
1937 if (!sym
->attr
.elemental
)
1939 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1940 if (se
->ss
->useflags
)
1942 gcc_assert (gfc_return_by_reference (sym
)
1943 && sym
->result
->attr
.dimension
);
1944 gcc_assert (se
->loop
!= NULL
);
1946 /* Access the previously obtained result. */
1947 gfc_conv_tmp_array_ref (se
);
1948 gfc_advance_se_ss_chain (se
);
1952 info
= &se
->ss
->data
.info
;
1957 gfc_init_block (&post
);
1958 gfc_init_interface_mapping (&mapping
);
1959 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
1960 && sym
->ts
.cl
->length
1961 && sym
->ts
.cl
->length
->expr_type
1963 || sym
->attr
.dimension
);
1964 formal
= sym
->formal
;
1965 /* Evaluate the arguments. */
1966 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1969 fsym
= formal
? formal
->sym
: NULL
;
1970 parm_kind
= MISSING
;
1974 if (se
->ignore_optional
)
1976 /* Some intrinsics have already been resolved to the correct
1980 else if (arg
->label
)
1982 has_alternate_specifier
= 1;
1987 /* Pass a NULL pointer for an absent arg. */
1988 gfc_init_se (&parmse
, NULL
);
1989 parmse
.expr
= null_pointer_node
;
1990 if (arg
->missing_arg_type
== BT_CHARACTER
)
1991 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
1994 else if (se
->ss
&& se
->ss
->useflags
)
1996 /* An elemental function inside a scalarized loop. */
1997 gfc_init_se (&parmse
, se
);
1998 gfc_conv_expr_reference (&parmse
, e
);
1999 parm_kind
= ELEMENTAL
;
2003 /* A scalar or transformational function. */
2004 gfc_init_se (&parmse
, NULL
);
2005 argss
= gfc_walk_expr (e
);
2007 if (argss
== gfc_ss_terminator
)
2009 gfc_conv_expr_reference (&parmse
, e
);
2011 if (fsym
&& fsym
->attr
.pointer
2012 && e
->expr_type
!= EXPR_NULL
)
2014 /* Scalar pointer dummy args require an extra level of
2015 indirection. The null pointer already contains
2016 this level of indirection. */
2017 parm_kind
= SCALAR_POINTER
;
2018 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2023 /* If the procedure requires an explicit interface, the actual
2024 argument is passed according to the corresponding formal
2025 argument. If the corresponding formal argument is a POINTER,
2026 ALLOCATABLE or assumed shape, we do not use g77's calling
2027 convention, and pass the address of the array descriptor
2028 instead. Otherwise we use g77's calling convention. */
2031 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2032 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2033 f
= f
|| !sym
->attr
.always_explicit
;
2035 if (e
->expr_type
== EXPR_VARIABLE
2036 && is_aliased_array (e
))
2037 /* The actual argument is a component reference to an
2038 array of derived types. In this case, the argument
2039 is converted to a temporary, which is passed and then
2040 written back after the procedure call. */
2041 gfc_conv_aliased_arg (&parmse
, e
, f
,
2042 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2044 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2046 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2047 allocated on entry, it must be deallocated. */
2048 if (fsym
&& fsym
->attr
.allocatable
2049 && fsym
->attr
.intent
== INTENT_OUT
)
2051 tmp
= e
->symtree
->n
.sym
->backend_decl
;
2052 if (e
->symtree
->n
.sym
->attr
.dummy
)
2053 tmp
= build_fold_indirect_ref (tmp
);
2054 tmp
= gfc_trans_dealloc_allocated (tmp
);
2055 gfc_add_expr_to_block (&se
->pre
, tmp
);
2065 /* If an optional argument is itself an optional dummy
2066 argument, check its presence and substitute a null
2068 if (e
->expr_type
== EXPR_VARIABLE
2069 && e
->symtree
->n
.sym
->attr
.optional
2070 && fsym
->attr
.optional
)
2071 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2073 /* If an INTENT(OUT) dummy of derived type has a default
2074 initializer, it must be (re)initialized here. */
2075 if (fsym
->attr
.intent
== INTENT_OUT
2076 && fsym
->ts
.type
== BT_DERIVED
2079 gcc_assert (!fsym
->attr
.allocatable
);
2080 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2081 gfc_add_expr_to_block (&se
->pre
, tmp
);
2084 /* Obtain the character length of an assumed character
2085 length procedure from the typespec. */
2086 if (fsym
->ts
.type
== BT_CHARACTER
2087 && parmse
.string_length
== NULL_TREE
2088 && e
->ts
.type
== BT_PROCEDURE
2089 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2090 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2092 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2093 parmse
.string_length
2094 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2098 if (need_interface_mapping
)
2099 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2102 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2103 gfc_add_block_to_block (&post
, &parmse
.post
);
2105 /* Allocated allocatable components of derived types must be
2106 deallocated for INTENT(OUT) dummy arguments and non-variable
2107 scalars. Non-variable arrays are dealt with in trans-array.c
2108 (gfc_conv_array_parameter). */
2109 if (e
&& e
->ts
.type
== BT_DERIVED
2110 && e
->ts
.derived
->attr
.alloc_comp
2111 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2113 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2116 tmp
= build_fold_indirect_ref (parmse
.expr
);
2117 parm_rank
= e
->rank
;
2125 case (SCALAR_POINTER
):
2126 tmp
= build_fold_indirect_ref (tmp
);
2133 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2134 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2135 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2136 tmp
, build_empty_stmt ());
2138 if (e
->expr_type
!= EXPR_VARIABLE
)
2139 /* Don't deallocate non-variables until they have been used. */
2140 gfc_add_expr_to_block (&se
->post
, tmp
);
2143 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2144 gfc_add_expr_to_block (&se
->pre
, tmp
);
2148 /* Character strings are passed as two parameters, a length and a
2150 if (parmse
.string_length
!= NULL_TREE
)
2151 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2153 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2155 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2158 if (ts
.type
== BT_CHARACTER
)
2160 if (sym
->ts
.cl
->length
== NULL
)
2162 /* Assumed character length results are not allowed by 5.1.1.5 of the
2163 standard and are trapped in resolve.c; except in the case of SPREAD
2164 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2165 we take the character length of the first argument for the result.
2166 For dummies, we have to look through the formal argument list for
2167 this function and use the character length found there.*/
2168 if (!sym
->attr
.dummy
)
2169 cl
.backend_decl
= TREE_VALUE (stringargs
);
2172 formal
= sym
->ns
->proc_name
->formal
;
2173 for (; formal
; formal
= formal
->next
)
2174 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2175 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2180 /* Calculate the length of the returned string. */
2181 gfc_init_se (&parmse
, NULL
);
2182 if (need_interface_mapping
)
2183 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2185 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2186 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2187 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2188 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2191 /* Set up a charlen structure for it. */
2196 len
= cl
.backend_decl
;
2199 byref
= gfc_return_by_reference (sym
);
2202 if (se
->direct_byref
)
2203 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2204 else if (sym
->result
->attr
.dimension
)
2206 gcc_assert (se
->loop
&& info
);
2208 /* Set the type of the array. */
2209 tmp
= gfc_typenode_for_spec (&ts
);
2210 info
->dimen
= se
->loop
->dimen
;
2212 /* Evaluate the bounds of the result, if known. */
2213 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2215 /* Create a temporary to store the result. In case the function
2216 returns a pointer, the temporary will be a shallow copy and
2217 mustn't be deallocated. */
2218 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2219 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2220 false, !sym
->attr
.pointer
, callee_alloc
,
2223 /* Pass the temporary as the first argument. */
2224 tmp
= info
->descriptor
;
2225 tmp
= build_fold_addr_expr (tmp
);
2226 retargs
= gfc_chainon_list (retargs
, tmp
);
2228 else if (ts
.type
== BT_CHARACTER
)
2230 /* Pass the string length. */
2231 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2232 type
= build_pointer_type (type
);
2234 /* Return an address to a char[0:len-1]* temporary for
2235 character pointers. */
2236 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2238 /* Build char[0:len-1] * pstr. */
2239 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2240 build_int_cst (gfc_charlen_type_node
, 1));
2241 tmp
= build_range_type (gfc_array_index_type
,
2242 gfc_index_zero_node
, tmp
);
2243 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2244 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2246 /* Provide an address expression for the function arguments. */
2247 var
= build_fold_addr_expr (var
);
2250 var
= gfc_conv_string_tmp (se
, type
, len
);
2252 retargs
= gfc_chainon_list (retargs
, var
);
2256 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2258 type
= gfc_get_complex_type (ts
.kind
);
2259 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2260 retargs
= gfc_chainon_list (retargs
, var
);
2263 /* Add the string length to the argument list. */
2264 if (ts
.type
== BT_CHARACTER
)
2265 retargs
= gfc_chainon_list (retargs
, len
);
2267 gfc_free_interface_mapping (&mapping
);
2269 /* Add the return arguments. */
2270 arglist
= chainon (retargs
, arglist
);
2272 /* Add the hidden string length parameters to the arguments. */
2273 arglist
= chainon (arglist
, stringargs
);
2275 /* We may want to append extra arguments here. This is used e.g. for
2276 calls to libgfortran_matmul_??, which need extra information. */
2277 if (append_args
!= NULL_TREE
)
2278 arglist
= chainon (arglist
, append_args
);
2280 /* Generate the actual call. */
2281 gfc_conv_function_val (se
, sym
);
2282 /* If there are alternate return labels, function type should be
2283 integer. Can't modify the type in place though, since it can be shared
2284 with other functions. */
2285 if (has_alternate_specifier
2286 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2288 gcc_assert (! sym
->attr
.dummy
);
2289 TREE_TYPE (sym
->backend_decl
)
2290 = build_function_type (integer_type_node
,
2291 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2292 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2295 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2296 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2297 arglist
, NULL_TREE
);
2299 /* If we have a pointer function, but we don't want a pointer, e.g.
2302 where f is pointer valued, we have to dereference the result. */
2303 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2304 se
->expr
= build_fold_indirect_ref (se
->expr
);
2306 /* f2c calling conventions require a scalar default real function to
2307 return a double precision result. Convert this back to default
2308 real. We only care about the cases that can happen in Fortran 77.
2310 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2311 && sym
->ts
.kind
== gfc_default_real_kind
2312 && !sym
->attr
.always_explicit
)
2313 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2315 /* A pure function may still have side-effects - it may modify its
2317 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2319 if (!sym
->attr
.pure
)
2320 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2325 /* Add the function call to the pre chain. There is no expression. */
2326 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2327 se
->expr
= NULL_TREE
;
2329 if (!se
->direct_byref
)
2331 if (sym
->attr
.dimension
)
2333 if (flag_bounds_check
)
2335 /* Check the data pointer hasn't been modified. This would
2336 happen in a function returning a pointer. */
2337 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2338 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2340 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2342 se
->expr
= info
->descriptor
;
2343 /* Bundle in the string length. */
2344 se
->string_length
= len
;
2346 else if (sym
->ts
.type
== BT_CHARACTER
)
2348 /* Dereference for character pointer results. */
2349 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2350 se
->expr
= build_fold_indirect_ref (var
);
2354 se
->string_length
= len
;
2358 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2359 se
->expr
= build_fold_indirect_ref (var
);
2364 /* Follow the function call with the argument post block. */
2366 gfc_add_block_to_block (&se
->pre
, &post
);
2368 gfc_add_block_to_block (&se
->post
, &post
);
2370 return has_alternate_specifier
;
2374 /* Generate code to copy a string. */
2377 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2378 tree slength
, tree src
)
2380 tree tmp
, dlen
, slen
;
2388 stmtblock_t tempblock
;
2390 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2391 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2393 /* Deal with single character specially. */
2394 dsc
= gfc_to_single_character (dlen
, dest
);
2395 ssc
= gfc_to_single_character (slen
, src
);
2396 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2398 gfc_add_modify_expr (block
, dsc
, ssc
);
2402 /* Do nothing if the destination length is zero. */
2403 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2404 build_int_cst (gfc_charlen_type_node
, 0));
2406 /* The following code was previously in _gfortran_copy_string:
2408 // The two strings may overlap so we use memmove.
2410 copy_string (GFC_INTEGER_4 destlen, char * dest,
2411 GFC_INTEGER_4 srclen, const char * src)
2413 if (srclen >= destlen)
2415 // This will truncate if too long.
2416 memmove (dest, src, destlen);
2420 memmove (dest, src, srclen);
2422 memset (&dest[srclen], ' ', destlen - srclen);
2426 We're now doing it here for better optimization, but the logic
2429 /* Truncate string if source is too long. */
2430 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2431 tmp2
= gfc_chainon_list (NULL_TREE
, dest
);
2432 tmp2
= gfc_chainon_list (tmp2
, src
);
2433 tmp2
= gfc_chainon_list (tmp2
, dlen
);
2434 tmp2
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp2
);
2436 /* Else copy and pad with spaces. */
2437 tmp3
= gfc_chainon_list (NULL_TREE
, dest
);
2438 tmp3
= gfc_chainon_list (tmp3
, src
);
2439 tmp3
= gfc_chainon_list (tmp3
, slen
);
2440 tmp3
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp3
);
2442 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2443 fold_convert (pchar_type_node
, slen
));
2444 tmp4
= gfc_chainon_list (NULL_TREE
, tmp4
);
2445 tmp4
= gfc_chainon_list (tmp4
, build_int_cst
2446 (gfc_get_int_type (gfc_c_int_kind
),
2447 lang_hooks
.to_target_charset (' ')));
2448 tmp4
= gfc_chainon_list (tmp4
, fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2450 tmp4
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], tmp4
);
2452 gfc_init_block (&tempblock
);
2453 gfc_add_expr_to_block (&tempblock
, tmp3
);
2454 gfc_add_expr_to_block (&tempblock
, tmp4
);
2455 tmp3
= gfc_finish_block (&tempblock
);
2457 /* The whole copy_string function is there. */
2458 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2459 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2460 gfc_add_expr_to_block (block
, tmp
);
2464 /* Translate a statement function.
2465 The value of a statement function reference is obtained by evaluating the
2466 expression using the values of the actual arguments for the values of the
2467 corresponding dummy arguments. */
2470 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2474 gfc_formal_arglist
*fargs
;
2475 gfc_actual_arglist
*args
;
2478 gfc_saved_var
*saved_vars
;
2484 sym
= expr
->symtree
->n
.sym
;
2485 args
= expr
->value
.function
.actual
;
2486 gfc_init_se (&lse
, NULL
);
2487 gfc_init_se (&rse
, NULL
);
2490 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2492 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2493 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2495 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2497 /* Each dummy shall be specified, explicitly or implicitly, to be
2499 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2502 /* Create a temporary to hold the value. */
2503 type
= gfc_typenode_for_spec (&fsym
->ts
);
2504 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2506 if (fsym
->ts
.type
== BT_CHARACTER
)
2508 /* Copy string arguments. */
2511 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2512 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2514 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2515 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2518 gfc_conv_expr (&rse
, args
->expr
);
2519 gfc_conv_string_parameter (&rse
);
2520 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2521 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2523 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2525 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2526 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2530 /* For everything else, just evaluate the expression. */
2531 gfc_conv_expr (&lse
, args
->expr
);
2533 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2534 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2535 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2541 /* Use the temporary variables in place of the real ones. */
2542 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2543 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2545 gfc_conv_expr (se
, sym
->value
);
2547 if (sym
->ts
.type
== BT_CHARACTER
)
2549 gfc_conv_const_charlen (sym
->ts
.cl
);
2551 /* Force the expression to the correct length. */
2552 if (!INTEGER_CST_P (se
->string_length
)
2553 || tree_int_cst_lt (se
->string_length
,
2554 sym
->ts
.cl
->backend_decl
))
2556 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2557 tmp
= gfc_create_var (type
, sym
->name
);
2558 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2559 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2560 se
->string_length
, se
->expr
);
2563 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2566 /* Restore the original variables. */
2567 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2568 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2569 gfc_free (saved_vars
);
2573 /* Translate a function expression. */
2576 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2580 if (expr
->value
.function
.isym
)
2582 gfc_conv_intrinsic_function (se
, expr
);
2586 /* We distinguish statement functions from general functions to improve
2587 runtime performance. */
2588 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2590 gfc_conv_statement_function (se
, expr
);
2594 /* expr.value.function.esym is the resolved (specific) function symbol for
2595 most functions. However this isn't set for dummy procedures. */
2596 sym
= expr
->value
.function
.esym
;
2598 sym
= expr
->symtree
->n
.sym
;
2599 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2604 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2606 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2607 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2609 gfc_conv_tmp_array_ref (se
);
2610 gfc_advance_se_ss_chain (se
);
2614 /* Build a static initializer. EXPR is the expression for the initial value.
2615 The other parameters describe the variable of the component being
2616 initialized. EXPR may be null. */
2619 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2620 bool array
, bool pointer
)
2624 if (!(expr
|| pointer
))
2629 /* Arrays need special handling. */
2631 return gfc_build_null_descriptor (type
);
2633 return gfc_conv_array_initializer (type
, expr
);
2636 return fold_convert (type
, null_pointer_node
);
2642 gfc_init_se (&se
, NULL
);
2643 gfc_conv_structure (&se
, expr
, 1);
2647 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2650 gfc_init_se (&se
, NULL
);
2651 gfc_conv_constant (&se
, expr
);
2658 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2670 gfc_start_block (&block
);
2672 /* Initialize the scalarizer. */
2673 gfc_init_loopinfo (&loop
);
2675 gfc_init_se (&lse
, NULL
);
2676 gfc_init_se (&rse
, NULL
);
2679 rss
= gfc_walk_expr (expr
);
2680 if (rss
== gfc_ss_terminator
)
2682 /* The rhs is scalar. Add a ss for the expression. */
2683 rss
= gfc_get_ss ();
2684 rss
->next
= gfc_ss_terminator
;
2685 rss
->type
= GFC_SS_SCALAR
;
2689 /* Create a SS for the destination. */
2690 lss
= gfc_get_ss ();
2691 lss
->type
= GFC_SS_COMPONENT
;
2693 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2694 lss
->next
= gfc_ss_terminator
;
2695 lss
->data
.info
.dimen
= cm
->as
->rank
;
2696 lss
->data
.info
.descriptor
= dest
;
2697 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2698 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2699 for (n
= 0; n
< cm
->as
->rank
; n
++)
2701 lss
->data
.info
.dim
[n
] = n
;
2702 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2703 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2705 mpz_init (lss
->shape
[n
]);
2706 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2707 cm
->as
->lower
[n
]->value
.integer
);
2708 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2711 /* Associate the SS with the loop. */
2712 gfc_add_ss_to_loop (&loop
, lss
);
2713 gfc_add_ss_to_loop (&loop
, rss
);
2715 /* Calculate the bounds of the scalarization. */
2716 gfc_conv_ss_startstride (&loop
);
2718 /* Setup the scalarizing loops. */
2719 gfc_conv_loop_setup (&loop
);
2721 /* Setup the gfc_se structures. */
2722 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2723 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2726 gfc_mark_ss_chain_used (rss
, 1);
2728 gfc_mark_ss_chain_used (lss
, 1);
2730 /* Start the scalarized loop body. */
2731 gfc_start_scalarized_body (&loop
, &body
);
2733 gfc_conv_tmp_array_ref (&lse
);
2734 if (cm
->ts
.type
== BT_CHARACTER
)
2735 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2737 gfc_conv_expr (&rse
, expr
);
2739 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2740 gfc_add_expr_to_block (&body
, tmp
);
2742 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2744 /* Generate the copying loops. */
2745 gfc_trans_scalarizing_loops (&loop
, &body
);
2747 /* Wrap the whole thing up. */
2748 gfc_add_block_to_block (&block
, &loop
.pre
);
2749 gfc_add_block_to_block (&block
, &loop
.post
);
2751 for (n
= 0; n
< cm
->as
->rank
; n
++)
2752 mpz_clear (lss
->shape
[n
]);
2753 gfc_free (lss
->shape
);
2755 gfc_cleanup_loop (&loop
);
2757 return gfc_finish_block (&block
);
2761 /* Assign a single component of a derived type constructor. */
2764 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2774 gfc_start_block (&block
);
2778 gfc_init_se (&se
, NULL
);
2779 /* Pointer component. */
2782 /* Array pointer. */
2783 if (expr
->expr_type
== EXPR_NULL
)
2784 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2787 rss
= gfc_walk_expr (expr
);
2788 se
.direct_byref
= 1;
2790 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2791 gfc_add_block_to_block (&block
, &se
.pre
);
2792 gfc_add_block_to_block (&block
, &se
.post
);
2797 /* Scalar pointers. */
2798 se
.want_pointer
= 1;
2799 gfc_conv_expr (&se
, expr
);
2800 gfc_add_block_to_block (&block
, &se
.pre
);
2801 gfc_add_modify_expr (&block
, dest
,
2802 fold_convert (TREE_TYPE (dest
), se
.expr
));
2803 gfc_add_block_to_block (&block
, &se
.post
);
2806 else if (cm
->dimension
)
2808 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2809 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2810 else if (cm
->allocatable
)
2814 gfc_init_se (&se
, NULL
);
2816 rss
= gfc_walk_expr (expr
);
2817 se
.want_pointer
= 0;
2818 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2819 gfc_add_block_to_block (&block
, &se
.pre
);
2821 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2822 gfc_add_modify_expr (&block
, dest
, tmp
);
2824 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2825 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2828 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2829 TREE_TYPE(cm
->backend_decl
),
2832 gfc_add_expr_to_block (&block
, tmp
);
2834 gfc_add_block_to_block (&block
, &se
.post
);
2835 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2837 /* Shift the lbound and ubound of temporaries to being unity, rather
2838 than zero, based. Calculate the offset for all cases. */
2839 offset
= gfc_conv_descriptor_offset (dest
);
2840 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2841 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2842 for (n
= 0; n
< expr
->rank
; n
++)
2844 if (expr
->expr_type
!= EXPR_VARIABLE
2845 && expr
->expr_type
!= EXPR_CONSTANT
)
2847 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2848 gfc_add_modify_expr (&block
, tmp
,
2849 fold_build2 (PLUS_EXPR
,
2850 gfc_array_index_type
,
2851 tmp
, gfc_index_one_node
));
2852 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2853 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2855 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2856 gfc_conv_descriptor_lbound (dest
,
2858 gfc_conv_descriptor_stride (dest
,
2860 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2861 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2862 gfc_add_modify_expr (&block
, offset
, tmp
);
2867 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2868 gfc_add_expr_to_block (&block
, tmp
);
2871 else if (expr
->ts
.type
== BT_DERIVED
)
2873 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2875 gfc_init_se (&se
, NULL
);
2876 gfc_conv_expr (&se
, expr
);
2877 gfc_add_modify_expr (&block
, dest
,
2878 fold_convert (TREE_TYPE (dest
), se
.expr
));
2882 /* Nested constructors. */
2883 tmp
= gfc_trans_structure_assign (dest
, expr
);
2884 gfc_add_expr_to_block (&block
, tmp
);
2889 /* Scalar component. */
2890 gfc_init_se (&se
, NULL
);
2891 gfc_init_se (&lse
, NULL
);
2893 gfc_conv_expr (&se
, expr
);
2894 if (cm
->ts
.type
== BT_CHARACTER
)
2895 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2897 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
2898 gfc_add_expr_to_block (&block
, tmp
);
2900 return gfc_finish_block (&block
);
2903 /* Assign a derived type constructor to a variable. */
2906 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2914 gfc_start_block (&block
);
2915 cm
= expr
->ts
.derived
->components
;
2916 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2918 /* Skip absent members in default initializers. */
2922 field
= cm
->backend_decl
;
2923 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
2924 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
2925 gfc_add_expr_to_block (&block
, tmp
);
2927 return gfc_finish_block (&block
);
2930 /* Build an expression for a constructor. If init is nonzero then
2931 this is part of a static variable initializer. */
2934 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
2941 VEC(constructor_elt
,gc
) *v
= NULL
;
2943 gcc_assert (se
->ss
== NULL
);
2944 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
2945 type
= gfc_typenode_for_spec (&expr
->ts
);
2949 /* Create a temporary variable and fill it in. */
2950 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
2951 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
2952 gfc_add_expr_to_block (&se
->pre
, tmp
);
2956 cm
= expr
->ts
.derived
->components
;
2958 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2960 /* Skip absent members in default initializers and allocatable
2961 components. Although the latter have a default initializer
2962 of EXPR_NULL,... by default, the static nullify is not needed
2963 since this is done every time we come into scope. */
2964 if (!c
->expr
|| cm
->allocatable
)
2967 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
2968 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
2970 /* Append it to the constructor list. */
2971 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
2973 se
->expr
= build_constructor (type
, v
);
2977 /* Translate a substring expression. */
2980 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
2986 gcc_assert (ref
->type
== REF_SUBSTRING
);
2988 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
2989 expr
->value
.character
.string
);
2990 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
2991 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
2993 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
2997 /* Entry point for expression translation. Evaluates a scalar quantity.
2998 EXPR is the expression to be translated, and SE is the state structure if
2999 called from within the scalarized. */
3002 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3004 if (se
->ss
&& se
->ss
->expr
== expr
3005 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3007 /* Substitute a scalar expression evaluated outside the scalarization
3009 se
->expr
= se
->ss
->data
.scalar
.expr
;
3010 se
->string_length
= se
->ss
->string_length
;
3011 gfc_advance_se_ss_chain (se
);
3015 switch (expr
->expr_type
)
3018 gfc_conv_expr_op (se
, expr
);
3022 gfc_conv_function_expr (se
, expr
);
3026 gfc_conv_constant (se
, expr
);
3030 gfc_conv_variable (se
, expr
);
3034 se
->expr
= null_pointer_node
;
3037 case EXPR_SUBSTRING
:
3038 gfc_conv_substring_expr (se
, expr
);
3041 case EXPR_STRUCTURE
:
3042 gfc_conv_structure (se
, expr
, 0);
3046 gfc_conv_array_constructor_expr (se
, expr
);
3055 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3056 of an assignment. */
3058 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3060 gfc_conv_expr (se
, expr
);
3061 /* All numeric lvalues should have empty post chains. If not we need to
3062 figure out a way of rewriting an lvalue so that it has no post chain. */
3063 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3066 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3067 numeric expressions. Used for scalar values where inserting cleanup code
3070 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3074 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3075 gfc_conv_expr (se
, expr
);
3078 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3079 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3081 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3085 /* Helper to translate and expression and convert it to a particular type. */
3087 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3089 gfc_conv_expr_val (se
, expr
);
3090 se
->expr
= convert (type
, se
->expr
);
3094 /* Converts an expression so that it can be passed by reference. Scalar
3098 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3102 if (se
->ss
&& se
->ss
->expr
== expr
3103 && se
->ss
->type
== GFC_SS_REFERENCE
)
3105 se
->expr
= se
->ss
->data
.scalar
.expr
;
3106 se
->string_length
= se
->ss
->string_length
;
3107 gfc_advance_se_ss_chain (se
);
3111 if (expr
->ts
.type
== BT_CHARACTER
)
3113 gfc_conv_expr (se
, expr
);
3114 gfc_conv_string_parameter (se
);
3118 if (expr
->expr_type
== EXPR_VARIABLE
)
3120 se
->want_pointer
= 1;
3121 gfc_conv_expr (se
, expr
);
3124 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3125 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3126 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3132 gfc_conv_expr (se
, expr
);
3134 /* Create a temporary var to hold the value. */
3135 if (TREE_CONSTANT (se
->expr
))
3137 tree tmp
= se
->expr
;
3138 STRIP_TYPE_NOPS (tmp
);
3139 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3140 DECL_INITIAL (var
) = tmp
;
3141 TREE_STATIC (var
) = 1;
3146 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3147 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3149 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3151 /* Take the address of that value. */
3152 se
->expr
= build_fold_addr_expr (var
);
3157 gfc_trans_pointer_assign (gfc_code
* code
)
3159 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3163 /* Generate code for a pointer assignment. */
3166 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3176 gfc_start_block (&block
);
3178 gfc_init_se (&lse
, NULL
);
3180 lss
= gfc_walk_expr (expr1
);
3181 rss
= gfc_walk_expr (expr2
);
3182 if (lss
== gfc_ss_terminator
)
3184 /* Scalar pointers. */
3185 lse
.want_pointer
= 1;
3186 gfc_conv_expr (&lse
, expr1
);
3187 gcc_assert (rss
== gfc_ss_terminator
);
3188 gfc_init_se (&rse
, NULL
);
3189 rse
.want_pointer
= 1;
3190 gfc_conv_expr (&rse
, expr2
);
3191 gfc_add_block_to_block (&block
, &lse
.pre
);
3192 gfc_add_block_to_block (&block
, &rse
.pre
);
3193 gfc_add_modify_expr (&block
, lse
.expr
,
3194 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3195 gfc_add_block_to_block (&block
, &rse
.post
);
3196 gfc_add_block_to_block (&block
, &lse
.post
);
3200 /* Array pointer. */
3201 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3202 switch (expr2
->expr_type
)
3205 /* Just set the data pointer to null. */
3206 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3210 /* Assign directly to the pointer's descriptor. */
3211 lse
.direct_byref
= 1;
3212 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3216 /* Assign to a temporary descriptor and then copy that
3217 temporary to the pointer. */
3219 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3222 lse
.direct_byref
= 1;
3223 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3224 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3227 gfc_add_block_to_block (&block
, &lse
.pre
);
3228 gfc_add_block_to_block (&block
, &lse
.post
);
3230 return gfc_finish_block (&block
);
3234 /* Makes sure se is suitable for passing as a function string parameter. */
3235 /* TODO: Need to check all callers fo this function. It may be abused. */
3238 gfc_conv_string_parameter (gfc_se
* se
)
3242 if (TREE_CODE (se
->expr
) == STRING_CST
)
3244 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3248 type
= TREE_TYPE (se
->expr
);
3249 if (TYPE_STRING_FLAG (type
))
3251 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3252 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3255 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3256 gcc_assert (se
->string_length
3257 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3261 /* Generate code for assignment of scalar variables. Includes character
3262 strings and derived types with allocatable components. */
3265 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3266 bool l_is_temp
, bool r_is_var
)
3272 gfc_init_block (&block
);
3274 if (ts
.type
== BT_CHARACTER
)
3276 gcc_assert (lse
->string_length
!= NULL_TREE
3277 && rse
->string_length
!= NULL_TREE
);
3279 gfc_conv_string_parameter (lse
);
3280 gfc_conv_string_parameter (rse
);
3282 gfc_add_block_to_block (&block
, &lse
->pre
);
3283 gfc_add_block_to_block (&block
, &rse
->pre
);
3285 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3286 rse
->string_length
, rse
->expr
);
3288 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3292 /* Are the rhs and the lhs the same? */
3295 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3296 build_fold_addr_expr (lse
->expr
),
3297 build_fold_addr_expr (rse
->expr
));
3298 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3301 /* Deallocate the lhs allocated components as long as it is not
3302 the same as the rhs. */
3305 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3307 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3308 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3311 gfc_add_block_to_block (&block
, &lse
->pre
);
3312 gfc_add_block_to_block (&block
, &rse
->pre
);
3314 gfc_add_modify_expr (&block
, lse
->expr
,
3315 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3317 /* Do a deep copy if the rhs is a variable, if it is not the
3321 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3322 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3323 gfc_add_expr_to_block (&block
, tmp
);
3328 gfc_add_block_to_block (&block
, &lse
->pre
);
3329 gfc_add_block_to_block (&block
, &rse
->pre
);
3331 gfc_add_modify_expr (&block
, lse
->expr
,
3332 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3335 gfc_add_block_to_block (&block
, &lse
->post
);
3336 gfc_add_block_to_block (&block
, &rse
->post
);
3338 return gfc_finish_block (&block
);
3342 /* Try to translate array(:) = func (...), where func is a transformational
3343 array function, without using a temporary. Returns NULL is this isn't the
3347 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3352 bool seen_array_ref
;
3354 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3355 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3358 /* Elemental functions don't need a temporary anyway. */
3359 if (expr2
->value
.function
.esym
!= NULL
3360 && expr2
->value
.function
.esym
->attr
.elemental
)
3363 /* Fail if EXPR1 can't be expressed as a descriptor. */
3364 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3367 /* Functions returning pointers need temporaries. */
3368 if (expr2
->symtree
->n
.sym
->attr
.pointer
3369 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3372 /* Check that no LHS component references appear during an array
3373 reference. This is needed because we do not have the means to
3374 span any arbitrary stride with an array descriptor. This check
3375 is not needed for the rhs because the function result has to be
3377 seen_array_ref
= false;
3378 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3380 if (ref
->type
== REF_ARRAY
)
3381 seen_array_ref
= true;
3382 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3386 /* Check for a dependency. */
3387 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3388 expr2
->value
.function
.esym
,
3389 expr2
->value
.function
.actual
))
3392 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3394 gcc_assert (expr2
->value
.function
.isym
3395 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3396 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3398 ss
= gfc_walk_expr (expr1
);
3399 gcc_assert (ss
!= gfc_ss_terminator
);
3400 gfc_init_se (&se
, NULL
);
3401 gfc_start_block (&se
.pre
);
3402 se
.want_pointer
= 1;
3404 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3406 se
.direct_byref
= 1;
3407 se
.ss
= gfc_walk_expr (expr2
);
3408 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3409 gfc_conv_function_expr (&se
, expr2
);
3410 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3412 return gfc_finish_block (&se
.pre
);
3416 /* Translate an assignment. Most of the code is concerned with
3417 setting up the scalarizer. */
3420 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3425 gfc_ss
*lss_section
;
3433 /* Special case a single function returning an array. */
3434 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3436 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3441 /* Assignment of the form lhs = rhs. */
3442 gfc_start_block (&block
);
3444 gfc_init_se (&lse
, NULL
);
3445 gfc_init_se (&rse
, NULL
);
3448 lss
= gfc_walk_expr (expr1
);
3450 if (lss
!= gfc_ss_terminator
)
3452 /* The assignment needs scalarization. */
3455 /* Find a non-scalar SS from the lhs. */
3456 while (lss_section
!= gfc_ss_terminator
3457 && lss_section
->type
!= GFC_SS_SECTION
)
3458 lss_section
= lss_section
->next
;
3460 gcc_assert (lss_section
!= gfc_ss_terminator
);
3462 /* Initialize the scalarizer. */
3463 gfc_init_loopinfo (&loop
);
3466 rss
= gfc_walk_expr (expr2
);
3467 if (rss
== gfc_ss_terminator
)
3469 /* The rhs is scalar. Add a ss for the expression. */
3470 rss
= gfc_get_ss ();
3471 rss
->next
= gfc_ss_terminator
;
3472 rss
->type
= GFC_SS_SCALAR
;
3475 /* Associate the SS with the loop. */
3476 gfc_add_ss_to_loop (&loop
, lss
);
3477 gfc_add_ss_to_loop (&loop
, rss
);
3479 /* Calculate the bounds of the scalarization. */
3480 gfc_conv_ss_startstride (&loop
);
3481 /* Resolve any data dependencies in the statement. */
3482 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3483 /* Setup the scalarizing loops. */
3484 gfc_conv_loop_setup (&loop
);
3486 /* Setup the gfc_se structures. */
3487 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3488 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3491 gfc_mark_ss_chain_used (rss
, 1);
3492 if (loop
.temp_ss
== NULL
)
3495 gfc_mark_ss_chain_used (lss
, 1);
3499 lse
.ss
= loop
.temp_ss
;
3500 gfc_mark_ss_chain_used (lss
, 3);
3501 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3504 /* Start the scalarized loop body. */
3505 gfc_start_scalarized_body (&loop
, &body
);
3508 gfc_init_block (&body
);
3510 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3512 /* Translate the expression. */
3513 gfc_conv_expr (&rse
, expr2
);
3517 gfc_conv_tmp_array_ref (&lse
);
3518 gfc_advance_se_ss_chain (&lse
);
3521 gfc_conv_expr (&lse
, expr1
);
3523 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3524 l_is_temp
|| init_flag
,
3525 expr2
->expr_type
== EXPR_VARIABLE
);
3526 gfc_add_expr_to_block (&body
, tmp
);
3528 if (lss
== gfc_ss_terminator
)
3530 /* Use the scalar assignment as is. */
3531 gfc_add_block_to_block (&block
, &body
);
3535 gcc_assert (lse
.ss
== gfc_ss_terminator
3536 && rse
.ss
== gfc_ss_terminator
);
3540 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3542 /* We need to copy the temporary to the actual lhs. */
3543 gfc_init_se (&lse
, NULL
);
3544 gfc_init_se (&rse
, NULL
);
3545 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3546 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3548 rse
.ss
= loop
.temp_ss
;
3551 gfc_conv_tmp_array_ref (&rse
);
3552 gfc_advance_se_ss_chain (&rse
);
3553 gfc_conv_expr (&lse
, expr1
);
3555 gcc_assert (lse
.ss
== gfc_ss_terminator
3556 && rse
.ss
== gfc_ss_terminator
);
3558 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3560 gfc_add_expr_to_block (&body
, tmp
);
3563 /* Generate the copying loops. */
3564 gfc_trans_scalarizing_loops (&loop
, &body
);
3566 /* Wrap the whole thing up. */
3567 gfc_add_block_to_block (&block
, &loop
.pre
);
3568 gfc_add_block_to_block (&block
, &loop
.post
);
3570 gfc_cleanup_loop (&loop
);
3573 return gfc_finish_block (&block
);
3577 gfc_trans_init_assign (gfc_code
* code
)
3579 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3583 gfc_trans_assign (gfc_code
* code
)
3585 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);