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"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
46 static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
55 dest
->loop
= src
->loop
;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
68 memset (se
, 0, sizeof (gfc_se
));
69 gfc_init_block (&se
->pre
);
70 gfc_init_block (&se
->post
);
75 gfc_copy_se_loopvars (se
, parent
);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se
* se
)
88 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se
* se
)
112 if (CONSTANT_CLASS_P (se
->expr
))
115 /* We need a temporary for this result. */
116 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
117 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol
* sym
)
130 gcc_assert (sym
->attr
.dummy
);
132 decl
= gfc_get_symbol_decl (sym
);
133 if (TREE_CODE (decl
) != PARM_DECL
)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
139 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 return build2 (NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
154 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
155 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
156 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
158 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
160 if (ts
.type
== BT_CHARACTER
)
162 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
163 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
164 se
->string_length
, tmp
);
165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
166 se
->string_length
= tmp
;
172 /* Get the character length of an expression, looking through gfc_refs
176 gfc_get_expr_charlen (gfc_expr
*e
)
181 gcc_assert (e
->expr_type
== EXPR_VARIABLE
182 && e
->ts
.type
== BT_CHARACTER
);
184 length
= NULL
; /* To silence compiler warning. */
186 /* First candidate: if the variable is of type CHARACTER, the
187 expression's length could be the length of the character
189 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
190 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
192 /* Look through the reference chain for component references. */
193 for (r
= e
->ref
; r
; r
= r
->next
)
198 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
199 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
207 /* We should never got substring references here. These will be
208 broken down by the scalarizer. */
213 gcc_assert (length
!= NULL
);
219 /* Generate code to initialize a string length variable. Returns the
223 gfc_conv_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
227 gfc_init_se (&se
, NULL
);
228 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
229 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
230 build_int_cst (gfc_charlen_type_node
, 0));
231 gfc_add_block_to_block (pblock
, &se
.pre
);
233 if (cl
->backend_decl
)
234 gfc_add_modify_expr (pblock
, cl
->backend_decl
, se
.expr
);
236 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
241 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
242 const char *name
, locus
*where
)
252 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
253 type
= build_pointer_type (type
);
256 gfc_init_se (&start
, se
);
257 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
258 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
260 if (integer_onep (start
.expr
))
261 gfc_conv_string_parameter (se
);
264 /* Avoid multiple evaluation of substring start. */
265 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
266 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
268 /* Change the start of the string. */
269 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
272 tmp
= build_fold_indirect_ref (se
->expr
);
273 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
274 se
->expr
= gfc_build_addr_expr (type
, tmp
);
277 /* Length = end + 1 - start. */
278 gfc_init_se (&end
, se
);
279 if (ref
->u
.ss
.end
== NULL
)
280 end
.expr
= se
->string_length
;
283 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
284 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
286 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
287 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
289 if (flag_bounds_check
)
291 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
292 start
.expr
, end
.expr
);
294 /* Check lower bound. */
295 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
296 build_int_cst (gfc_charlen_type_node
, 1));
297 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
300 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
301 "is less than one", name
);
303 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
305 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
306 fold_convert (long_integer_type_node
,
310 /* Check upper bound. */
311 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
313 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
316 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
317 "exceeds string length (%%ld)", name
);
319 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
320 "exceeds string length (%%ld)");
321 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
322 fold_convert (long_integer_type_node
, end
.expr
),
323 fold_convert (long_integer_type_node
,
328 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
329 build_int_cst (gfc_charlen_type_node
, 1),
331 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
332 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
333 build_int_cst (gfc_charlen_type_node
, 0));
334 se
->string_length
= tmp
;
338 /* Convert a derived type component reference. */
341 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
348 c
= ref
->u
.c
.component
;
350 gcc_assert (c
->backend_decl
);
352 field
= c
->backend_decl
;
353 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
355 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
359 if (c
->ts
.type
== BT_CHARACTER
)
361 tmp
= c
->ts
.cl
->backend_decl
;
362 /* Components must always be constant length. */
363 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
364 se
->string_length
= tmp
;
367 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
368 se
->expr
= build_fold_indirect_ref (se
->expr
);
372 /* Return the contents of a variable. Also handles reference/pointer
373 variables (all Fortran pointer references are implicit). */
376 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
383 bool alternate_entry
;
386 sym
= expr
->symtree
->n
.sym
;
389 /* Check that something hasn't gone horribly wrong. */
390 gcc_assert (se
->ss
!= gfc_ss_terminator
);
391 gcc_assert (se
->ss
->expr
== expr
);
393 /* A scalarized term. We already know the descriptor. */
394 se
->expr
= se
->ss
->data
.info
.descriptor
;
395 se
->string_length
= se
->ss
->string_length
;
396 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
397 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
402 tree se_expr
= NULL_TREE
;
404 se
->expr
= gfc_get_symbol_decl (sym
);
406 /* Deal with references to a parent results or entries by storing
407 the current_function_decl and moving to the parent_decl. */
408 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
409 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
410 && sym
->result
== sym
;
411 entry_master
= sym
->attr
.result
412 && sym
->ns
->proc_name
->attr
.entry_master
413 && !gfc_return_by_reference (sym
->ns
->proc_name
);
414 parent_decl
= DECL_CONTEXT (current_function_decl
);
416 if ((se
->expr
== parent_decl
&& return_value
)
417 || (sym
->ns
&& sym
->ns
->proc_name
419 && sym
->ns
->proc_name
->backend_decl
== parent_decl
420 && (alternate_entry
|| entry_master
)))
425 /* Special case for assigning the return value of a function.
426 Self recursive functions must have an explicit return value. */
427 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
428 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
430 /* Similarly for alternate entry points. */
431 else if (alternate_entry
432 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
435 gfc_entry_list
*el
= NULL
;
437 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
440 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
445 else if (entry_master
446 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
448 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
453 /* Procedure actual arguments. */
454 else if (sym
->attr
.flavor
== FL_PROCEDURE
455 && se
->expr
!= current_function_decl
)
457 gcc_assert (se
->want_pointer
);
458 if (!sym
->attr
.dummy
)
460 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
461 se
->expr
= build_fold_addr_expr (se
->expr
);
467 /* Dereference the expression, where needed. Since characters
468 are entirely different from other types, they are treated
470 if (sym
->ts
.type
== BT_CHARACTER
)
472 /* Dereference character pointer dummy arguments
474 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
476 || sym
->attr
.function
477 || sym
->attr
.result
))
478 se
->expr
= build_fold_indirect_ref (se
->expr
);
481 else if (!sym
->attr
.value
)
483 /* Dereference non-character scalar dummy arguments. */
484 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
485 se
->expr
= build_fold_indirect_ref (se
->expr
);
487 /* Dereference scalar hidden result. */
488 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
489 && (sym
->attr
.function
|| sym
->attr
.result
)
490 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
491 se
->expr
= build_fold_indirect_ref (se
->expr
);
493 /* Dereference non-character pointer variables.
494 These must be dummies, results, or scalars. */
495 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
497 || sym
->attr
.function
499 || !sym
->attr
.dimension
))
500 se
->expr
= build_fold_indirect_ref (se
->expr
);
506 /* For character variables, also get the length. */
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 /* If the character length of an entry isn't set, get the length from
510 the master function instead. */
511 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
512 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
514 se
->string_length
= sym
->ts
.cl
->backend_decl
;
515 gcc_assert (se
->string_length
);
523 /* Return the descriptor if that's what we want and this is an array
524 section reference. */
525 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
527 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
528 /* Return the descriptor for array pointers and allocations. */
530 && ref
->next
== NULL
&& (se
->descriptor_only
))
533 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
534 /* Return a pointer to an element. */
538 gfc_conv_component_ref (se
, ref
);
542 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
543 expr
->symtree
->name
, &expr
->where
);
552 /* Pointer assignment, allocation or pass by reference. Arrays are handled
554 if (se
->want_pointer
)
556 if (expr
->ts
.type
== BT_CHARACTER
)
557 gfc_conv_string_parameter (se
);
559 se
->expr
= build_fold_addr_expr (se
->expr
);
564 /* Unary ops are easy... Or they would be if ! was a valid op. */
567 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
572 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
573 /* Initialize the operand. */
574 gfc_init_se (&operand
, se
);
575 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
576 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
578 type
= gfc_typenode_for_spec (&expr
->ts
);
580 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
581 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
582 All other unary operators have an equivalent GIMPLE unary operator. */
583 if (code
== TRUTH_NOT_EXPR
)
584 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
585 build_int_cst (type
, 0));
587 se
->expr
= build1 (code
, type
, operand
.expr
);
591 /* Expand power operator to optimal multiplications when a value is raised
592 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
593 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
594 Programming", 3rd Edition, 1998. */
596 /* This code is mostly duplicated from expand_powi in the backend.
597 We establish the "optimal power tree" lookup table with the defined size.
598 The items in the table are the exponents used to calculate the index
599 exponents. Any integer n less than the value can get an "addition chain",
600 with the first node being one. */
601 #define POWI_TABLE_SIZE 256
603 /* The table is from builtins.c. */
604 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
606 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
607 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
608 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
609 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
610 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
611 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
612 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
613 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
614 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
615 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
616 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
617 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
618 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
619 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
620 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
621 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
622 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
623 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
624 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
625 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
626 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
627 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
628 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
629 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
630 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
631 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
632 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
633 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
634 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
635 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
636 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
637 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
640 /* If n is larger than lookup table's max index, we use the "window
642 #define POWI_WINDOW_SIZE 3
644 /* Recursive function to expand the power operator. The temporary
645 values are put in tmpvar. The function returns tmpvar[1] ** n. */
647 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
654 if (n
< POWI_TABLE_SIZE
)
659 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
660 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
664 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
665 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
666 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
670 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
674 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
675 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
677 if (n
< POWI_TABLE_SIZE
)
684 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
685 return 1. Else return 0 and a call to runtime library functions
686 will have to be built. */
688 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
693 tree vartmp
[POWI_TABLE_SIZE
];
695 unsigned HOST_WIDE_INT n
;
698 /* If exponent is too large, we won't expand it anyway, so don't bother
699 with large integer values. */
700 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
703 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
704 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
705 of the asymmetric range of the integer type. */
706 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
708 type
= TREE_TYPE (lhs
);
709 sgn
= tree_int_cst_sgn (rhs
);
711 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
712 || optimize_size
) && (m
> 2 || m
< -1))
718 se
->expr
= gfc_build_const (type
, integer_one_node
);
722 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
723 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
725 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
726 build_int_cst (TREE_TYPE (lhs
), -1));
727 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
728 build_int_cst (TREE_TYPE (lhs
), 1));
731 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
734 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
735 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
736 build_int_cst (type
, 0));
740 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
741 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
742 build_int_cst (type
, 0));
743 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
747 memset (vartmp
, 0, sizeof (vartmp
));
751 tmp
= gfc_build_const (type
, integer_one_node
);
752 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
755 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
761 /* Power op (**). Constant integer exponent has special handling. */
764 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
766 tree gfc_int4_type_node
;
773 gfc_init_se (&lse
, se
);
774 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
775 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
776 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
778 gfc_init_se (&rse
, se
);
779 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
780 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
782 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
783 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
784 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
787 gfc_int4_type_node
= gfc_get_int_type (4);
789 kind
= expr
->value
.op
.op1
->ts
.kind
;
790 switch (expr
->value
.op
.op2
->ts
.type
)
793 ikind
= expr
->value
.op
.op2
->ts
.kind
;
798 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
820 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
821 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
846 switch (expr
->value
.op
.op1
->ts
.type
)
849 if (kind
== 3) /* Case 16 was not handled properly above. */
851 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
855 /* Use builtins for real ** int4. */
861 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
865 fndecl
= built_in_decls
[BUILT_IN_POWI
];
870 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
878 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
882 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
894 fndecl
= built_in_decls
[BUILT_IN_POWF
];
897 fndecl
= built_in_decls
[BUILT_IN_POW
];
901 fndecl
= built_in_decls
[BUILT_IN_POWL
];
912 fndecl
= gfor_fndecl_math_cpowf
;
915 fndecl
= gfor_fndecl_math_cpow
;
918 fndecl
= gfor_fndecl_math_cpowl10
;
921 fndecl
= gfor_fndecl_math_cpowl16
;
933 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
937 /* Generate code to allocate a string temporary. */
940 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
945 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
947 if (gfc_can_put_var_on_stack (len
))
949 /* Create a temporary variable to hold the result. */
950 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
951 build_int_cst (gfc_charlen_type_node
, 1));
952 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
953 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
954 var
= gfc_create_var (tmp
, "str");
955 var
= gfc_build_addr_expr (type
, var
);
959 /* Allocate a temporary to hold the result. */
960 var
= gfc_create_var (type
, "pstr");
961 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
962 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
964 /* Free the temporary afterwards. */
965 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
966 gfc_add_expr_to_block (&se
->post
, tmp
);
973 /* Handle a string concatenation operation. A temporary will be allocated to
977 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
986 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
987 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
989 gfc_init_se (&lse
, se
);
990 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
991 gfc_conv_string_parameter (&lse
);
992 gfc_init_se (&rse
, se
);
993 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
994 gfc_conv_string_parameter (&rse
);
996 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
997 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
999 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1000 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1001 if (len
== NULL_TREE
)
1003 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1004 lse
.string_length
, rse
.string_length
);
1007 type
= build_pointer_type (type
);
1009 var
= gfc_conv_string_tmp (se
, type
, len
);
1011 /* Do the actual concatenation. */
1012 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1014 lse
.string_length
, lse
.expr
,
1015 rse
.string_length
, rse
.expr
);
1016 gfc_add_expr_to_block (&se
->pre
, tmp
);
1018 /* Add the cleanup for the operands. */
1019 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1020 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1023 se
->string_length
= len
;
1026 /* Translates an op expression. Common (binary) cases are handled by this
1027 function, others are passed on. Recursion is used in either case.
1028 We use the fact that (op1.ts == op2.ts) (except for the power
1030 Operators need no special handling for scalarized expressions as long as
1031 they call gfc_conv_simple_val to get their operands.
1032 Character strings get special handling. */
1035 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1037 enum tree_code code
;
1046 switch (expr
->value
.op
.operator)
1048 case INTRINSIC_UPLUS
:
1049 case INTRINSIC_PARENTHESES
:
1050 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1053 case INTRINSIC_UMINUS
:
1054 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1058 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1061 case INTRINSIC_PLUS
:
1065 case INTRINSIC_MINUS
:
1069 case INTRINSIC_TIMES
:
1073 case INTRINSIC_DIVIDE
:
1074 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1075 an integer, we must round towards zero, so we use a
1077 if (expr
->ts
.type
== BT_INTEGER
)
1078 code
= TRUNC_DIV_EXPR
;
1083 case INTRINSIC_POWER
:
1084 gfc_conv_power_op (se
, expr
);
1087 case INTRINSIC_CONCAT
:
1088 gfc_conv_concat_op (se
, expr
);
1092 code
= TRUTH_ANDIF_EXPR
;
1097 code
= TRUTH_ORIF_EXPR
;
1101 /* EQV and NEQV only work on logicals, but since we represent them
1102 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1104 case INTRINSIC_EQ_OS
:
1112 case INTRINSIC_NE_OS
:
1113 case INTRINSIC_NEQV
:
1120 case INTRINSIC_GT_OS
:
1127 case INTRINSIC_GE_OS
:
1134 case INTRINSIC_LT_OS
:
1141 case INTRINSIC_LE_OS
:
1147 case INTRINSIC_USER
:
1148 case INTRINSIC_ASSIGN
:
1149 /* These should be converted into function calls by the frontend. */
1153 fatal_error ("Unknown intrinsic op");
1157 /* The only exception to this is **, which is handled separately anyway. */
1158 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1160 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1164 gfc_init_se (&lse
, se
);
1165 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1166 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1169 gfc_init_se (&rse
, se
);
1170 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1171 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1175 gfc_conv_string_parameter (&lse
);
1176 gfc_conv_string_parameter (&rse
);
1178 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1179 rse
.string_length
, rse
.expr
);
1180 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1181 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1184 type
= gfc_typenode_for_spec (&expr
->ts
);
1188 /* The result of logical ops is always boolean_type_node. */
1189 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1190 se
->expr
= convert (type
, tmp
);
1193 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1195 /* Add the post blocks. */
1196 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1197 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1200 /* If a string's length is one, we convert it to a single character. */
1203 gfc_to_single_character (tree len
, tree str
)
1205 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1207 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1208 && TREE_INT_CST_HIGH (len
) == 0)
1210 str
= fold_convert (pchar_type_node
, str
);
1211 return build_fold_indirect_ref (str
);
1219 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1222 if (sym
->backend_decl
)
1224 /* This becomes the nominal_type in
1225 function.c:assign_parm_find_data_types. */
1226 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1227 /* This becomes the passed_type in
1228 function.c:assign_parm_find_data_types. C promotes char to
1229 integer for argument passing. */
1230 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1232 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1237 /* If we have a constant character expression, make it into an
1239 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1243 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1244 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1246 /* The expr needs to be compatible with a C int. If the
1247 conversion fails, then the 2 causes an ICE. */
1248 ts
.type
= BT_INTEGER
;
1249 ts
.kind
= gfc_c_int_kind
;
1250 gfc_convert_type (*expr
, &ts
, 2);
1253 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1255 if ((*expr
)->ref
== NULL
)
1257 se
->expr
= gfc_to_single_character
1258 (build_int_cst (integer_type_node
, 1),
1259 gfc_build_addr_expr (pchar_type_node
,
1261 ((*expr
)->symtree
->n
.sym
)));
1265 gfc_conv_variable (se
, *expr
);
1266 se
->expr
= gfc_to_single_character
1267 (build_int_cst (integer_type_node
, 1),
1268 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1275 /* Compare two strings. If they are all single characters, the result is the
1276 subtraction of them. Otherwise, we build a library call. */
1279 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1285 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1286 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1288 sc1
= gfc_to_single_character (len1
, str1
);
1289 sc2
= gfc_to_single_character (len2
, str2
);
1291 /* Deal with single character specially. */
1292 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1294 sc1
= fold_convert (integer_type_node
, sc1
);
1295 sc2
= fold_convert (integer_type_node
, sc2
);
1296 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1299 /* Build a call for the comparison. */
1300 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1301 len1
, str1
, len2
, str2
);
1306 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1310 if (sym
->attr
.dummy
)
1312 tmp
= gfc_get_symbol_decl (sym
);
1313 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1314 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1318 if (!sym
->backend_decl
)
1319 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1321 tmp
= sym
->backend_decl
;
1322 if (sym
->attr
.cray_pointee
)
1323 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1324 gfc_get_symbol_decl (sym
->cp_pointer
));
1325 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1327 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1328 tmp
= build_fold_addr_expr (tmp
);
1335 /* Translate the call for an elemental subroutine call used in an operator
1336 assignment. This is a simplified version of gfc_conv_function_call. */
1339 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1346 /* Only elemental subroutines with two arguments. */
1347 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1348 gcc_assert (sym
->formal
->next
->next
== NULL
);
1350 gfc_init_block (&block
);
1352 gfc_add_block_to_block (&block
, &lse
->pre
);
1353 gfc_add_block_to_block (&block
, &rse
->pre
);
1355 /* Build the argument list for the call, including hidden string lengths. */
1356 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1357 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1358 if (lse
->string_length
!= NULL_TREE
)
1359 args
= gfc_chainon_list (args
, lse
->string_length
);
1360 if (rse
->string_length
!= NULL_TREE
)
1361 args
= gfc_chainon_list (args
, rse
->string_length
);
1363 /* Build the function call. */
1364 gfc_init_se (&se
, NULL
);
1365 gfc_conv_function_val (&se
, sym
);
1366 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1367 tmp
= build_call_list (tmp
, se
.expr
, args
);
1368 gfc_add_expr_to_block (&block
, tmp
);
1370 gfc_add_block_to_block (&block
, &lse
->post
);
1371 gfc_add_block_to_block (&block
, &rse
->post
);
1373 return gfc_finish_block (&block
);
1377 /* Initialize MAPPING. */
1380 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1382 mapping
->syms
= NULL
;
1383 mapping
->charlens
= NULL
;
1387 /* Free all memory held by MAPPING (but not MAPPING itself). */
1390 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1392 gfc_interface_sym_mapping
*sym
;
1393 gfc_interface_sym_mapping
*nextsym
;
1395 gfc_charlen
*nextcl
;
1397 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1399 nextsym
= sym
->next
;
1400 gfc_free_symbol (sym
->new->n
.sym
);
1401 gfc_free (sym
->new);
1404 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1407 gfc_free_expr (cl
->length
);
1413 /* Return a copy of gfc_charlen CL. Add the returned structure to
1414 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1416 static gfc_charlen
*
1417 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1422 new = gfc_get_charlen ();
1423 new->next
= mapping
->charlens
;
1424 new->length
= gfc_copy_expr (cl
->length
);
1426 mapping
->charlens
= new;
1431 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1432 array variable that can be used as the actual argument for dummy
1433 argument SYM. Add any initialization code to BLOCK. PACKED is as
1434 for gfc_get_nodesc_array_type and DATA points to the first element
1435 in the passed array. */
1438 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1439 gfc_packed packed
, tree data
)
1444 type
= gfc_typenode_for_spec (&sym
->ts
);
1445 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1447 var
= gfc_create_var (type
, "ifm");
1448 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1454 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1455 and offset of descriptorless array type TYPE given that it has the same
1456 size as DESC. Add any set-up code to BLOCK. */
1459 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1466 offset
= gfc_index_zero_node
;
1467 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1469 dim
= gfc_rank_cst
[n
];
1470 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1471 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1473 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1474 = gfc_conv_descriptor_lbound (desc
, dim
);
1475 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1476 = gfc_conv_descriptor_ubound (desc
, dim
);
1478 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1480 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1481 gfc_conv_descriptor_ubound (desc
, dim
),
1482 gfc_conv_descriptor_lbound (desc
, dim
));
1483 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1484 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1486 tmp
= gfc_evaluate_now (tmp
, block
);
1487 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1489 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1490 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1491 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1492 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1494 offset
= gfc_evaluate_now (offset
, block
);
1495 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1499 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1500 in SE. The caller may still use se->expr and se->string_length after
1501 calling this function. */
1504 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1505 gfc_symbol
* sym
, gfc_se
* se
)
1507 gfc_interface_sym_mapping
*sm
;
1511 gfc_symbol
*new_sym
;
1513 gfc_symtree
*new_symtree
;
1515 /* Create a new symbol to represent the actual argument. */
1516 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1517 new_sym
->ts
= sym
->ts
;
1518 new_sym
->attr
.referenced
= 1;
1519 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1520 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1521 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1522 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1524 /* Create a fake symtree for it. */
1526 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1527 new_symtree
->n
.sym
= new_sym
;
1528 gcc_assert (new_symtree
== root
);
1530 /* Create a dummy->actual mapping. */
1531 sm
= gfc_getmem (sizeof (*sm
));
1532 sm
->next
= mapping
->syms
;
1534 sm
->new = new_symtree
;
1537 /* Stabilize the argument's value. */
1538 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1540 if (sym
->ts
.type
== BT_CHARACTER
)
1542 /* Create a copy of the dummy argument's length. */
1543 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1545 /* If the length is specified as "*", record the length that
1546 the caller is passing. We should use the callee's length
1547 in all other cases. */
1548 if (!new_sym
->ts
.cl
->length
)
1550 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1551 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1555 /* Use the passed value as-is if the argument is a function. */
1556 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1559 /* If the argument is either a string or a pointer to a string,
1560 convert it to a boundless character type. */
1561 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1563 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1564 tmp
= build_pointer_type (tmp
);
1565 if (sym
->attr
.pointer
)
1566 value
= build_fold_indirect_ref (se
->expr
);
1569 value
= fold_convert (tmp
, value
);
1572 /* If the argument is a scalar, a pointer to an array or an allocatable,
1574 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1575 value
= build_fold_indirect_ref (se
->expr
);
1577 /* For character(*), use the actual argument's descriptor. */
1578 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1579 value
= build_fold_indirect_ref (se
->expr
);
1581 /* If the argument is an array descriptor, use it to determine
1582 information about the actual argument's shape. */
1583 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1584 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1586 /* Get the actual argument's descriptor. */
1587 desc
= build_fold_indirect_ref (se
->expr
);
1589 /* Create the replacement variable. */
1590 tmp
= gfc_conv_descriptor_data_get (desc
);
1591 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1594 /* Use DESC to work out the upper bounds, strides and offset. */
1595 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1598 /* Otherwise we have a packed array. */
1599 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1600 PACKED_FULL
, se
->expr
);
1602 new_sym
->backend_decl
= value
;
1606 /* Called once all dummy argument mappings have been added to MAPPING,
1607 but before the mapping is used to evaluate expressions. Pre-evaluate
1608 the length of each argument, adding any initialization code to PRE and
1609 any finalization code to POST. */
1612 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1613 stmtblock_t
* pre
, stmtblock_t
* post
)
1615 gfc_interface_sym_mapping
*sym
;
1619 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1620 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1621 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1623 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1624 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1625 gfc_init_se (&se
, NULL
);
1626 gfc_conv_expr (&se
, expr
);
1628 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1629 gfc_add_block_to_block (pre
, &se
.pre
);
1630 gfc_add_block_to_block (post
, &se
.post
);
1632 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1637 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1641 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1642 gfc_constructor
* c
)
1644 for (; c
; c
= c
->next
)
1646 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1649 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1650 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1651 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1657 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1661 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1666 for (; ref
; ref
= ref
->next
)
1670 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1672 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1673 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1674 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1676 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1683 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1684 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1690 /* EXPR is a copy of an expression that appeared in the interface
1691 associated with MAPPING. Walk it recursively looking for references to
1692 dummy arguments that MAPPING maps to actual arguments. Replace each such
1693 reference with a reference to the associated actual argument. */
1696 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1699 gfc_interface_sym_mapping
*sym
;
1700 gfc_actual_arglist
*actual
;
1701 int seen_result
= 0;
1706 /* Copying an expression does not copy its length, so do that here. */
1707 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1709 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1710 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1713 /* Apply the mapping to any references. */
1714 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1716 /* ...and to the expression's symbol, if it has one. */
1718 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1719 if (sym
->old
== expr
->symtree
->n
.sym
)
1720 expr
->symtree
= sym
->new;
1722 /* ...and to subexpressions in expr->value. */
1723 switch (expr
->expr_type
)
1726 if (expr
->symtree
->n
.sym
->attr
.result
)
1730 case EXPR_SUBSTRING
:
1734 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1735 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1739 if (expr
->value
.function
.esym
== NULL
1740 && expr
->value
.function
.isym
!= NULL
1741 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1742 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1743 && gfc_apply_interface_mapping_to_expr (mapping
,
1744 expr
->value
.function
.actual
->expr
))
1747 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1749 gfc_free (new_expr
);
1750 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1754 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1755 if (sym
->old
== expr
->value
.function
.esym
)
1756 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1758 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1759 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1763 case EXPR_STRUCTURE
:
1764 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1771 /* Evaluate interface expression EXPR using MAPPING. Store the result
1775 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1776 gfc_se
* se
, gfc_expr
* expr
)
1778 expr
= gfc_copy_expr (expr
);
1779 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1780 gfc_conv_expr (se
, expr
);
1781 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1782 gfc_free_expr (expr
);
1785 /* Returns a reference to a temporary array into which a component of
1786 an actual argument derived type array is copied and then returned
1787 after the function call.
1788 TODO Get rid of this kludge, when array descriptors are capable of
1789 handling arrays with a bigger stride in bytes than size. */
1792 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1793 int g77
, sym_intent intent
)
1809 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1811 gfc_init_se (&lse
, NULL
);
1812 gfc_init_se (&rse
, NULL
);
1814 /* Walk the argument expression. */
1815 rss
= gfc_walk_expr (expr
);
1817 gcc_assert (rss
!= gfc_ss_terminator
);
1819 /* Initialize the scalarizer. */
1820 gfc_init_loopinfo (&loop
);
1821 gfc_add_ss_to_loop (&loop
, rss
);
1823 /* Calculate the bounds of the scalarization. */
1824 gfc_conv_ss_startstride (&loop
);
1826 /* Build an ss for the temporary. */
1827 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
1828 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
1830 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1831 if (GFC_ARRAY_TYPE_P (base_type
)
1832 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1833 base_type
= gfc_get_element_type (base_type
);
1835 loop
.temp_ss
= gfc_get_ss ();;
1836 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1837 loop
.temp_ss
->data
.temp
.type
= base_type
;
1839 if (expr
->ts
.type
== BT_CHARACTER
)
1840 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1842 loop
.temp_ss
->string_length
= NULL
;
1844 parmse
->string_length
= loop
.temp_ss
->string_length
;
1845 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1846 loop
.temp_ss
->next
= gfc_ss_terminator
;
1848 /* Associate the SS with the loop. */
1849 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1851 /* Setup the scalarizing loops. */
1852 gfc_conv_loop_setup (&loop
);
1854 /* Pass the temporary descriptor back to the caller. */
1855 info
= &loop
.temp_ss
->data
.info
;
1856 parmse
->expr
= info
->descriptor
;
1858 /* Setup the gfc_se structures. */
1859 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1860 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1863 lse
.ss
= loop
.temp_ss
;
1864 gfc_mark_ss_chain_used (rss
, 1);
1865 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1867 /* Start the scalarized loop body. */
1868 gfc_start_scalarized_body (&loop
, &body
);
1870 /* Translate the expression. */
1871 gfc_conv_expr (&rse
, expr
);
1873 gfc_conv_tmp_array_ref (&lse
);
1874 gfc_advance_se_ss_chain (&lse
);
1876 if (intent
!= INTENT_OUT
)
1878 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1879 gfc_add_expr_to_block (&body
, tmp
);
1880 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1881 gfc_trans_scalarizing_loops (&loop
, &body
);
1885 /* Make sure that the temporary declaration survives by merging
1886 all the loop declarations into the current context. */
1887 for (n
= 0; n
< loop
.dimen
; n
++)
1889 gfc_merge_block_scope (&body
);
1890 body
= loop
.code
[loop
.order
[n
]];
1892 gfc_merge_block_scope (&body
);
1895 /* Add the post block after the second loop, so that any
1896 freeing of allocated memory is done at the right time. */
1897 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1899 /**********Copy the temporary back again.*********/
1901 gfc_init_se (&lse
, NULL
);
1902 gfc_init_se (&rse
, NULL
);
1904 /* Walk the argument expression. */
1905 lss
= gfc_walk_expr (expr
);
1906 rse
.ss
= loop
.temp_ss
;
1909 /* Initialize the scalarizer. */
1910 gfc_init_loopinfo (&loop2
);
1911 gfc_add_ss_to_loop (&loop2
, lss
);
1913 /* Calculate the bounds of the scalarization. */
1914 gfc_conv_ss_startstride (&loop2
);
1916 /* Setup the scalarizing loops. */
1917 gfc_conv_loop_setup (&loop2
);
1919 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1920 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1922 gfc_mark_ss_chain_used (lss
, 1);
1923 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1925 /* Declare the variable to hold the temporary offset and start the
1926 scalarized loop body. */
1927 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1928 gfc_start_scalarized_body (&loop2
, &body
);
1930 /* Build the offsets for the temporary from the loop variables. The
1931 temporary array has lbounds of zero and strides of one in all
1932 dimensions, so this is very simple. The offset is only computed
1933 outside the innermost loop, so the overall transfer could be
1934 optimized further. */
1935 info
= &rse
.ss
->data
.info
;
1937 tmp_index
= gfc_index_zero_node
;
1938 for (n
= info
->dimen
- 1; n
> 0; n
--)
1941 tmp
= rse
.loop
->loopvar
[n
];
1942 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1943 tmp
, rse
.loop
->from
[n
]);
1944 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1947 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1948 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1949 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1950 tmp_str
, gfc_index_one_node
);
1952 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1956 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1957 tmp_index
, rse
.loop
->from
[0]);
1958 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1960 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1961 rse
.loop
->loopvar
[0], offset
);
1963 /* Now use the offset for the reference. */
1964 tmp
= build_fold_indirect_ref (info
->data
);
1965 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1967 if (expr
->ts
.type
== BT_CHARACTER
)
1968 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1970 gfc_conv_expr (&lse
, expr
);
1972 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1974 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1975 gfc_add_expr_to_block (&body
, tmp
);
1977 /* Generate the copying loops. */
1978 gfc_trans_scalarizing_loops (&loop2
, &body
);
1980 /* Wrap the whole thing up by adding the second loop to the post-block
1981 and following it by the post-block of the first loop. In this way,
1982 if the temporary needs freeing, it is done after use! */
1983 if (intent
!= INTENT_IN
)
1985 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1986 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1989 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1991 gfc_cleanup_loop (&loop
);
1992 gfc_cleanup_loop (&loop2
);
1994 /* Pass the string length to the argument expression. */
1995 if (expr
->ts
.type
== BT_CHARACTER
)
1996 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1998 /* We want either the address for the data or the address of the descriptor,
1999 depending on the mode of passing array arguments. */
2001 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2003 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2008 /* Is true if an array reference is followed by a component or substring
2012 is_aliased_array (gfc_expr
* e
)
2018 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2020 if (ref
->type
== REF_ARRAY
2021 && ref
->u
.ar
.type
!= AR_ELEMENT
)
2025 && ref
->type
!= REF_ARRAY
)
2031 /* Generate the code for argument list functions. */
2034 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2036 /* Pass by value for g77 %VAL(arg), pass the address
2037 indirectly for %LOC, else by reference. Thus %REF
2038 is a "do-nothing" and %LOC is the same as an F95
2040 if (strncmp (name
, "%VAL", 4) == 0)
2041 gfc_conv_expr (se
, expr
);
2042 else if (strncmp (name
, "%LOC", 4) == 0)
2044 gfc_conv_expr_reference (se
, expr
);
2045 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2047 else if (strncmp (name
, "%REF", 4) == 0)
2048 gfc_conv_expr_reference (se
, expr
);
2050 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2054 /* Generate code for a procedure call. Note can return se->post != NULL.
2055 If se->direct_byref is set then se->expr contains the return parameter.
2056 Return nonzero, if the call has alternate specifiers. */
2059 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2060 gfc_actual_arglist
* arg
, tree append_args
)
2062 gfc_interface_mapping mapping
;
2076 gfc_formal_arglist
*formal
;
2077 int has_alternate_specifier
= 0;
2078 bool need_interface_mapping
;
2085 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2087 arglist
= NULL_TREE
;
2088 retargs
= NULL_TREE
;
2089 stringargs
= NULL_TREE
;
2093 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2095 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2097 if (arg
->expr
->rank
== 0)
2098 gfc_conv_expr_reference (se
, arg
->expr
);
2102 /* This is really the actual arg because no formal arglist is
2103 created for C_LOC. */
2104 fsym
= arg
->expr
->symtree
->n
.sym
;
2106 /* We should want it to do g77 calling convention. */
2108 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2109 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2110 f
= f
|| !sym
->attr
.always_explicit
;
2112 argss
= gfc_walk_expr (arg
->expr
);
2113 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2118 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2120 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2121 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2122 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2123 gfc_conv_expr_reference (se
, arg
->expr
);
2131 if (!sym
->attr
.elemental
)
2133 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2134 if (se
->ss
->useflags
)
2136 gcc_assert (gfc_return_by_reference (sym
)
2137 && sym
->result
->attr
.dimension
);
2138 gcc_assert (se
->loop
!= NULL
);
2140 /* Access the previously obtained result. */
2141 gfc_conv_tmp_array_ref (se
);
2142 gfc_advance_se_ss_chain (se
);
2146 info
= &se
->ss
->data
.info
;
2151 gfc_init_block (&post
);
2152 gfc_init_interface_mapping (&mapping
);
2153 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2154 && sym
->ts
.cl
->length
2155 && sym
->ts
.cl
->length
->expr_type
2157 || sym
->attr
.dimension
);
2158 formal
= sym
->formal
;
2159 /* Evaluate the arguments. */
2160 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2163 fsym
= formal
? formal
->sym
: NULL
;
2164 parm_kind
= MISSING
;
2168 if (se
->ignore_optional
)
2170 /* Some intrinsics have already been resolved to the correct
2174 else if (arg
->label
)
2176 has_alternate_specifier
= 1;
2181 /* Pass a NULL pointer for an absent arg. */
2182 gfc_init_se (&parmse
, NULL
);
2183 parmse
.expr
= null_pointer_node
;
2184 if (arg
->missing_arg_type
== BT_CHARACTER
)
2185 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2188 else if (se
->ss
&& se
->ss
->useflags
)
2190 /* An elemental function inside a scalarized loop. */
2191 gfc_init_se (&parmse
, se
);
2192 gfc_conv_expr_reference (&parmse
, e
);
2193 parm_kind
= ELEMENTAL
;
2197 /* A scalar or transformational function. */
2198 gfc_init_se (&parmse
, NULL
);
2199 argss
= gfc_walk_expr (e
);
2201 if (argss
== gfc_ss_terminator
)
2203 if (fsym
&& fsym
->attr
.value
)
2205 if (fsym
->ts
.type
== BT_CHARACTER
2206 && fsym
->ts
.is_c_interop
2207 && fsym
->ns
->proc_name
!= NULL
2208 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2211 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2212 if (parmse
.expr
== NULL
)
2213 gfc_conv_expr (&parmse
, e
);
2216 gfc_conv_expr (&parmse
, e
);
2218 else if (arg
->name
&& arg
->name
[0] == '%')
2219 /* Argument list functions %VAL, %LOC and %REF are signalled
2220 through arg->name. */
2221 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2222 else if ((e
->expr_type
== EXPR_FUNCTION
)
2223 && e
->symtree
->n
.sym
->attr
.pointer
2224 && fsym
&& fsym
->attr
.target
)
2226 gfc_conv_expr (&parmse
, e
);
2227 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2231 gfc_conv_expr_reference (&parmse
, e
);
2232 if (fsym
&& fsym
->attr
.pointer
2233 && fsym
->attr
.flavor
!= FL_PROCEDURE
2234 && e
->expr_type
!= EXPR_NULL
)
2236 /* Scalar pointer dummy args require an extra level of
2237 indirection. The null pointer already contains
2238 this level of indirection. */
2239 parm_kind
= SCALAR_POINTER
;
2240 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2246 /* If the procedure requires an explicit interface, the actual
2247 argument is passed according to the corresponding formal
2248 argument. If the corresponding formal argument is a POINTER,
2249 ALLOCATABLE or assumed shape, we do not use g77's calling
2250 convention, and pass the address of the array descriptor
2251 instead. Otherwise we use g77's calling convention. */
2254 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2255 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2256 f
= f
|| !sym
->attr
.always_explicit
;
2258 if (e
->expr_type
== EXPR_VARIABLE
2259 && is_aliased_array (e
))
2260 /* The actual argument is a component reference to an
2261 array of derived types. In this case, the argument
2262 is converted to a temporary, which is passed and then
2263 written back after the procedure call. */
2264 gfc_conv_aliased_arg (&parmse
, e
, f
,
2265 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2267 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2269 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2270 allocated on entry, it must be deallocated. */
2271 if (fsym
&& fsym
->attr
.allocatable
2272 && fsym
->attr
.intent
== INTENT_OUT
)
2274 tmp
= build_fold_indirect_ref (parmse
.expr
);
2275 tmp
= gfc_trans_dealloc_allocated (tmp
);
2276 gfc_add_expr_to_block (&se
->pre
, tmp
);
2282 /* The case with fsym->attr.optional is that of a user subroutine
2283 with an interface indicating an optional argument. When we call
2284 an intrinsic subroutine, however, fsym is NULL, but we might still
2285 have an optional argument, so we proceed to the substitution
2287 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2289 /* If an optional argument is itself an optional dummy argument,
2290 check its presence and substitute a null if absent. */
2291 if (e
->expr_type
== EXPR_VARIABLE
2292 && e
->symtree
->n
.sym
->attr
.optional
)
2293 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
);
2298 /* Obtain the character length of an assumed character length
2299 length procedure from the typespec. */
2300 if (fsym
->ts
.type
== BT_CHARACTER
2301 && parmse
.string_length
== NULL_TREE
2302 && e
->ts
.type
== BT_PROCEDURE
2303 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2304 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2306 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2307 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2311 if (fsym
&& need_interface_mapping
)
2312 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2314 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2315 gfc_add_block_to_block (&post
, &parmse
.post
);
2317 /* Allocated allocatable components of derived types must be
2318 deallocated for INTENT(OUT) dummy arguments and non-variable
2319 scalars. Non-variable arrays are dealt with in trans-array.c
2320 (gfc_conv_array_parameter). */
2321 if (e
&& e
->ts
.type
== BT_DERIVED
2322 && e
->ts
.derived
->attr
.alloc_comp
2323 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2325 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2328 tmp
= build_fold_indirect_ref (parmse
.expr
);
2329 parm_rank
= e
->rank
;
2337 case (SCALAR_POINTER
):
2338 tmp
= build_fold_indirect_ref (tmp
);
2345 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2346 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2347 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2348 tmp
, build_empty_stmt ());
2350 if (e
->expr_type
!= EXPR_VARIABLE
)
2351 /* Don't deallocate non-variables until they have been used. */
2352 gfc_add_expr_to_block (&se
->post
, tmp
);
2355 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2356 gfc_add_expr_to_block (&se
->pre
, tmp
);
2360 /* Character strings are passed as two parameters, a length and a
2362 if (parmse
.string_length
!= NULL_TREE
)
2363 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2365 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2367 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2370 if (ts
.type
== BT_CHARACTER
)
2372 if (sym
->ts
.cl
->length
== NULL
)
2374 /* Assumed character length results are not allowed by 5.1.1.5 of the
2375 standard and are trapped in resolve.c; except in the case of SPREAD
2376 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2377 we take the character length of the first argument for the result.
2378 For dummies, we have to look through the formal argument list for
2379 this function and use the character length found there.*/
2380 if (!sym
->attr
.dummy
)
2381 cl
.backend_decl
= TREE_VALUE (stringargs
);
2384 formal
= sym
->ns
->proc_name
->formal
;
2385 for (; formal
; formal
= formal
->next
)
2386 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2387 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2394 /* Calculate the length of the returned string. */
2395 gfc_init_se (&parmse
, NULL
);
2396 if (need_interface_mapping
)
2397 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2399 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2400 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2401 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2403 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2404 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2405 build_int_cst (gfc_charlen_type_node
, 0));
2406 cl
.backend_decl
= tmp
;
2409 /* Set up a charlen structure for it. */
2414 len
= cl
.backend_decl
;
2417 byref
= gfc_return_by_reference (sym
);
2420 if (se
->direct_byref
)
2422 /* Sometimes, too much indirection can be applied; eg. for
2423 function_result = array_valued_recursive_function. */
2424 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2425 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2426 && GFC_DESCRIPTOR_TYPE_P
2427 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2428 se
->expr
= build_fold_indirect_ref (se
->expr
);
2430 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2432 else if (sym
->result
->attr
.dimension
)
2434 gcc_assert (se
->loop
&& info
);
2436 /* Set the type of the array. */
2437 tmp
= gfc_typenode_for_spec (&ts
);
2438 info
->dimen
= se
->loop
->dimen
;
2440 /* Evaluate the bounds of the result, if known. */
2441 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2443 /* Create a temporary to store the result. In case the function
2444 returns a pointer, the temporary will be a shallow copy and
2445 mustn't be deallocated. */
2446 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2447 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2448 false, !sym
->attr
.pointer
, callee_alloc
);
2450 /* Pass the temporary as the first argument. */
2451 tmp
= info
->descriptor
;
2452 tmp
= build_fold_addr_expr (tmp
);
2453 retargs
= gfc_chainon_list (retargs
, tmp
);
2455 else if (ts
.type
== BT_CHARACTER
)
2457 /* Pass the string length. */
2458 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2459 type
= build_pointer_type (type
);
2461 /* Return an address to a char[0:len-1]* temporary for
2462 character pointers. */
2463 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2465 /* Build char[0:len-1] * pstr. */
2466 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2467 build_int_cst (gfc_charlen_type_node
, 1));
2468 tmp
= build_range_type (gfc_array_index_type
,
2469 gfc_index_zero_node
, tmp
);
2470 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2471 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2473 /* Provide an address expression for the function arguments. */
2474 var
= build_fold_addr_expr (var
);
2477 var
= gfc_conv_string_tmp (se
, type
, len
);
2479 retargs
= gfc_chainon_list (retargs
, var
);
2483 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2485 type
= gfc_get_complex_type (ts
.kind
);
2486 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2487 retargs
= gfc_chainon_list (retargs
, var
);
2490 /* Add the string length to the argument list. */
2491 if (ts
.type
== BT_CHARACTER
)
2492 retargs
= gfc_chainon_list (retargs
, len
);
2494 gfc_free_interface_mapping (&mapping
);
2496 /* Add the return arguments. */
2497 arglist
= chainon (retargs
, arglist
);
2499 /* Add the hidden string length parameters to the arguments. */
2500 arglist
= chainon (arglist
, stringargs
);
2502 /* We may want to append extra arguments here. This is used e.g. for
2503 calls to libgfortran_matmul_??, which need extra information. */
2504 if (append_args
!= NULL_TREE
)
2505 arglist
= chainon (arglist
, append_args
);
2507 /* Generate the actual call. */
2508 gfc_conv_function_val (se
, sym
);
2510 /* If there are alternate return labels, function type should be
2511 integer. Can't modify the type in place though, since it can be shared
2512 with other functions. For dummy arguments, the typing is done to
2513 to this result, even if it has to be repeated for each call. */
2514 if (has_alternate_specifier
2515 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2517 if (!sym
->attr
.dummy
)
2519 TREE_TYPE (sym
->backend_decl
)
2520 = build_function_type (integer_type_node
,
2521 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2522 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2525 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2528 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2529 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2531 /* If we have a pointer function, but we don't want a pointer, e.g.
2534 where f is pointer valued, we have to dereference the result. */
2535 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2536 se
->expr
= build_fold_indirect_ref (se
->expr
);
2538 /* f2c calling conventions require a scalar default real function to
2539 return a double precision result. Convert this back to default
2540 real. We only care about the cases that can happen in Fortran 77.
2542 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2543 && sym
->ts
.kind
== gfc_default_real_kind
2544 && !sym
->attr
.always_explicit
)
2545 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2547 /* A pure function may still have side-effects - it may modify its
2549 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2551 if (!sym
->attr
.pure
)
2552 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2557 /* Add the function call to the pre chain. There is no expression. */
2558 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2559 se
->expr
= NULL_TREE
;
2561 if (!se
->direct_byref
)
2563 if (sym
->attr
.dimension
)
2565 if (flag_bounds_check
)
2567 /* Check the data pointer hasn't been modified. This would
2568 happen in a function returning a pointer. */
2569 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2570 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2572 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2574 se
->expr
= info
->descriptor
;
2575 /* Bundle in the string length. */
2576 se
->string_length
= len
;
2578 else if (sym
->ts
.type
== BT_CHARACTER
)
2580 /* Dereference for character pointer results. */
2581 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2582 se
->expr
= build_fold_indirect_ref (var
);
2586 se
->string_length
= len
;
2590 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2591 se
->expr
= build_fold_indirect_ref (var
);
2596 /* Follow the function call with the argument post block. */
2598 gfc_add_block_to_block (&se
->pre
, &post
);
2600 gfc_add_block_to_block (&se
->post
, &post
);
2602 return has_alternate_specifier
;
2606 /* Generate code to copy a string. */
2609 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2610 tree slength
, tree src
)
2612 tree tmp
, dlen
, slen
;
2620 stmtblock_t tempblock
;
2622 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2623 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2625 /* Deal with single character specially. */
2626 dsc
= gfc_to_single_character (dlen
, dest
);
2627 ssc
= gfc_to_single_character (slen
, src
);
2628 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2630 gfc_add_modify_expr (block
, dsc
, ssc
);
2634 /* Do nothing if the destination length is zero. */
2635 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2636 build_int_cst (size_type_node
, 0));
2638 /* The following code was previously in _gfortran_copy_string:
2640 // The two strings may overlap so we use memmove.
2642 copy_string (GFC_INTEGER_4 destlen, char * dest,
2643 GFC_INTEGER_4 srclen, const char * src)
2645 if (srclen >= destlen)
2647 // This will truncate if too long.
2648 memmove (dest, src, destlen);
2652 memmove (dest, src, srclen);
2654 memset (&dest[srclen], ' ', destlen - srclen);
2658 We're now doing it here for better optimization, but the logic
2661 /* Truncate string if source is too long. */
2662 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2663 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2664 3, dest
, src
, dlen
);
2666 /* Else copy and pad with spaces. */
2667 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2668 3, dest
, src
, slen
);
2670 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, dest
,
2671 fold_convert (sizetype
, slen
));
2672 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2674 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2675 lang_hooks
.to_target_charset (' ')),
2676 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2679 gfc_init_block (&tempblock
);
2680 gfc_add_expr_to_block (&tempblock
, tmp3
);
2681 gfc_add_expr_to_block (&tempblock
, tmp4
);
2682 tmp3
= gfc_finish_block (&tempblock
);
2684 /* The whole copy_string function is there. */
2685 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2686 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2687 gfc_add_expr_to_block (block
, tmp
);
2691 /* Translate a statement function.
2692 The value of a statement function reference is obtained by evaluating the
2693 expression using the values of the actual arguments for the values of the
2694 corresponding dummy arguments. */
2697 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2701 gfc_formal_arglist
*fargs
;
2702 gfc_actual_arglist
*args
;
2705 gfc_saved_var
*saved_vars
;
2711 sym
= expr
->symtree
->n
.sym
;
2712 args
= expr
->value
.function
.actual
;
2713 gfc_init_se (&lse
, NULL
);
2714 gfc_init_se (&rse
, NULL
);
2717 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2719 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2720 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2722 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2724 /* Each dummy shall be specified, explicitly or implicitly, to be
2726 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2729 /* Create a temporary to hold the value. */
2730 type
= gfc_typenode_for_spec (&fsym
->ts
);
2731 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2733 if (fsym
->ts
.type
== BT_CHARACTER
)
2735 /* Copy string arguments. */
2738 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2739 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2741 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2742 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2745 gfc_conv_expr (&rse
, args
->expr
);
2746 gfc_conv_string_parameter (&rse
);
2747 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2748 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2750 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2752 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2753 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2757 /* For everything else, just evaluate the expression. */
2758 gfc_conv_expr (&lse
, args
->expr
);
2760 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2761 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2762 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2768 /* Use the temporary variables in place of the real ones. */
2769 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2770 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2772 gfc_conv_expr (se
, sym
->value
);
2774 if (sym
->ts
.type
== BT_CHARACTER
)
2776 gfc_conv_const_charlen (sym
->ts
.cl
);
2778 /* Force the expression to the correct length. */
2779 if (!INTEGER_CST_P (se
->string_length
)
2780 || tree_int_cst_lt (se
->string_length
,
2781 sym
->ts
.cl
->backend_decl
))
2783 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2784 tmp
= gfc_create_var (type
, sym
->name
);
2785 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2786 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2787 se
->string_length
, se
->expr
);
2790 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2793 /* Restore the original variables. */
2794 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2795 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2796 gfc_free (saved_vars
);
2800 /* Translate a function expression. */
2803 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2807 if (expr
->value
.function
.isym
)
2809 gfc_conv_intrinsic_function (se
, expr
);
2813 /* We distinguish statement functions from general functions to improve
2814 runtime performance. */
2815 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2817 gfc_conv_statement_function (se
, expr
);
2821 /* expr.value.function.esym is the resolved (specific) function symbol for
2822 most functions. However this isn't set for dummy procedures. */
2823 sym
= expr
->value
.function
.esym
;
2825 sym
= expr
->symtree
->n
.sym
;
2826 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2831 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2833 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2834 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2836 gfc_conv_tmp_array_ref (se
);
2837 gfc_advance_se_ss_chain (se
);
2841 /* Build a static initializer. EXPR is the expression for the initial value.
2842 The other parameters describe the variable of the component being
2843 initialized. EXPR may be null. */
2846 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2847 bool array
, bool pointer
)
2851 if (!(expr
|| pointer
))
2854 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2855 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
2856 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
2857 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
))
2858 expr
= gfc_int_expr (0);
2862 /* Arrays need special handling. */
2864 return gfc_build_null_descriptor (type
);
2866 return gfc_conv_array_initializer (type
, expr
);
2869 return fold_convert (type
, null_pointer_node
);
2875 gfc_init_se (&se
, NULL
);
2876 gfc_conv_structure (&se
, expr
, 1);
2880 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2883 gfc_init_se (&se
, NULL
);
2884 gfc_conv_constant (&se
, expr
);
2891 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2903 gfc_start_block (&block
);
2905 /* Initialize the scalarizer. */
2906 gfc_init_loopinfo (&loop
);
2908 gfc_init_se (&lse
, NULL
);
2909 gfc_init_se (&rse
, NULL
);
2912 rss
= gfc_walk_expr (expr
);
2913 if (rss
== gfc_ss_terminator
)
2915 /* The rhs is scalar. Add a ss for the expression. */
2916 rss
= gfc_get_ss ();
2917 rss
->next
= gfc_ss_terminator
;
2918 rss
->type
= GFC_SS_SCALAR
;
2922 /* Create a SS for the destination. */
2923 lss
= gfc_get_ss ();
2924 lss
->type
= GFC_SS_COMPONENT
;
2926 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2927 lss
->next
= gfc_ss_terminator
;
2928 lss
->data
.info
.dimen
= cm
->as
->rank
;
2929 lss
->data
.info
.descriptor
= dest
;
2930 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2931 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2932 for (n
= 0; n
< cm
->as
->rank
; n
++)
2934 lss
->data
.info
.dim
[n
] = n
;
2935 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2936 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2938 mpz_init (lss
->shape
[n
]);
2939 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2940 cm
->as
->lower
[n
]->value
.integer
);
2941 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2944 /* Associate the SS with the loop. */
2945 gfc_add_ss_to_loop (&loop
, lss
);
2946 gfc_add_ss_to_loop (&loop
, rss
);
2948 /* Calculate the bounds of the scalarization. */
2949 gfc_conv_ss_startstride (&loop
);
2951 /* Setup the scalarizing loops. */
2952 gfc_conv_loop_setup (&loop
);
2954 /* Setup the gfc_se structures. */
2955 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2956 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2959 gfc_mark_ss_chain_used (rss
, 1);
2961 gfc_mark_ss_chain_used (lss
, 1);
2963 /* Start the scalarized loop body. */
2964 gfc_start_scalarized_body (&loop
, &body
);
2966 gfc_conv_tmp_array_ref (&lse
);
2967 if (cm
->ts
.type
== BT_CHARACTER
)
2968 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2970 gfc_conv_expr (&rse
, expr
);
2972 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2973 gfc_add_expr_to_block (&body
, tmp
);
2975 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2977 /* Generate the copying loops. */
2978 gfc_trans_scalarizing_loops (&loop
, &body
);
2980 /* Wrap the whole thing up. */
2981 gfc_add_block_to_block (&block
, &loop
.pre
);
2982 gfc_add_block_to_block (&block
, &loop
.post
);
2984 for (n
= 0; n
< cm
->as
->rank
; n
++)
2985 mpz_clear (lss
->shape
[n
]);
2986 gfc_free (lss
->shape
);
2988 gfc_cleanup_loop (&loop
);
2990 return gfc_finish_block (&block
);
2994 /* Assign a single component of a derived type constructor. */
2997 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3007 gfc_start_block (&block
);
3011 gfc_init_se (&se
, NULL
);
3012 /* Pointer component. */
3015 /* Array pointer. */
3016 if (expr
->expr_type
== EXPR_NULL
)
3017 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3020 rss
= gfc_walk_expr (expr
);
3021 se
.direct_byref
= 1;
3023 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3024 gfc_add_block_to_block (&block
, &se
.pre
);
3025 gfc_add_block_to_block (&block
, &se
.post
);
3030 /* Scalar pointers. */
3031 se
.want_pointer
= 1;
3032 gfc_conv_expr (&se
, expr
);
3033 gfc_add_block_to_block (&block
, &se
.pre
);
3034 gfc_add_modify_expr (&block
, dest
,
3035 fold_convert (TREE_TYPE (dest
), se
.expr
));
3036 gfc_add_block_to_block (&block
, &se
.post
);
3039 else if (cm
->dimension
)
3041 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3042 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3043 else if (cm
->allocatable
)
3047 gfc_init_se (&se
, NULL
);
3049 rss
= gfc_walk_expr (expr
);
3050 se
.want_pointer
= 0;
3051 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3052 gfc_add_block_to_block (&block
, &se
.pre
);
3054 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3055 gfc_add_modify_expr (&block
, dest
, tmp
);
3057 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3058 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3061 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3062 TREE_TYPE(cm
->backend_decl
),
3065 gfc_add_expr_to_block (&block
, tmp
);
3067 gfc_add_block_to_block (&block
, &se
.post
);
3068 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3070 /* Shift the lbound and ubound of temporaries to being unity, rather
3071 than zero, based. Calculate the offset for all cases. */
3072 offset
= gfc_conv_descriptor_offset (dest
);
3073 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3074 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3075 for (n
= 0; n
< expr
->rank
; n
++)
3077 if (expr
->expr_type
!= EXPR_VARIABLE
3078 && expr
->expr_type
!= EXPR_CONSTANT
)
3081 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3082 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3083 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3084 gfc_add_modify_expr (&block
, tmp
,
3085 fold_build2 (PLUS_EXPR
,
3086 gfc_array_index_type
,
3087 span
, gfc_index_one_node
));
3088 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3089 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3091 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3092 gfc_conv_descriptor_lbound (dest
,
3094 gfc_conv_descriptor_stride (dest
,
3096 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3097 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3098 gfc_add_modify_expr (&block
, offset
, tmp
);
3103 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3104 gfc_add_expr_to_block (&block
, tmp
);
3107 else if (expr
->ts
.type
== BT_DERIVED
)
3109 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3111 gfc_init_se (&se
, NULL
);
3112 gfc_conv_expr (&se
, expr
);
3113 gfc_add_modify_expr (&block
, dest
,
3114 fold_convert (TREE_TYPE (dest
), se
.expr
));
3118 /* Nested constructors. */
3119 tmp
= gfc_trans_structure_assign (dest
, expr
);
3120 gfc_add_expr_to_block (&block
, tmp
);
3125 /* Scalar component. */
3126 gfc_init_se (&se
, NULL
);
3127 gfc_init_se (&lse
, NULL
);
3129 gfc_conv_expr (&se
, expr
);
3130 if (cm
->ts
.type
== BT_CHARACTER
)
3131 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3133 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3134 gfc_add_expr_to_block (&block
, tmp
);
3136 return gfc_finish_block (&block
);
3139 /* Assign a derived type constructor to a variable. */
3142 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3150 gfc_start_block (&block
);
3151 cm
= expr
->ts
.derived
->components
;
3152 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3154 /* Skip absent members in default initializers. */
3158 field
= cm
->backend_decl
;
3159 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3160 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3161 gfc_add_expr_to_block (&block
, tmp
);
3163 return gfc_finish_block (&block
);
3166 /* Build an expression for a constructor. If init is nonzero then
3167 this is part of a static variable initializer. */
3170 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3177 VEC(constructor_elt
,gc
) *v
= NULL
;
3179 gcc_assert (se
->ss
== NULL
);
3180 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3181 type
= gfc_typenode_for_spec (&expr
->ts
);
3185 /* Create a temporary variable and fill it in. */
3186 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3187 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3188 gfc_add_expr_to_block (&se
->pre
, tmp
);
3192 cm
= expr
->ts
.derived
->components
;
3194 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3196 /* Skip absent members in default initializers and allocatable
3197 components. Although the latter have a default initializer
3198 of EXPR_NULL,... by default, the static nullify is not needed
3199 since this is done every time we come into scope. */
3200 if (!c
->expr
|| cm
->allocatable
)
3203 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3204 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3206 /* Append it to the constructor list. */
3207 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3209 se
->expr
= build_constructor (type
, v
);
3213 /* Translate a substring expression. */
3216 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3222 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3224 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3225 expr
->value
.character
.string
);
3226 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3227 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3230 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3234 /* Entry point for expression translation. Evaluates a scalar quantity.
3235 EXPR is the expression to be translated, and SE is the state structure if
3236 called from within the scalarized. */
3239 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3241 if (se
->ss
&& se
->ss
->expr
== expr
3242 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3244 /* Substitute a scalar expression evaluated outside the scalarization
3246 se
->expr
= se
->ss
->data
.scalar
.expr
;
3247 se
->string_length
= se
->ss
->string_length
;
3248 gfc_advance_se_ss_chain (se
);
3252 /* We need to convert the expressions for the iso_c_binding derived types.
3253 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3254 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3255 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3256 updated to be an integer with a kind equal to the size of a (void *). */
3257 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3258 && expr
->ts
.derived
->attr
.is_iso_c
)
3260 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3261 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3263 /* Set expr_type to EXPR_NULL, which will result in
3264 null_pointer_node being used below. */
3265 expr
->expr_type
= EXPR_NULL
;
3269 /* Update the type/kind of the expression to be what the new
3270 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3271 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3272 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3273 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3277 switch (expr
->expr_type
)
3280 gfc_conv_expr_op (se
, expr
);
3284 gfc_conv_function_expr (se
, expr
);
3288 gfc_conv_constant (se
, expr
);
3292 gfc_conv_variable (se
, expr
);
3296 se
->expr
= null_pointer_node
;
3299 case EXPR_SUBSTRING
:
3300 gfc_conv_substring_expr (se
, expr
);
3303 case EXPR_STRUCTURE
:
3304 gfc_conv_structure (se
, expr
, 0);
3308 gfc_conv_array_constructor_expr (se
, expr
);
3317 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3318 of an assignment. */
3320 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3322 gfc_conv_expr (se
, expr
);
3323 /* All numeric lvalues should have empty post chains. If not we need to
3324 figure out a way of rewriting an lvalue so that it has no post chain. */
3325 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3328 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3329 numeric expressions. Used for scalar values where inserting cleanup code
3332 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3336 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3337 gfc_conv_expr (se
, expr
);
3340 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3341 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3343 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3347 /* Helper to translate and expression and convert it to a particular type. */
3349 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3351 gfc_conv_expr_val (se
, expr
);
3352 se
->expr
= convert (type
, se
->expr
);
3356 /* Converts an expression so that it can be passed by reference. Scalar
3360 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3364 if (se
->ss
&& se
->ss
->expr
== expr
3365 && se
->ss
->type
== GFC_SS_REFERENCE
)
3367 se
->expr
= se
->ss
->data
.scalar
.expr
;
3368 se
->string_length
= se
->ss
->string_length
;
3369 gfc_advance_se_ss_chain (se
);
3373 if (expr
->ts
.type
== BT_CHARACTER
)
3375 gfc_conv_expr (se
, expr
);
3376 gfc_conv_string_parameter (se
);
3380 if (expr
->expr_type
== EXPR_VARIABLE
)
3382 se
->want_pointer
= 1;
3383 gfc_conv_expr (se
, expr
);
3386 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3387 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3388 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3394 if (expr
->expr_type
== EXPR_FUNCTION
3395 && expr
->symtree
->n
.sym
->attr
.pointer
3396 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3398 se
->want_pointer
= 1;
3399 gfc_conv_expr (se
, expr
);
3400 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3401 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3407 gfc_conv_expr (se
, expr
);
3409 /* Create a temporary var to hold the value. */
3410 if (TREE_CONSTANT (se
->expr
))
3412 tree tmp
= se
->expr
;
3413 STRIP_TYPE_NOPS (tmp
);
3414 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3415 DECL_INITIAL (var
) = tmp
;
3416 TREE_STATIC (var
) = 1;
3421 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3422 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3424 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3426 /* Take the address of that value. */
3427 se
->expr
= build_fold_addr_expr (var
);
3432 gfc_trans_pointer_assign (gfc_code
* code
)
3434 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3438 /* Generate code for a pointer assignment. */
3441 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3451 gfc_start_block (&block
);
3453 gfc_init_se (&lse
, NULL
);
3455 lss
= gfc_walk_expr (expr1
);
3456 rss
= gfc_walk_expr (expr2
);
3457 if (lss
== gfc_ss_terminator
)
3459 /* Scalar pointers. */
3460 lse
.want_pointer
= 1;
3461 gfc_conv_expr (&lse
, expr1
);
3462 gcc_assert (rss
== gfc_ss_terminator
);
3463 gfc_init_se (&rse
, NULL
);
3464 rse
.want_pointer
= 1;
3465 gfc_conv_expr (&rse
, expr2
);
3466 gfc_add_block_to_block (&block
, &lse
.pre
);
3467 gfc_add_block_to_block (&block
, &rse
.pre
);
3468 gfc_add_modify_expr (&block
, lse
.expr
,
3469 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3470 gfc_add_block_to_block (&block
, &rse
.post
);
3471 gfc_add_block_to_block (&block
, &lse
.post
);
3475 /* Array pointer. */
3476 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3477 switch (expr2
->expr_type
)
3480 /* Just set the data pointer to null. */
3481 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3485 /* Assign directly to the pointer's descriptor. */
3486 lse
.direct_byref
= 1;
3487 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3491 /* Assign to a temporary descriptor and then copy that
3492 temporary to the pointer. */
3494 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3497 lse
.direct_byref
= 1;
3498 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3499 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3502 gfc_add_block_to_block (&block
, &lse
.pre
);
3503 gfc_add_block_to_block (&block
, &lse
.post
);
3505 return gfc_finish_block (&block
);
3509 /* Makes sure se is suitable for passing as a function string parameter. */
3510 /* TODO: Need to check all callers fo this function. It may be abused. */
3513 gfc_conv_string_parameter (gfc_se
* se
)
3517 if (TREE_CODE (se
->expr
) == STRING_CST
)
3519 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3523 type
= TREE_TYPE (se
->expr
);
3524 if (TYPE_STRING_FLAG (type
))
3526 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3527 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3530 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3531 gcc_assert (se
->string_length
3532 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3536 /* Generate code for assignment of scalar variables. Includes character
3537 strings and derived types with allocatable components. */
3540 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3541 bool l_is_temp
, bool r_is_var
)
3547 gfc_init_block (&block
);
3549 if (ts
.type
== BT_CHARACTER
)
3551 gcc_assert (lse
->string_length
!= NULL_TREE
3552 && rse
->string_length
!= NULL_TREE
);
3554 gfc_conv_string_parameter (lse
);
3555 gfc_conv_string_parameter (rse
);
3557 gfc_add_block_to_block (&block
, &lse
->pre
);
3558 gfc_add_block_to_block (&block
, &rse
->pre
);
3560 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3561 rse
->string_length
, rse
->expr
);
3563 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3567 /* Are the rhs and the lhs the same? */
3570 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3571 build_fold_addr_expr (lse
->expr
),
3572 build_fold_addr_expr (rse
->expr
));
3573 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3576 /* Deallocate the lhs allocated components as long as it is not
3577 the same as the rhs. This must be done following the assignment
3578 to prevent deallocating data that could be used in the rhs
3582 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3583 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3585 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3586 gfc_add_expr_to_block (&lse
->post
, tmp
);
3589 gfc_add_block_to_block (&block
, &rse
->pre
);
3590 gfc_add_block_to_block (&block
, &lse
->pre
);
3592 gfc_add_modify_expr (&block
, lse
->expr
,
3593 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3595 /* Do a deep copy if the rhs is a variable, if it is not the
3599 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3600 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3601 gfc_add_expr_to_block (&block
, tmp
);
3606 gfc_add_block_to_block (&block
, &lse
->pre
);
3607 gfc_add_block_to_block (&block
, &rse
->pre
);
3609 gfc_add_modify_expr (&block
, lse
->expr
,
3610 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3613 gfc_add_block_to_block (&block
, &lse
->post
);
3614 gfc_add_block_to_block (&block
, &rse
->post
);
3616 return gfc_finish_block (&block
);
3620 /* Try to translate array(:) = func (...), where func is a transformational
3621 array function, without using a temporary. Returns NULL is this isn't the
3625 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3630 bool seen_array_ref
;
3632 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3633 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3636 /* Elemental functions don't need a temporary anyway. */
3637 if (expr2
->value
.function
.esym
!= NULL
3638 && expr2
->value
.function
.esym
->attr
.elemental
)
3641 /* Fail if EXPR1 can't be expressed as a descriptor. */
3642 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3645 /* Functions returning pointers need temporaries. */
3646 if (expr2
->symtree
->n
.sym
->attr
.pointer
3647 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3650 /* Character array functions need temporaries unless the
3651 character lengths are the same. */
3652 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3654 if (expr1
->ts
.cl
->length
== NULL
3655 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3658 if (expr2
->ts
.cl
->length
== NULL
3659 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3662 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3663 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3667 /* Check that no LHS component references appear during an array
3668 reference. This is needed because we do not have the means to
3669 span any arbitrary stride with an array descriptor. This check
3670 is not needed for the rhs because the function result has to be
3672 seen_array_ref
= false;
3673 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3675 if (ref
->type
== REF_ARRAY
)
3676 seen_array_ref
= true;
3677 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3681 /* Check for a dependency. */
3682 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3683 expr2
->value
.function
.esym
,
3684 expr2
->value
.function
.actual
))
3687 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3689 gcc_assert (expr2
->value
.function
.isym
3690 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3691 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3693 ss
= gfc_walk_expr (expr1
);
3694 gcc_assert (ss
!= gfc_ss_terminator
);
3695 gfc_init_se (&se
, NULL
);
3696 gfc_start_block (&se
.pre
);
3697 se
.want_pointer
= 1;
3699 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3701 se
.direct_byref
= 1;
3702 se
.ss
= gfc_walk_expr (expr2
);
3703 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3704 gfc_conv_function_expr (&se
, expr2
);
3705 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3707 return gfc_finish_block (&se
.pre
);
3710 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3713 is_zero_initializer_p (gfc_expr
* expr
)
3715 if (expr
->expr_type
!= EXPR_CONSTANT
)
3718 /* We ignore constants with prescribed memory representations for now. */
3719 if (expr
->representation
.string
)
3722 switch (expr
->ts
.type
)
3725 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3728 return mpfr_zero_p (expr
->value
.real
)
3729 && MPFR_SIGN (expr
->value
.real
) >= 0;
3732 return expr
->value
.logical
== 0;
3735 return mpfr_zero_p (expr
->value
.complex.r
)
3736 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3737 && mpfr_zero_p (expr
->value
.complex.i
)
3738 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3746 /* Try to efficiently translate array(:) = 0. Return NULL if this
3750 gfc_trans_zero_assign (gfc_expr
* expr
)
3752 tree dest
, len
, type
;
3756 sym
= expr
->symtree
->n
.sym
;
3757 dest
= gfc_get_symbol_decl (sym
);
3759 type
= TREE_TYPE (dest
);
3760 if (POINTER_TYPE_P (type
))
3761 type
= TREE_TYPE (type
);
3762 if (!GFC_ARRAY_TYPE_P (type
))
3765 /* Determine the length of the array. */
3766 len
= GFC_TYPE_ARRAY_SIZE (type
);
3767 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3770 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3771 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3772 fold_convert (gfc_array_index_type
, tmp
));
3774 /* Convert arguments to the correct types. */
3775 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3776 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3778 dest
= fold_convert (pvoid_type_node
, dest
);
3779 len
= fold_convert (size_type_node
, len
);
3781 /* Construct call to __builtin_memset. */
3782 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3783 3, dest
, integer_zero_node
, len
);
3784 return fold_convert (void_type_node
, tmp
);
3788 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3789 that constructs the call to __builtin_memcpy. */
3792 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3796 /* Convert arguments to the correct types. */
3797 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3798 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3800 dst
= fold_convert (pvoid_type_node
, dst
);
3802 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3803 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3805 src
= fold_convert (pvoid_type_node
, src
);
3807 len
= fold_convert (size_type_node
, len
);
3809 /* Construct call to __builtin_memcpy. */
3810 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3811 return fold_convert (void_type_node
, tmp
);
3815 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3816 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3817 source/rhs, both are gfc_full_array_ref_p which have been checked for
3821 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3823 tree dst
, dlen
, dtype
;
3824 tree src
, slen
, stype
;
3827 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3828 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3830 dtype
= TREE_TYPE (dst
);
3831 if (POINTER_TYPE_P (dtype
))
3832 dtype
= TREE_TYPE (dtype
);
3833 stype
= TREE_TYPE (src
);
3834 if (POINTER_TYPE_P (stype
))
3835 stype
= TREE_TYPE (stype
);
3837 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3840 /* Determine the lengths of the arrays. */
3841 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3842 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3844 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3845 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3846 fold_convert (gfc_array_index_type
, tmp
));
3848 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3849 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3851 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3852 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3853 fold_convert (gfc_array_index_type
, tmp
));
3855 /* Sanity check that they are the same. This should always be
3856 the case, as we should already have checked for conformance. */
3857 if (!tree_int_cst_equal (slen
, dlen
))
3860 return gfc_build_memcpy_call (dst
, src
, dlen
);
3864 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3865 this can't be done. EXPR1 is the destination/lhs for which
3866 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3869 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3871 unsigned HOST_WIDE_INT nelem
;
3877 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3881 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3882 dtype
= TREE_TYPE (dst
);
3883 if (POINTER_TYPE_P (dtype
))
3884 dtype
= TREE_TYPE (dtype
);
3885 if (!GFC_ARRAY_TYPE_P (dtype
))
3888 /* Determine the lengths of the array. */
3889 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3890 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3893 /* Confirm that the constructor is the same size. */
3894 if (compare_tree_int (len
, nelem
) != 0)
3897 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3898 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3899 fold_convert (gfc_array_index_type
, tmp
));
3901 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3902 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3904 stype
= TREE_TYPE (src
);
3905 if (POINTER_TYPE_P (stype
))
3906 stype
= TREE_TYPE (stype
);
3908 return gfc_build_memcpy_call (dst
, src
, len
);
3912 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3913 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3916 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3921 gfc_ss
*lss_section
;
3929 /* Assignment of the form lhs = rhs. */
3930 gfc_start_block (&block
);
3932 gfc_init_se (&lse
, NULL
);
3933 gfc_init_se (&rse
, NULL
);
3936 lss
= gfc_walk_expr (expr1
);
3938 if (lss
!= gfc_ss_terminator
)
3940 /* The assignment needs scalarization. */
3943 /* Find a non-scalar SS from the lhs. */
3944 while (lss_section
!= gfc_ss_terminator
3945 && lss_section
->type
!= GFC_SS_SECTION
)
3946 lss_section
= lss_section
->next
;
3948 gcc_assert (lss_section
!= gfc_ss_terminator
);
3950 /* Initialize the scalarizer. */
3951 gfc_init_loopinfo (&loop
);
3954 rss
= gfc_walk_expr (expr2
);
3955 if (rss
== gfc_ss_terminator
)
3957 /* The rhs is scalar. Add a ss for the expression. */
3958 rss
= gfc_get_ss ();
3959 rss
->next
= gfc_ss_terminator
;
3960 rss
->type
= GFC_SS_SCALAR
;
3963 /* Associate the SS with the loop. */
3964 gfc_add_ss_to_loop (&loop
, lss
);
3965 gfc_add_ss_to_loop (&loop
, rss
);
3967 /* Calculate the bounds of the scalarization. */
3968 gfc_conv_ss_startstride (&loop
);
3969 /* Resolve any data dependencies in the statement. */
3970 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3971 /* Setup the scalarizing loops. */
3972 gfc_conv_loop_setup (&loop
);
3974 /* Setup the gfc_se structures. */
3975 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3976 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3979 gfc_mark_ss_chain_used (rss
, 1);
3980 if (loop
.temp_ss
== NULL
)
3983 gfc_mark_ss_chain_used (lss
, 1);
3987 lse
.ss
= loop
.temp_ss
;
3988 gfc_mark_ss_chain_used (lss
, 3);
3989 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3992 /* Start the scalarized loop body. */
3993 gfc_start_scalarized_body (&loop
, &body
);
3996 gfc_init_block (&body
);
3998 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4000 /* Translate the expression. */
4001 gfc_conv_expr (&rse
, expr2
);
4005 gfc_conv_tmp_array_ref (&lse
);
4006 gfc_advance_se_ss_chain (&lse
);
4009 gfc_conv_expr (&lse
, expr1
);
4011 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4012 l_is_temp
|| init_flag
,
4013 expr2
->expr_type
== EXPR_VARIABLE
);
4014 gfc_add_expr_to_block (&body
, tmp
);
4016 if (lss
== gfc_ss_terminator
)
4018 /* Use the scalar assignment as is. */
4019 gfc_add_block_to_block (&block
, &body
);
4023 gcc_assert (lse
.ss
== gfc_ss_terminator
4024 && rse
.ss
== gfc_ss_terminator
);
4028 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4030 /* We need to copy the temporary to the actual lhs. */
4031 gfc_init_se (&lse
, NULL
);
4032 gfc_init_se (&rse
, NULL
);
4033 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4034 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4036 rse
.ss
= loop
.temp_ss
;
4039 gfc_conv_tmp_array_ref (&rse
);
4040 gfc_advance_se_ss_chain (&rse
);
4041 gfc_conv_expr (&lse
, expr1
);
4043 gcc_assert (lse
.ss
== gfc_ss_terminator
4044 && rse
.ss
== gfc_ss_terminator
);
4046 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4048 gfc_add_expr_to_block (&body
, tmp
);
4051 /* Generate the copying loops. */
4052 gfc_trans_scalarizing_loops (&loop
, &body
);
4054 /* Wrap the whole thing up. */
4055 gfc_add_block_to_block (&block
, &loop
.pre
);
4056 gfc_add_block_to_block (&block
, &loop
.post
);
4058 gfc_cleanup_loop (&loop
);
4061 return gfc_finish_block (&block
);
4065 /* Check whether EXPR is a copyable array. */
4068 copyable_array_p (gfc_expr
* expr
)
4070 if (expr
->expr_type
!= EXPR_VARIABLE
)
4073 /* First check it's an array. */
4074 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4077 if (!gfc_full_array_ref_p (expr
->ref
))
4080 /* Next check that it's of a simple enough type. */
4081 switch (expr
->ts
.type
)
4093 return !expr
->ts
.derived
->attr
.alloc_comp
;
4102 /* Translate an assignment. */
4105 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4109 /* Special case a single function returning an array. */
4110 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4112 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4117 /* Special case assigning an array to zero. */
4118 if (copyable_array_p (expr1
)
4119 && is_zero_initializer_p (expr2
))
4121 tmp
= gfc_trans_zero_assign (expr1
);
4126 /* Special case copying one array to another. */
4127 if (copyable_array_p (expr1
)
4128 && copyable_array_p (expr2
)
4129 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4130 && !gfc_check_dependency (expr1
, expr2
, 0))
4132 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4137 /* Special case initializing an array from a constant array constructor. */
4138 if (copyable_array_p (expr1
)
4139 && expr2
->expr_type
== EXPR_ARRAY
4140 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4142 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4147 /* Fallback to the scalarizer to generate explicit loops. */
4148 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4152 gfc_trans_init_assign (gfc_code
* code
)
4154 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4158 gfc_trans_assign (gfc_code
* code
)
4160 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);