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_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
228 gfc_init_se (&se
, NULL
);
229 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
230 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
231 build_int_cst (gfc_charlen_type_node
, 0));
232 gfc_add_block_to_block (pblock
, &se
.pre
);
234 tmp
= cl
->backend_decl
;
235 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
240 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
241 const char *name
, locus
*where
)
251 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
252 type
= build_pointer_type (type
);
255 gfc_init_se (&start
, se
);
256 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
257 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
259 if (integer_onep (start
.expr
))
260 gfc_conv_string_parameter (se
);
263 /* Avoid multiple evaluation of substring start. */
264 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
265 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
267 /* Change the start of the string. */
268 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
271 tmp
= build_fold_indirect_ref (se
->expr
);
272 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
273 se
->expr
= gfc_build_addr_expr (type
, tmp
);
276 /* Length = end + 1 - start. */
277 gfc_init_se (&end
, se
);
278 if (ref
->u
.ss
.end
== NULL
)
279 end
.expr
= se
->string_length
;
282 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
283 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
285 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
286 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
288 if (flag_bounds_check
)
290 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
291 start
.expr
, end
.expr
);
293 /* Check lower bound. */
294 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
295 build_int_cst (gfc_charlen_type_node
, 1));
296 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
299 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
300 "is less than one", name
);
302 asprintf (&msg
, "Substring out of bounds: lower bound "
304 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
307 /* Check upper bound. */
308 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
310 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
313 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
314 "exceeds string length", name
);
316 asprintf (&msg
, "Substring out of bounds: upper bound "
317 "exceeds string length");
318 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
322 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
323 build_int_cst (gfc_charlen_type_node
, 1),
325 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
326 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
327 build_int_cst (gfc_charlen_type_node
, 0));
328 se
->string_length
= tmp
;
332 /* Convert a derived type component reference. */
335 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
342 c
= ref
->u
.c
.component
;
344 gcc_assert (c
->backend_decl
);
346 field
= c
->backend_decl
;
347 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
349 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
353 if (c
->ts
.type
== BT_CHARACTER
)
355 tmp
= c
->ts
.cl
->backend_decl
;
356 /* Components must always be constant length. */
357 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
358 se
->string_length
= tmp
;
361 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
362 se
->expr
= build_fold_indirect_ref (se
->expr
);
366 /* Return the contents of a variable. Also handles reference/pointer
367 variables (all Fortran pointer references are implicit). */
370 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
377 bool alternate_entry
;
380 sym
= expr
->symtree
->n
.sym
;
383 /* Check that something hasn't gone horribly wrong. */
384 gcc_assert (se
->ss
!= gfc_ss_terminator
);
385 gcc_assert (se
->ss
->expr
== expr
);
387 /* A scalarized term. We already know the descriptor. */
388 se
->expr
= se
->ss
->data
.info
.descriptor
;
389 se
->string_length
= se
->ss
->string_length
;
390 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
391 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
396 tree se_expr
= NULL_TREE
;
398 se
->expr
= gfc_get_symbol_decl (sym
);
400 /* Deal with references to a parent results or entries by storing
401 the current_function_decl and moving to the parent_decl. */
402 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
403 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
404 && sym
->result
== sym
;
405 entry_master
= sym
->attr
.result
406 && sym
->ns
->proc_name
->attr
.entry_master
407 && !gfc_return_by_reference (sym
->ns
->proc_name
);
408 parent_decl
= DECL_CONTEXT (current_function_decl
);
410 if ((se
->expr
== parent_decl
&& return_value
)
411 || (sym
->ns
&& sym
->ns
->proc_name
413 && sym
->ns
->proc_name
->backend_decl
== parent_decl
414 && (alternate_entry
|| entry_master
)))
419 /* Special case for assigning the return value of a function.
420 Self recursive functions must have an explicit return value. */
421 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
422 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
424 /* Similarly for alternate entry points. */
425 else if (alternate_entry
426 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
429 gfc_entry_list
*el
= NULL
;
431 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
434 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
439 else if (entry_master
440 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
442 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
447 /* Procedure actual arguments. */
448 else if (sym
->attr
.flavor
== FL_PROCEDURE
449 && se
->expr
!= current_function_decl
)
451 gcc_assert (se
->want_pointer
);
452 if (!sym
->attr
.dummy
)
454 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
455 se
->expr
= build_fold_addr_expr (se
->expr
);
461 /* Dereference the expression, where needed. Since characters
462 are entirely different from other types, they are treated
464 if (sym
->ts
.type
== BT_CHARACTER
)
466 /* Dereference character pointer dummy arguments
468 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
470 || sym
->attr
.function
471 || sym
->attr
.result
))
472 se
->expr
= build_fold_indirect_ref (se
->expr
);
475 else if (!sym
->attr
.value
)
477 /* Dereference non-character scalar dummy arguments. */
478 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
479 se
->expr
= build_fold_indirect_ref (se
->expr
);
481 /* Dereference scalar hidden result. */
482 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
483 && (sym
->attr
.function
|| sym
->attr
.result
)
484 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
485 se
->expr
= build_fold_indirect_ref (se
->expr
);
487 /* Dereference non-character pointer variables.
488 These must be dummies, results, or scalars. */
489 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
491 || sym
->attr
.function
493 || !sym
->attr
.dimension
))
494 se
->expr
= build_fold_indirect_ref (se
->expr
);
500 /* For character variables, also get the length. */
501 if (sym
->ts
.type
== BT_CHARACTER
)
503 /* If the character length of an entry isn't set, get the length from
504 the master function instead. */
505 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
506 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
508 se
->string_length
= sym
->ts
.cl
->backend_decl
;
509 gcc_assert (se
->string_length
);
517 /* Return the descriptor if that's what we want and this is an array
518 section reference. */
519 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
521 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
522 /* Return the descriptor for array pointers and allocations. */
524 && ref
->next
== NULL
&& (se
->descriptor_only
))
527 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
528 /* Return a pointer to an element. */
532 gfc_conv_component_ref (se
, ref
);
536 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
537 expr
->symtree
->name
, &expr
->where
);
546 /* Pointer assignment, allocation or pass by reference. Arrays are handled
548 if (se
->want_pointer
)
550 if (expr
->ts
.type
== BT_CHARACTER
)
551 gfc_conv_string_parameter (se
);
553 se
->expr
= build_fold_addr_expr (se
->expr
);
558 /* Unary ops are easy... Or they would be if ! was a valid op. */
561 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
566 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
567 /* Initialize the operand. */
568 gfc_init_se (&operand
, se
);
569 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
570 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
572 type
= gfc_typenode_for_spec (&expr
->ts
);
574 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
575 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
576 All other unary operators have an equivalent GIMPLE unary operator. */
577 if (code
== TRUTH_NOT_EXPR
)
578 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
579 build_int_cst (type
, 0));
581 se
->expr
= build1 (code
, type
, operand
.expr
);
585 /* Expand power operator to optimal multiplications when a value is raised
586 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
587 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
588 Programming", 3rd Edition, 1998. */
590 /* This code is mostly duplicated from expand_powi in the backend.
591 We establish the "optimal power tree" lookup table with the defined size.
592 The items in the table are the exponents used to calculate the index
593 exponents. Any integer n less than the value can get an "addition chain",
594 with the first node being one. */
595 #define POWI_TABLE_SIZE 256
597 /* The table is from builtins.c. */
598 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
600 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
601 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
602 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
603 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
604 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
605 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
606 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
607 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
608 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
609 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
610 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
611 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
612 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
613 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
614 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
615 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
616 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
617 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
618 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
619 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
620 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
621 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
622 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
623 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
624 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
625 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
626 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
627 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
628 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
629 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
630 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
631 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
634 /* If n is larger than lookup table's max index, we use the "window
636 #define POWI_WINDOW_SIZE 3
638 /* Recursive function to expand the power operator. The temporary
639 values are put in tmpvar. The function returns tmpvar[1] ** n. */
641 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
648 if (n
< POWI_TABLE_SIZE
)
653 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
654 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
658 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
659 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
660 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
664 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
668 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
669 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
671 if (n
< POWI_TABLE_SIZE
)
678 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
679 return 1. Else return 0 and a call to runtime library functions
680 will have to be built. */
682 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
687 tree vartmp
[POWI_TABLE_SIZE
];
689 unsigned HOST_WIDE_INT n
;
692 /* If exponent is too large, we won't expand it anyway, so don't bother
693 with large integer values. */
694 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
697 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
698 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
699 of the asymmetric range of the integer type. */
700 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
702 type
= TREE_TYPE (lhs
);
703 sgn
= tree_int_cst_sgn (rhs
);
705 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
706 || optimize_size
) && (m
> 2 || m
< -1))
712 se
->expr
= gfc_build_const (type
, integer_one_node
);
716 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
717 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
719 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
720 build_int_cst (TREE_TYPE (lhs
), -1));
721 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
722 build_int_cst (TREE_TYPE (lhs
), 1));
725 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
728 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
729 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
730 build_int_cst (type
, 0));
734 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
735 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
736 build_int_cst (type
, 0));
737 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
741 memset (vartmp
, 0, sizeof (vartmp
));
745 tmp
= gfc_build_const (type
, integer_one_node
);
746 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
749 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
755 /* Power op (**). Constant integer exponent has special handling. */
758 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
760 tree gfc_int4_type_node
;
767 gfc_init_se (&lse
, se
);
768 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
769 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
770 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
772 gfc_init_se (&rse
, se
);
773 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
774 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
776 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
777 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
778 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
781 gfc_int4_type_node
= gfc_get_int_type (4);
783 kind
= expr
->value
.op
.op1
->ts
.kind
;
784 switch (expr
->value
.op
.op2
->ts
.type
)
787 ikind
= expr
->value
.op
.op2
->ts
.kind
;
792 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
814 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
815 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
840 switch (expr
->value
.op
.op1
->ts
.type
)
843 if (kind
== 3) /* Case 16 was not handled properly above. */
845 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
849 /* Use builtins for real ** int4. */
855 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
859 fndecl
= built_in_decls
[BUILT_IN_POWI
];
864 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
872 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
876 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
888 fndecl
= built_in_decls
[BUILT_IN_POWF
];
891 fndecl
= built_in_decls
[BUILT_IN_POW
];
895 fndecl
= built_in_decls
[BUILT_IN_POWL
];
906 fndecl
= gfor_fndecl_math_cpowf
;
909 fndecl
= gfor_fndecl_math_cpow
;
912 fndecl
= gfor_fndecl_math_cpowl10
;
915 fndecl
= gfor_fndecl_math_cpowl16
;
927 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
931 /* Generate code to allocate a string temporary. */
934 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
939 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
941 if (gfc_can_put_var_on_stack (len
))
943 /* Create a temporary variable to hold the result. */
944 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
945 build_int_cst (gfc_charlen_type_node
, 1));
946 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
947 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
948 var
= gfc_create_var (tmp
, "str");
949 var
= gfc_build_addr_expr (type
, var
);
953 /* Allocate a temporary to hold the result. */
954 var
= gfc_create_var (type
, "pstr");
955 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
956 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
958 /* Free the temporary afterwards. */
959 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
960 gfc_add_expr_to_block (&se
->post
, tmp
);
967 /* Handle a string concatenation operation. A temporary will be allocated to
971 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
980 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
981 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
983 gfc_init_se (&lse
, se
);
984 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
985 gfc_conv_string_parameter (&lse
);
986 gfc_init_se (&rse
, se
);
987 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
988 gfc_conv_string_parameter (&rse
);
990 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
991 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
993 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
994 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
995 if (len
== NULL_TREE
)
997 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
998 lse
.string_length
, rse
.string_length
);
1001 type
= build_pointer_type (type
);
1003 var
= gfc_conv_string_tmp (se
, type
, len
);
1005 /* Do the actual concatenation. */
1006 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1008 lse
.string_length
, lse
.expr
,
1009 rse
.string_length
, rse
.expr
);
1010 gfc_add_expr_to_block (&se
->pre
, tmp
);
1012 /* Add the cleanup for the operands. */
1013 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1014 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1017 se
->string_length
= len
;
1020 /* Translates an op expression. Common (binary) cases are handled by this
1021 function, others are passed on. Recursion is used in either case.
1022 We use the fact that (op1.ts == op2.ts) (except for the power
1024 Operators need no special handling for scalarized expressions as long as
1025 they call gfc_conv_simple_val to get their operands.
1026 Character strings get special handling. */
1029 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1031 enum tree_code code
;
1041 switch (expr
->value
.op
.operator)
1043 case INTRINSIC_UPLUS
:
1044 case INTRINSIC_PARENTHESES
:
1045 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1048 case INTRINSIC_UMINUS
:
1049 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1053 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1056 case INTRINSIC_PLUS
:
1060 case INTRINSIC_MINUS
:
1064 case INTRINSIC_TIMES
:
1068 case INTRINSIC_DIVIDE
:
1069 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1070 an integer, we must round towards zero, so we use a
1072 if (expr
->ts
.type
== BT_INTEGER
)
1073 code
= TRUNC_DIV_EXPR
;
1078 case INTRINSIC_POWER
:
1079 gfc_conv_power_op (se
, expr
);
1082 case INTRINSIC_CONCAT
:
1083 gfc_conv_concat_op (se
, expr
);
1087 code
= TRUTH_ANDIF_EXPR
;
1092 code
= TRUTH_ORIF_EXPR
;
1096 /* EQV and NEQV only work on logicals, but since we represent them
1097 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1099 case INTRINSIC_EQ_OS
:
1107 case INTRINSIC_NE_OS
:
1108 case INTRINSIC_NEQV
:
1115 case INTRINSIC_GT_OS
:
1122 case INTRINSIC_GE_OS
:
1129 case INTRINSIC_LT_OS
:
1136 case INTRINSIC_LE_OS
:
1142 case INTRINSIC_USER
:
1143 case INTRINSIC_ASSIGN
:
1144 /* These should be converted into function calls by the frontend. */
1148 fatal_error ("Unknown intrinsic op");
1152 /* The only exception to this is **, which is handled separately anyway. */
1153 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1155 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1159 gfc_init_se (&lse
, se
);
1160 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1161 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1164 gfc_init_se (&rse
, se
);
1165 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1166 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1170 gfc_conv_string_parameter (&lse
);
1171 gfc_conv_string_parameter (&rse
);
1173 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1174 rse
.string_length
, rse
.expr
);
1175 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1176 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1179 type
= gfc_typenode_for_spec (&expr
->ts
);
1183 /* The result of logical ops is always boolean_type_node. */
1184 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1185 se
->expr
= convert (type
, tmp
);
1188 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1190 /* Add the post blocks. */
1191 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1192 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1195 /* If a string's length is one, we convert it to a single character. */
1198 gfc_to_single_character (tree len
, tree str
)
1200 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1202 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1203 && TREE_INT_CST_HIGH (len
) == 0)
1205 str
= fold_convert (pchar_type_node
, str
);
1206 return build_fold_indirect_ref (str
);
1214 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1217 if (sym
->backend_decl
)
1219 /* This becomes the nominal_type in
1220 function.c:assign_parm_find_data_types. */
1221 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1222 /* This becomes the passed_type in
1223 function.c:assign_parm_find_data_types. C promotes char to
1224 integer for argument passing. */
1225 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1227 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1232 /* If we have a constant character expression, make it into an
1234 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1238 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1239 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1241 /* The expr needs to be compatible with a C int. If the
1242 conversion fails, then the 2 causes an ICE. */
1243 ts
.type
= BT_INTEGER
;
1244 ts
.kind
= gfc_c_int_kind
;
1245 gfc_convert_type (*expr
, &ts
, 2);
1248 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1250 if ((*expr
)->ref
== NULL
)
1252 se
->expr
= gfc_to_single_character
1253 (build_int_cst (integer_type_node
, 1),
1254 gfc_build_addr_expr (pchar_type_node
,
1256 ((*expr
)->symtree
->n
.sym
)));
1260 gfc_conv_variable (se
, *expr
);
1261 se
->expr
= gfc_to_single_character
1262 (build_int_cst (integer_type_node
, 1),
1263 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1270 /* Compare two strings. If they are all single characters, the result is the
1271 subtraction of them. Otherwise, we build a library call. */
1274 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1281 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1282 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1284 type
= gfc_get_int_type (gfc_default_integer_kind
);
1286 sc1
= gfc_to_single_character (len1
, str1
);
1287 sc2
= gfc_to_single_character (len2
, str2
);
1289 /* Deal with single character specially. */
1290 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1292 sc1
= fold_convert (type
, sc1
);
1293 sc2
= fold_convert (type
, sc2
);
1294 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1297 /* Build a call for the comparison. */
1298 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1299 len1
, str1
, len2
, str2
);
1304 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1308 if (sym
->attr
.dummy
)
1310 tmp
= gfc_get_symbol_decl (sym
);
1311 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1312 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1316 if (!sym
->backend_decl
)
1317 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1319 tmp
= sym
->backend_decl
;
1320 if (sym
->attr
.cray_pointee
)
1321 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1322 gfc_get_symbol_decl (sym
->cp_pointer
));
1323 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1325 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1326 tmp
= build_fold_addr_expr (tmp
);
1333 /* Translate the call for an elemental subroutine call used in an operator
1334 assignment. This is a simplified version of gfc_conv_function_call. */
1337 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1344 /* Only elemental subroutines with two arguments. */
1345 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1346 gcc_assert (sym
->formal
->next
->next
== NULL
);
1348 gfc_init_block (&block
);
1350 gfc_add_block_to_block (&block
, &lse
->pre
);
1351 gfc_add_block_to_block (&block
, &rse
->pre
);
1353 /* Build the argument list for the call, including hidden string lengths. */
1354 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1355 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1356 if (lse
->string_length
!= NULL_TREE
)
1357 args
= gfc_chainon_list (args
, lse
->string_length
);
1358 if (rse
->string_length
!= NULL_TREE
)
1359 args
= gfc_chainon_list (args
, rse
->string_length
);
1361 /* Build the function call. */
1362 gfc_init_se (&se
, NULL
);
1363 gfc_conv_function_val (&se
, sym
);
1364 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1365 tmp
= build_call_list (tmp
, se
.expr
, args
);
1366 gfc_add_expr_to_block (&block
, tmp
);
1368 gfc_add_block_to_block (&block
, &lse
->post
);
1369 gfc_add_block_to_block (&block
, &rse
->post
);
1371 return gfc_finish_block (&block
);
1375 /* Initialize MAPPING. */
1378 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1380 mapping
->syms
= NULL
;
1381 mapping
->charlens
= NULL
;
1385 /* Free all memory held by MAPPING (but not MAPPING itself). */
1388 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1390 gfc_interface_sym_mapping
*sym
;
1391 gfc_interface_sym_mapping
*nextsym
;
1393 gfc_charlen
*nextcl
;
1395 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1397 nextsym
= sym
->next
;
1398 gfc_free_symbol (sym
->new->n
.sym
);
1399 gfc_free (sym
->new);
1402 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1405 gfc_free_expr (cl
->length
);
1411 /* Return a copy of gfc_charlen CL. Add the returned structure to
1412 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1414 static gfc_charlen
*
1415 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1420 new = gfc_get_charlen ();
1421 new->next
= mapping
->charlens
;
1422 new->length
= gfc_copy_expr (cl
->length
);
1424 mapping
->charlens
= new;
1429 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1430 array variable that can be used as the actual argument for dummy
1431 argument SYM. Add any initialization code to BLOCK. PACKED is as
1432 for gfc_get_nodesc_array_type and DATA points to the first element
1433 in the passed array. */
1436 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1437 gfc_packed packed
, tree data
)
1442 type
= gfc_typenode_for_spec (&sym
->ts
);
1443 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1445 var
= gfc_create_var (type
, "ifm");
1446 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1452 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1453 and offset of descriptorless array type TYPE given that it has the same
1454 size as DESC. Add any set-up code to BLOCK. */
1457 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1464 offset
= gfc_index_zero_node
;
1465 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1467 dim
= gfc_rank_cst
[n
];
1468 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1469 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1471 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1472 = gfc_conv_descriptor_lbound (desc
, dim
);
1473 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1474 = gfc_conv_descriptor_ubound (desc
, dim
);
1476 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1478 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1479 gfc_conv_descriptor_ubound (desc
, dim
),
1480 gfc_conv_descriptor_lbound (desc
, dim
));
1481 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1482 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1484 tmp
= gfc_evaluate_now (tmp
, block
);
1485 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1487 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1488 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1489 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1490 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1492 offset
= gfc_evaluate_now (offset
, block
);
1493 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1497 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1498 in SE. The caller may still use se->expr and se->string_length after
1499 calling this function. */
1502 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1503 gfc_symbol
* sym
, gfc_se
* se
)
1505 gfc_interface_sym_mapping
*sm
;
1509 gfc_symbol
*new_sym
;
1511 gfc_symtree
*new_symtree
;
1513 /* Create a new symbol to represent the actual argument. */
1514 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1515 new_sym
->ts
= sym
->ts
;
1516 new_sym
->attr
.referenced
= 1;
1517 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1518 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1519 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1520 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1522 /* Create a fake symtree for it. */
1524 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1525 new_symtree
->n
.sym
= new_sym
;
1526 gcc_assert (new_symtree
== root
);
1528 /* Create a dummy->actual mapping. */
1529 sm
= gfc_getmem (sizeof (*sm
));
1530 sm
->next
= mapping
->syms
;
1532 sm
->new = new_symtree
;
1535 /* Stabilize the argument's value. */
1536 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1538 if (sym
->ts
.type
== BT_CHARACTER
)
1540 /* Create a copy of the dummy argument's length. */
1541 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1543 /* If the length is specified as "*", record the length that
1544 the caller is passing. We should use the callee's length
1545 in all other cases. */
1546 if (!new_sym
->ts
.cl
->length
)
1548 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1549 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1553 /* Use the passed value as-is if the argument is a function. */
1554 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1557 /* If the argument is either a string or a pointer to a string,
1558 convert it to a boundless character type. */
1559 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1561 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1562 tmp
= build_pointer_type (tmp
);
1563 if (sym
->attr
.pointer
)
1564 value
= build_fold_indirect_ref (se
->expr
);
1567 value
= fold_convert (tmp
, value
);
1570 /* If the argument is a scalar, a pointer to an array or an allocatable,
1572 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1573 value
= build_fold_indirect_ref (se
->expr
);
1575 /* For character(*), use the actual argument's descriptor. */
1576 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1577 value
= build_fold_indirect_ref (se
->expr
);
1579 /* If the argument is an array descriptor, use it to determine
1580 information about the actual argument's shape. */
1581 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1582 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1584 /* Get the actual argument's descriptor. */
1585 desc
= build_fold_indirect_ref (se
->expr
);
1587 /* Create the replacement variable. */
1588 tmp
= gfc_conv_descriptor_data_get (desc
);
1589 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1592 /* Use DESC to work out the upper bounds, strides and offset. */
1593 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1596 /* Otherwise we have a packed array. */
1597 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1598 PACKED_FULL
, se
->expr
);
1600 new_sym
->backend_decl
= value
;
1604 /* Called once all dummy argument mappings have been added to MAPPING,
1605 but before the mapping is used to evaluate expressions. Pre-evaluate
1606 the length of each argument, adding any initialization code to PRE and
1607 any finalization code to POST. */
1610 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1611 stmtblock_t
* pre
, stmtblock_t
* post
)
1613 gfc_interface_sym_mapping
*sym
;
1617 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1618 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1619 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1621 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1622 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1623 gfc_init_se (&se
, NULL
);
1624 gfc_conv_expr (&se
, expr
);
1626 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1627 gfc_add_block_to_block (pre
, &se
.pre
);
1628 gfc_add_block_to_block (post
, &se
.post
);
1630 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1635 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1639 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1640 gfc_constructor
* c
)
1642 for (; c
; c
= c
->next
)
1644 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1647 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1648 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1649 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1655 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1659 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1664 for (; ref
; ref
= ref
->next
)
1668 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1670 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1671 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1672 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1674 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1681 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1682 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1688 /* EXPR is a copy of an expression that appeared in the interface
1689 associated with MAPPING. Walk it recursively looking for references to
1690 dummy arguments that MAPPING maps to actual arguments. Replace each such
1691 reference with a reference to the associated actual argument. */
1694 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1697 gfc_interface_sym_mapping
*sym
;
1698 gfc_actual_arglist
*actual
;
1699 int seen_result
= 0;
1704 /* Copying an expression does not copy its length, so do that here. */
1705 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1707 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1708 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1711 /* Apply the mapping to any references. */
1712 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1714 /* ...and to the expression's symbol, if it has one. */
1716 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1717 if (sym
->old
== expr
->symtree
->n
.sym
)
1718 expr
->symtree
= sym
->new;
1720 /* ...and to subexpressions in expr->value. */
1721 switch (expr
->expr_type
)
1724 if (expr
->symtree
->n
.sym
->attr
.result
)
1728 case EXPR_SUBSTRING
:
1732 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1733 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1737 if (expr
->value
.function
.esym
== NULL
1738 && expr
->value
.function
.isym
!= NULL
1739 && expr
->value
.function
.isym
->id
== GFC_ISYM_LEN
1740 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1741 && gfc_apply_interface_mapping_to_expr (mapping
,
1742 expr
->value
.function
.actual
->expr
))
1745 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1747 gfc_free (new_expr
);
1748 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1752 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1753 if (sym
->old
== expr
->value
.function
.esym
)
1754 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1756 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1757 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1761 case EXPR_STRUCTURE
:
1762 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1769 /* Evaluate interface expression EXPR using MAPPING. Store the result
1773 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1774 gfc_se
* se
, gfc_expr
* expr
)
1776 expr
= gfc_copy_expr (expr
);
1777 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1778 gfc_conv_expr (se
, expr
);
1779 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1780 gfc_free_expr (expr
);
1783 /* Returns a reference to a temporary array into which a component of
1784 an actual argument derived type array is copied and then returned
1785 after the function call.
1786 TODO Get rid of this kludge, when array descriptors are capable of
1787 handling arrays with a bigger stride in bytes than size. */
1790 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1791 int g77
, sym_intent intent
)
1807 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1809 gfc_init_se (&lse
, NULL
);
1810 gfc_init_se (&rse
, NULL
);
1812 /* Walk the argument expression. */
1813 rss
= gfc_walk_expr (expr
);
1815 gcc_assert (rss
!= gfc_ss_terminator
);
1817 /* Initialize the scalarizer. */
1818 gfc_init_loopinfo (&loop
);
1819 gfc_add_ss_to_loop (&loop
, rss
);
1821 /* Calculate the bounds of the scalarization. */
1822 gfc_conv_ss_startstride (&loop
);
1824 /* Build an ss for the temporary. */
1825 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1826 if (GFC_ARRAY_TYPE_P (base_type
)
1827 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1828 base_type
= gfc_get_element_type (base_type
);
1830 loop
.temp_ss
= gfc_get_ss ();;
1831 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1832 loop
.temp_ss
->data
.temp
.type
= base_type
;
1834 if (expr
->ts
.type
== BT_CHARACTER
)
1836 gfc_ref
*char_ref
= expr
->ref
;
1838 for (; char_ref
; char_ref
= char_ref
->next
)
1839 if (char_ref
->type
== REF_SUBSTRING
)
1843 expr
->ts
.cl
= gfc_get_charlen ();
1844 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1845 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1847 gfc_init_se (&tmp_se
, NULL
);
1848 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1849 gfc_array_index_type
);
1850 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1851 tmp_se
.expr
, gfc_index_one_node
);
1852 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1853 gfc_init_se (&tmp_se
, NULL
);
1854 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1855 gfc_array_index_type
);
1856 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1858 expr
->ts
.cl
->backend_decl
= tmp
;
1862 loop
.temp_ss
->data
.temp
.type
1863 = gfc_typenode_for_spec (&expr
->ts
);
1864 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1867 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1868 loop
.temp_ss
->next
= gfc_ss_terminator
;
1870 /* Associate the SS with the loop. */
1871 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1873 /* Setup the scalarizing loops. */
1874 gfc_conv_loop_setup (&loop
);
1876 /* Pass the temporary descriptor back to the caller. */
1877 info
= &loop
.temp_ss
->data
.info
;
1878 parmse
->expr
= info
->descriptor
;
1880 /* Setup the gfc_se structures. */
1881 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1882 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1885 lse
.ss
= loop
.temp_ss
;
1886 gfc_mark_ss_chain_used (rss
, 1);
1887 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1889 /* Start the scalarized loop body. */
1890 gfc_start_scalarized_body (&loop
, &body
);
1892 /* Translate the expression. */
1893 gfc_conv_expr (&rse
, expr
);
1895 gfc_conv_tmp_array_ref (&lse
);
1896 gfc_advance_se_ss_chain (&lse
);
1898 if (intent
!= INTENT_OUT
)
1900 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1901 gfc_add_expr_to_block (&body
, tmp
);
1902 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1903 gfc_trans_scalarizing_loops (&loop
, &body
);
1907 /* Make sure that the temporary declaration survives by merging
1908 all the loop declarations into the current context. */
1909 for (n
= 0; n
< loop
.dimen
; n
++)
1911 gfc_merge_block_scope (&body
);
1912 body
= loop
.code
[loop
.order
[n
]];
1914 gfc_merge_block_scope (&body
);
1917 /* Add the post block after the second loop, so that any
1918 freeing of allocated memory is done at the right time. */
1919 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1921 /**********Copy the temporary back again.*********/
1923 gfc_init_se (&lse
, NULL
);
1924 gfc_init_se (&rse
, NULL
);
1926 /* Walk the argument expression. */
1927 lss
= gfc_walk_expr (expr
);
1928 rse
.ss
= loop
.temp_ss
;
1931 /* Initialize the scalarizer. */
1932 gfc_init_loopinfo (&loop2
);
1933 gfc_add_ss_to_loop (&loop2
, lss
);
1935 /* Calculate the bounds of the scalarization. */
1936 gfc_conv_ss_startstride (&loop2
);
1938 /* Setup the scalarizing loops. */
1939 gfc_conv_loop_setup (&loop2
);
1941 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1942 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1944 gfc_mark_ss_chain_used (lss
, 1);
1945 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1947 /* Declare the variable to hold the temporary offset and start the
1948 scalarized loop body. */
1949 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1950 gfc_start_scalarized_body (&loop2
, &body
);
1952 /* Build the offsets for the temporary from the loop variables. The
1953 temporary array has lbounds of zero and strides of one in all
1954 dimensions, so this is very simple. The offset is only computed
1955 outside the innermost loop, so the overall transfer could be
1956 optimized further. */
1957 info
= &rse
.ss
->data
.info
;
1959 tmp_index
= gfc_index_zero_node
;
1960 for (n
= info
->dimen
- 1; n
> 0; n
--)
1963 tmp
= rse
.loop
->loopvar
[n
];
1964 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1965 tmp
, rse
.loop
->from
[n
]);
1966 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1969 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1970 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1971 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1972 tmp_str
, gfc_index_one_node
);
1974 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1978 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1979 tmp_index
, rse
.loop
->from
[0]);
1980 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1982 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1983 rse
.loop
->loopvar
[0], offset
);
1985 /* Now use the offset for the reference. */
1986 tmp
= build_fold_indirect_ref (info
->data
);
1987 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1989 if (expr
->ts
.type
== BT_CHARACTER
)
1990 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1992 gfc_conv_expr (&lse
, expr
);
1994 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1996 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1997 gfc_add_expr_to_block (&body
, tmp
);
1999 /* Generate the copying loops. */
2000 gfc_trans_scalarizing_loops (&loop2
, &body
);
2002 /* Wrap the whole thing up by adding the second loop to the post-block
2003 and following it by the post-block of the first loop. In this way,
2004 if the temporary needs freeing, it is done after use! */
2005 if (intent
!= INTENT_IN
)
2007 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2008 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2011 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2013 gfc_cleanup_loop (&loop
);
2014 gfc_cleanup_loop (&loop2
);
2016 /* Pass the string length to the argument expression. */
2017 if (expr
->ts
.type
== BT_CHARACTER
)
2018 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2020 /* We want either the address for the data or the address of the descriptor,
2021 depending on the mode of passing array arguments. */
2023 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2025 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2030 /* Is true if an array reference is followed by a component or substring
2034 is_aliased_array (gfc_expr
* e
)
2040 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2042 if (ref
->type
== REF_ARRAY
2043 && ref
->u
.ar
.type
!= AR_ELEMENT
)
2047 && ref
->type
!= REF_ARRAY
)
2053 /* Generate the code for argument list functions. */
2056 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2058 /* Pass by value for g77 %VAL(arg), pass the address
2059 indirectly for %LOC, else by reference. Thus %REF
2060 is a "do-nothing" and %LOC is the same as an F95
2062 if (strncmp (name
, "%VAL", 4) == 0)
2063 gfc_conv_expr (se
, expr
);
2064 else if (strncmp (name
, "%LOC", 4) == 0)
2066 gfc_conv_expr_reference (se
, expr
);
2067 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2069 else if (strncmp (name
, "%REF", 4) == 0)
2070 gfc_conv_expr_reference (se
, expr
);
2072 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2076 /* Generate code for a procedure call. Note can return se->post != NULL.
2077 If se->direct_byref is set then se->expr contains the return parameter.
2078 Return nonzero, if the call has alternate specifiers. */
2081 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2082 gfc_actual_arglist
* arg
, tree append_args
)
2084 gfc_interface_mapping mapping
;
2098 gfc_formal_arglist
*formal
;
2099 int has_alternate_specifier
= 0;
2100 bool need_interface_mapping
;
2107 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2109 arglist
= NULL_TREE
;
2110 retargs
= NULL_TREE
;
2111 stringargs
= NULL_TREE
;
2115 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2117 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2119 if (arg
->expr
->rank
== 0)
2120 gfc_conv_expr_reference (se
, arg
->expr
);
2124 /* This is really the actual arg because no formal arglist is
2125 created for C_LOC. */
2126 fsym
= arg
->expr
->symtree
->n
.sym
;
2128 /* We should want it to do g77 calling convention. */
2130 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2131 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2132 f
= f
|| !sym
->attr
.always_explicit
;
2134 argss
= gfc_walk_expr (arg
->expr
);
2135 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2140 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2142 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2143 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2144 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2145 gfc_conv_expr_reference (se
, arg
->expr
);
2153 if (!sym
->attr
.elemental
)
2155 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2156 if (se
->ss
->useflags
)
2158 gcc_assert (gfc_return_by_reference (sym
)
2159 && sym
->result
->attr
.dimension
);
2160 gcc_assert (se
->loop
!= NULL
);
2162 /* Access the previously obtained result. */
2163 gfc_conv_tmp_array_ref (se
);
2164 gfc_advance_se_ss_chain (se
);
2168 info
= &se
->ss
->data
.info
;
2173 gfc_init_block (&post
);
2174 gfc_init_interface_mapping (&mapping
);
2175 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2176 && sym
->ts
.cl
->length
2177 && sym
->ts
.cl
->length
->expr_type
2179 || sym
->attr
.dimension
);
2180 formal
= sym
->formal
;
2181 /* Evaluate the arguments. */
2182 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2185 fsym
= formal
? formal
->sym
: NULL
;
2186 parm_kind
= MISSING
;
2190 if (se
->ignore_optional
)
2192 /* Some intrinsics have already been resolved to the correct
2196 else if (arg
->label
)
2198 has_alternate_specifier
= 1;
2203 /* Pass a NULL pointer for an absent arg. */
2204 gfc_init_se (&parmse
, NULL
);
2205 parmse
.expr
= null_pointer_node
;
2206 if (arg
->missing_arg_type
== BT_CHARACTER
)
2207 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2210 else if (se
->ss
&& se
->ss
->useflags
)
2212 /* An elemental function inside a scalarized loop. */
2213 gfc_init_se (&parmse
, se
);
2214 gfc_conv_expr_reference (&parmse
, e
);
2215 parm_kind
= ELEMENTAL
;
2219 /* A scalar or transformational function. */
2220 gfc_init_se (&parmse
, NULL
);
2221 argss
= gfc_walk_expr (e
);
2223 if (argss
== gfc_ss_terminator
)
2225 if (fsym
&& fsym
->attr
.value
)
2227 if (fsym
->ts
.type
== BT_CHARACTER
2228 && fsym
->ts
.is_c_interop
2229 && fsym
->ns
->proc_name
!= NULL
2230 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2233 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2234 if (parmse
.expr
== NULL
)
2235 gfc_conv_expr (&parmse
, e
);
2238 gfc_conv_expr (&parmse
, e
);
2240 else if (arg
->name
&& arg
->name
[0] == '%')
2241 /* Argument list functions %VAL, %LOC and %REF are signalled
2242 through arg->name. */
2243 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2244 else if ((e
->expr_type
== EXPR_FUNCTION
)
2245 && e
->symtree
->n
.sym
->attr
.pointer
2246 && fsym
&& fsym
->attr
.target
)
2248 gfc_conv_expr (&parmse
, e
);
2249 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2253 gfc_conv_expr_reference (&parmse
, e
);
2254 if (fsym
&& fsym
->attr
.pointer
2255 && fsym
->attr
.flavor
!= FL_PROCEDURE
2256 && e
->expr_type
!= EXPR_NULL
)
2258 /* Scalar pointer dummy args require an extra level of
2259 indirection. The null pointer already contains
2260 this level of indirection. */
2261 parm_kind
= SCALAR_POINTER
;
2262 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2268 /* If the procedure requires an explicit interface, the actual
2269 argument is passed according to the corresponding formal
2270 argument. If the corresponding formal argument is a POINTER,
2271 ALLOCATABLE or assumed shape, we do not use g77's calling
2272 convention, and pass the address of the array descriptor
2273 instead. Otherwise we use g77's calling convention. */
2276 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2277 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2278 f
= f
|| !sym
->attr
.always_explicit
;
2280 if (e
->expr_type
== EXPR_VARIABLE
2281 && is_aliased_array (e
))
2282 /* The actual argument is a component reference to an
2283 array of derived types. In this case, the argument
2284 is converted to a temporary, which is passed and then
2285 written back after the procedure call. */
2286 gfc_conv_aliased_arg (&parmse
, e
, f
,
2287 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2289 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2291 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2292 allocated on entry, it must be deallocated. */
2293 if (fsym
&& fsym
->attr
.allocatable
2294 && fsym
->attr
.intent
== INTENT_OUT
)
2296 tmp
= build_fold_indirect_ref (parmse
.expr
);
2297 tmp
= gfc_trans_dealloc_allocated (tmp
);
2298 gfc_add_expr_to_block (&se
->pre
, tmp
);
2308 /* If an optional argument is itself an optional dummy
2309 argument, check its presence and substitute a null
2311 if (e
->expr_type
== EXPR_VARIABLE
2312 && e
->symtree
->n
.sym
->attr
.optional
2313 && fsym
->attr
.optional
)
2314 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2316 /* Obtain the character length of an assumed character
2317 length procedure from the typespec. */
2318 if (fsym
->ts
.type
== BT_CHARACTER
2319 && parmse
.string_length
== NULL_TREE
2320 && e
->ts
.type
== BT_PROCEDURE
2321 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2322 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2324 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2325 parmse
.string_length
2326 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2330 if (need_interface_mapping
)
2331 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2334 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2335 gfc_add_block_to_block (&post
, &parmse
.post
);
2337 /* Allocated allocatable components of derived types must be
2338 deallocated for INTENT(OUT) dummy arguments and non-variable
2339 scalars. Non-variable arrays are dealt with in trans-array.c
2340 (gfc_conv_array_parameter). */
2341 if (e
&& e
->ts
.type
== BT_DERIVED
2342 && e
->ts
.derived
->attr
.alloc_comp
2343 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2345 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2348 tmp
= build_fold_indirect_ref (parmse
.expr
);
2349 parm_rank
= e
->rank
;
2357 case (SCALAR_POINTER
):
2358 tmp
= build_fold_indirect_ref (tmp
);
2365 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2366 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2367 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2368 tmp
, build_empty_stmt ());
2370 if (e
->expr_type
!= EXPR_VARIABLE
)
2371 /* Don't deallocate non-variables until they have been used. */
2372 gfc_add_expr_to_block (&se
->post
, tmp
);
2375 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2376 gfc_add_expr_to_block (&se
->pre
, tmp
);
2380 /* Character strings are passed as two parameters, a length and a
2382 if (parmse
.string_length
!= NULL_TREE
)
2383 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2385 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2387 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2390 if (ts
.type
== BT_CHARACTER
)
2392 if (sym
->ts
.cl
->length
== NULL
)
2394 /* Assumed character length results are not allowed by 5.1.1.5 of the
2395 standard and are trapped in resolve.c; except in the case of SPREAD
2396 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2397 we take the character length of the first argument for the result.
2398 For dummies, we have to look through the formal argument list for
2399 this function and use the character length found there.*/
2400 if (!sym
->attr
.dummy
)
2401 cl
.backend_decl
= TREE_VALUE (stringargs
);
2404 formal
= sym
->ns
->proc_name
->formal
;
2405 for (; formal
; formal
= formal
->next
)
2406 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2407 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2414 /* Calculate the length of the returned string. */
2415 gfc_init_se (&parmse
, NULL
);
2416 if (need_interface_mapping
)
2417 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2419 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2420 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2421 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2423 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2424 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2425 build_int_cst (gfc_charlen_type_node
, 0));
2426 cl
.backend_decl
= tmp
;
2429 /* Set up a charlen structure for it. */
2434 len
= cl
.backend_decl
;
2437 byref
= gfc_return_by_reference (sym
);
2440 if (se
->direct_byref
)
2442 /* Sometimes, too much indirection can be applied; eg. for
2443 function_result = array_valued_recursive_function. */
2444 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2445 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2446 && GFC_DESCRIPTOR_TYPE_P
2447 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2448 se
->expr
= build_fold_indirect_ref (se
->expr
);
2450 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2452 else if (sym
->result
->attr
.dimension
)
2454 gcc_assert (se
->loop
&& info
);
2456 /* Set the type of the array. */
2457 tmp
= gfc_typenode_for_spec (&ts
);
2458 info
->dimen
= se
->loop
->dimen
;
2460 /* Evaluate the bounds of the result, if known. */
2461 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2463 /* Create a temporary to store the result. In case the function
2464 returns a pointer, the temporary will be a shallow copy and
2465 mustn't be deallocated. */
2466 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2467 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2468 false, !sym
->attr
.pointer
, callee_alloc
);
2470 /* Pass the temporary as the first argument. */
2471 tmp
= info
->descriptor
;
2472 tmp
= build_fold_addr_expr (tmp
);
2473 retargs
= gfc_chainon_list (retargs
, tmp
);
2475 else if (ts
.type
== BT_CHARACTER
)
2477 /* Pass the string length. */
2478 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2479 type
= build_pointer_type (type
);
2481 /* Return an address to a char[0:len-1]* temporary for
2482 character pointers. */
2483 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2485 /* Build char[0:len-1] * pstr. */
2486 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2487 build_int_cst (gfc_charlen_type_node
, 1));
2488 tmp
= build_range_type (gfc_array_index_type
,
2489 gfc_index_zero_node
, tmp
);
2490 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2491 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2493 /* Provide an address expression for the function arguments. */
2494 var
= build_fold_addr_expr (var
);
2497 var
= gfc_conv_string_tmp (se
, type
, len
);
2499 retargs
= gfc_chainon_list (retargs
, var
);
2503 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2505 type
= gfc_get_complex_type (ts
.kind
);
2506 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2507 retargs
= gfc_chainon_list (retargs
, var
);
2510 /* Add the string length to the argument list. */
2511 if (ts
.type
== BT_CHARACTER
)
2512 retargs
= gfc_chainon_list (retargs
, len
);
2514 gfc_free_interface_mapping (&mapping
);
2516 /* Add the return arguments. */
2517 arglist
= chainon (retargs
, arglist
);
2519 /* Add the hidden string length parameters to the arguments. */
2520 arglist
= chainon (arglist
, stringargs
);
2522 /* We may want to append extra arguments here. This is used e.g. for
2523 calls to libgfortran_matmul_??, which need extra information. */
2524 if (append_args
!= NULL_TREE
)
2525 arglist
= chainon (arglist
, append_args
);
2527 /* Generate the actual call. */
2528 gfc_conv_function_val (se
, sym
);
2530 /* If there are alternate return labels, function type should be
2531 integer. Can't modify the type in place though, since it can be shared
2532 with other functions. For dummy arguments, the typing is done to
2533 to this result, even if it has to be repeated for each call. */
2534 if (has_alternate_specifier
2535 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2537 if (!sym
->attr
.dummy
)
2539 TREE_TYPE (sym
->backend_decl
)
2540 = build_function_type (integer_type_node
,
2541 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2542 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2545 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2548 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2549 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2551 /* If we have a pointer function, but we don't want a pointer, e.g.
2554 where f is pointer valued, we have to dereference the result. */
2555 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2556 se
->expr
= build_fold_indirect_ref (se
->expr
);
2558 /* f2c calling conventions require a scalar default real function to
2559 return a double precision result. Convert this back to default
2560 real. We only care about the cases that can happen in Fortran 77.
2562 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2563 && sym
->ts
.kind
== gfc_default_real_kind
2564 && !sym
->attr
.always_explicit
)
2565 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2567 /* A pure function may still have side-effects - it may modify its
2569 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2571 if (!sym
->attr
.pure
)
2572 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2577 /* Add the function call to the pre chain. There is no expression. */
2578 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2579 se
->expr
= NULL_TREE
;
2581 if (!se
->direct_byref
)
2583 if (sym
->attr
.dimension
)
2585 if (flag_bounds_check
)
2587 /* Check the data pointer hasn't been modified. This would
2588 happen in a function returning a pointer. */
2589 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2590 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2592 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2594 se
->expr
= info
->descriptor
;
2595 /* Bundle in the string length. */
2596 se
->string_length
= len
;
2598 else if (sym
->ts
.type
== BT_CHARACTER
)
2600 /* Dereference for character pointer results. */
2601 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2602 se
->expr
= build_fold_indirect_ref (var
);
2606 se
->string_length
= len
;
2610 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2611 se
->expr
= build_fold_indirect_ref (var
);
2616 /* Follow the function call with the argument post block. */
2618 gfc_add_block_to_block (&se
->pre
, &post
);
2620 gfc_add_block_to_block (&se
->post
, &post
);
2622 return has_alternate_specifier
;
2626 /* Generate code to copy a string. */
2629 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2630 tree slength
, tree src
)
2632 tree tmp
, dlen
, slen
;
2640 stmtblock_t tempblock
;
2642 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2643 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2645 /* Deal with single character specially. */
2646 dsc
= gfc_to_single_character (dlen
, dest
);
2647 ssc
= gfc_to_single_character (slen
, src
);
2648 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2650 gfc_add_modify_expr (block
, dsc
, ssc
);
2654 /* Do nothing if the destination length is zero. */
2655 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2656 build_int_cst (size_type_node
, 0));
2658 /* The following code was previously in _gfortran_copy_string:
2660 // The two strings may overlap so we use memmove.
2662 copy_string (GFC_INTEGER_4 destlen, char * dest,
2663 GFC_INTEGER_4 srclen, const char * src)
2665 if (srclen >= destlen)
2667 // This will truncate if too long.
2668 memmove (dest, src, destlen);
2672 memmove (dest, src, srclen);
2674 memset (&dest[srclen], ' ', destlen - srclen);
2678 We're now doing it here for better optimization, but the logic
2681 /* Truncate string if source is too long. */
2682 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2683 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2684 3, dest
, src
, dlen
);
2686 /* Else copy and pad with spaces. */
2687 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2688 3, dest
, src
, slen
);
2690 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, dest
,
2691 fold_convert (sizetype
, slen
));
2692 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2694 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2695 lang_hooks
.to_target_charset (' ')),
2696 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2699 gfc_init_block (&tempblock
);
2700 gfc_add_expr_to_block (&tempblock
, tmp3
);
2701 gfc_add_expr_to_block (&tempblock
, tmp4
);
2702 tmp3
= gfc_finish_block (&tempblock
);
2704 /* The whole copy_string function is there. */
2705 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2706 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2707 gfc_add_expr_to_block (block
, tmp
);
2711 /* Translate a statement function.
2712 The value of a statement function reference is obtained by evaluating the
2713 expression using the values of the actual arguments for the values of the
2714 corresponding dummy arguments. */
2717 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2721 gfc_formal_arglist
*fargs
;
2722 gfc_actual_arglist
*args
;
2725 gfc_saved_var
*saved_vars
;
2731 sym
= expr
->symtree
->n
.sym
;
2732 args
= expr
->value
.function
.actual
;
2733 gfc_init_se (&lse
, NULL
);
2734 gfc_init_se (&rse
, NULL
);
2737 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2739 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2740 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2742 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2744 /* Each dummy shall be specified, explicitly or implicitly, to be
2746 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2749 /* Create a temporary to hold the value. */
2750 type
= gfc_typenode_for_spec (&fsym
->ts
);
2751 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2753 if (fsym
->ts
.type
== BT_CHARACTER
)
2755 /* Copy string arguments. */
2758 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2759 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2761 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2762 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2765 gfc_conv_expr (&rse
, args
->expr
);
2766 gfc_conv_string_parameter (&rse
);
2767 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2768 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2770 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2772 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2773 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2777 /* For everything else, just evaluate the expression. */
2778 gfc_conv_expr (&lse
, args
->expr
);
2780 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2781 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2782 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2788 /* Use the temporary variables in place of the real ones. */
2789 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2790 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2792 gfc_conv_expr (se
, sym
->value
);
2794 if (sym
->ts
.type
== BT_CHARACTER
)
2796 gfc_conv_const_charlen (sym
->ts
.cl
);
2798 /* Force the expression to the correct length. */
2799 if (!INTEGER_CST_P (se
->string_length
)
2800 || tree_int_cst_lt (se
->string_length
,
2801 sym
->ts
.cl
->backend_decl
))
2803 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2804 tmp
= gfc_create_var (type
, sym
->name
);
2805 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2806 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2807 se
->string_length
, se
->expr
);
2810 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2813 /* Restore the original variables. */
2814 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2815 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2816 gfc_free (saved_vars
);
2820 /* Translate a function expression. */
2823 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2827 if (expr
->value
.function
.isym
)
2829 gfc_conv_intrinsic_function (se
, expr
);
2833 /* We distinguish statement functions from general functions to improve
2834 runtime performance. */
2835 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2837 gfc_conv_statement_function (se
, expr
);
2841 /* expr.value.function.esym is the resolved (specific) function symbol for
2842 most functions. However this isn't set for dummy procedures. */
2843 sym
= expr
->value
.function
.esym
;
2845 sym
= expr
->symtree
->n
.sym
;
2846 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2851 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2853 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2854 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2856 gfc_conv_tmp_array_ref (se
);
2857 gfc_advance_se_ss_chain (se
);
2861 /* Build a static initializer. EXPR is the expression for the initial value.
2862 The other parameters describe the variable of the component being
2863 initialized. EXPR may be null. */
2866 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2867 bool array
, bool pointer
)
2871 if (!(expr
|| pointer
))
2874 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
2875 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
2876 && (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
2877 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
))
2878 expr
= gfc_int_expr (0);
2882 /* Arrays need special handling. */
2884 return gfc_build_null_descriptor (type
);
2886 return gfc_conv_array_initializer (type
, expr
);
2889 return fold_convert (type
, null_pointer_node
);
2895 gfc_init_se (&se
, NULL
);
2896 gfc_conv_structure (&se
, expr
, 1);
2900 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2903 gfc_init_se (&se
, NULL
);
2904 gfc_conv_constant (&se
, expr
);
2911 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2923 gfc_start_block (&block
);
2925 /* Initialize the scalarizer. */
2926 gfc_init_loopinfo (&loop
);
2928 gfc_init_se (&lse
, NULL
);
2929 gfc_init_se (&rse
, NULL
);
2932 rss
= gfc_walk_expr (expr
);
2933 if (rss
== gfc_ss_terminator
)
2935 /* The rhs is scalar. Add a ss for the expression. */
2936 rss
= gfc_get_ss ();
2937 rss
->next
= gfc_ss_terminator
;
2938 rss
->type
= GFC_SS_SCALAR
;
2942 /* Create a SS for the destination. */
2943 lss
= gfc_get_ss ();
2944 lss
->type
= GFC_SS_COMPONENT
;
2946 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2947 lss
->next
= gfc_ss_terminator
;
2948 lss
->data
.info
.dimen
= cm
->as
->rank
;
2949 lss
->data
.info
.descriptor
= dest
;
2950 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2951 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2952 for (n
= 0; n
< cm
->as
->rank
; n
++)
2954 lss
->data
.info
.dim
[n
] = n
;
2955 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2956 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2958 mpz_init (lss
->shape
[n
]);
2959 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2960 cm
->as
->lower
[n
]->value
.integer
);
2961 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2964 /* Associate the SS with the loop. */
2965 gfc_add_ss_to_loop (&loop
, lss
);
2966 gfc_add_ss_to_loop (&loop
, rss
);
2968 /* Calculate the bounds of the scalarization. */
2969 gfc_conv_ss_startstride (&loop
);
2971 /* Setup the scalarizing loops. */
2972 gfc_conv_loop_setup (&loop
);
2974 /* Setup the gfc_se structures. */
2975 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2976 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2979 gfc_mark_ss_chain_used (rss
, 1);
2981 gfc_mark_ss_chain_used (lss
, 1);
2983 /* Start the scalarized loop body. */
2984 gfc_start_scalarized_body (&loop
, &body
);
2986 gfc_conv_tmp_array_ref (&lse
);
2987 if (cm
->ts
.type
== BT_CHARACTER
)
2988 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2990 gfc_conv_expr (&rse
, expr
);
2992 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2993 gfc_add_expr_to_block (&body
, tmp
);
2995 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2997 /* Generate the copying loops. */
2998 gfc_trans_scalarizing_loops (&loop
, &body
);
3000 /* Wrap the whole thing up. */
3001 gfc_add_block_to_block (&block
, &loop
.pre
);
3002 gfc_add_block_to_block (&block
, &loop
.post
);
3004 for (n
= 0; n
< cm
->as
->rank
; n
++)
3005 mpz_clear (lss
->shape
[n
]);
3006 gfc_free (lss
->shape
);
3008 gfc_cleanup_loop (&loop
);
3010 return gfc_finish_block (&block
);
3014 /* Assign a single component of a derived type constructor. */
3017 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3027 gfc_start_block (&block
);
3031 gfc_init_se (&se
, NULL
);
3032 /* Pointer component. */
3035 /* Array pointer. */
3036 if (expr
->expr_type
== EXPR_NULL
)
3037 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3040 rss
= gfc_walk_expr (expr
);
3041 se
.direct_byref
= 1;
3043 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3044 gfc_add_block_to_block (&block
, &se
.pre
);
3045 gfc_add_block_to_block (&block
, &se
.post
);
3050 /* Scalar pointers. */
3051 se
.want_pointer
= 1;
3052 gfc_conv_expr (&se
, expr
);
3053 gfc_add_block_to_block (&block
, &se
.pre
);
3054 gfc_add_modify_expr (&block
, dest
,
3055 fold_convert (TREE_TYPE (dest
), se
.expr
));
3056 gfc_add_block_to_block (&block
, &se
.post
);
3059 else if (cm
->dimension
)
3061 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3062 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3063 else if (cm
->allocatable
)
3067 gfc_init_se (&se
, NULL
);
3069 rss
= gfc_walk_expr (expr
);
3070 se
.want_pointer
= 0;
3071 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3072 gfc_add_block_to_block (&block
, &se
.pre
);
3074 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3075 gfc_add_modify_expr (&block
, dest
, tmp
);
3077 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3078 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3081 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3082 TREE_TYPE(cm
->backend_decl
),
3085 gfc_add_expr_to_block (&block
, tmp
);
3087 gfc_add_block_to_block (&block
, &se
.post
);
3088 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3090 /* Shift the lbound and ubound of temporaries to being unity, rather
3091 than zero, based. Calculate the offset for all cases. */
3092 offset
= gfc_conv_descriptor_offset (dest
);
3093 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3094 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3095 for (n
= 0; n
< expr
->rank
; n
++)
3097 if (expr
->expr_type
!= EXPR_VARIABLE
3098 && expr
->expr_type
!= EXPR_CONSTANT
)
3101 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3102 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3103 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3104 gfc_add_modify_expr (&block
, tmp
,
3105 fold_build2 (PLUS_EXPR
,
3106 gfc_array_index_type
,
3107 span
, gfc_index_one_node
));
3108 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3109 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3111 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3112 gfc_conv_descriptor_lbound (dest
,
3114 gfc_conv_descriptor_stride (dest
,
3116 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3117 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3118 gfc_add_modify_expr (&block
, offset
, tmp
);
3123 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3124 gfc_add_expr_to_block (&block
, tmp
);
3127 else if (expr
->ts
.type
== BT_DERIVED
)
3129 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3131 gfc_init_se (&se
, NULL
);
3132 gfc_conv_expr (&se
, expr
);
3133 gfc_add_modify_expr (&block
, dest
,
3134 fold_convert (TREE_TYPE (dest
), se
.expr
));
3138 /* Nested constructors. */
3139 tmp
= gfc_trans_structure_assign (dest
, expr
);
3140 gfc_add_expr_to_block (&block
, tmp
);
3145 /* Scalar component. */
3146 gfc_init_se (&se
, NULL
);
3147 gfc_init_se (&lse
, NULL
);
3149 gfc_conv_expr (&se
, expr
);
3150 if (cm
->ts
.type
== BT_CHARACTER
)
3151 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3153 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3154 gfc_add_expr_to_block (&block
, tmp
);
3156 return gfc_finish_block (&block
);
3159 /* Assign a derived type constructor to a variable. */
3162 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3170 gfc_start_block (&block
);
3171 cm
= expr
->ts
.derived
->components
;
3172 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3174 /* Skip absent members in default initializers. */
3178 field
= cm
->backend_decl
;
3179 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3180 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3181 gfc_add_expr_to_block (&block
, tmp
);
3183 return gfc_finish_block (&block
);
3186 /* Build an expression for a constructor. If init is nonzero then
3187 this is part of a static variable initializer. */
3190 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3197 VEC(constructor_elt
,gc
) *v
= NULL
;
3199 gcc_assert (se
->ss
== NULL
);
3200 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3201 type
= gfc_typenode_for_spec (&expr
->ts
);
3205 /* Create a temporary variable and fill it in. */
3206 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3207 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3208 gfc_add_expr_to_block (&se
->pre
, tmp
);
3212 cm
= expr
->ts
.derived
->components
;
3214 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3216 /* Skip absent members in default initializers and allocatable
3217 components. Although the latter have a default initializer
3218 of EXPR_NULL,... by default, the static nullify is not needed
3219 since this is done every time we come into scope. */
3220 if (!c
->expr
|| cm
->allocatable
)
3223 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3224 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3226 /* Append it to the constructor list. */
3227 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3229 se
->expr
= build_constructor (type
, v
);
3233 /* Translate a substring expression. */
3236 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3242 gcc_assert (ref
->type
== REF_SUBSTRING
);
3244 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3245 expr
->value
.character
.string
);
3246 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3247 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3249 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3253 /* Entry point for expression translation. Evaluates a scalar quantity.
3254 EXPR is the expression to be translated, and SE is the state structure if
3255 called from within the scalarized. */
3258 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3260 if (se
->ss
&& se
->ss
->expr
== expr
3261 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3263 /* Substitute a scalar expression evaluated outside the scalarization
3265 se
->expr
= se
->ss
->data
.scalar
.expr
;
3266 se
->string_length
= se
->ss
->string_length
;
3267 gfc_advance_se_ss_chain (se
);
3271 /* We need to convert the expressions for the iso_c_binding derived types.
3272 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3273 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3274 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3275 updated to be an integer with a kind equal to the size of a (void *). */
3276 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3277 && expr
->ts
.derived
->attr
.is_iso_c
)
3279 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3280 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3282 /* Set expr_type to EXPR_NULL, which will result in
3283 null_pointer_node being used below. */
3284 expr
->expr_type
= EXPR_NULL
;
3288 /* Update the type/kind of the expression to be what the new
3289 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3290 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3291 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3292 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3296 switch (expr
->expr_type
)
3299 gfc_conv_expr_op (se
, expr
);
3303 gfc_conv_function_expr (se
, expr
);
3307 gfc_conv_constant (se
, expr
);
3311 gfc_conv_variable (se
, expr
);
3315 se
->expr
= null_pointer_node
;
3318 case EXPR_SUBSTRING
:
3319 gfc_conv_substring_expr (se
, expr
);
3322 case EXPR_STRUCTURE
:
3323 gfc_conv_structure (se
, expr
, 0);
3327 gfc_conv_array_constructor_expr (se
, expr
);
3336 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3337 of an assignment. */
3339 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3341 gfc_conv_expr (se
, expr
);
3342 /* All numeric lvalues should have empty post chains. If not we need to
3343 figure out a way of rewriting an lvalue so that it has no post chain. */
3344 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3347 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3348 numeric expressions. Used for scalar values where inserting cleanup code
3351 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3355 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3356 gfc_conv_expr (se
, expr
);
3359 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3360 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3362 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3366 /* Helper to translate and expression and convert it to a particular type. */
3368 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3370 gfc_conv_expr_val (se
, expr
);
3371 se
->expr
= convert (type
, se
->expr
);
3375 /* Converts an expression so that it can be passed by reference. Scalar
3379 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3383 if (se
->ss
&& se
->ss
->expr
== expr
3384 && se
->ss
->type
== GFC_SS_REFERENCE
)
3386 se
->expr
= se
->ss
->data
.scalar
.expr
;
3387 se
->string_length
= se
->ss
->string_length
;
3388 gfc_advance_se_ss_chain (se
);
3392 if (expr
->ts
.type
== BT_CHARACTER
)
3394 gfc_conv_expr (se
, expr
);
3395 gfc_conv_string_parameter (se
);
3399 if (expr
->expr_type
== EXPR_VARIABLE
)
3401 se
->want_pointer
= 1;
3402 gfc_conv_expr (se
, expr
);
3405 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3406 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3407 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3413 if (expr
->expr_type
== EXPR_FUNCTION
3414 && expr
->symtree
->n
.sym
->attr
.pointer
3415 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3417 se
->want_pointer
= 1;
3418 gfc_conv_expr (se
, expr
);
3419 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3420 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3426 gfc_conv_expr (se
, expr
);
3428 /* Create a temporary var to hold the value. */
3429 if (TREE_CONSTANT (se
->expr
))
3431 tree tmp
= se
->expr
;
3432 STRIP_TYPE_NOPS (tmp
);
3433 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3434 DECL_INITIAL (var
) = tmp
;
3435 TREE_STATIC (var
) = 1;
3440 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3441 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3443 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3445 /* Take the address of that value. */
3446 se
->expr
= build_fold_addr_expr (var
);
3451 gfc_trans_pointer_assign (gfc_code
* code
)
3453 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3457 /* Generate code for a pointer assignment. */
3460 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3470 gfc_start_block (&block
);
3472 gfc_init_se (&lse
, NULL
);
3474 lss
= gfc_walk_expr (expr1
);
3475 rss
= gfc_walk_expr (expr2
);
3476 if (lss
== gfc_ss_terminator
)
3478 /* Scalar pointers. */
3479 lse
.want_pointer
= 1;
3480 gfc_conv_expr (&lse
, expr1
);
3481 gcc_assert (rss
== gfc_ss_terminator
);
3482 gfc_init_se (&rse
, NULL
);
3483 rse
.want_pointer
= 1;
3484 gfc_conv_expr (&rse
, expr2
);
3485 gfc_add_block_to_block (&block
, &lse
.pre
);
3486 gfc_add_block_to_block (&block
, &rse
.pre
);
3487 gfc_add_modify_expr (&block
, lse
.expr
,
3488 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3489 gfc_add_block_to_block (&block
, &rse
.post
);
3490 gfc_add_block_to_block (&block
, &lse
.post
);
3494 /* Array pointer. */
3495 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3496 switch (expr2
->expr_type
)
3499 /* Just set the data pointer to null. */
3500 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3504 /* Assign directly to the pointer's descriptor. */
3505 lse
.direct_byref
= 1;
3506 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3510 /* Assign to a temporary descriptor and then copy that
3511 temporary to the pointer. */
3513 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3516 lse
.direct_byref
= 1;
3517 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3518 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3521 gfc_add_block_to_block (&block
, &lse
.pre
);
3522 gfc_add_block_to_block (&block
, &lse
.post
);
3524 return gfc_finish_block (&block
);
3528 /* Makes sure se is suitable for passing as a function string parameter. */
3529 /* TODO: Need to check all callers fo this function. It may be abused. */
3532 gfc_conv_string_parameter (gfc_se
* se
)
3536 if (TREE_CODE (se
->expr
) == STRING_CST
)
3538 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3542 type
= TREE_TYPE (se
->expr
);
3543 if (TYPE_STRING_FLAG (type
))
3545 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3546 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3549 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3550 gcc_assert (se
->string_length
3551 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3555 /* Generate code for assignment of scalar variables. Includes character
3556 strings and derived types with allocatable components. */
3559 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3560 bool l_is_temp
, bool r_is_var
)
3566 gfc_init_block (&block
);
3568 if (ts
.type
== BT_CHARACTER
)
3570 gcc_assert (lse
->string_length
!= NULL_TREE
3571 && rse
->string_length
!= NULL_TREE
);
3573 gfc_conv_string_parameter (lse
);
3574 gfc_conv_string_parameter (rse
);
3576 gfc_add_block_to_block (&block
, &lse
->pre
);
3577 gfc_add_block_to_block (&block
, &rse
->pre
);
3579 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3580 rse
->string_length
, rse
->expr
);
3582 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3586 /* Are the rhs and the lhs the same? */
3589 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3590 build_fold_addr_expr (lse
->expr
),
3591 build_fold_addr_expr (rse
->expr
));
3592 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3595 /* Deallocate the lhs allocated components as long as it is not
3596 the same as the rhs. This must be done following the assignment
3597 to prevent deallocating data that could be used in the rhs
3601 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3602 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3604 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3605 gfc_add_expr_to_block (&lse
->post
, tmp
);
3608 gfc_add_block_to_block (&block
, &rse
->pre
);
3609 gfc_add_block_to_block (&block
, &lse
->pre
);
3611 gfc_add_modify_expr (&block
, lse
->expr
,
3612 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3614 /* Do a deep copy if the rhs is a variable, if it is not the
3618 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3619 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3620 gfc_add_expr_to_block (&block
, tmp
);
3625 gfc_add_block_to_block (&block
, &lse
->pre
);
3626 gfc_add_block_to_block (&block
, &rse
->pre
);
3628 gfc_add_modify_expr (&block
, lse
->expr
,
3629 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3632 gfc_add_block_to_block (&block
, &lse
->post
);
3633 gfc_add_block_to_block (&block
, &rse
->post
);
3635 return gfc_finish_block (&block
);
3639 /* Try to translate array(:) = func (...), where func is a transformational
3640 array function, without using a temporary. Returns NULL is this isn't the
3644 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3649 bool seen_array_ref
;
3651 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3652 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3655 /* Elemental functions don't need a temporary anyway. */
3656 if (expr2
->value
.function
.esym
!= NULL
3657 && expr2
->value
.function
.esym
->attr
.elemental
)
3660 /* Fail if EXPR1 can't be expressed as a descriptor. */
3661 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3664 /* Functions returning pointers need temporaries. */
3665 if (expr2
->symtree
->n
.sym
->attr
.pointer
3666 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3669 /* Character array functions need temporaries unless the
3670 character lengths are the same. */
3671 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3673 if (expr1
->ts
.cl
->length
== NULL
3674 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3677 if (expr2
->ts
.cl
->length
== NULL
3678 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3681 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3682 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3686 /* Check that no LHS component references appear during an array
3687 reference. This is needed because we do not have the means to
3688 span any arbitrary stride with an array descriptor. This check
3689 is not needed for the rhs because the function result has to be
3691 seen_array_ref
= false;
3692 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3694 if (ref
->type
== REF_ARRAY
)
3695 seen_array_ref
= true;
3696 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3700 /* Check for a dependency. */
3701 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3702 expr2
->value
.function
.esym
,
3703 expr2
->value
.function
.actual
))
3706 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3708 gcc_assert (expr2
->value
.function
.isym
3709 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3710 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3712 ss
= gfc_walk_expr (expr1
);
3713 gcc_assert (ss
!= gfc_ss_terminator
);
3714 gfc_init_se (&se
, NULL
);
3715 gfc_start_block (&se
.pre
);
3716 se
.want_pointer
= 1;
3718 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3720 se
.direct_byref
= 1;
3721 se
.ss
= gfc_walk_expr (expr2
);
3722 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3723 gfc_conv_function_expr (&se
, expr2
);
3724 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3726 return gfc_finish_block (&se
.pre
);
3729 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3732 is_zero_initializer_p (gfc_expr
* expr
)
3734 if (expr
->expr_type
!= EXPR_CONSTANT
)
3737 /* We ignore constants with prescribed memory representations for now. */
3738 if (expr
->representation
.string
)
3741 switch (expr
->ts
.type
)
3744 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3747 return mpfr_zero_p (expr
->value
.real
)
3748 && MPFR_SIGN (expr
->value
.real
) >= 0;
3751 return expr
->value
.logical
== 0;
3754 return mpfr_zero_p (expr
->value
.complex.r
)
3755 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3756 && mpfr_zero_p (expr
->value
.complex.i
)
3757 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3765 /* Try to efficiently translate array(:) = 0. Return NULL if this
3769 gfc_trans_zero_assign (gfc_expr
* expr
)
3771 tree dest
, len
, type
;
3775 sym
= expr
->symtree
->n
.sym
;
3776 dest
= gfc_get_symbol_decl (sym
);
3778 type
= TREE_TYPE (dest
);
3779 if (POINTER_TYPE_P (type
))
3780 type
= TREE_TYPE (type
);
3781 if (!GFC_ARRAY_TYPE_P (type
))
3784 /* Determine the length of the array. */
3785 len
= GFC_TYPE_ARRAY_SIZE (type
);
3786 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3789 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
3790 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3791 fold_convert (gfc_array_index_type
, tmp
));
3793 /* Convert arguments to the correct types. */
3794 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3795 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3797 dest
= fold_convert (pvoid_type_node
, dest
);
3798 len
= fold_convert (size_type_node
, len
);
3800 /* Construct call to __builtin_memset. */
3801 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3802 3, dest
, integer_zero_node
, len
);
3803 return fold_convert (void_type_node
, tmp
);
3807 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3808 that constructs the call to __builtin_memcpy. */
3811 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3815 /* Convert arguments to the correct types. */
3816 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3817 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3819 dst
= fold_convert (pvoid_type_node
, dst
);
3821 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3822 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3824 src
= fold_convert (pvoid_type_node
, src
);
3826 len
= fold_convert (size_type_node
, len
);
3828 /* Construct call to __builtin_memcpy. */
3829 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3830 return fold_convert (void_type_node
, tmp
);
3834 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3835 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3836 source/rhs, both are gfc_full_array_ref_p which have been checked for
3840 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3842 tree dst
, dlen
, dtype
;
3843 tree src
, slen
, stype
;
3846 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3847 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3849 dtype
= TREE_TYPE (dst
);
3850 if (POINTER_TYPE_P (dtype
))
3851 dtype
= TREE_TYPE (dtype
);
3852 stype
= TREE_TYPE (src
);
3853 if (POINTER_TYPE_P (stype
))
3854 stype
= TREE_TYPE (stype
);
3856 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3859 /* Determine the lengths of the arrays. */
3860 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3861 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3863 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3864 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3865 fold_convert (gfc_array_index_type
, tmp
));
3867 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3868 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3870 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
3871 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3872 fold_convert (gfc_array_index_type
, tmp
));
3874 /* Sanity check that they are the same. This should always be
3875 the case, as we should already have checked for conformance. */
3876 if (!tree_int_cst_equal (slen
, dlen
))
3879 return gfc_build_memcpy_call (dst
, src
, dlen
);
3883 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3884 this can't be done. EXPR1 is the destination/lhs for which
3885 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3888 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3890 unsigned HOST_WIDE_INT nelem
;
3896 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3900 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3901 dtype
= TREE_TYPE (dst
);
3902 if (POINTER_TYPE_P (dtype
))
3903 dtype
= TREE_TYPE (dtype
);
3904 if (!GFC_ARRAY_TYPE_P (dtype
))
3907 /* Determine the lengths of the array. */
3908 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3909 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3912 /* Confirm that the constructor is the same size. */
3913 if (compare_tree_int (len
, nelem
) != 0)
3916 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
3917 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3918 fold_convert (gfc_array_index_type
, tmp
));
3920 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3921 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3923 stype
= TREE_TYPE (src
);
3924 if (POINTER_TYPE_P (stype
))
3925 stype
= TREE_TYPE (stype
);
3927 return gfc_build_memcpy_call (dst
, src
, len
);
3931 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3932 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3935 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3940 gfc_ss
*lss_section
;
3948 /* Assignment of the form lhs = rhs. */
3949 gfc_start_block (&block
);
3951 gfc_init_se (&lse
, NULL
);
3952 gfc_init_se (&rse
, NULL
);
3955 lss
= gfc_walk_expr (expr1
);
3957 if (lss
!= gfc_ss_terminator
)
3959 /* The assignment needs scalarization. */
3962 /* Find a non-scalar SS from the lhs. */
3963 while (lss_section
!= gfc_ss_terminator
3964 && lss_section
->type
!= GFC_SS_SECTION
)
3965 lss_section
= lss_section
->next
;
3967 gcc_assert (lss_section
!= gfc_ss_terminator
);
3969 /* Initialize the scalarizer. */
3970 gfc_init_loopinfo (&loop
);
3973 rss
= gfc_walk_expr (expr2
);
3974 if (rss
== gfc_ss_terminator
)
3976 /* The rhs is scalar. Add a ss for the expression. */
3977 rss
= gfc_get_ss ();
3978 rss
->next
= gfc_ss_terminator
;
3979 rss
->type
= GFC_SS_SCALAR
;
3982 /* Associate the SS with the loop. */
3983 gfc_add_ss_to_loop (&loop
, lss
);
3984 gfc_add_ss_to_loop (&loop
, rss
);
3986 /* Calculate the bounds of the scalarization. */
3987 gfc_conv_ss_startstride (&loop
);
3988 /* Resolve any data dependencies in the statement. */
3989 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3990 /* Setup the scalarizing loops. */
3991 gfc_conv_loop_setup (&loop
);
3993 /* Setup the gfc_se structures. */
3994 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3995 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3998 gfc_mark_ss_chain_used (rss
, 1);
3999 if (loop
.temp_ss
== NULL
)
4002 gfc_mark_ss_chain_used (lss
, 1);
4006 lse
.ss
= loop
.temp_ss
;
4007 gfc_mark_ss_chain_used (lss
, 3);
4008 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4011 /* Start the scalarized loop body. */
4012 gfc_start_scalarized_body (&loop
, &body
);
4015 gfc_init_block (&body
);
4017 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4019 /* Translate the expression. */
4020 gfc_conv_expr (&rse
, expr2
);
4024 gfc_conv_tmp_array_ref (&lse
);
4025 gfc_advance_se_ss_chain (&lse
);
4028 gfc_conv_expr (&lse
, expr1
);
4030 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4031 l_is_temp
|| init_flag
,
4032 expr2
->expr_type
== EXPR_VARIABLE
);
4033 gfc_add_expr_to_block (&body
, tmp
);
4035 if (lss
== gfc_ss_terminator
)
4037 /* Use the scalar assignment as is. */
4038 gfc_add_block_to_block (&block
, &body
);
4042 gcc_assert (lse
.ss
== gfc_ss_terminator
4043 && rse
.ss
== gfc_ss_terminator
);
4047 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4049 /* We need to copy the temporary to the actual lhs. */
4050 gfc_init_se (&lse
, NULL
);
4051 gfc_init_se (&rse
, NULL
);
4052 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4053 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4055 rse
.ss
= loop
.temp_ss
;
4058 gfc_conv_tmp_array_ref (&rse
);
4059 gfc_advance_se_ss_chain (&rse
);
4060 gfc_conv_expr (&lse
, expr1
);
4062 gcc_assert (lse
.ss
== gfc_ss_terminator
4063 && rse
.ss
== gfc_ss_terminator
);
4065 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4067 gfc_add_expr_to_block (&body
, tmp
);
4070 /* Generate the copying loops. */
4071 gfc_trans_scalarizing_loops (&loop
, &body
);
4073 /* Wrap the whole thing up. */
4074 gfc_add_block_to_block (&block
, &loop
.pre
);
4075 gfc_add_block_to_block (&block
, &loop
.post
);
4077 gfc_cleanup_loop (&loop
);
4080 return gfc_finish_block (&block
);
4084 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
4087 copyable_array_p (gfc_expr
* expr
)
4089 /* First check it's an array. */
4090 if (expr
->rank
< 1 || !expr
->ref
)
4093 /* Next check that it's of a simple enough type. */
4094 switch (expr
->ts
.type
)
4106 return !expr
->ts
.derived
->attr
.alloc_comp
;
4115 /* Translate an assignment. */
4118 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4122 /* Special case a single function returning an array. */
4123 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4125 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4130 /* Special case assigning an array to zero. */
4131 if (expr1
->expr_type
== EXPR_VARIABLE
4134 && expr1
->ref
->next
== NULL
4135 && gfc_full_array_ref_p (expr1
->ref
)
4136 && is_zero_initializer_p (expr2
))
4138 tmp
= gfc_trans_zero_assign (expr1
);
4143 /* Special case copying one array to another. */
4144 if (expr1
->expr_type
== EXPR_VARIABLE
4145 && copyable_array_p (expr1
)
4146 && gfc_full_array_ref_p (expr1
->ref
)
4147 && expr2
->expr_type
== EXPR_VARIABLE
4148 && copyable_array_p (expr2
)
4149 && gfc_full_array_ref_p (expr2
->ref
)
4150 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4151 && !gfc_check_dependency (expr1
, expr2
, 0))
4153 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4158 /* Special case initializing an array from a constant array constructor. */
4159 if (expr1
->expr_type
== EXPR_VARIABLE
4160 && copyable_array_p (expr1
)
4161 && gfc_full_array_ref_p (expr1
->ref
)
4162 && expr2
->expr_type
== EXPR_ARRAY
4163 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4165 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4170 /* Fallback to the scalarizer to generate explicit loops. */
4171 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4175 gfc_trans_init_assign (gfc_code
* code
)
4177 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4181 gfc_trans_assign (gfc_code
* code
)
4183 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);