1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
157 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
158 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
159 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
163 tmp
= gfc_get_int_type (kind
);
164 tmp
= fold_convert (tmp
, se
->expr
);
165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
170 if (ts
.type
== BT_CHARACTER
)
172 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
173 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
174 se
->string_length
, tmp
);
175 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
176 se
->string_length
= tmp
;
182 /* Get the character length of an expression, looking through gfc_refs
186 gfc_get_expr_charlen (gfc_expr
*e
)
191 gcc_assert (e
->expr_type
== EXPR_VARIABLE
192 && e
->ts
.type
== BT_CHARACTER
);
194 length
= NULL
; /* To silence compiler warning. */
196 if (is_subref_array (e
) && e
->ts
.cl
->length
)
199 gfc_init_se (&tmpse
, NULL
);
200 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
201 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
205 /* First candidate: if the variable is of type CHARACTER, the
206 expression's length could be the length of the character
208 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
209 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
211 /* Look through the reference chain for component references. */
212 for (r
= e
->ref
; r
; r
= r
->next
)
217 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
218 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
226 /* We should never got substring references here. These will be
227 broken down by the scalarizer. */
233 gcc_assert (length
!= NULL
);
239 /* Generate code to initialize a string length variable. Returns the
243 gfc_conv_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
247 gfc_init_se (&se
, NULL
);
248 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
249 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
250 build_int_cst (gfc_charlen_type_node
, 0));
251 gfc_add_block_to_block (pblock
, &se
.pre
);
253 if (cl
->backend_decl
)
254 gfc_add_modify_expr (pblock
, cl
->backend_decl
, se
.expr
);
256 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
261 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
262 const char *name
, locus
*where
)
272 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
273 type
= build_pointer_type (type
);
276 gfc_init_se (&start
, se
);
277 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
278 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
280 if (integer_onep (start
.expr
))
281 gfc_conv_string_parameter (se
);
284 /* Avoid multiple evaluation of substring start. */
285 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
286 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
288 /* Change the start of the string. */
289 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
292 tmp
= build_fold_indirect_ref (se
->expr
);
293 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
294 se
->expr
= gfc_build_addr_expr (type
, tmp
);
297 /* Length = end + 1 - start. */
298 gfc_init_se (&end
, se
);
299 if (ref
->u
.ss
.end
== NULL
)
300 end
.expr
= se
->string_length
;
303 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
304 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
306 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
307 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
309 if (flag_bounds_check
)
311 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
312 start
.expr
, end
.expr
);
314 /* Check lower bound. */
315 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
316 build_int_cst (gfc_charlen_type_node
, 1));
317 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
320 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
321 "is less than one", name
);
323 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
325 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
326 fold_convert (long_integer_type_node
,
330 /* Check upper bound. */
331 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
333 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
336 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
337 "exceeds string length (%%ld)", name
);
339 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
340 "exceeds string length (%%ld)");
341 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
342 fold_convert (long_integer_type_node
, end
.expr
),
343 fold_convert (long_integer_type_node
,
348 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
349 build_int_cst (gfc_charlen_type_node
, 1),
351 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
352 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
353 build_int_cst (gfc_charlen_type_node
, 0));
354 se
->string_length
= tmp
;
358 /* Convert a derived type component reference. */
361 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
368 c
= ref
->u
.c
.component
;
370 gcc_assert (c
->backend_decl
);
372 field
= c
->backend_decl
;
373 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
375 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
379 if (c
->ts
.type
== BT_CHARACTER
)
381 tmp
= c
->ts
.cl
->backend_decl
;
382 /* Components must always be constant length. */
383 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
384 se
->string_length
= tmp
;
387 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
388 se
->expr
= build_fold_indirect_ref (se
->expr
);
392 /* Return the contents of a variable. Also handles reference/pointer
393 variables (all Fortran pointer references are implicit). */
396 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
403 bool alternate_entry
;
406 sym
= expr
->symtree
->n
.sym
;
409 /* Check that something hasn't gone horribly wrong. */
410 gcc_assert (se
->ss
!= gfc_ss_terminator
);
411 gcc_assert (se
->ss
->expr
== expr
);
413 /* A scalarized term. We already know the descriptor. */
414 se
->expr
= se
->ss
->data
.info
.descriptor
;
415 se
->string_length
= se
->ss
->string_length
;
416 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
417 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
422 tree se_expr
= NULL_TREE
;
424 se
->expr
= gfc_get_symbol_decl (sym
);
426 /* Deal with references to a parent results or entries by storing
427 the current_function_decl and moving to the parent_decl. */
428 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
429 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
430 && sym
->result
== sym
;
431 entry_master
= sym
->attr
.result
432 && sym
->ns
->proc_name
->attr
.entry_master
433 && !gfc_return_by_reference (sym
->ns
->proc_name
);
434 parent_decl
= DECL_CONTEXT (current_function_decl
);
436 if ((se
->expr
== parent_decl
&& return_value
)
437 || (sym
->ns
&& sym
->ns
->proc_name
439 && sym
->ns
->proc_name
->backend_decl
== parent_decl
440 && (alternate_entry
|| entry_master
)))
445 /* Special case for assigning the return value of a function.
446 Self recursive functions must have an explicit return value. */
447 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
448 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
450 /* Similarly for alternate entry points. */
451 else if (alternate_entry
452 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
455 gfc_entry_list
*el
= NULL
;
457 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
460 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
465 else if (entry_master
466 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
468 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
473 /* Procedure actual arguments. */
474 else if (sym
->attr
.flavor
== FL_PROCEDURE
475 && se
->expr
!= current_function_decl
)
477 gcc_assert (se
->want_pointer
);
478 if (!sym
->attr
.dummy
)
480 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
481 se
->expr
= build_fold_addr_expr (se
->expr
);
487 /* Dereference the expression, where needed. Since characters
488 are entirely different from other types, they are treated
490 if (sym
->ts
.type
== BT_CHARACTER
)
492 /* Dereference character pointer dummy arguments
494 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
496 || sym
->attr
.function
497 || sym
->attr
.result
))
498 se
->expr
= build_fold_indirect_ref (se
->expr
);
501 else if (!sym
->attr
.value
)
503 /* Dereference non-character scalar dummy arguments. */
504 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
505 se
->expr
= build_fold_indirect_ref (se
->expr
);
507 /* Dereference scalar hidden result. */
508 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
509 && (sym
->attr
.function
|| sym
->attr
.result
)
510 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
511 se
->expr
= build_fold_indirect_ref (se
->expr
);
513 /* Dereference non-character pointer variables.
514 These must be dummies, results, or scalars. */
515 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
517 || sym
->attr
.function
519 || !sym
->attr
.dimension
))
520 se
->expr
= build_fold_indirect_ref (se
->expr
);
526 /* For character variables, also get the length. */
527 if (sym
->ts
.type
== BT_CHARACTER
)
529 /* If the character length of an entry isn't set, get the length from
530 the master function instead. */
531 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
532 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
534 se
->string_length
= sym
->ts
.cl
->backend_decl
;
535 gcc_assert (se
->string_length
);
543 /* Return the descriptor if that's what we want and this is an array
544 section reference. */
545 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
547 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
548 /* Return the descriptor for array pointers and allocations. */
550 && ref
->next
== NULL
&& (se
->descriptor_only
))
553 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
554 /* Return a pointer to an element. */
558 gfc_conv_component_ref (se
, ref
);
562 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
563 expr
->symtree
->name
, &expr
->where
);
572 /* Pointer assignment, allocation or pass by reference. Arrays are handled
574 if (se
->want_pointer
)
576 if (expr
->ts
.type
== BT_CHARACTER
)
577 gfc_conv_string_parameter (se
);
579 se
->expr
= build_fold_addr_expr (se
->expr
);
584 /* Unary ops are easy... Or they would be if ! was a valid op. */
587 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
592 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
593 /* Initialize the operand. */
594 gfc_init_se (&operand
, se
);
595 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
596 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
598 type
= gfc_typenode_for_spec (&expr
->ts
);
600 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
601 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
602 All other unary operators have an equivalent GIMPLE unary operator. */
603 if (code
== TRUTH_NOT_EXPR
)
604 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
605 build_int_cst (type
, 0));
607 se
->expr
= build1 (code
, type
, operand
.expr
);
611 /* Expand power operator to optimal multiplications when a value is raised
612 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
613 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
614 Programming", 3rd Edition, 1998. */
616 /* This code is mostly duplicated from expand_powi in the backend.
617 We establish the "optimal power tree" lookup table with the defined size.
618 The items in the table are the exponents used to calculate the index
619 exponents. Any integer n less than the value can get an "addition chain",
620 with the first node being one. */
621 #define POWI_TABLE_SIZE 256
623 /* The table is from builtins.c. */
624 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
626 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
627 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
628 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
629 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
630 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
631 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
632 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
633 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
634 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
635 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
636 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
637 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
638 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
639 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
640 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
641 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
642 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
643 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
644 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
645 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
646 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
647 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
648 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
649 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
650 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
651 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
652 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
653 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
654 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
655 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
656 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
657 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
660 /* If n is larger than lookup table's max index, we use the "window
662 #define POWI_WINDOW_SIZE 3
664 /* Recursive function to expand the power operator. The temporary
665 values are put in tmpvar. The function returns tmpvar[1] ** n. */
667 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
674 if (n
< POWI_TABLE_SIZE
)
679 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
680 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
684 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
685 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
686 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
690 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
694 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
695 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
697 if (n
< POWI_TABLE_SIZE
)
704 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
705 return 1. Else return 0 and a call to runtime library functions
706 will have to be built. */
708 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
713 tree vartmp
[POWI_TABLE_SIZE
];
715 unsigned HOST_WIDE_INT n
;
718 /* If exponent is too large, we won't expand it anyway, so don't bother
719 with large integer values. */
720 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
723 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
724 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
725 of the asymmetric range of the integer type. */
726 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
728 type
= TREE_TYPE (lhs
);
729 sgn
= tree_int_cst_sgn (rhs
);
731 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
732 || optimize_size
) && (m
> 2 || m
< -1))
738 se
->expr
= gfc_build_const (type
, integer_one_node
);
742 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
743 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
745 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
746 build_int_cst (TREE_TYPE (lhs
), -1));
747 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
748 build_int_cst (TREE_TYPE (lhs
), 1));
751 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
754 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
755 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
756 build_int_cst (type
, 0));
760 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
761 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
762 build_int_cst (type
, 0));
763 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
767 memset (vartmp
, 0, sizeof (vartmp
));
771 tmp
= gfc_build_const (type
, integer_one_node
);
772 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
775 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
781 /* Power op (**). Constant integer exponent has special handling. */
784 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
786 tree gfc_int4_type_node
;
793 gfc_init_se (&lse
, se
);
794 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
795 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
796 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
798 gfc_init_se (&rse
, se
);
799 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
800 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
802 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
803 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
804 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
807 gfc_int4_type_node
= gfc_get_int_type (4);
809 kind
= expr
->value
.op
.op1
->ts
.kind
;
810 switch (expr
->value
.op
.op2
->ts
.type
)
813 ikind
= expr
->value
.op
.op2
->ts
.kind
;
818 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
840 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
841 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
866 switch (expr
->value
.op
.op1
->ts
.type
)
869 if (kind
== 3) /* Case 16 was not handled properly above. */
871 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
875 /* Use builtins for real ** int4. */
881 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
885 fndecl
= built_in_decls
[BUILT_IN_POWI
];
890 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
898 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
902 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
914 fndecl
= built_in_decls
[BUILT_IN_POWF
];
917 fndecl
= built_in_decls
[BUILT_IN_POW
];
921 fndecl
= built_in_decls
[BUILT_IN_POWL
];
932 fndecl
= gfor_fndecl_math_cpowf
;
935 fndecl
= gfor_fndecl_math_cpow
;
938 fndecl
= gfor_fndecl_math_cpowl10
;
941 fndecl
= gfor_fndecl_math_cpowl16
;
953 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
957 /* Generate code to allocate a string temporary. */
960 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
965 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
967 if (gfc_can_put_var_on_stack (len
))
969 /* Create a temporary variable to hold the result. */
970 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
971 build_int_cst (gfc_charlen_type_node
, 1));
972 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
973 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
974 var
= gfc_create_var (tmp
, "str");
975 var
= gfc_build_addr_expr (type
, var
);
979 /* Allocate a temporary to hold the result. */
980 var
= gfc_create_var (type
, "pstr");
981 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
982 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
984 /* Free the temporary afterwards. */
985 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
986 gfc_add_expr_to_block (&se
->post
, tmp
);
993 /* Handle a string concatenation operation. A temporary will be allocated to
997 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1006 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1007 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1009 gfc_init_se (&lse
, se
);
1010 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1011 gfc_conv_string_parameter (&lse
);
1012 gfc_init_se (&rse
, se
);
1013 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1014 gfc_conv_string_parameter (&rse
);
1016 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1017 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1019 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1020 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1021 if (len
== NULL_TREE
)
1023 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1024 lse
.string_length
, rse
.string_length
);
1027 type
= build_pointer_type (type
);
1029 var
= gfc_conv_string_tmp (se
, type
, len
);
1031 /* Do the actual concatenation. */
1032 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1034 lse
.string_length
, lse
.expr
,
1035 rse
.string_length
, rse
.expr
);
1036 gfc_add_expr_to_block (&se
->pre
, tmp
);
1038 /* Add the cleanup for the operands. */
1039 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1040 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1043 se
->string_length
= len
;
1046 /* Translates an op expression. Common (binary) cases are handled by this
1047 function, others are passed on. Recursion is used in either case.
1048 We use the fact that (op1.ts == op2.ts) (except for the power
1050 Operators need no special handling for scalarized expressions as long as
1051 they call gfc_conv_simple_val to get their operands.
1052 Character strings get special handling. */
1055 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1057 enum tree_code code
;
1066 switch (expr
->value
.op
.operator)
1068 case INTRINSIC_UPLUS
:
1069 case INTRINSIC_PARENTHESES
:
1070 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1073 case INTRINSIC_UMINUS
:
1074 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1078 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1081 case INTRINSIC_PLUS
:
1085 case INTRINSIC_MINUS
:
1089 case INTRINSIC_TIMES
:
1093 case INTRINSIC_DIVIDE
:
1094 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1095 an integer, we must round towards zero, so we use a
1097 if (expr
->ts
.type
== BT_INTEGER
)
1098 code
= TRUNC_DIV_EXPR
;
1103 case INTRINSIC_POWER
:
1104 gfc_conv_power_op (se
, expr
);
1107 case INTRINSIC_CONCAT
:
1108 gfc_conv_concat_op (se
, expr
);
1112 code
= TRUTH_ANDIF_EXPR
;
1117 code
= TRUTH_ORIF_EXPR
;
1121 /* EQV and NEQV only work on logicals, but since we represent them
1122 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1124 case INTRINSIC_EQ_OS
:
1132 case INTRINSIC_NE_OS
:
1133 case INTRINSIC_NEQV
:
1140 case INTRINSIC_GT_OS
:
1147 case INTRINSIC_GE_OS
:
1154 case INTRINSIC_LT_OS
:
1161 case INTRINSIC_LE_OS
:
1167 case INTRINSIC_USER
:
1168 case INTRINSIC_ASSIGN
:
1169 /* These should be converted into function calls by the frontend. */
1173 fatal_error ("Unknown intrinsic op");
1177 /* The only exception to this is **, which is handled separately anyway. */
1178 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1180 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1184 gfc_init_se (&lse
, se
);
1185 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1186 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1189 gfc_init_se (&rse
, se
);
1190 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1191 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1195 gfc_conv_string_parameter (&lse
);
1196 gfc_conv_string_parameter (&rse
);
1198 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1199 rse
.string_length
, rse
.expr
);
1200 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1201 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1204 type
= gfc_typenode_for_spec (&expr
->ts
);
1208 /* The result of logical ops is always boolean_type_node. */
1209 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1210 se
->expr
= convert (type
, tmp
);
1213 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1215 /* Add the post blocks. */
1216 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1217 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1220 /* If a string's length is one, we convert it to a single character. */
1223 gfc_to_single_character (tree len
, tree str
)
1225 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1227 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1228 && TREE_INT_CST_HIGH (len
) == 0)
1230 str
= fold_convert (pchar_type_node
, str
);
1231 return build_fold_indirect_ref (str
);
1239 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1242 if (sym
->backend_decl
)
1244 /* This becomes the nominal_type in
1245 function.c:assign_parm_find_data_types. */
1246 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1247 /* This becomes the passed_type in
1248 function.c:assign_parm_find_data_types. C promotes char to
1249 integer for argument passing. */
1250 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1252 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1257 /* If we have a constant character expression, make it into an
1259 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1263 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1264 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1266 /* The expr needs to be compatible with a C int. If the
1267 conversion fails, then the 2 causes an ICE. */
1268 ts
.type
= BT_INTEGER
;
1269 ts
.kind
= gfc_c_int_kind
;
1270 gfc_convert_type (*expr
, &ts
, 2);
1273 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1275 if ((*expr
)->ref
== NULL
)
1277 se
->expr
= gfc_to_single_character
1278 (build_int_cst (integer_type_node
, 1),
1279 gfc_build_addr_expr (pchar_type_node
,
1281 ((*expr
)->symtree
->n
.sym
)));
1285 gfc_conv_variable (se
, *expr
);
1286 se
->expr
= gfc_to_single_character
1287 (build_int_cst (integer_type_node
, 1),
1288 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1295 /* Compare two strings. If they are all single characters, the result is the
1296 subtraction of them. Otherwise, we build a library call. */
1299 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1305 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1306 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1308 sc1
= gfc_to_single_character (len1
, str1
);
1309 sc2
= gfc_to_single_character (len2
, str2
);
1311 /* Deal with single character specially. */
1312 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1314 sc1
= fold_convert (integer_type_node
, sc1
);
1315 sc2
= fold_convert (integer_type_node
, sc2
);
1316 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1319 /* Build a call for the comparison. */
1320 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1321 len1
, str1
, len2
, str2
);
1326 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1330 if (sym
->attr
.dummy
)
1332 tmp
= gfc_get_symbol_decl (sym
);
1333 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1334 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1338 if (!sym
->backend_decl
)
1339 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1341 tmp
= sym
->backend_decl
;
1342 if (sym
->attr
.cray_pointee
)
1343 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1344 gfc_get_symbol_decl (sym
->cp_pointer
));
1345 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1347 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1348 tmp
= build_fold_addr_expr (tmp
);
1355 /* Translate the call for an elemental subroutine call used in an operator
1356 assignment. This is a simplified version of gfc_conv_function_call. */
1359 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1366 /* Only elemental subroutines with two arguments. */
1367 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1368 gcc_assert (sym
->formal
->next
->next
== NULL
);
1370 gfc_init_block (&block
);
1372 gfc_add_block_to_block (&block
, &lse
->pre
);
1373 gfc_add_block_to_block (&block
, &rse
->pre
);
1375 /* Build the argument list for the call, including hidden string lengths. */
1376 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1377 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1378 if (lse
->string_length
!= NULL_TREE
)
1379 args
= gfc_chainon_list (args
, lse
->string_length
);
1380 if (rse
->string_length
!= NULL_TREE
)
1381 args
= gfc_chainon_list (args
, rse
->string_length
);
1383 /* Build the function call. */
1384 gfc_init_se (&se
, NULL
);
1385 gfc_conv_function_val (&se
, sym
);
1386 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1387 tmp
= build_call_list (tmp
, se
.expr
, args
);
1388 gfc_add_expr_to_block (&block
, tmp
);
1390 gfc_add_block_to_block (&block
, &lse
->post
);
1391 gfc_add_block_to_block (&block
, &rse
->post
);
1393 return gfc_finish_block (&block
);
1397 /* Initialize MAPPING. */
1400 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1402 mapping
->syms
= NULL
;
1403 mapping
->charlens
= NULL
;
1407 /* Free all memory held by MAPPING (but not MAPPING itself). */
1410 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1412 gfc_interface_sym_mapping
*sym
;
1413 gfc_interface_sym_mapping
*nextsym
;
1415 gfc_charlen
*nextcl
;
1417 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1419 nextsym
= sym
->next
;
1420 gfc_free_symbol (sym
->new->n
.sym
);
1421 gfc_free_expr (sym
->expr
);
1422 gfc_free (sym
->new);
1425 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1428 gfc_free_expr (cl
->length
);
1434 /* Return a copy of gfc_charlen CL. Add the returned structure to
1435 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1437 static gfc_charlen
*
1438 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1443 new = gfc_get_charlen ();
1444 new->next
= mapping
->charlens
;
1445 new->length
= gfc_copy_expr (cl
->length
);
1447 mapping
->charlens
= new;
1452 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1453 array variable that can be used as the actual argument for dummy
1454 argument SYM. Add any initialization code to BLOCK. PACKED is as
1455 for gfc_get_nodesc_array_type and DATA points to the first element
1456 in the passed array. */
1459 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1460 gfc_packed packed
, tree data
)
1465 type
= gfc_typenode_for_spec (&sym
->ts
);
1466 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1468 var
= gfc_create_var (type
, "ifm");
1469 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1475 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1476 and offset of descriptorless array type TYPE given that it has the same
1477 size as DESC. Add any set-up code to BLOCK. */
1480 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1487 offset
= gfc_index_zero_node
;
1488 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1490 dim
= gfc_rank_cst
[n
];
1491 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1492 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1494 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1495 = gfc_conv_descriptor_lbound (desc
, dim
);
1496 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1497 = gfc_conv_descriptor_ubound (desc
, dim
);
1499 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1501 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1502 gfc_conv_descriptor_ubound (desc
, dim
),
1503 gfc_conv_descriptor_lbound (desc
, dim
));
1504 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1505 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1507 tmp
= gfc_evaluate_now (tmp
, block
);
1508 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1510 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1511 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1512 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1513 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1515 offset
= gfc_evaluate_now (offset
, block
);
1516 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1520 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1521 in SE. The caller may still use se->expr and se->string_length after
1522 calling this function. */
1525 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1526 gfc_symbol
* sym
, gfc_se
* se
,
1529 gfc_interface_sym_mapping
*sm
;
1533 gfc_symbol
*new_sym
;
1535 gfc_symtree
*new_symtree
;
1537 /* Create a new symbol to represent the actual argument. */
1538 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1539 new_sym
->ts
= sym
->ts
;
1540 new_sym
->attr
.referenced
= 1;
1541 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1542 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1543 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1544 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1545 new_sym
->attr
.function
= sym
->attr
.function
;
1547 /* Create a fake symtree for it. */
1549 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1550 new_symtree
->n
.sym
= new_sym
;
1551 gcc_assert (new_symtree
== root
);
1553 /* Create a dummy->actual mapping. */
1554 sm
= gfc_getmem (sizeof (*sm
));
1555 sm
->next
= mapping
->syms
;
1557 sm
->new = new_symtree
;
1558 sm
->expr
= gfc_copy_expr (expr
);
1561 /* Stabilize the argument's value. */
1562 if (!sym
->attr
.function
&& se
)
1563 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1565 if (sym
->ts
.type
== BT_CHARACTER
)
1567 /* Create a copy of the dummy argument's length. */
1568 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1569 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1571 /* If the length is specified as "*", record the length that
1572 the caller is passing. We should use the callee's length
1573 in all other cases. */
1574 if (!new_sym
->ts
.cl
->length
&& se
)
1576 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1577 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1584 /* Use the passed value as-is if the argument is a function. */
1585 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1588 /* If the argument is either a string or a pointer to a string,
1589 convert it to a boundless character type. */
1590 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1592 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1593 tmp
= build_pointer_type (tmp
);
1594 if (sym
->attr
.pointer
)
1595 value
= build_fold_indirect_ref (se
->expr
);
1598 value
= fold_convert (tmp
, value
);
1601 /* If the argument is a scalar, a pointer to an array or an allocatable,
1603 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1604 value
= build_fold_indirect_ref (se
->expr
);
1606 /* For character(*), use the actual argument's descriptor. */
1607 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1608 value
= build_fold_indirect_ref (se
->expr
);
1610 /* If the argument is an array descriptor, use it to determine
1611 information about the actual argument's shape. */
1612 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1613 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1615 /* Get the actual argument's descriptor. */
1616 desc
= build_fold_indirect_ref (se
->expr
);
1618 /* Create the replacement variable. */
1619 tmp
= gfc_conv_descriptor_data_get (desc
);
1620 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1623 /* Use DESC to work out the upper bounds, strides and offset. */
1624 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1627 /* Otherwise we have a packed array. */
1628 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1629 PACKED_FULL
, se
->expr
);
1631 new_sym
->backend_decl
= value
;
1635 /* Called once all dummy argument mappings have been added to MAPPING,
1636 but before the mapping is used to evaluate expressions. Pre-evaluate
1637 the length of each argument, adding any initialization code to PRE and
1638 any finalization code to POST. */
1641 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1642 stmtblock_t
* pre
, stmtblock_t
* post
)
1644 gfc_interface_sym_mapping
*sym
;
1648 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1649 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1650 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1652 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1653 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1654 gfc_init_se (&se
, NULL
);
1655 gfc_conv_expr (&se
, expr
);
1657 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1658 gfc_add_block_to_block (pre
, &se
.pre
);
1659 gfc_add_block_to_block (post
, &se
.post
);
1661 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1666 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1670 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1671 gfc_constructor
* c
)
1673 for (; c
; c
= c
->next
)
1675 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1678 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1679 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1680 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1686 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1690 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1695 for (; ref
; ref
= ref
->next
)
1699 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1701 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1702 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1703 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1705 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1712 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1713 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1719 /* Convert intrinsic function calls into result expressions. */
1721 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
* mapping
)
1729 arg1
= expr
->value
.function
.actual
->expr
;
1730 if (expr
->value
.function
.actual
->next
)
1731 arg2
= expr
->value
.function
.actual
->next
->expr
;
1735 sym
= arg1
->symtree
->n
.sym
;
1737 if (sym
->attr
.dummy
)
1742 switch (expr
->value
.function
.isym
->id
)
1745 /* TODO figure out why this condition is necessary. */
1746 if (sym
->attr
.function
1747 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1748 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)
1751 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1758 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1760 dup
= mpz_get_si (arg2
->value
.integer
);
1765 dup
= sym
->as
->rank
;
1769 for (; d
< dup
; d
++)
1772 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1773 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1775 new_expr
= gfc_multiply (new_expr
, tmp
);
1781 case GFC_ISYM_LBOUND
:
1782 case GFC_ISYM_UBOUND
:
1783 /* TODO These implementations of lbound and ubound do not limit if
1784 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1789 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1790 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1792 /* TODO: If the need arises, this could produce an array of
1796 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1797 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1799 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1806 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
1810 gfc_replace_expr (expr
, new_expr
);
1816 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
1817 gfc_interface_mapping
* mapping
)
1819 gfc_formal_arglist
*f
;
1820 gfc_actual_arglist
*actual
;
1822 actual
= expr
->value
.function
.actual
;
1823 f
= map_expr
->symtree
->n
.sym
->formal
;
1825 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
1830 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
1833 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
1838 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
1840 for (d
= 0; d
< as
->rank
; d
++)
1842 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
1843 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
1846 expr
->value
.function
.esym
->as
= as
;
1849 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1851 expr
->value
.function
.esym
->ts
.cl
->length
1852 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
1854 gfc_apply_interface_mapping_to_expr (mapping
,
1855 expr
->value
.function
.esym
->ts
.cl
->length
);
1860 /* EXPR is a copy of an expression that appeared in the interface
1861 associated with MAPPING. Walk it recursively looking for references to
1862 dummy arguments that MAPPING maps to actual arguments. Replace each such
1863 reference with a reference to the associated actual argument. */
1866 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1869 gfc_interface_sym_mapping
*sym
;
1870 gfc_actual_arglist
*actual
;
1875 /* Copying an expression does not copy its length, so do that here. */
1876 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1878 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1879 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1882 /* Apply the mapping to any references. */
1883 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1885 /* ...and to the expression's symbol, if it has one. */
1886 /* TODO Find out why the condition on expr->symtree had to be moved into
1887 the loop rather than being ouside it, as originally. */
1888 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1889 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
1891 if (sym
->new->n
.sym
->backend_decl
)
1892 expr
->symtree
= sym
->new;
1894 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
1897 /* ...and to subexpressions in expr->value. */
1898 switch (expr
->expr_type
)
1903 case EXPR_SUBSTRING
:
1907 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1908 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1912 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1913 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1915 if (expr
->value
.function
.esym
== NULL
1916 && expr
->value
.function
.isym
!= NULL
1917 && expr
->value
.function
.actual
->expr
->symtree
1918 && gfc_map_intrinsic_function (expr
, mapping
))
1921 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1922 if (sym
->old
== expr
->value
.function
.esym
)
1924 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1925 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
1926 expr
->value
.function
.esym
->result
= sym
->new->n
.sym
;
1931 case EXPR_STRUCTURE
:
1932 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1940 /* Evaluate interface expression EXPR using MAPPING. Store the result
1944 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1945 gfc_se
* se
, gfc_expr
* expr
)
1947 expr
= gfc_copy_expr (expr
);
1948 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1949 gfc_conv_expr (se
, expr
);
1950 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1951 gfc_free_expr (expr
);
1955 /* Returns a reference to a temporary array into which a component of
1956 an actual argument derived type array is copied and then returned
1957 after the function call. */
1959 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1960 int g77
, sym_intent intent
)
1976 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1978 gfc_init_se (&lse
, NULL
);
1979 gfc_init_se (&rse
, NULL
);
1981 /* Walk the argument expression. */
1982 rss
= gfc_walk_expr (expr
);
1984 gcc_assert (rss
!= gfc_ss_terminator
);
1986 /* Initialize the scalarizer. */
1987 gfc_init_loopinfo (&loop
);
1988 gfc_add_ss_to_loop (&loop
, rss
);
1990 /* Calculate the bounds of the scalarization. */
1991 gfc_conv_ss_startstride (&loop
);
1993 /* Build an ss for the temporary. */
1994 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
1995 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
1997 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1998 if (GFC_ARRAY_TYPE_P (base_type
)
1999 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2000 base_type
= gfc_get_element_type (base_type
);
2002 loop
.temp_ss
= gfc_get_ss ();;
2003 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2004 loop
.temp_ss
->data
.temp
.type
= base_type
;
2006 if (expr
->ts
.type
== BT_CHARACTER
)
2007 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2009 loop
.temp_ss
->string_length
= NULL
;
2011 parmse
->string_length
= loop
.temp_ss
->string_length
;
2012 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2013 loop
.temp_ss
->next
= gfc_ss_terminator
;
2015 /* Associate the SS with the loop. */
2016 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2018 /* Setup the scalarizing loops. */
2019 gfc_conv_loop_setup (&loop
);
2021 /* Pass the temporary descriptor back to the caller. */
2022 info
= &loop
.temp_ss
->data
.info
;
2023 parmse
->expr
= info
->descriptor
;
2025 /* Setup the gfc_se structures. */
2026 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2027 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2030 lse
.ss
= loop
.temp_ss
;
2031 gfc_mark_ss_chain_used (rss
, 1);
2032 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2034 /* Start the scalarized loop body. */
2035 gfc_start_scalarized_body (&loop
, &body
);
2037 /* Translate the expression. */
2038 gfc_conv_expr (&rse
, expr
);
2040 gfc_conv_tmp_array_ref (&lse
);
2041 gfc_advance_se_ss_chain (&lse
);
2043 if (intent
!= INTENT_OUT
)
2045 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2046 gfc_add_expr_to_block (&body
, tmp
);
2047 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2048 gfc_trans_scalarizing_loops (&loop
, &body
);
2052 /* Make sure that the temporary declaration survives by merging
2053 all the loop declarations into the current context. */
2054 for (n
= 0; n
< loop
.dimen
; n
++)
2056 gfc_merge_block_scope (&body
);
2057 body
= loop
.code
[loop
.order
[n
]];
2059 gfc_merge_block_scope (&body
);
2062 /* Add the post block after the second loop, so that any
2063 freeing of allocated memory is done at the right time. */
2064 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2066 /**********Copy the temporary back again.*********/
2068 gfc_init_se (&lse
, NULL
);
2069 gfc_init_se (&rse
, NULL
);
2071 /* Walk the argument expression. */
2072 lss
= gfc_walk_expr (expr
);
2073 rse
.ss
= loop
.temp_ss
;
2076 /* Initialize the scalarizer. */
2077 gfc_init_loopinfo (&loop2
);
2078 gfc_add_ss_to_loop (&loop2
, lss
);
2080 /* Calculate the bounds of the scalarization. */
2081 gfc_conv_ss_startstride (&loop2
);
2083 /* Setup the scalarizing loops. */
2084 gfc_conv_loop_setup (&loop2
);
2086 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2087 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2089 gfc_mark_ss_chain_used (lss
, 1);
2090 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2092 /* Declare the variable to hold the temporary offset and start the
2093 scalarized loop body. */
2094 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2095 gfc_start_scalarized_body (&loop2
, &body
);
2097 /* Build the offsets for the temporary from the loop variables. The
2098 temporary array has lbounds of zero and strides of one in all
2099 dimensions, so this is very simple. The offset is only computed
2100 outside the innermost loop, so the overall transfer could be
2101 optimized further. */
2102 info
= &rse
.ss
->data
.info
;
2104 tmp_index
= gfc_index_zero_node
;
2105 for (n
= info
->dimen
- 1; n
> 0; n
--)
2108 tmp
= rse
.loop
->loopvar
[n
];
2109 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2110 tmp
, rse
.loop
->from
[n
]);
2111 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2114 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2115 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2116 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2117 tmp_str
, gfc_index_one_node
);
2119 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2123 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2124 tmp_index
, rse
.loop
->from
[0]);
2125 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
2127 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2128 rse
.loop
->loopvar
[0], offset
);
2130 /* Now use the offset for the reference. */
2131 tmp
= build_fold_indirect_ref (info
->data
);
2132 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2134 if (expr
->ts
.type
== BT_CHARACTER
)
2135 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2137 gfc_conv_expr (&lse
, expr
);
2139 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2141 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2142 gfc_add_expr_to_block (&body
, tmp
);
2144 /* Generate the copying loops. */
2145 gfc_trans_scalarizing_loops (&loop2
, &body
);
2147 /* Wrap the whole thing up by adding the second loop to the post-block
2148 and following it by the post-block of the first loop. In this way,
2149 if the temporary needs freeing, it is done after use! */
2150 if (intent
!= INTENT_IN
)
2152 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2153 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2156 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2158 gfc_cleanup_loop (&loop
);
2159 gfc_cleanup_loop (&loop2
);
2161 /* Pass the string length to the argument expression. */
2162 if (expr
->ts
.type
== BT_CHARACTER
)
2163 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2165 /* We want either the address for the data or the address of the descriptor,
2166 depending on the mode of passing array arguments. */
2168 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2170 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2176 /* Generate the code for argument list functions. */
2179 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2181 /* Pass by value for g77 %VAL(arg), pass the address
2182 indirectly for %LOC, else by reference. Thus %REF
2183 is a "do-nothing" and %LOC is the same as an F95
2185 if (strncmp (name
, "%VAL", 4) == 0)
2186 gfc_conv_expr (se
, expr
);
2187 else if (strncmp (name
, "%LOC", 4) == 0)
2189 gfc_conv_expr_reference (se
, expr
);
2190 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2192 else if (strncmp (name
, "%REF", 4) == 0)
2193 gfc_conv_expr_reference (se
, expr
);
2195 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2199 /* Generate code for a procedure call. Note can return se->post != NULL.
2200 If se->direct_byref is set then se->expr contains the return parameter.
2201 Return nonzero, if the call has alternate specifiers. */
2204 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2205 gfc_actual_arglist
* arg
, tree append_args
)
2207 gfc_interface_mapping mapping
;
2221 gfc_formal_arglist
*formal
;
2222 int has_alternate_specifier
= 0;
2223 bool need_interface_mapping
;
2230 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2232 arglist
= NULL_TREE
;
2233 retargs
= NULL_TREE
;
2234 stringargs
= NULL_TREE
;
2238 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2240 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2242 if (arg
->expr
->rank
== 0)
2243 gfc_conv_expr_reference (se
, arg
->expr
);
2247 /* This is really the actual arg because no formal arglist is
2248 created for C_LOC. */
2249 fsym
= arg
->expr
->symtree
->n
.sym
;
2251 /* We should want it to do g77 calling convention. */
2253 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2254 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2255 f
= f
|| !sym
->attr
.always_explicit
;
2257 argss
= gfc_walk_expr (arg
->expr
);
2258 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2263 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2265 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2266 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2267 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2268 gfc_conv_expr_reference (se
, arg
->expr
);
2272 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2277 /* Build the addr_expr for the first argument. The argument is
2278 already an *address* so we don't need to set want_pointer in
2280 gfc_init_se (&arg1se
, NULL
);
2281 gfc_conv_expr (&arg1se
, arg
->expr
);
2282 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2283 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2285 /* See if we were given two arguments. */
2286 if (arg
->next
== NULL
)
2287 /* Only given one arg so generate a null and do a
2288 not-equal comparison against the first arg. */
2289 se
->expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2290 fold_convert (TREE_TYPE (arg1se
.expr
),
2291 null_pointer_node
));
2297 /* Given two arguments so build the arg2se from second arg. */
2298 gfc_init_se (&arg2se
, NULL
);
2299 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2300 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2301 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2303 /* Generate test to compare that the two args are equal. */
2304 eq_expr
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
,
2306 /* Generate test to ensure that the first arg is not null. */
2307 not_null_expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2310 /* Finally, the generated test must check that both arg1 is not
2311 NULL and that it is equal to the second arg. */
2312 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2313 not_null_expr
, eq_expr
);
2322 if (!sym
->attr
.elemental
)
2324 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2325 if (se
->ss
->useflags
)
2327 gcc_assert (gfc_return_by_reference (sym
)
2328 && sym
->result
->attr
.dimension
);
2329 gcc_assert (se
->loop
!= NULL
);
2331 /* Access the previously obtained result. */
2332 gfc_conv_tmp_array_ref (se
);
2333 gfc_advance_se_ss_chain (se
);
2337 info
= &se
->ss
->data
.info
;
2342 gfc_init_block (&post
);
2343 gfc_init_interface_mapping (&mapping
);
2344 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2345 && sym
->ts
.cl
->length
2346 && sym
->ts
.cl
->length
->expr_type
2348 || sym
->attr
.dimension
);
2349 formal
= sym
->formal
;
2350 /* Evaluate the arguments. */
2351 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2354 fsym
= formal
? formal
->sym
: NULL
;
2355 parm_kind
= MISSING
;
2359 if (se
->ignore_optional
)
2361 /* Some intrinsics have already been resolved to the correct
2365 else if (arg
->label
)
2367 has_alternate_specifier
= 1;
2372 /* Pass a NULL pointer for an absent arg. */
2373 gfc_init_se (&parmse
, NULL
);
2374 parmse
.expr
= null_pointer_node
;
2375 if (arg
->missing_arg_type
== BT_CHARACTER
)
2376 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2379 else if (se
->ss
&& se
->ss
->useflags
)
2381 /* An elemental function inside a scalarized loop. */
2382 gfc_init_se (&parmse
, se
);
2383 gfc_conv_expr_reference (&parmse
, e
);
2384 parm_kind
= ELEMENTAL
;
2388 /* A scalar or transformational function. */
2389 gfc_init_se (&parmse
, NULL
);
2390 argss
= gfc_walk_expr (e
);
2392 if (argss
== gfc_ss_terminator
)
2394 if (fsym
&& fsym
->attr
.value
)
2396 if (fsym
->ts
.type
== BT_CHARACTER
2397 && fsym
->ts
.is_c_interop
2398 && fsym
->ns
->proc_name
!= NULL
2399 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2402 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2403 if (parmse
.expr
== NULL
)
2404 gfc_conv_expr (&parmse
, e
);
2407 gfc_conv_expr (&parmse
, e
);
2409 else if (arg
->name
&& arg
->name
[0] == '%')
2410 /* Argument list functions %VAL, %LOC and %REF are signalled
2411 through arg->name. */
2412 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2413 else if ((e
->expr_type
== EXPR_FUNCTION
)
2414 && e
->symtree
->n
.sym
->attr
.pointer
2415 && fsym
&& fsym
->attr
.target
)
2417 gfc_conv_expr (&parmse
, e
);
2418 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2422 gfc_conv_expr_reference (&parmse
, e
);
2423 if (fsym
&& fsym
->attr
.pointer
2424 && fsym
->attr
.flavor
!= FL_PROCEDURE
2425 && e
->expr_type
!= EXPR_NULL
)
2427 /* Scalar pointer dummy args require an extra level of
2428 indirection. The null pointer already contains
2429 this level of indirection. */
2430 parm_kind
= SCALAR_POINTER
;
2431 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2437 /* If the procedure requires an explicit interface, the actual
2438 argument is passed according to the corresponding formal
2439 argument. If the corresponding formal argument is a POINTER,
2440 ALLOCATABLE or assumed shape, we do not use g77's calling
2441 convention, and pass the address of the array descriptor
2442 instead. Otherwise we use g77's calling convention. */
2445 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2446 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2447 f
= f
|| !sym
->attr
.always_explicit
;
2449 if (e
->expr_type
== EXPR_VARIABLE
2450 && is_subref_array (e
))
2451 /* The actual argument is a component reference to an
2452 array of derived types. In this case, the argument
2453 is converted to a temporary, which is passed and then
2454 written back after the procedure call. */
2455 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2456 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2458 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2460 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2461 allocated on entry, it must be deallocated. */
2462 if (fsym
&& fsym
->attr
.allocatable
2463 && fsym
->attr
.intent
== INTENT_OUT
)
2465 tmp
= build_fold_indirect_ref (parmse
.expr
);
2466 tmp
= gfc_trans_dealloc_allocated (tmp
);
2467 gfc_add_expr_to_block (&se
->pre
, tmp
);
2473 /* The case with fsym->attr.optional is that of a user subroutine
2474 with an interface indicating an optional argument. When we call
2475 an intrinsic subroutine, however, fsym is NULL, but we might still
2476 have an optional argument, so we proceed to the substitution
2478 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2480 /* If an optional argument is itself an optional dummy argument,
2481 check its presence and substitute a null if absent. */
2482 if (e
->expr_type
== EXPR_VARIABLE
2483 && e
->symtree
->n
.sym
->attr
.optional
)
2484 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2485 e
->representation
.length
);
2490 /* Obtain the character length of an assumed character length
2491 length procedure from the typespec. */
2492 if (fsym
->ts
.type
== BT_CHARACTER
2493 && parmse
.string_length
== NULL_TREE
2494 && e
->ts
.type
== BT_PROCEDURE
2495 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2496 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2498 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2499 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2503 if (fsym
&& need_interface_mapping
)
2504 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2506 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2507 gfc_add_block_to_block (&post
, &parmse
.post
);
2509 /* Allocated allocatable components of derived types must be
2510 deallocated for INTENT(OUT) dummy arguments and non-variable
2511 scalars. Non-variable arrays are dealt with in trans-array.c
2512 (gfc_conv_array_parameter). */
2513 if (e
&& e
->ts
.type
== BT_DERIVED
2514 && e
->ts
.derived
->attr
.alloc_comp
2515 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2517 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2520 tmp
= build_fold_indirect_ref (parmse
.expr
);
2521 parm_rank
= e
->rank
;
2529 case (SCALAR_POINTER
):
2530 tmp
= build_fold_indirect_ref (tmp
);
2537 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2538 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2539 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2540 tmp
, build_empty_stmt ());
2542 if (e
->expr_type
!= EXPR_VARIABLE
)
2543 /* Don't deallocate non-variables until they have been used. */
2544 gfc_add_expr_to_block (&se
->post
, tmp
);
2547 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2548 gfc_add_expr_to_block (&se
->pre
, tmp
);
2552 /* Character strings are passed as two parameters, a length and a
2553 pointer - except for Bind(c) which only passes the pointer. */
2554 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2555 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2557 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2559 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2562 if (ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2564 if (sym
->ts
.cl
->length
== NULL
)
2566 /* Assumed character length results are not allowed by 5.1.1.5 of the
2567 standard and are trapped in resolve.c; except in the case of SPREAD
2568 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2569 we take the character length of the first argument for the result.
2570 For dummies, we have to look through the formal argument list for
2571 this function and use the character length found there.*/
2572 if (!sym
->attr
.dummy
)
2573 cl
.backend_decl
= TREE_VALUE (stringargs
);
2576 formal
= sym
->ns
->proc_name
->formal
;
2577 for (; formal
; formal
= formal
->next
)
2578 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2579 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2586 /* Calculate the length of the returned string. */
2587 gfc_init_se (&parmse
, NULL
);
2588 if (need_interface_mapping
)
2589 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2591 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2592 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2593 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2595 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2596 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2597 build_int_cst (gfc_charlen_type_node
, 0));
2598 cl
.backend_decl
= tmp
;
2601 /* Set up a charlen structure for it. */
2606 len
= cl
.backend_decl
;
2609 byref
= gfc_return_by_reference (sym
);
2612 if (se
->direct_byref
)
2614 /* Sometimes, too much indirection can be applied; eg. for
2615 function_result = array_valued_recursive_function. */
2616 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2617 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2618 && GFC_DESCRIPTOR_TYPE_P
2619 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2620 se
->expr
= build_fold_indirect_ref (se
->expr
);
2622 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2624 else if (sym
->result
->attr
.dimension
)
2626 gcc_assert (se
->loop
&& info
);
2628 /* Set the type of the array. */
2629 tmp
= gfc_typenode_for_spec (&ts
);
2630 info
->dimen
= se
->loop
->dimen
;
2632 /* Evaluate the bounds of the result, if known. */
2633 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2635 /* Create a temporary to store the result. In case the function
2636 returns a pointer, the temporary will be a shallow copy and
2637 mustn't be deallocated. */
2638 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2639 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2640 false, !sym
->attr
.pointer
, callee_alloc
);
2642 /* Pass the temporary as the first argument. */
2643 tmp
= info
->descriptor
;
2644 tmp
= build_fold_addr_expr (tmp
);
2645 retargs
= gfc_chainon_list (retargs
, tmp
);
2647 else if (ts
.type
== BT_CHARACTER
)
2649 /* Pass the string length. */
2650 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2651 type
= build_pointer_type (type
);
2653 /* Return an address to a char[0:len-1]* temporary for
2654 character pointers. */
2655 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2657 /* Build char[0:len-1] * pstr. */
2658 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2659 build_int_cst (gfc_charlen_type_node
, 1));
2660 tmp
= build_range_type (gfc_array_index_type
,
2661 gfc_index_zero_node
, tmp
);
2662 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2663 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2665 /* Provide an address expression for the function arguments. */
2666 var
= build_fold_addr_expr (var
);
2669 var
= gfc_conv_string_tmp (se
, type
, len
);
2671 retargs
= gfc_chainon_list (retargs
, var
);
2675 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2677 type
= gfc_get_complex_type (ts
.kind
);
2678 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2679 retargs
= gfc_chainon_list (retargs
, var
);
2682 /* Add the string length to the argument list. */
2683 if (ts
.type
== BT_CHARACTER
)
2684 retargs
= gfc_chainon_list (retargs
, len
);
2686 gfc_free_interface_mapping (&mapping
);
2688 /* Add the return arguments. */
2689 arglist
= chainon (retargs
, arglist
);
2691 /* Add the hidden string length parameters to the arguments. */
2692 arglist
= chainon (arglist
, stringargs
);
2694 /* We may want to append extra arguments here. This is used e.g. for
2695 calls to libgfortran_matmul_??, which need extra information. */
2696 if (append_args
!= NULL_TREE
)
2697 arglist
= chainon (arglist
, append_args
);
2699 /* Generate the actual call. */
2700 gfc_conv_function_val (se
, sym
);
2702 /* If there are alternate return labels, function type should be
2703 integer. Can't modify the type in place though, since it can be shared
2704 with other functions. For dummy arguments, the typing is done to
2705 to this result, even if it has to be repeated for each call. */
2706 if (has_alternate_specifier
2707 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2709 if (!sym
->attr
.dummy
)
2711 TREE_TYPE (sym
->backend_decl
)
2712 = build_function_type (integer_type_node
,
2713 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2714 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2717 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2720 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2721 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2723 /* If we have a pointer function, but we don't want a pointer, e.g.
2726 where f is pointer valued, we have to dereference the result. */
2727 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2728 se
->expr
= build_fold_indirect_ref (se
->expr
);
2730 /* f2c calling conventions require a scalar default real function to
2731 return a double precision result. Convert this back to default
2732 real. We only care about the cases that can happen in Fortran 77.
2734 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2735 && sym
->ts
.kind
== gfc_default_real_kind
2736 && !sym
->attr
.always_explicit
)
2737 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2739 /* A pure function may still have side-effects - it may modify its
2741 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2743 if (!sym
->attr
.pure
)
2744 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2749 /* Add the function call to the pre chain. There is no expression. */
2750 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2751 se
->expr
= NULL_TREE
;
2753 if (!se
->direct_byref
)
2755 if (sym
->attr
.dimension
)
2757 if (flag_bounds_check
)
2759 /* Check the data pointer hasn't been modified. This would
2760 happen in a function returning a pointer. */
2761 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2762 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2764 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2766 se
->expr
= info
->descriptor
;
2767 /* Bundle in the string length. */
2768 se
->string_length
= len
;
2770 else if (sym
->ts
.type
== BT_CHARACTER
)
2772 /* Dereference for character pointer results. */
2773 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2774 se
->expr
= build_fold_indirect_ref (var
);
2778 se
->string_length
= len
;
2782 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2783 se
->expr
= build_fold_indirect_ref (var
);
2788 /* Follow the function call with the argument post block. */
2790 gfc_add_block_to_block (&se
->pre
, &post
);
2792 gfc_add_block_to_block (&se
->post
, &post
);
2794 return has_alternate_specifier
;
2798 /* Generate code to copy a string. */
2801 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2802 tree slength
, tree src
)
2804 tree tmp
, dlen
, slen
;
2812 stmtblock_t tempblock
;
2814 if (slength
!= NULL_TREE
)
2816 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2817 ssc
= gfc_to_single_character (slen
, src
);
2821 slen
= build_int_cst (size_type_node
, 1);
2825 if (dlength
!= NULL_TREE
)
2827 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2828 dsc
= gfc_to_single_character (slen
, dest
);
2832 dlen
= build_int_cst (size_type_node
, 1);
2836 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
2837 ssc
= gfc_to_single_character (slen
, src
);
2838 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
2839 dsc
= gfc_to_single_character (dlen
, dest
);
2842 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2844 gfc_add_modify_expr (block
, dsc
, ssc
);
2848 /* Do nothing if the destination length is zero. */
2849 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2850 build_int_cst (size_type_node
, 0));
2852 /* The following code was previously in _gfortran_copy_string:
2854 // The two strings may overlap so we use memmove.
2856 copy_string (GFC_INTEGER_4 destlen, char * dest,
2857 GFC_INTEGER_4 srclen, const char * src)
2859 if (srclen >= destlen)
2861 // This will truncate if too long.
2862 memmove (dest, src, destlen);
2866 memmove (dest, src, srclen);
2868 memset (&dest[srclen], ' ', destlen - srclen);
2872 We're now doing it here for better optimization, but the logic
2876 dest
= fold_convert (pvoid_type_node
, dest
);
2878 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
2881 src
= fold_convert (pvoid_type_node
, src
);
2883 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
2885 /* Truncate string if source is too long. */
2886 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2887 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2888 3, dest
, src
, dlen
);
2890 /* Else copy and pad with spaces. */
2891 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2892 3, dest
, src
, slen
);
2894 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
2895 fold_convert (sizetype
, slen
));
2896 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2898 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2899 lang_hooks
.to_target_charset (' ')),
2900 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2903 gfc_init_block (&tempblock
);
2904 gfc_add_expr_to_block (&tempblock
, tmp3
);
2905 gfc_add_expr_to_block (&tempblock
, tmp4
);
2906 tmp3
= gfc_finish_block (&tempblock
);
2908 /* The whole copy_string function is there. */
2909 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2910 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2911 gfc_add_expr_to_block (block
, tmp
);
2915 /* Translate a statement function.
2916 The value of a statement function reference is obtained by evaluating the
2917 expression using the values of the actual arguments for the values of the
2918 corresponding dummy arguments. */
2921 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2925 gfc_formal_arglist
*fargs
;
2926 gfc_actual_arglist
*args
;
2929 gfc_saved_var
*saved_vars
;
2935 sym
= expr
->symtree
->n
.sym
;
2936 args
= expr
->value
.function
.actual
;
2937 gfc_init_se (&lse
, NULL
);
2938 gfc_init_se (&rse
, NULL
);
2941 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2943 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2944 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2946 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2948 /* Each dummy shall be specified, explicitly or implicitly, to be
2950 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2953 /* Create a temporary to hold the value. */
2954 type
= gfc_typenode_for_spec (&fsym
->ts
);
2955 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2957 if (fsym
->ts
.type
== BT_CHARACTER
)
2959 /* Copy string arguments. */
2962 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2963 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2965 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2966 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2969 gfc_conv_expr (&rse
, args
->expr
);
2970 gfc_conv_string_parameter (&rse
);
2971 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2972 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2974 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2976 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2977 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2981 /* For everything else, just evaluate the expression. */
2982 gfc_conv_expr (&lse
, args
->expr
);
2984 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2985 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2986 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2992 /* Use the temporary variables in place of the real ones. */
2993 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2994 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2996 gfc_conv_expr (se
, sym
->value
);
2998 if (sym
->ts
.type
== BT_CHARACTER
)
3000 gfc_conv_const_charlen (sym
->ts
.cl
);
3002 /* Force the expression to the correct length. */
3003 if (!INTEGER_CST_P (se
->string_length
)
3004 || tree_int_cst_lt (se
->string_length
,
3005 sym
->ts
.cl
->backend_decl
))
3007 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3008 tmp
= gfc_create_var (type
, sym
->name
);
3009 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3010 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3011 se
->string_length
, se
->expr
);
3014 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3017 /* Restore the original variables. */
3018 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3019 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3020 gfc_free (saved_vars
);
3024 /* Translate a function expression. */
3027 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3031 if (expr
->value
.function
.isym
)
3033 gfc_conv_intrinsic_function (se
, expr
);
3037 /* We distinguish statement functions from general functions to improve
3038 runtime performance. */
3039 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3041 gfc_conv_statement_function (se
, expr
);
3045 /* expr.value.function.esym is the resolved (specific) function symbol for
3046 most functions. However this isn't set for dummy procedures. */
3047 sym
= expr
->value
.function
.esym
;
3049 sym
= expr
->symtree
->n
.sym
;
3050 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
3055 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3057 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3058 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3060 gfc_conv_tmp_array_ref (se
);
3061 gfc_advance_se_ss_chain (se
);
3065 /* Build a static initializer. EXPR is the expression for the initial value.
3066 The other parameters describe the variable of the component being
3067 initialized. EXPR may be null. */
3070 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3071 bool array
, bool pointer
)
3075 if (!(expr
|| pointer
))
3078 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3079 (these are the only two iso_c_binding derived types that can be
3080 used as initialization expressions). If so, we need to modify
3081 the 'expr' to be that for a (void *). */
3082 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3083 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3085 gfc_symbol
*derived
= expr
->ts
.derived
;
3087 expr
= gfc_int_expr (0);
3089 /* The derived symbol has already been converted to a (void *). Use
3091 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3092 expr
->ts
.kind
= derived
->ts
.kind
;
3097 /* Arrays need special handling. */
3099 return gfc_build_null_descriptor (type
);
3101 return gfc_conv_array_initializer (type
, expr
);
3104 return fold_convert (type
, null_pointer_node
);
3110 gfc_init_se (&se
, NULL
);
3111 gfc_conv_structure (&se
, expr
, 1);
3115 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3118 gfc_init_se (&se
, NULL
);
3119 gfc_conv_constant (&se
, expr
);
3126 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3138 gfc_start_block (&block
);
3140 /* Initialize the scalarizer. */
3141 gfc_init_loopinfo (&loop
);
3143 gfc_init_se (&lse
, NULL
);
3144 gfc_init_se (&rse
, NULL
);
3147 rss
= gfc_walk_expr (expr
);
3148 if (rss
== gfc_ss_terminator
)
3150 /* The rhs is scalar. Add a ss for the expression. */
3151 rss
= gfc_get_ss ();
3152 rss
->next
= gfc_ss_terminator
;
3153 rss
->type
= GFC_SS_SCALAR
;
3157 /* Create a SS for the destination. */
3158 lss
= gfc_get_ss ();
3159 lss
->type
= GFC_SS_COMPONENT
;
3161 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3162 lss
->next
= gfc_ss_terminator
;
3163 lss
->data
.info
.dimen
= cm
->as
->rank
;
3164 lss
->data
.info
.descriptor
= dest
;
3165 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3166 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3167 for (n
= 0; n
< cm
->as
->rank
; n
++)
3169 lss
->data
.info
.dim
[n
] = n
;
3170 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3171 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3173 mpz_init (lss
->shape
[n
]);
3174 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3175 cm
->as
->lower
[n
]->value
.integer
);
3176 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3179 /* Associate the SS with the loop. */
3180 gfc_add_ss_to_loop (&loop
, lss
);
3181 gfc_add_ss_to_loop (&loop
, rss
);
3183 /* Calculate the bounds of the scalarization. */
3184 gfc_conv_ss_startstride (&loop
);
3186 /* Setup the scalarizing loops. */
3187 gfc_conv_loop_setup (&loop
);
3189 /* Setup the gfc_se structures. */
3190 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3191 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3194 gfc_mark_ss_chain_used (rss
, 1);
3196 gfc_mark_ss_chain_used (lss
, 1);
3198 /* Start the scalarized loop body. */
3199 gfc_start_scalarized_body (&loop
, &body
);
3201 gfc_conv_tmp_array_ref (&lse
);
3202 if (cm
->ts
.type
== BT_CHARACTER
)
3203 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3205 gfc_conv_expr (&rse
, expr
);
3207 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3208 gfc_add_expr_to_block (&body
, tmp
);
3210 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3212 /* Generate the copying loops. */
3213 gfc_trans_scalarizing_loops (&loop
, &body
);
3215 /* Wrap the whole thing up. */
3216 gfc_add_block_to_block (&block
, &loop
.pre
);
3217 gfc_add_block_to_block (&block
, &loop
.post
);
3219 for (n
= 0; n
< cm
->as
->rank
; n
++)
3220 mpz_clear (lss
->shape
[n
]);
3221 gfc_free (lss
->shape
);
3223 gfc_cleanup_loop (&loop
);
3225 return gfc_finish_block (&block
);
3229 /* Assign a single component of a derived type constructor. */
3232 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3242 gfc_start_block (&block
);
3246 gfc_init_se (&se
, NULL
);
3247 /* Pointer component. */
3250 /* Array pointer. */
3251 if (expr
->expr_type
== EXPR_NULL
)
3252 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3255 rss
= gfc_walk_expr (expr
);
3256 se
.direct_byref
= 1;
3258 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3259 gfc_add_block_to_block (&block
, &se
.pre
);
3260 gfc_add_block_to_block (&block
, &se
.post
);
3265 /* Scalar pointers. */
3266 se
.want_pointer
= 1;
3267 gfc_conv_expr (&se
, expr
);
3268 gfc_add_block_to_block (&block
, &se
.pre
);
3269 gfc_add_modify_expr (&block
, dest
,
3270 fold_convert (TREE_TYPE (dest
), se
.expr
));
3271 gfc_add_block_to_block (&block
, &se
.post
);
3274 else if (cm
->dimension
)
3276 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3277 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3278 else if (cm
->allocatable
)
3282 gfc_init_se (&se
, NULL
);
3284 rss
= gfc_walk_expr (expr
);
3285 se
.want_pointer
= 0;
3286 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3287 gfc_add_block_to_block (&block
, &se
.pre
);
3289 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3290 gfc_add_modify_expr (&block
, dest
, tmp
);
3292 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3293 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3296 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3297 TREE_TYPE(cm
->backend_decl
),
3300 gfc_add_expr_to_block (&block
, tmp
);
3302 gfc_add_block_to_block (&block
, &se
.post
);
3303 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3305 /* Shift the lbound and ubound of temporaries to being unity, rather
3306 than zero, based. Calculate the offset for all cases. */
3307 offset
= gfc_conv_descriptor_offset (dest
);
3308 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3309 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3310 for (n
= 0; n
< expr
->rank
; n
++)
3312 if (expr
->expr_type
!= EXPR_VARIABLE
3313 && expr
->expr_type
!= EXPR_CONSTANT
)
3316 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3317 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3318 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3319 gfc_add_modify_expr (&block
, tmp
,
3320 fold_build2 (PLUS_EXPR
,
3321 gfc_array_index_type
,
3322 span
, gfc_index_one_node
));
3323 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3324 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3326 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3327 gfc_conv_descriptor_lbound (dest
,
3329 gfc_conv_descriptor_stride (dest
,
3331 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3332 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3333 gfc_add_modify_expr (&block
, offset
, tmp
);
3338 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3339 gfc_add_expr_to_block (&block
, tmp
);
3342 else if (expr
->ts
.type
== BT_DERIVED
)
3344 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3346 gfc_init_se (&se
, NULL
);
3347 gfc_conv_expr (&se
, expr
);
3348 gfc_add_modify_expr (&block
, dest
,
3349 fold_convert (TREE_TYPE (dest
), se
.expr
));
3353 /* Nested constructors. */
3354 tmp
= gfc_trans_structure_assign (dest
, expr
);
3355 gfc_add_expr_to_block (&block
, tmp
);
3360 /* Scalar component. */
3361 gfc_init_se (&se
, NULL
);
3362 gfc_init_se (&lse
, NULL
);
3364 gfc_conv_expr (&se
, expr
);
3365 if (cm
->ts
.type
== BT_CHARACTER
)
3366 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3368 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3369 gfc_add_expr_to_block (&block
, tmp
);
3371 return gfc_finish_block (&block
);
3374 /* Assign a derived type constructor to a variable. */
3377 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3385 gfc_start_block (&block
);
3386 cm
= expr
->ts
.derived
->components
;
3387 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3389 /* Skip absent members in default initializers. */
3393 /* Update the type/kind of the expression if it represents either
3394 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3395 be the first place reached for initializing output variables that
3396 have components of type C_PTR/C_FUNPTR that are initialized. */
3397 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3398 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3400 c
->expr
->expr_type
= EXPR_NULL
;
3401 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3402 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3403 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3406 field
= cm
->backend_decl
;
3407 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3408 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3409 gfc_add_expr_to_block (&block
, tmp
);
3411 return gfc_finish_block (&block
);
3414 /* Build an expression for a constructor. If init is nonzero then
3415 this is part of a static variable initializer. */
3418 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3425 VEC(constructor_elt
,gc
) *v
= NULL
;
3427 gcc_assert (se
->ss
== NULL
);
3428 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3429 type
= gfc_typenode_for_spec (&expr
->ts
);
3433 /* Create a temporary variable and fill it in. */
3434 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3435 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3436 gfc_add_expr_to_block (&se
->pre
, tmp
);
3440 cm
= expr
->ts
.derived
->components
;
3442 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3444 /* Skip absent members in default initializers and allocatable
3445 components. Although the latter have a default initializer
3446 of EXPR_NULL,... by default, the static nullify is not needed
3447 since this is done every time we come into scope. */
3448 if (!c
->expr
|| cm
->allocatable
)
3451 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3452 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3454 /* Append it to the constructor list. */
3455 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3457 se
->expr
= build_constructor (type
, v
);
3460 TREE_CONSTANT(se
->expr
) = 1;
3461 TREE_INVARIANT(se
->expr
) = 1;
3466 /* Translate a substring expression. */
3469 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3475 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3477 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3478 expr
->value
.character
.string
);
3479 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3480 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3483 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3487 /* Entry point for expression translation. Evaluates a scalar quantity.
3488 EXPR is the expression to be translated, and SE is the state structure if
3489 called from within the scalarized. */
3492 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3494 if (se
->ss
&& se
->ss
->expr
== expr
3495 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3497 /* Substitute a scalar expression evaluated outside the scalarization
3499 se
->expr
= se
->ss
->data
.scalar
.expr
;
3500 se
->string_length
= se
->ss
->string_length
;
3501 gfc_advance_se_ss_chain (se
);
3505 /* We need to convert the expressions for the iso_c_binding derived types.
3506 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3507 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3508 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3509 updated to be an integer with a kind equal to the size of a (void *). */
3510 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3511 && expr
->ts
.derived
->attr
.is_iso_c
)
3513 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3514 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3516 /* Set expr_type to EXPR_NULL, which will result in
3517 null_pointer_node being used below. */
3518 expr
->expr_type
= EXPR_NULL
;
3522 /* Update the type/kind of the expression to be what the new
3523 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3524 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3525 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3526 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3530 switch (expr
->expr_type
)
3533 gfc_conv_expr_op (se
, expr
);
3537 gfc_conv_function_expr (se
, expr
);
3541 gfc_conv_constant (se
, expr
);
3545 gfc_conv_variable (se
, expr
);
3549 se
->expr
= null_pointer_node
;
3552 case EXPR_SUBSTRING
:
3553 gfc_conv_substring_expr (se
, expr
);
3556 case EXPR_STRUCTURE
:
3557 gfc_conv_structure (se
, expr
, 0);
3561 gfc_conv_array_constructor_expr (se
, expr
);
3570 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3571 of an assignment. */
3573 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3575 gfc_conv_expr (se
, expr
);
3576 /* All numeric lvalues should have empty post chains. If not we need to
3577 figure out a way of rewriting an lvalue so that it has no post chain. */
3578 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3581 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3582 numeric expressions. Used for scalar values where inserting cleanup code
3585 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3589 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3590 gfc_conv_expr (se
, expr
);
3593 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3594 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3596 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3600 /* Helper to translate an expression and convert it to a particular type. */
3602 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3604 gfc_conv_expr_val (se
, expr
);
3605 se
->expr
= convert (type
, se
->expr
);
3609 /* Converts an expression so that it can be passed by reference. Scalar
3613 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3617 if (se
->ss
&& se
->ss
->expr
== expr
3618 && se
->ss
->type
== GFC_SS_REFERENCE
)
3620 se
->expr
= se
->ss
->data
.scalar
.expr
;
3621 se
->string_length
= se
->ss
->string_length
;
3622 gfc_advance_se_ss_chain (se
);
3626 if (expr
->ts
.type
== BT_CHARACTER
)
3628 gfc_conv_expr (se
, expr
);
3629 gfc_conv_string_parameter (se
);
3633 if (expr
->expr_type
== EXPR_VARIABLE
)
3635 se
->want_pointer
= 1;
3636 gfc_conv_expr (se
, expr
);
3639 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3640 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3641 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3647 if (expr
->expr_type
== EXPR_FUNCTION
3648 && expr
->symtree
->n
.sym
->attr
.pointer
3649 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3651 se
->want_pointer
= 1;
3652 gfc_conv_expr (se
, expr
);
3653 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3654 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3660 gfc_conv_expr (se
, expr
);
3662 /* Create a temporary var to hold the value. */
3663 if (TREE_CONSTANT (se
->expr
))
3665 tree tmp
= se
->expr
;
3666 STRIP_TYPE_NOPS (tmp
);
3667 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3668 DECL_INITIAL (var
) = tmp
;
3669 TREE_STATIC (var
) = 1;
3674 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3675 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3677 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3679 /* Take the address of that value. */
3680 se
->expr
= build_fold_addr_expr (var
);
3685 gfc_trans_pointer_assign (gfc_code
* code
)
3687 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3691 /* Generate code for a pointer assignment. */
3694 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3706 gfc_start_block (&block
);
3708 gfc_init_se (&lse
, NULL
);
3710 lss
= gfc_walk_expr (expr1
);
3711 rss
= gfc_walk_expr (expr2
);
3712 if (lss
== gfc_ss_terminator
)
3714 /* Scalar pointers. */
3715 lse
.want_pointer
= 1;
3716 gfc_conv_expr (&lse
, expr1
);
3717 gcc_assert (rss
== gfc_ss_terminator
);
3718 gfc_init_se (&rse
, NULL
);
3719 rse
.want_pointer
= 1;
3720 gfc_conv_expr (&rse
, expr2
);
3721 gfc_add_block_to_block (&block
, &lse
.pre
);
3722 gfc_add_block_to_block (&block
, &rse
.pre
);
3723 gfc_add_modify_expr (&block
, lse
.expr
,
3724 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3725 gfc_add_block_to_block (&block
, &rse
.post
);
3726 gfc_add_block_to_block (&block
, &lse
.post
);
3730 /* Array pointer. */
3731 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3732 switch (expr2
->expr_type
)
3735 /* Just set the data pointer to null. */
3736 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3740 /* Assign directly to the pointer's descriptor. */
3741 lse
.direct_byref
= 1;
3742 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3744 /* If this is a subreference array pointer assignment, use the rhs
3745 descriptor element size for the lhs span. */
3746 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3748 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3749 gfc_init_se (&rse
, NULL
);
3750 rse
.descriptor_only
= 1;
3751 gfc_conv_expr (&rse
, expr2
);
3752 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3753 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3754 if (!INTEGER_CST_P (tmp
))
3755 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3756 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3762 /* Assign to a temporary descriptor and then copy that
3763 temporary to the pointer. */
3765 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3768 lse
.direct_byref
= 1;
3769 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3770 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3773 gfc_add_block_to_block (&block
, &lse
.pre
);
3774 gfc_add_block_to_block (&block
, &lse
.post
);
3776 return gfc_finish_block (&block
);
3780 /* Makes sure se is suitable for passing as a function string parameter. */
3781 /* TODO: Need to check all callers fo this function. It may be abused. */
3784 gfc_conv_string_parameter (gfc_se
* se
)
3788 if (TREE_CODE (se
->expr
) == STRING_CST
)
3790 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3794 type
= TREE_TYPE (se
->expr
);
3795 if (TYPE_STRING_FLAG (type
))
3797 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3798 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3801 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3803 type
= build_pointer_type (type
);
3804 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3808 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3809 gcc_assert (se
->string_length
3810 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3814 /* Generate code for assignment of scalar variables. Includes character
3815 strings and derived types with allocatable components. */
3818 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3819 bool l_is_temp
, bool r_is_var
)
3825 gfc_init_block (&block
);
3827 if (ts
.type
== BT_CHARACTER
)
3832 if (lse
->string_length
!= NULL_TREE
)
3834 gfc_conv_string_parameter (lse
);
3835 gfc_add_block_to_block (&block
, &lse
->pre
);
3836 llen
= lse
->string_length
;
3839 if (rse
->string_length
!= NULL_TREE
)
3841 gcc_assert (rse
->string_length
!= NULL_TREE
);
3842 gfc_conv_string_parameter (rse
);
3843 gfc_add_block_to_block (&block
, &rse
->pre
);
3844 rlen
= rse
->string_length
;
3847 gfc_trans_string_copy (&block
, llen
, lse
->expr
, rlen
, rse
->expr
);
3849 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3853 /* Are the rhs and the lhs the same? */
3856 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3857 build_fold_addr_expr (lse
->expr
),
3858 build_fold_addr_expr (rse
->expr
));
3859 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3862 /* Deallocate the lhs allocated components as long as it is not
3863 the same as the rhs. This must be done following the assignment
3864 to prevent deallocating data that could be used in the rhs
3868 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3869 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3871 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3872 gfc_add_expr_to_block (&lse
->post
, tmp
);
3875 gfc_add_block_to_block (&block
, &rse
->pre
);
3876 gfc_add_block_to_block (&block
, &lse
->pre
);
3878 gfc_add_modify_expr (&block
, lse
->expr
,
3879 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3881 /* Do a deep copy if the rhs is a variable, if it is not the
3885 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3886 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3887 gfc_add_expr_to_block (&block
, tmp
);
3892 gfc_add_block_to_block (&block
, &lse
->pre
);
3893 gfc_add_block_to_block (&block
, &rse
->pre
);
3895 gfc_add_modify_expr (&block
, lse
->expr
,
3896 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3899 gfc_add_block_to_block (&block
, &lse
->post
);
3900 gfc_add_block_to_block (&block
, &rse
->post
);
3902 return gfc_finish_block (&block
);
3906 /* Try to translate array(:) = func (...), where func is a transformational
3907 array function, without using a temporary. Returns NULL is this isn't the
3911 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3916 bool seen_array_ref
;
3918 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3919 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3922 /* Elemental functions don't need a temporary anyway. */
3923 if (expr2
->value
.function
.esym
!= NULL
3924 && expr2
->value
.function
.esym
->attr
.elemental
)
3927 /* Fail if EXPR1 can't be expressed as a descriptor. */
3928 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3931 /* Functions returning pointers need temporaries. */
3932 if (expr2
->symtree
->n
.sym
->attr
.pointer
3933 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3936 /* Character array functions need temporaries unless the
3937 character lengths are the same. */
3938 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3940 if (expr1
->ts
.cl
->length
== NULL
3941 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3944 if (expr2
->ts
.cl
->length
== NULL
3945 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3948 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3949 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3953 /* Check that no LHS component references appear during an array
3954 reference. This is needed because we do not have the means to
3955 span any arbitrary stride with an array descriptor. This check
3956 is not needed for the rhs because the function result has to be
3958 seen_array_ref
= false;
3959 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3961 if (ref
->type
== REF_ARRAY
)
3962 seen_array_ref
= true;
3963 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3967 /* Check for a dependency. */
3968 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3969 expr2
->value
.function
.esym
,
3970 expr2
->value
.function
.actual
))
3973 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3975 gcc_assert (expr2
->value
.function
.isym
3976 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3977 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3979 ss
= gfc_walk_expr (expr1
);
3980 gcc_assert (ss
!= gfc_ss_terminator
);
3981 gfc_init_se (&se
, NULL
);
3982 gfc_start_block (&se
.pre
);
3983 se
.want_pointer
= 1;
3985 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3987 se
.direct_byref
= 1;
3988 se
.ss
= gfc_walk_expr (expr2
);
3989 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3990 gfc_conv_function_expr (&se
, expr2
);
3991 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3993 return gfc_finish_block (&se
.pre
);
3996 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3999 is_zero_initializer_p (gfc_expr
* expr
)
4001 if (expr
->expr_type
!= EXPR_CONSTANT
)
4004 /* We ignore constants with prescribed memory representations for now. */
4005 if (expr
->representation
.string
)
4008 switch (expr
->ts
.type
)
4011 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4014 return mpfr_zero_p (expr
->value
.real
)
4015 && MPFR_SIGN (expr
->value
.real
) >= 0;
4018 return expr
->value
.logical
== 0;
4021 return mpfr_zero_p (expr
->value
.complex.r
)
4022 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
4023 && mpfr_zero_p (expr
->value
.complex.i
)
4024 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
4032 /* Try to efficiently translate array(:) = 0. Return NULL if this
4036 gfc_trans_zero_assign (gfc_expr
* expr
)
4038 tree dest
, len
, type
;
4042 sym
= expr
->symtree
->n
.sym
;
4043 dest
= gfc_get_symbol_decl (sym
);
4045 type
= TREE_TYPE (dest
);
4046 if (POINTER_TYPE_P (type
))
4047 type
= TREE_TYPE (type
);
4048 if (!GFC_ARRAY_TYPE_P (type
))
4051 /* Determine the length of the array. */
4052 len
= GFC_TYPE_ARRAY_SIZE (type
);
4053 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4056 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4057 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4058 fold_convert (gfc_array_index_type
, tmp
));
4060 /* Convert arguments to the correct types. */
4061 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4062 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4064 dest
= fold_convert (pvoid_type_node
, dest
);
4065 len
= fold_convert (size_type_node
, len
);
4067 /* Construct call to __builtin_memset. */
4068 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4069 3, dest
, integer_zero_node
, len
);
4070 return fold_convert (void_type_node
, tmp
);
4074 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4075 that constructs the call to __builtin_memcpy. */
4078 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4082 /* Convert arguments to the correct types. */
4083 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4084 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4086 dst
= fold_convert (pvoid_type_node
, dst
);
4088 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4089 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4091 src
= fold_convert (pvoid_type_node
, src
);
4093 len
= fold_convert (size_type_node
, len
);
4095 /* Construct call to __builtin_memcpy. */
4096 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4097 return fold_convert (void_type_node
, tmp
);
4101 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4102 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4103 source/rhs, both are gfc_full_array_ref_p which have been checked for
4107 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4109 tree dst
, dlen
, dtype
;
4110 tree src
, slen
, stype
;
4113 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4114 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4116 dtype
= TREE_TYPE (dst
);
4117 if (POINTER_TYPE_P (dtype
))
4118 dtype
= TREE_TYPE (dtype
);
4119 stype
= TREE_TYPE (src
);
4120 if (POINTER_TYPE_P (stype
))
4121 stype
= TREE_TYPE (stype
);
4123 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4126 /* Determine the lengths of the arrays. */
4127 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4128 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4130 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4131 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4132 fold_convert (gfc_array_index_type
, tmp
));
4134 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4135 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4137 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4138 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4139 fold_convert (gfc_array_index_type
, tmp
));
4141 /* Sanity check that they are the same. This should always be
4142 the case, as we should already have checked for conformance. */
4143 if (!tree_int_cst_equal (slen
, dlen
))
4146 return gfc_build_memcpy_call (dst
, src
, dlen
);
4150 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4151 this can't be done. EXPR1 is the destination/lhs for which
4152 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4155 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4157 unsigned HOST_WIDE_INT nelem
;
4163 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4167 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4168 dtype
= TREE_TYPE (dst
);
4169 if (POINTER_TYPE_P (dtype
))
4170 dtype
= TREE_TYPE (dtype
);
4171 if (!GFC_ARRAY_TYPE_P (dtype
))
4174 /* Determine the lengths of the array. */
4175 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4176 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4179 /* Confirm that the constructor is the same size. */
4180 if (compare_tree_int (len
, nelem
) != 0)
4183 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4184 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4185 fold_convert (gfc_array_index_type
, tmp
));
4187 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4188 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4190 stype
= TREE_TYPE (src
);
4191 if (POINTER_TYPE_P (stype
))
4192 stype
= TREE_TYPE (stype
);
4194 return gfc_build_memcpy_call (dst
, src
, len
);
4198 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4199 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4202 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4207 gfc_ss
*lss_section
;
4215 /* Assignment of the form lhs = rhs. */
4216 gfc_start_block (&block
);
4218 gfc_init_se (&lse
, NULL
);
4219 gfc_init_se (&rse
, NULL
);
4222 lss
= gfc_walk_expr (expr1
);
4224 if (lss
!= gfc_ss_terminator
)
4226 /* The assignment needs scalarization. */
4229 /* Find a non-scalar SS from the lhs. */
4230 while (lss_section
!= gfc_ss_terminator
4231 && lss_section
->type
!= GFC_SS_SECTION
)
4232 lss_section
= lss_section
->next
;
4234 gcc_assert (lss_section
!= gfc_ss_terminator
);
4236 /* Initialize the scalarizer. */
4237 gfc_init_loopinfo (&loop
);
4240 rss
= gfc_walk_expr (expr2
);
4241 if (rss
== gfc_ss_terminator
)
4243 /* The rhs is scalar. Add a ss for the expression. */
4244 rss
= gfc_get_ss ();
4245 rss
->next
= gfc_ss_terminator
;
4246 rss
->type
= GFC_SS_SCALAR
;
4249 /* Associate the SS with the loop. */
4250 gfc_add_ss_to_loop (&loop
, lss
);
4251 gfc_add_ss_to_loop (&loop
, rss
);
4253 /* Calculate the bounds of the scalarization. */
4254 gfc_conv_ss_startstride (&loop
);
4255 /* Resolve any data dependencies in the statement. */
4256 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4257 /* Setup the scalarizing loops. */
4258 gfc_conv_loop_setup (&loop
);
4260 /* Setup the gfc_se structures. */
4261 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4262 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4265 gfc_mark_ss_chain_used (rss
, 1);
4266 if (loop
.temp_ss
== NULL
)
4269 gfc_mark_ss_chain_used (lss
, 1);
4273 lse
.ss
= loop
.temp_ss
;
4274 gfc_mark_ss_chain_used (lss
, 3);
4275 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4278 /* Start the scalarized loop body. */
4279 gfc_start_scalarized_body (&loop
, &body
);
4282 gfc_init_block (&body
);
4284 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4286 /* Translate the expression. */
4287 gfc_conv_expr (&rse
, expr2
);
4291 gfc_conv_tmp_array_ref (&lse
);
4292 gfc_advance_se_ss_chain (&lse
);
4295 gfc_conv_expr (&lse
, expr1
);
4297 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4298 l_is_temp
|| init_flag
,
4299 expr2
->expr_type
== EXPR_VARIABLE
);
4300 gfc_add_expr_to_block (&body
, tmp
);
4302 if (lss
== gfc_ss_terminator
)
4304 /* Use the scalar assignment as is. */
4305 gfc_add_block_to_block (&block
, &body
);
4309 gcc_assert (lse
.ss
== gfc_ss_terminator
4310 && rse
.ss
== gfc_ss_terminator
);
4314 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4316 /* We need to copy the temporary to the actual lhs. */
4317 gfc_init_se (&lse
, NULL
);
4318 gfc_init_se (&rse
, NULL
);
4319 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4320 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4322 rse
.ss
= loop
.temp_ss
;
4325 gfc_conv_tmp_array_ref (&rse
);
4326 gfc_advance_se_ss_chain (&rse
);
4327 gfc_conv_expr (&lse
, expr1
);
4329 gcc_assert (lse
.ss
== gfc_ss_terminator
4330 && rse
.ss
== gfc_ss_terminator
);
4332 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4334 gfc_add_expr_to_block (&body
, tmp
);
4337 /* Generate the copying loops. */
4338 gfc_trans_scalarizing_loops (&loop
, &body
);
4340 /* Wrap the whole thing up. */
4341 gfc_add_block_to_block (&block
, &loop
.pre
);
4342 gfc_add_block_to_block (&block
, &loop
.post
);
4344 gfc_cleanup_loop (&loop
);
4347 return gfc_finish_block (&block
);
4351 /* Check whether EXPR is a copyable array. */
4354 copyable_array_p (gfc_expr
* expr
)
4356 if (expr
->expr_type
!= EXPR_VARIABLE
)
4359 /* First check it's an array. */
4360 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4363 if (!gfc_full_array_ref_p (expr
->ref
))
4366 /* Next check that it's of a simple enough type. */
4367 switch (expr
->ts
.type
)
4379 return !expr
->ts
.derived
->attr
.alloc_comp
;
4388 /* Translate an assignment. */
4391 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4395 /* Special case a single function returning an array. */
4396 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4398 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4403 /* Special case assigning an array to zero. */
4404 if (copyable_array_p (expr1
)
4405 && is_zero_initializer_p (expr2
))
4407 tmp
= gfc_trans_zero_assign (expr1
);
4412 /* Special case copying one array to another. */
4413 if (copyable_array_p (expr1
)
4414 && copyable_array_p (expr2
)
4415 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4416 && !gfc_check_dependency (expr1
, expr2
, 0))
4418 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4423 /* Special case initializing an array from a constant array constructor. */
4424 if (copyable_array_p (expr1
)
4425 && expr2
->expr_type
== EXPR_ARRAY
4426 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4428 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4433 /* Fallback to the scalarizer to generate explicit loops. */
4434 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4438 gfc_trans_init_assign (gfc_code
* code
)
4440 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4444 gfc_trans_assign (gfc_code
* code
)
4446 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);