1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
159 /* Create a temporary and convert it to the correct type. */
160 tmp
= gfc_get_int_type (kind
);
161 tmp
= fold_convert (tmp
, build_fold_indirect_ref (se
->expr
));
163 /* Test for a NULL value. */
164 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
, tmp
, integer_one_node
);
165 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
166 se
->expr
= build_fold_addr_expr (tmp
);
170 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
171 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
172 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
176 if (ts
.type
== BT_CHARACTER
)
178 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
179 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
180 se
->string_length
, tmp
);
181 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
182 se
->string_length
= tmp
;
188 /* Get the character length of an expression, looking through gfc_refs
192 gfc_get_expr_charlen (gfc_expr
*e
)
197 gcc_assert (e
->expr_type
== EXPR_VARIABLE
198 && e
->ts
.type
== BT_CHARACTER
);
200 length
= NULL
; /* To silence compiler warning. */
202 if (is_subref_array (e
) && e
->ts
.cl
->length
)
205 gfc_init_se (&tmpse
, NULL
);
206 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
207 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
211 /* First candidate: if the variable is of type CHARACTER, the
212 expression's length could be the length of the character
214 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
215 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
217 /* Look through the reference chain for component references. */
218 for (r
= e
->ref
; r
; r
= r
->next
)
223 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
224 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
232 /* We should never got substring references here. These will be
233 broken down by the scalarizer. */
239 gcc_assert (length
!= NULL
);
245 /* Generate code to initialize a string length variable. Returns the
249 gfc_conv_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
253 gfc_init_se (&se
, NULL
);
254 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
255 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
256 build_int_cst (gfc_charlen_type_node
, 0));
257 gfc_add_block_to_block (pblock
, &se
.pre
);
259 if (cl
->backend_decl
)
260 gfc_add_modify_expr (pblock
, cl
->backend_decl
, se
.expr
);
262 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
267 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
268 const char *name
, locus
*where
)
278 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
279 type
= build_pointer_type (type
);
282 gfc_init_se (&start
, se
);
283 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
284 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
286 if (integer_onep (start
.expr
))
287 gfc_conv_string_parameter (se
);
290 /* Avoid multiple evaluation of substring start. */
291 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
292 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
294 /* Change the start of the string. */
295 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
298 tmp
= build_fold_indirect_ref (se
->expr
);
299 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
300 se
->expr
= gfc_build_addr_expr (type
, tmp
);
303 /* Length = end + 1 - start. */
304 gfc_init_se (&end
, se
);
305 if (ref
->u
.ss
.end
== NULL
)
306 end
.expr
= se
->string_length
;
309 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
310 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
312 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
313 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
315 if (flag_bounds_check
)
317 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
318 start
.expr
, end
.expr
);
320 /* Check lower bound. */
321 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
322 build_int_cst (gfc_charlen_type_node
, 1));
323 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
326 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
327 "is less than one", name
);
329 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
331 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
332 fold_convert (long_integer_type_node
,
336 /* Check upper bound. */
337 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
339 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
342 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
343 "exceeds string length (%%ld)", name
);
345 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
346 "exceeds string length (%%ld)");
347 gfc_trans_runtime_check (fault
, &se
->pre
, where
, msg
,
348 fold_convert (long_integer_type_node
, end
.expr
),
349 fold_convert (long_integer_type_node
,
354 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
355 build_int_cst (gfc_charlen_type_node
, 1),
357 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
358 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
359 build_int_cst (gfc_charlen_type_node
, 0));
360 se
->string_length
= tmp
;
364 /* Convert a derived type component reference. */
367 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
374 c
= ref
->u
.c
.component
;
376 gcc_assert (c
->backend_decl
);
378 field
= c
->backend_decl
;
379 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
381 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
385 if (c
->ts
.type
== BT_CHARACTER
)
387 tmp
= c
->ts
.cl
->backend_decl
;
388 /* Components must always be constant length. */
389 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
390 se
->string_length
= tmp
;
393 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
394 se
->expr
= build_fold_indirect_ref (se
->expr
);
398 /* Return the contents of a variable. Also handles reference/pointer
399 variables (all Fortran pointer references are implicit). */
402 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
409 bool alternate_entry
;
412 sym
= expr
->symtree
->n
.sym
;
415 /* Check that something hasn't gone horribly wrong. */
416 gcc_assert (se
->ss
!= gfc_ss_terminator
);
417 gcc_assert (se
->ss
->expr
== expr
);
419 /* A scalarized term. We already know the descriptor. */
420 se
->expr
= se
->ss
->data
.info
.descriptor
;
421 se
->string_length
= se
->ss
->string_length
;
422 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
423 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
428 tree se_expr
= NULL_TREE
;
430 se
->expr
= gfc_get_symbol_decl (sym
);
432 /* Deal with references to a parent results or entries by storing
433 the current_function_decl and moving to the parent_decl. */
434 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
435 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
436 && sym
->result
== sym
;
437 entry_master
= sym
->attr
.result
438 && sym
->ns
->proc_name
->attr
.entry_master
439 && !gfc_return_by_reference (sym
->ns
->proc_name
);
440 parent_decl
= DECL_CONTEXT (current_function_decl
);
442 if ((se
->expr
== parent_decl
&& return_value
)
443 || (sym
->ns
&& sym
->ns
->proc_name
445 && sym
->ns
->proc_name
->backend_decl
== parent_decl
446 && (alternate_entry
|| entry_master
)))
451 /* Special case for assigning the return value of a function.
452 Self recursive functions must have an explicit return value. */
453 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
454 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
456 /* Similarly for alternate entry points. */
457 else if (alternate_entry
458 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
461 gfc_entry_list
*el
= NULL
;
463 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
466 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
471 else if (entry_master
472 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
474 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
479 /* Procedure actual arguments. */
480 else if (sym
->attr
.flavor
== FL_PROCEDURE
481 && se
->expr
!= current_function_decl
)
483 gcc_assert (se
->want_pointer
);
484 if (!sym
->attr
.dummy
)
486 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
487 se
->expr
= build_fold_addr_expr (se
->expr
);
493 /* Dereference the expression, where needed. Since characters
494 are entirely different from other types, they are treated
496 if (sym
->ts
.type
== BT_CHARACTER
)
498 /* Dereference character pointer dummy arguments
500 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
502 || sym
->attr
.function
503 || sym
->attr
.result
))
504 se
->expr
= build_fold_indirect_ref (se
->expr
);
507 else if (!sym
->attr
.value
)
509 /* Dereference non-character scalar dummy arguments. */
510 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
511 se
->expr
= build_fold_indirect_ref (se
->expr
);
513 /* Dereference scalar hidden result. */
514 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
515 && (sym
->attr
.function
|| sym
->attr
.result
)
516 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
517 se
->expr
= build_fold_indirect_ref (se
->expr
);
519 /* Dereference non-character pointer variables.
520 These must be dummies, results, or scalars. */
521 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
523 || sym
->attr
.function
525 || !sym
->attr
.dimension
))
526 se
->expr
= build_fold_indirect_ref (se
->expr
);
532 /* For character variables, also get the length. */
533 if (sym
->ts
.type
== BT_CHARACTER
)
535 /* If the character length of an entry isn't set, get the length from
536 the master function instead. */
537 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
538 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
540 se
->string_length
= sym
->ts
.cl
->backend_decl
;
541 gcc_assert (se
->string_length
);
549 /* Return the descriptor if that's what we want and this is an array
550 section reference. */
551 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
553 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
554 /* Return the descriptor for array pointers and allocations. */
556 && ref
->next
== NULL
&& (se
->descriptor_only
))
559 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
560 /* Return a pointer to an element. */
564 gfc_conv_component_ref (se
, ref
);
568 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
569 expr
->symtree
->name
, &expr
->where
);
578 /* Pointer assignment, allocation or pass by reference. Arrays are handled
580 if (se
->want_pointer
)
582 if (expr
->ts
.type
== BT_CHARACTER
)
583 gfc_conv_string_parameter (se
);
585 se
->expr
= build_fold_addr_expr (se
->expr
);
590 /* Unary ops are easy... Or they would be if ! was a valid op. */
593 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
598 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
599 /* Initialize the operand. */
600 gfc_init_se (&operand
, se
);
601 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
602 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
604 type
= gfc_typenode_for_spec (&expr
->ts
);
606 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
607 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
608 All other unary operators have an equivalent GIMPLE unary operator. */
609 if (code
== TRUTH_NOT_EXPR
)
610 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
611 build_int_cst (type
, 0));
613 se
->expr
= build1 (code
, type
, operand
.expr
);
617 /* Expand power operator to optimal multiplications when a value is raised
618 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
619 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
620 Programming", 3rd Edition, 1998. */
622 /* This code is mostly duplicated from expand_powi in the backend.
623 We establish the "optimal power tree" lookup table with the defined size.
624 The items in the table are the exponents used to calculate the index
625 exponents. Any integer n less than the value can get an "addition chain",
626 with the first node being one. */
627 #define POWI_TABLE_SIZE 256
629 /* The table is from builtins.c. */
630 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
632 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
633 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
634 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
635 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
636 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
637 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
638 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
639 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
640 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
641 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
642 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
643 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
644 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
645 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
646 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
647 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
648 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
649 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
650 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
651 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
652 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
653 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
654 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
655 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
656 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
657 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
658 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
659 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
660 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
661 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
662 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
663 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
666 /* If n is larger than lookup table's max index, we use the "window
668 #define POWI_WINDOW_SIZE 3
670 /* Recursive function to expand the power operator. The temporary
671 values are put in tmpvar. The function returns tmpvar[1] ** n. */
673 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
680 if (n
< POWI_TABLE_SIZE
)
685 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
686 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
690 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
691 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
692 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
696 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
700 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
701 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
703 if (n
< POWI_TABLE_SIZE
)
710 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
711 return 1. Else return 0 and a call to runtime library functions
712 will have to be built. */
714 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
719 tree vartmp
[POWI_TABLE_SIZE
];
721 unsigned HOST_WIDE_INT n
;
724 /* If exponent is too large, we won't expand it anyway, so don't bother
725 with large integer values. */
726 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
729 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
730 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
731 of the asymmetric range of the integer type. */
732 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
734 type
= TREE_TYPE (lhs
);
735 sgn
= tree_int_cst_sgn (rhs
);
737 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
738 || optimize_size
) && (m
> 2 || m
< -1))
744 se
->expr
= gfc_build_const (type
, integer_one_node
);
748 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
749 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
751 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
752 build_int_cst (TREE_TYPE (lhs
), -1));
753 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
754 build_int_cst (TREE_TYPE (lhs
), 1));
757 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
760 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
761 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
762 build_int_cst (type
, 0));
766 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
767 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
768 build_int_cst (type
, 0));
769 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
773 memset (vartmp
, 0, sizeof (vartmp
));
777 tmp
= gfc_build_const (type
, integer_one_node
);
778 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
781 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
787 /* Power op (**). Constant integer exponent has special handling. */
790 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
792 tree gfc_int4_type_node
;
799 gfc_init_se (&lse
, se
);
800 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
801 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
802 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
804 gfc_init_se (&rse
, se
);
805 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
806 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
808 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
809 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
810 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
813 gfc_int4_type_node
= gfc_get_int_type (4);
815 kind
= expr
->value
.op
.op1
->ts
.kind
;
816 switch (expr
->value
.op
.op2
->ts
.type
)
819 ikind
= expr
->value
.op
.op2
->ts
.kind
;
824 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
846 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
847 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
872 switch (expr
->value
.op
.op1
->ts
.type
)
875 if (kind
== 3) /* Case 16 was not handled properly above. */
877 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
881 /* Use builtins for real ** int4. */
887 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
891 fndecl
= built_in_decls
[BUILT_IN_POWI
];
896 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
904 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
908 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
920 fndecl
= built_in_decls
[BUILT_IN_POWF
];
923 fndecl
= built_in_decls
[BUILT_IN_POW
];
927 fndecl
= built_in_decls
[BUILT_IN_POWL
];
938 fndecl
= gfor_fndecl_math_cpowf
;
941 fndecl
= gfor_fndecl_math_cpow
;
944 fndecl
= gfor_fndecl_math_cpowl10
;
947 fndecl
= gfor_fndecl_math_cpowl16
;
959 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
963 /* Generate code to allocate a string temporary. */
966 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
971 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
973 if (gfc_can_put_var_on_stack (len
))
975 /* Create a temporary variable to hold the result. */
976 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
977 build_int_cst (gfc_charlen_type_node
, 1));
978 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
979 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
980 var
= gfc_create_var (tmp
, "str");
981 var
= gfc_build_addr_expr (type
, var
);
985 /* Allocate a temporary to hold the result. */
986 var
= gfc_create_var (type
, "pstr");
987 tmp
= gfc_call_malloc (&se
->pre
, type
, len
);
988 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
990 /* Free the temporary afterwards. */
991 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
992 gfc_add_expr_to_block (&se
->post
, tmp
);
999 /* Handle a string concatenation operation. A temporary will be allocated to
1003 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1012 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1013 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1015 gfc_init_se (&lse
, se
);
1016 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1017 gfc_conv_string_parameter (&lse
);
1018 gfc_init_se (&rse
, se
);
1019 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1020 gfc_conv_string_parameter (&rse
);
1022 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1023 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1025 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1026 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1027 if (len
== NULL_TREE
)
1029 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1030 lse
.string_length
, rse
.string_length
);
1033 type
= build_pointer_type (type
);
1035 var
= gfc_conv_string_tmp (se
, type
, len
);
1037 /* Do the actual concatenation. */
1038 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
1040 lse
.string_length
, lse
.expr
,
1041 rse
.string_length
, rse
.expr
);
1042 gfc_add_expr_to_block (&se
->pre
, tmp
);
1044 /* Add the cleanup for the operands. */
1045 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1046 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1049 se
->string_length
= len
;
1052 /* Translates an op expression. Common (binary) cases are handled by this
1053 function, others are passed on. Recursion is used in either case.
1054 We use the fact that (op1.ts == op2.ts) (except for the power
1056 Operators need no special handling for scalarized expressions as long as
1057 they call gfc_conv_simple_val to get their operands.
1058 Character strings get special handling. */
1061 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1063 enum tree_code code
;
1072 switch (expr
->value
.op
.operator)
1074 case INTRINSIC_UPLUS
:
1075 case INTRINSIC_PARENTHESES
:
1076 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1079 case INTRINSIC_UMINUS
:
1080 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1084 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1087 case INTRINSIC_PLUS
:
1091 case INTRINSIC_MINUS
:
1095 case INTRINSIC_TIMES
:
1099 case INTRINSIC_DIVIDE
:
1100 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1101 an integer, we must round towards zero, so we use a
1103 if (expr
->ts
.type
== BT_INTEGER
)
1104 code
= TRUNC_DIV_EXPR
;
1109 case INTRINSIC_POWER
:
1110 gfc_conv_power_op (se
, expr
);
1113 case INTRINSIC_CONCAT
:
1114 gfc_conv_concat_op (se
, expr
);
1118 code
= TRUTH_ANDIF_EXPR
;
1123 code
= TRUTH_ORIF_EXPR
;
1127 /* EQV and NEQV only work on logicals, but since we represent them
1128 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1130 case INTRINSIC_EQ_OS
:
1138 case INTRINSIC_NE_OS
:
1139 case INTRINSIC_NEQV
:
1146 case INTRINSIC_GT_OS
:
1153 case INTRINSIC_GE_OS
:
1160 case INTRINSIC_LT_OS
:
1167 case INTRINSIC_LE_OS
:
1173 case INTRINSIC_USER
:
1174 case INTRINSIC_ASSIGN
:
1175 /* These should be converted into function calls by the frontend. */
1179 fatal_error ("Unknown intrinsic op");
1183 /* The only exception to this is **, which is handled separately anyway. */
1184 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1186 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1190 gfc_init_se (&lse
, se
);
1191 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1192 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1195 gfc_init_se (&rse
, se
);
1196 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1197 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1201 gfc_conv_string_parameter (&lse
);
1202 gfc_conv_string_parameter (&rse
);
1204 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1205 rse
.string_length
, rse
.expr
);
1206 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1207 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1210 type
= gfc_typenode_for_spec (&expr
->ts
);
1214 /* The result of logical ops is always boolean_type_node. */
1215 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1216 se
->expr
= convert (type
, tmp
);
1219 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1221 /* Add the post blocks. */
1222 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1223 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1226 /* If a string's length is one, we convert it to a single character. */
1229 gfc_to_single_character (tree len
, tree str
)
1231 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1233 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1234 && TREE_INT_CST_HIGH (len
) == 0)
1236 str
= fold_convert (pchar_type_node
, str
);
1237 return build_fold_indirect_ref (str
);
1245 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1248 if (sym
->backend_decl
)
1250 /* This becomes the nominal_type in
1251 function.c:assign_parm_find_data_types. */
1252 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1253 /* This becomes the passed_type in
1254 function.c:assign_parm_find_data_types. C promotes char to
1255 integer for argument passing. */
1256 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1258 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1263 /* If we have a constant character expression, make it into an
1265 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1269 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1270 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1272 /* The expr needs to be compatible with a C int. If the
1273 conversion fails, then the 2 causes an ICE. */
1274 ts
.type
= BT_INTEGER
;
1275 ts
.kind
= gfc_c_int_kind
;
1276 gfc_convert_type (*expr
, &ts
, 2);
1279 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1281 if ((*expr
)->ref
== NULL
)
1283 se
->expr
= gfc_to_single_character
1284 (build_int_cst (integer_type_node
, 1),
1285 gfc_build_addr_expr (pchar_type_node
,
1287 ((*expr
)->symtree
->n
.sym
)));
1291 gfc_conv_variable (se
, *expr
);
1292 se
->expr
= gfc_to_single_character
1293 (build_int_cst (integer_type_node
, 1),
1294 gfc_build_addr_expr (pchar_type_node
, se
->expr
));
1301 /* Compare two strings. If they are all single characters, the result is the
1302 subtraction of them. Otherwise, we build a library call. */
1305 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1311 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1312 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1314 sc1
= gfc_to_single_character (len1
, str1
);
1315 sc2
= gfc_to_single_character (len2
, str2
);
1317 /* Deal with single character specially. */
1318 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1320 sc1
= fold_convert (integer_type_node
, sc1
);
1321 sc2
= fold_convert (integer_type_node
, sc2
);
1322 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1325 /* Build a call for the comparison. */
1326 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1327 len1
, str1
, len2
, str2
);
1332 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1336 if (sym
->attr
.dummy
)
1338 tmp
= gfc_get_symbol_decl (sym
);
1339 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1340 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1344 if (!sym
->backend_decl
)
1345 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1347 tmp
= sym
->backend_decl
;
1348 if (sym
->attr
.cray_pointee
)
1349 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1350 gfc_get_symbol_decl (sym
->cp_pointer
));
1351 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1353 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1354 tmp
= build_fold_addr_expr (tmp
);
1361 /* Translate the call for an elemental subroutine call used in an operator
1362 assignment. This is a simplified version of gfc_conv_function_call. */
1365 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1372 /* Only elemental subroutines with two arguments. */
1373 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1374 gcc_assert (sym
->formal
->next
->next
== NULL
);
1376 gfc_init_block (&block
);
1378 gfc_add_block_to_block (&block
, &lse
->pre
);
1379 gfc_add_block_to_block (&block
, &rse
->pre
);
1381 /* Build the argument list for the call, including hidden string lengths. */
1382 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1383 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1384 if (lse
->string_length
!= NULL_TREE
)
1385 args
= gfc_chainon_list (args
, lse
->string_length
);
1386 if (rse
->string_length
!= NULL_TREE
)
1387 args
= gfc_chainon_list (args
, rse
->string_length
);
1389 /* Build the function call. */
1390 gfc_init_se (&se
, NULL
);
1391 gfc_conv_function_val (&se
, sym
);
1392 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1393 tmp
= build_call_list (tmp
, se
.expr
, args
);
1394 gfc_add_expr_to_block (&block
, tmp
);
1396 gfc_add_block_to_block (&block
, &lse
->post
);
1397 gfc_add_block_to_block (&block
, &rse
->post
);
1399 return gfc_finish_block (&block
);
1403 /* Initialize MAPPING. */
1406 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1408 mapping
->syms
= NULL
;
1409 mapping
->charlens
= NULL
;
1413 /* Free all memory held by MAPPING (but not MAPPING itself). */
1416 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1418 gfc_interface_sym_mapping
*sym
;
1419 gfc_interface_sym_mapping
*nextsym
;
1421 gfc_charlen
*nextcl
;
1423 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1425 nextsym
= sym
->next
;
1426 gfc_free_symbol (sym
->new->n
.sym
);
1427 gfc_free_expr (sym
->expr
);
1428 gfc_free (sym
->new);
1431 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1434 gfc_free_expr (cl
->length
);
1440 /* Return a copy of gfc_charlen CL. Add the returned structure to
1441 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1443 static gfc_charlen
*
1444 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1449 new = gfc_get_charlen ();
1450 new->next
= mapping
->charlens
;
1451 new->length
= gfc_copy_expr (cl
->length
);
1453 mapping
->charlens
= new;
1458 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1459 array variable that can be used as the actual argument for dummy
1460 argument SYM. Add any initialization code to BLOCK. PACKED is as
1461 for gfc_get_nodesc_array_type and DATA points to the first element
1462 in the passed array. */
1465 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1466 gfc_packed packed
, tree data
)
1471 type
= gfc_typenode_for_spec (&sym
->ts
);
1472 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1474 var
= gfc_create_var (type
, "ifm");
1475 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1481 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1482 and offset of descriptorless array type TYPE given that it has the same
1483 size as DESC. Add any set-up code to BLOCK. */
1486 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1493 offset
= gfc_index_zero_node
;
1494 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1496 dim
= gfc_rank_cst
[n
];
1497 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1498 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1500 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1501 = gfc_conv_descriptor_lbound (desc
, dim
);
1502 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1503 = gfc_conv_descriptor_ubound (desc
, dim
);
1505 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1507 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1508 gfc_conv_descriptor_ubound (desc
, dim
),
1509 gfc_conv_descriptor_lbound (desc
, dim
));
1510 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1511 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1513 tmp
= gfc_evaluate_now (tmp
, block
);
1514 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1516 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1517 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1518 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1519 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1521 offset
= gfc_evaluate_now (offset
, block
);
1522 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1526 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1527 in SE. The caller may still use se->expr and se->string_length after
1528 calling this function. */
1531 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1532 gfc_symbol
* sym
, gfc_se
* se
,
1535 gfc_interface_sym_mapping
*sm
;
1539 gfc_symbol
*new_sym
;
1541 gfc_symtree
*new_symtree
;
1543 /* Create a new symbol to represent the actual argument. */
1544 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1545 new_sym
->ts
= sym
->ts
;
1546 new_sym
->attr
.referenced
= 1;
1547 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1548 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1549 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1550 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1551 new_sym
->attr
.function
= sym
->attr
.function
;
1553 /* Create a fake symtree for it. */
1555 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1556 new_symtree
->n
.sym
= new_sym
;
1557 gcc_assert (new_symtree
== root
);
1559 /* Create a dummy->actual mapping. */
1560 sm
= gfc_getmem (sizeof (*sm
));
1561 sm
->next
= mapping
->syms
;
1563 sm
->new = new_symtree
;
1564 sm
->expr
= gfc_copy_expr (expr
);
1567 /* Stabilize the argument's value. */
1568 if (!sym
->attr
.function
&& se
)
1569 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1571 if (sym
->ts
.type
== BT_CHARACTER
)
1573 /* Create a copy of the dummy argument's length. */
1574 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1575 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1577 /* If the length is specified as "*", record the length that
1578 the caller is passing. We should use the callee's length
1579 in all other cases. */
1580 if (!new_sym
->ts
.cl
->length
&& se
)
1582 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1583 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1590 /* Use the passed value as-is if the argument is a function. */
1591 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1594 /* If the argument is either a string or a pointer to a string,
1595 convert it to a boundless character type. */
1596 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1598 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1599 tmp
= build_pointer_type (tmp
);
1600 if (sym
->attr
.pointer
)
1601 value
= build_fold_indirect_ref (se
->expr
);
1604 value
= fold_convert (tmp
, value
);
1607 /* If the argument is a scalar, a pointer to an array or an allocatable,
1609 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1610 value
= build_fold_indirect_ref (se
->expr
);
1612 /* For character(*), use the actual argument's descriptor. */
1613 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1614 value
= build_fold_indirect_ref (se
->expr
);
1616 /* If the argument is an array descriptor, use it to determine
1617 information about the actual argument's shape. */
1618 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1619 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1621 /* Get the actual argument's descriptor. */
1622 desc
= build_fold_indirect_ref (se
->expr
);
1624 /* Create the replacement variable. */
1625 tmp
= gfc_conv_descriptor_data_get (desc
);
1626 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1629 /* Use DESC to work out the upper bounds, strides and offset. */
1630 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1633 /* Otherwise we have a packed array. */
1634 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1635 PACKED_FULL
, se
->expr
);
1637 new_sym
->backend_decl
= value
;
1641 /* Called once all dummy argument mappings have been added to MAPPING,
1642 but before the mapping is used to evaluate expressions. Pre-evaluate
1643 the length of each argument, adding any initialization code to PRE and
1644 any finalization code to POST. */
1647 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1648 stmtblock_t
* pre
, stmtblock_t
* post
)
1650 gfc_interface_sym_mapping
*sym
;
1654 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1655 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1656 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1658 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1659 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1660 gfc_init_se (&se
, NULL
);
1661 gfc_conv_expr (&se
, expr
);
1663 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1664 gfc_add_block_to_block (pre
, &se
.pre
);
1665 gfc_add_block_to_block (post
, &se
.post
);
1667 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1672 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1676 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1677 gfc_constructor
* c
)
1679 for (; c
; c
= c
->next
)
1681 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1684 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1685 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1686 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1692 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1696 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1701 for (; ref
; ref
= ref
->next
)
1705 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1707 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1708 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1709 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1711 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1718 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1719 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1725 /* Convert intrinsic function calls into result expressions. */
1727 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
* mapping
)
1735 arg1
= expr
->value
.function
.actual
->expr
;
1736 if (expr
->value
.function
.actual
->next
)
1737 arg2
= expr
->value
.function
.actual
->next
->expr
;
1741 sym
= arg1
->symtree
->n
.sym
;
1743 if (sym
->attr
.dummy
)
1748 switch (expr
->value
.function
.isym
->id
)
1751 /* TODO figure out why this condition is necessary. */
1752 if (sym
->attr
.function
1753 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1754 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)
1757 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1764 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1766 dup
= mpz_get_si (arg2
->value
.integer
);
1771 dup
= sym
->as
->rank
;
1775 for (; d
< dup
; d
++)
1778 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1779 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1781 new_expr
= gfc_multiply (new_expr
, tmp
);
1787 case GFC_ISYM_LBOUND
:
1788 case GFC_ISYM_UBOUND
:
1789 /* TODO These implementations of lbound and ubound do not limit if
1790 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1795 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1796 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1798 /* TODO: If the need arises, this could produce an array of
1802 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1803 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1805 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1812 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
1816 gfc_replace_expr (expr
, new_expr
);
1822 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
1823 gfc_interface_mapping
* mapping
)
1825 gfc_formal_arglist
*f
;
1826 gfc_actual_arglist
*actual
;
1828 actual
= expr
->value
.function
.actual
;
1829 f
= map_expr
->symtree
->n
.sym
->formal
;
1831 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
1836 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
1839 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
1844 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
1846 for (d
= 0; d
< as
->rank
; d
++)
1848 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
1849 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
1852 expr
->value
.function
.esym
->as
= as
;
1855 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1857 expr
->value
.function
.esym
->ts
.cl
->length
1858 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
1860 gfc_apply_interface_mapping_to_expr (mapping
,
1861 expr
->value
.function
.esym
->ts
.cl
->length
);
1866 /* EXPR is a copy of an expression that appeared in the interface
1867 associated with MAPPING. Walk it recursively looking for references to
1868 dummy arguments that MAPPING maps to actual arguments. Replace each such
1869 reference with a reference to the associated actual argument. */
1872 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1875 gfc_interface_sym_mapping
*sym
;
1876 gfc_actual_arglist
*actual
;
1881 /* Copying an expression does not copy its length, so do that here. */
1882 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1884 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1885 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1888 /* Apply the mapping to any references. */
1889 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1891 /* ...and to the expression's symbol, if it has one. */
1892 /* TODO Find out why the condition on expr->symtree had to be moved into
1893 the loop rather than being ouside it, as originally. */
1894 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1895 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
1897 if (sym
->new->n
.sym
->backend_decl
)
1898 expr
->symtree
= sym
->new;
1900 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
1903 /* ...and to subexpressions in expr->value. */
1904 switch (expr
->expr_type
)
1909 case EXPR_SUBSTRING
:
1913 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1914 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1918 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1919 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1921 if (expr
->value
.function
.esym
== NULL
1922 && expr
->value
.function
.isym
!= NULL
1923 && expr
->value
.function
.actual
->expr
->symtree
1924 && gfc_map_intrinsic_function (expr
, mapping
))
1927 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1928 if (sym
->old
== expr
->value
.function
.esym
)
1930 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1931 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
1932 expr
->value
.function
.esym
->result
= sym
->new->n
.sym
;
1937 case EXPR_STRUCTURE
:
1938 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1946 /* Evaluate interface expression EXPR using MAPPING. Store the result
1950 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1951 gfc_se
* se
, gfc_expr
* expr
)
1953 expr
= gfc_copy_expr (expr
);
1954 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1955 gfc_conv_expr (se
, expr
);
1956 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1957 gfc_free_expr (expr
);
1961 /* Returns a reference to a temporary array into which a component of
1962 an actual argument derived type array is copied and then returned
1963 after the function call. */
1965 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1966 int g77
, sym_intent intent
)
1982 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1984 gfc_init_se (&lse
, NULL
);
1985 gfc_init_se (&rse
, NULL
);
1987 /* Walk the argument expression. */
1988 rss
= gfc_walk_expr (expr
);
1990 gcc_assert (rss
!= gfc_ss_terminator
);
1992 /* Initialize the scalarizer. */
1993 gfc_init_loopinfo (&loop
);
1994 gfc_add_ss_to_loop (&loop
, rss
);
1996 /* Calculate the bounds of the scalarization. */
1997 gfc_conv_ss_startstride (&loop
);
1999 /* Build an ss for the temporary. */
2000 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
2001 gfc_conv_string_length (expr
->ts
.cl
, &parmse
->pre
);
2003 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2004 if (GFC_ARRAY_TYPE_P (base_type
)
2005 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2006 base_type
= gfc_get_element_type (base_type
);
2008 loop
.temp_ss
= gfc_get_ss ();;
2009 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2010 loop
.temp_ss
->data
.temp
.type
= base_type
;
2012 if (expr
->ts
.type
== BT_CHARACTER
)
2013 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2015 loop
.temp_ss
->string_length
= NULL
;
2017 parmse
->string_length
= loop
.temp_ss
->string_length
;
2018 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2019 loop
.temp_ss
->next
= gfc_ss_terminator
;
2021 /* Associate the SS with the loop. */
2022 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2024 /* Setup the scalarizing loops. */
2025 gfc_conv_loop_setup (&loop
);
2027 /* Pass the temporary descriptor back to the caller. */
2028 info
= &loop
.temp_ss
->data
.info
;
2029 parmse
->expr
= info
->descriptor
;
2031 /* Setup the gfc_se structures. */
2032 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2033 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2036 lse
.ss
= loop
.temp_ss
;
2037 gfc_mark_ss_chain_used (rss
, 1);
2038 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2040 /* Start the scalarized loop body. */
2041 gfc_start_scalarized_body (&loop
, &body
);
2043 /* Translate the expression. */
2044 gfc_conv_expr (&rse
, expr
);
2046 gfc_conv_tmp_array_ref (&lse
);
2047 gfc_advance_se_ss_chain (&lse
);
2049 if (intent
!= INTENT_OUT
)
2051 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2052 gfc_add_expr_to_block (&body
, tmp
);
2053 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2054 gfc_trans_scalarizing_loops (&loop
, &body
);
2058 /* Make sure that the temporary declaration survives by merging
2059 all the loop declarations into the current context. */
2060 for (n
= 0; n
< loop
.dimen
; n
++)
2062 gfc_merge_block_scope (&body
);
2063 body
= loop
.code
[loop
.order
[n
]];
2065 gfc_merge_block_scope (&body
);
2068 /* Add the post block after the second loop, so that any
2069 freeing of allocated memory is done at the right time. */
2070 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2072 /**********Copy the temporary back again.*********/
2074 gfc_init_se (&lse
, NULL
);
2075 gfc_init_se (&rse
, NULL
);
2077 /* Walk the argument expression. */
2078 lss
= gfc_walk_expr (expr
);
2079 rse
.ss
= loop
.temp_ss
;
2082 /* Initialize the scalarizer. */
2083 gfc_init_loopinfo (&loop2
);
2084 gfc_add_ss_to_loop (&loop2
, lss
);
2086 /* Calculate the bounds of the scalarization. */
2087 gfc_conv_ss_startstride (&loop2
);
2089 /* Setup the scalarizing loops. */
2090 gfc_conv_loop_setup (&loop2
);
2092 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2093 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2095 gfc_mark_ss_chain_used (lss
, 1);
2096 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2098 /* Declare the variable to hold the temporary offset and start the
2099 scalarized loop body. */
2100 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2101 gfc_start_scalarized_body (&loop2
, &body
);
2103 /* Build the offsets for the temporary from the loop variables. The
2104 temporary array has lbounds of zero and strides of one in all
2105 dimensions, so this is very simple. The offset is only computed
2106 outside the innermost loop, so the overall transfer could be
2107 optimized further. */
2108 info
= &rse
.ss
->data
.info
;
2110 tmp_index
= gfc_index_zero_node
;
2111 for (n
= info
->dimen
- 1; n
> 0; n
--)
2114 tmp
= rse
.loop
->loopvar
[n
];
2115 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2116 tmp
, rse
.loop
->from
[n
]);
2117 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2120 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2121 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2122 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2123 tmp_str
, gfc_index_one_node
);
2125 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2129 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2130 tmp_index
, rse
.loop
->from
[0]);
2131 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
2133 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2134 rse
.loop
->loopvar
[0], offset
);
2136 /* Now use the offset for the reference. */
2137 tmp
= build_fold_indirect_ref (info
->data
);
2138 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2140 if (expr
->ts
.type
== BT_CHARACTER
)
2141 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2143 gfc_conv_expr (&lse
, expr
);
2145 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2147 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2148 gfc_add_expr_to_block (&body
, tmp
);
2150 /* Generate the copying loops. */
2151 gfc_trans_scalarizing_loops (&loop2
, &body
);
2153 /* Wrap the whole thing up by adding the second loop to the post-block
2154 and following it by the post-block of the first loop. In this way,
2155 if the temporary needs freeing, it is done after use! */
2156 if (intent
!= INTENT_IN
)
2158 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2159 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2162 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2164 gfc_cleanup_loop (&loop
);
2165 gfc_cleanup_loop (&loop2
);
2167 /* Pass the string length to the argument expression. */
2168 if (expr
->ts
.type
== BT_CHARACTER
)
2169 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2171 /* We want either the address for the data or the address of the descriptor,
2172 depending on the mode of passing array arguments. */
2174 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2176 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
2182 /* Generate the code for argument list functions. */
2185 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2187 /* Pass by value for g77 %VAL(arg), pass the address
2188 indirectly for %LOC, else by reference. Thus %REF
2189 is a "do-nothing" and %LOC is the same as an F95
2191 if (strncmp (name
, "%VAL", 4) == 0)
2192 gfc_conv_expr (se
, expr
);
2193 else if (strncmp (name
, "%LOC", 4) == 0)
2195 gfc_conv_expr_reference (se
, expr
);
2196 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2198 else if (strncmp (name
, "%REF", 4) == 0)
2199 gfc_conv_expr_reference (se
, expr
);
2201 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2205 /* Generate code for a procedure call. Note can return se->post != NULL.
2206 If se->direct_byref is set then se->expr contains the return parameter.
2207 Return nonzero, if the call has alternate specifiers. */
2210 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
2211 gfc_actual_arglist
* arg
, tree append_args
)
2213 gfc_interface_mapping mapping
;
2227 gfc_formal_arglist
*formal
;
2228 int has_alternate_specifier
= 0;
2229 bool need_interface_mapping
;
2236 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2238 arglist
= NULL_TREE
;
2239 retargs
= NULL_TREE
;
2240 stringargs
= NULL_TREE
;
2244 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2246 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2248 if (arg
->expr
->rank
== 0)
2249 gfc_conv_expr_reference (se
, arg
->expr
);
2253 /* This is really the actual arg because no formal arglist is
2254 created for C_LOC. */
2255 fsym
= arg
->expr
->symtree
->n
.sym
;
2257 /* We should want it to do g77 calling convention. */
2259 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2260 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2261 f
= f
|| !sym
->attr
.always_explicit
;
2263 argss
= gfc_walk_expr (arg
->expr
);
2264 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
);
2269 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2271 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2272 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2273 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2274 gfc_conv_expr_reference (se
, arg
->expr
);
2278 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2283 /* Build the addr_expr for the first argument. The argument is
2284 already an *address* so we don't need to set want_pointer in
2286 gfc_init_se (&arg1se
, NULL
);
2287 gfc_conv_expr (&arg1se
, arg
->expr
);
2288 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2289 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2291 /* See if we were given two arguments. */
2292 if (arg
->next
== NULL
)
2293 /* Only given one arg so generate a null and do a
2294 not-equal comparison against the first arg. */
2295 se
->expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2296 fold_convert (TREE_TYPE (arg1se
.expr
),
2297 null_pointer_node
));
2303 /* Given two arguments so build the arg2se from second arg. */
2304 gfc_init_se (&arg2se
, NULL
);
2305 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2306 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2307 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2309 /* Generate test to compare that the two args are equal. */
2310 eq_expr
= build2 (EQ_EXPR
, boolean_type_node
, arg1se
.expr
,
2312 /* Generate test to ensure that the first arg is not null. */
2313 not_null_expr
= build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2316 /* Finally, the generated test must check that both arg1 is not
2317 NULL and that it is equal to the second arg. */
2318 se
->expr
= build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2319 not_null_expr
, eq_expr
);
2328 if (!sym
->attr
.elemental
)
2330 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2331 if (se
->ss
->useflags
)
2333 gcc_assert (gfc_return_by_reference (sym
)
2334 && sym
->result
->attr
.dimension
);
2335 gcc_assert (se
->loop
!= NULL
);
2337 /* Access the previously obtained result. */
2338 gfc_conv_tmp_array_ref (se
);
2339 gfc_advance_se_ss_chain (se
);
2343 info
= &se
->ss
->data
.info
;
2348 gfc_init_block (&post
);
2349 gfc_init_interface_mapping (&mapping
);
2350 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2351 && sym
->ts
.cl
->length
2352 && sym
->ts
.cl
->length
->expr_type
2354 || sym
->attr
.dimension
);
2355 formal
= sym
->formal
;
2356 /* Evaluate the arguments. */
2357 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2360 fsym
= formal
? formal
->sym
: NULL
;
2361 parm_kind
= MISSING
;
2365 if (se
->ignore_optional
)
2367 /* Some intrinsics have already been resolved to the correct
2371 else if (arg
->label
)
2373 has_alternate_specifier
= 1;
2378 /* Pass a NULL pointer for an absent arg. */
2379 gfc_init_se (&parmse
, NULL
);
2380 parmse
.expr
= null_pointer_node
;
2381 if (arg
->missing_arg_type
== BT_CHARACTER
)
2382 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2385 else if (se
->ss
&& se
->ss
->useflags
)
2387 /* An elemental function inside a scalarized loop. */
2388 gfc_init_se (&parmse
, se
);
2389 gfc_conv_expr_reference (&parmse
, e
);
2390 parm_kind
= ELEMENTAL
;
2394 /* A scalar or transformational function. */
2395 gfc_init_se (&parmse
, NULL
);
2396 argss
= gfc_walk_expr (e
);
2398 if (argss
== gfc_ss_terminator
)
2400 if (fsym
&& fsym
->attr
.value
)
2402 if (fsym
->ts
.type
== BT_CHARACTER
2403 && fsym
->ts
.is_c_interop
2404 && fsym
->ns
->proc_name
!= NULL
2405 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2408 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2409 if (parmse
.expr
== NULL
)
2410 gfc_conv_expr (&parmse
, e
);
2413 gfc_conv_expr (&parmse
, e
);
2415 else if (arg
->name
&& arg
->name
[0] == '%')
2416 /* Argument list functions %VAL, %LOC and %REF are signalled
2417 through arg->name. */
2418 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2419 else if ((e
->expr_type
== EXPR_FUNCTION
)
2420 && e
->symtree
->n
.sym
->attr
.pointer
2421 && fsym
&& fsym
->attr
.target
)
2423 gfc_conv_expr (&parmse
, e
);
2424 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2428 gfc_conv_expr_reference (&parmse
, e
);
2429 if (fsym
&& fsym
->attr
.pointer
2430 && fsym
->attr
.flavor
!= FL_PROCEDURE
2431 && e
->expr_type
!= EXPR_NULL
)
2433 /* Scalar pointer dummy args require an extra level of
2434 indirection. The null pointer already contains
2435 this level of indirection. */
2436 parm_kind
= SCALAR_POINTER
;
2437 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2443 /* If the procedure requires an explicit interface, the actual
2444 argument is passed according to the corresponding formal
2445 argument. If the corresponding formal argument is a POINTER,
2446 ALLOCATABLE or assumed shape, we do not use g77's calling
2447 convention, and pass the address of the array descriptor
2448 instead. Otherwise we use g77's calling convention. */
2451 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2452 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2453 f
= f
|| !sym
->attr
.always_explicit
;
2455 if (e
->expr_type
== EXPR_VARIABLE
2456 && is_subref_array (e
))
2457 /* The actual argument is a component reference to an
2458 array of derived types. In this case, the argument
2459 is converted to a temporary, which is passed and then
2460 written back after the procedure call. */
2461 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2462 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2464 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2466 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2467 allocated on entry, it must be deallocated. */
2468 if (fsym
&& fsym
->attr
.allocatable
2469 && fsym
->attr
.intent
== INTENT_OUT
)
2471 tmp
= build_fold_indirect_ref (parmse
.expr
);
2472 tmp
= gfc_trans_dealloc_allocated (tmp
);
2473 gfc_add_expr_to_block (&se
->pre
, tmp
);
2479 /* The case with fsym->attr.optional is that of a user subroutine
2480 with an interface indicating an optional argument. When we call
2481 an intrinsic subroutine, however, fsym is NULL, but we might still
2482 have an optional argument, so we proceed to the substitution
2484 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2486 /* If an optional argument is itself an optional dummy argument,
2487 check its presence and substitute a null if absent. */
2488 if (e
->expr_type
== EXPR_VARIABLE
2489 && e
->symtree
->n
.sym
->attr
.optional
)
2490 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2491 e
->representation
.length
);
2496 /* Obtain the character length of an assumed character length
2497 length procedure from the typespec. */
2498 if (fsym
->ts
.type
== BT_CHARACTER
2499 && parmse
.string_length
== NULL_TREE
2500 && e
->ts
.type
== BT_PROCEDURE
2501 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2502 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2504 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2505 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2509 if (fsym
&& need_interface_mapping
&& e
)
2510 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2512 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2513 gfc_add_block_to_block (&post
, &parmse
.post
);
2515 /* Allocated allocatable components of derived types must be
2516 deallocated for INTENT(OUT) dummy arguments and non-variable
2517 scalars. Non-variable arrays are dealt with in trans-array.c
2518 (gfc_conv_array_parameter). */
2519 if (e
&& e
->ts
.type
== BT_DERIVED
2520 && e
->ts
.derived
->attr
.alloc_comp
2521 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2523 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2526 tmp
= build_fold_indirect_ref (parmse
.expr
);
2527 parm_rank
= e
->rank
;
2535 case (SCALAR_POINTER
):
2536 tmp
= build_fold_indirect_ref (tmp
);
2543 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2544 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2545 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2546 tmp
, build_empty_stmt ());
2548 if (e
->expr_type
!= EXPR_VARIABLE
)
2549 /* Don't deallocate non-variables until they have been used. */
2550 gfc_add_expr_to_block (&se
->post
, tmp
);
2553 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2554 gfc_add_expr_to_block (&se
->pre
, tmp
);
2558 /* Character strings are passed as two parameters, a length and a
2559 pointer - except for Bind(c) which only passes the pointer. */
2560 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2561 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2563 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2565 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2568 if (ts
.type
== BT_CHARACTER
&& !sym
->attr
.is_bind_c
)
2570 if (sym
->ts
.cl
->length
== NULL
)
2572 /* Assumed character length results are not allowed by 5.1.1.5 of the
2573 standard and are trapped in resolve.c; except in the case of SPREAD
2574 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2575 we take the character length of the first argument for the result.
2576 For dummies, we have to look through the formal argument list for
2577 this function and use the character length found there.*/
2578 if (!sym
->attr
.dummy
)
2579 cl
.backend_decl
= TREE_VALUE (stringargs
);
2582 formal
= sym
->ns
->proc_name
->formal
;
2583 for (; formal
; formal
= formal
->next
)
2584 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2585 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2592 /* Calculate the length of the returned string. */
2593 gfc_init_se (&parmse
, NULL
);
2594 if (need_interface_mapping
)
2595 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2597 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2598 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2599 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2601 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2602 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2603 build_int_cst (gfc_charlen_type_node
, 0));
2604 cl
.backend_decl
= tmp
;
2607 /* Set up a charlen structure for it. */
2612 len
= cl
.backend_decl
;
2615 byref
= gfc_return_by_reference (sym
);
2618 if (se
->direct_byref
)
2620 /* Sometimes, too much indirection can be applied; eg. for
2621 function_result = array_valued_recursive_function. */
2622 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2623 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2624 && GFC_DESCRIPTOR_TYPE_P
2625 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2626 se
->expr
= build_fold_indirect_ref (se
->expr
);
2628 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2630 else if (sym
->result
->attr
.dimension
)
2632 gcc_assert (se
->loop
&& info
);
2634 /* Set the type of the array. */
2635 tmp
= gfc_typenode_for_spec (&ts
);
2636 info
->dimen
= se
->loop
->dimen
;
2638 /* Evaluate the bounds of the result, if known. */
2639 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2641 /* Create a temporary to store the result. In case the function
2642 returns a pointer, the temporary will be a shallow copy and
2643 mustn't be deallocated. */
2644 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2645 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2646 false, !sym
->attr
.pointer
, callee_alloc
);
2648 /* Pass the temporary as the first argument. */
2649 tmp
= info
->descriptor
;
2650 tmp
= build_fold_addr_expr (tmp
);
2651 retargs
= gfc_chainon_list (retargs
, tmp
);
2653 else if (ts
.type
== BT_CHARACTER
)
2655 /* Pass the string length. */
2656 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2657 type
= build_pointer_type (type
);
2659 /* Return an address to a char[0:len-1]* temporary for
2660 character pointers. */
2661 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2663 var
= gfc_create_var (type
, "pstr");
2665 /* Provide an address expression for the function arguments. */
2666 var
= build_fold_addr_expr (var
);
2669 var
= gfc_conv_string_tmp (se
, type
, len
);
2671 retargs
= gfc_chainon_list (retargs
, var
);
2675 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2677 type
= gfc_get_complex_type (ts
.kind
);
2678 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2679 retargs
= gfc_chainon_list (retargs
, var
);
2682 /* Add the string length to the argument list. */
2683 if (ts
.type
== BT_CHARACTER
)
2684 retargs
= gfc_chainon_list (retargs
, len
);
2686 gfc_free_interface_mapping (&mapping
);
2688 /* Add the return arguments. */
2689 arglist
= chainon (retargs
, arglist
);
2691 /* Add the hidden string length parameters to the arguments. */
2692 arglist
= chainon (arglist
, stringargs
);
2694 /* We may want to append extra arguments here. This is used e.g. for
2695 calls to libgfortran_matmul_??, which need extra information. */
2696 if (append_args
!= NULL_TREE
)
2697 arglist
= chainon (arglist
, append_args
);
2699 /* Generate the actual call. */
2700 gfc_conv_function_val (se
, sym
);
2702 /* If there are alternate return labels, function type should be
2703 integer. Can't modify the type in place though, since it can be shared
2704 with other functions. For dummy arguments, the typing is done to
2705 to this result, even if it has to be repeated for each call. */
2706 if (has_alternate_specifier
2707 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2709 if (!sym
->attr
.dummy
)
2711 TREE_TYPE (sym
->backend_decl
)
2712 = build_function_type (integer_type_node
,
2713 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2714 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2717 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2720 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2721 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2723 /* If we have a pointer function, but we don't want a pointer, e.g.
2726 where f is pointer valued, we have to dereference the result. */
2727 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2728 se
->expr
= build_fold_indirect_ref (se
->expr
);
2730 /* f2c calling conventions require a scalar default real function to
2731 return a double precision result. Convert this back to default
2732 real. We only care about the cases that can happen in Fortran 77.
2734 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2735 && sym
->ts
.kind
== gfc_default_real_kind
2736 && !sym
->attr
.always_explicit
)
2737 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2739 /* A pure function may still have side-effects - it may modify its
2741 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2743 if (!sym
->attr
.pure
)
2744 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2749 /* Add the function call to the pre chain. There is no expression. */
2750 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2751 se
->expr
= NULL_TREE
;
2753 if (!se
->direct_byref
)
2755 if (sym
->attr
.dimension
)
2757 if (flag_bounds_check
)
2759 /* Check the data pointer hasn't been modified. This would
2760 happen in a function returning a pointer. */
2761 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2762 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2764 gfc_trans_runtime_check (tmp
, &se
->pre
, NULL
, gfc_msg_fault
);
2766 se
->expr
= info
->descriptor
;
2767 /* Bundle in the string length. */
2768 se
->string_length
= len
;
2770 else if (sym
->ts
.type
== BT_CHARACTER
)
2772 /* Dereference for character pointer results. */
2773 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2774 se
->expr
= build_fold_indirect_ref (var
);
2778 se
->string_length
= len
;
2782 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2783 se
->expr
= build_fold_indirect_ref (var
);
2788 /* Follow the function call with the argument post block. */
2790 gfc_add_block_to_block (&se
->pre
, &post
);
2792 gfc_add_block_to_block (&se
->post
, &post
);
2794 return has_alternate_specifier
;
2798 /* Generate code to copy a string. */
2801 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2802 tree slength
, tree src
)
2804 tree tmp
, dlen
, slen
;
2812 stmtblock_t tempblock
;
2814 if (slength
!= NULL_TREE
)
2816 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2817 ssc
= gfc_to_single_character (slen
, src
);
2821 slen
= build_int_cst (size_type_node
, 1);
2825 if (dlength
!= NULL_TREE
)
2827 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2828 dsc
= gfc_to_single_character (slen
, dest
);
2832 dlen
= build_int_cst (size_type_node
, 1);
2836 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
2837 ssc
= gfc_to_single_character (slen
, src
);
2838 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
2839 dsc
= gfc_to_single_character (dlen
, dest
);
2842 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2844 gfc_add_modify_expr (block
, dsc
, ssc
);
2848 /* Do nothing if the destination length is zero. */
2849 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2850 build_int_cst (size_type_node
, 0));
2852 /* The following code was previously in _gfortran_copy_string:
2854 // The two strings may overlap so we use memmove.
2856 copy_string (GFC_INTEGER_4 destlen, char * dest,
2857 GFC_INTEGER_4 srclen, const char * src)
2859 if (srclen >= destlen)
2861 // This will truncate if too long.
2862 memmove (dest, src, destlen);
2866 memmove (dest, src, srclen);
2868 memset (&dest[srclen], ' ', destlen - srclen);
2872 We're now doing it here for better optimization, but the logic
2876 dest
= fold_convert (pvoid_type_node
, dest
);
2878 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
2881 src
= fold_convert (pvoid_type_node
, src
);
2883 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
2885 /* Truncate string if source is too long. */
2886 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2887 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2888 3, dest
, src
, dlen
);
2890 /* Else copy and pad with spaces. */
2891 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2892 3, dest
, src
, slen
);
2894 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
2895 fold_convert (sizetype
, slen
));
2896 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2898 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2899 lang_hooks
.to_target_charset (' ')),
2900 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2903 gfc_init_block (&tempblock
);
2904 gfc_add_expr_to_block (&tempblock
, tmp3
);
2905 gfc_add_expr_to_block (&tempblock
, tmp4
);
2906 tmp3
= gfc_finish_block (&tempblock
);
2908 /* The whole copy_string function is there. */
2909 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2910 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2911 gfc_add_expr_to_block (block
, tmp
);
2915 /* Translate a statement function.
2916 The value of a statement function reference is obtained by evaluating the
2917 expression using the values of the actual arguments for the values of the
2918 corresponding dummy arguments. */
2921 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2925 gfc_formal_arglist
*fargs
;
2926 gfc_actual_arglist
*args
;
2929 gfc_saved_var
*saved_vars
;
2935 sym
= expr
->symtree
->n
.sym
;
2936 args
= expr
->value
.function
.actual
;
2937 gfc_init_se (&lse
, NULL
);
2938 gfc_init_se (&rse
, NULL
);
2941 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2943 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2944 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2946 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2948 /* Each dummy shall be specified, explicitly or implicitly, to be
2950 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2953 /* Create a temporary to hold the value. */
2954 type
= gfc_typenode_for_spec (&fsym
->ts
);
2955 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2957 if (fsym
->ts
.type
== BT_CHARACTER
)
2959 /* Copy string arguments. */
2962 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2963 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2965 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2966 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2969 gfc_conv_expr (&rse
, args
->expr
);
2970 gfc_conv_string_parameter (&rse
);
2971 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2972 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2974 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2976 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2977 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2981 /* For everything else, just evaluate the expression. */
2982 gfc_conv_expr (&lse
, args
->expr
);
2984 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2985 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2986 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2992 /* Use the temporary variables in place of the real ones. */
2993 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2994 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2996 gfc_conv_expr (se
, sym
->value
);
2998 if (sym
->ts
.type
== BT_CHARACTER
)
3000 gfc_conv_const_charlen (sym
->ts
.cl
);
3002 /* Force the expression to the correct length. */
3003 if (!INTEGER_CST_P (se
->string_length
)
3004 || tree_int_cst_lt (se
->string_length
,
3005 sym
->ts
.cl
->backend_decl
))
3007 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3008 tmp
= gfc_create_var (type
, sym
->name
);
3009 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3010 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3011 se
->string_length
, se
->expr
);
3014 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3017 /* Restore the original variables. */
3018 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3019 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3020 gfc_free (saved_vars
);
3024 /* Translate a function expression. */
3027 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3031 if (expr
->value
.function
.isym
)
3033 gfc_conv_intrinsic_function (se
, expr
);
3037 /* We distinguish statement functions from general functions to improve
3038 runtime performance. */
3039 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3041 gfc_conv_statement_function (se
, expr
);
3045 /* expr.value.function.esym is the resolved (specific) function symbol for
3046 most functions. However this isn't set for dummy procedures. */
3047 sym
= expr
->value
.function
.esym
;
3049 sym
= expr
->symtree
->n
.sym
;
3050 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
3055 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3057 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3058 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3060 gfc_conv_tmp_array_ref (se
);
3061 gfc_advance_se_ss_chain (se
);
3065 /* Build a static initializer. EXPR is the expression for the initial value.
3066 The other parameters describe the variable of the component being
3067 initialized. EXPR may be null. */
3070 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3071 bool array
, bool pointer
)
3075 if (!(expr
|| pointer
))
3078 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3079 (these are the only two iso_c_binding derived types that can be
3080 used as initialization expressions). If so, we need to modify
3081 the 'expr' to be that for a (void *). */
3082 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3083 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3085 gfc_symbol
*derived
= expr
->ts
.derived
;
3087 expr
= gfc_int_expr (0);
3089 /* The derived symbol has already been converted to a (void *). Use
3091 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3092 expr
->ts
.kind
= derived
->ts
.kind
;
3097 /* Arrays need special handling. */
3099 return gfc_build_null_descriptor (type
);
3101 return gfc_conv_array_initializer (type
, expr
);
3104 return fold_convert (type
, null_pointer_node
);
3110 gfc_init_se (&se
, NULL
);
3111 gfc_conv_structure (&se
, expr
, 1);
3115 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3118 gfc_init_se (&se
, NULL
);
3119 gfc_conv_constant (&se
, expr
);
3126 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3138 gfc_start_block (&block
);
3140 /* Initialize the scalarizer. */
3141 gfc_init_loopinfo (&loop
);
3143 gfc_init_se (&lse
, NULL
);
3144 gfc_init_se (&rse
, NULL
);
3147 rss
= gfc_walk_expr (expr
);
3148 if (rss
== gfc_ss_terminator
)
3150 /* The rhs is scalar. Add a ss for the expression. */
3151 rss
= gfc_get_ss ();
3152 rss
->next
= gfc_ss_terminator
;
3153 rss
->type
= GFC_SS_SCALAR
;
3157 /* Create a SS for the destination. */
3158 lss
= gfc_get_ss ();
3159 lss
->type
= GFC_SS_COMPONENT
;
3161 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3162 lss
->next
= gfc_ss_terminator
;
3163 lss
->data
.info
.dimen
= cm
->as
->rank
;
3164 lss
->data
.info
.descriptor
= dest
;
3165 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3166 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3167 for (n
= 0; n
< cm
->as
->rank
; n
++)
3169 lss
->data
.info
.dim
[n
] = n
;
3170 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3171 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3173 mpz_init (lss
->shape
[n
]);
3174 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3175 cm
->as
->lower
[n
]->value
.integer
);
3176 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3179 /* Associate the SS with the loop. */
3180 gfc_add_ss_to_loop (&loop
, lss
);
3181 gfc_add_ss_to_loop (&loop
, rss
);
3183 /* Calculate the bounds of the scalarization. */
3184 gfc_conv_ss_startstride (&loop
);
3186 /* Setup the scalarizing loops. */
3187 gfc_conv_loop_setup (&loop
);
3189 /* Setup the gfc_se structures. */
3190 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3191 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3194 gfc_mark_ss_chain_used (rss
, 1);
3196 gfc_mark_ss_chain_used (lss
, 1);
3198 /* Start the scalarized loop body. */
3199 gfc_start_scalarized_body (&loop
, &body
);
3201 gfc_conv_tmp_array_ref (&lse
);
3202 if (cm
->ts
.type
== BT_CHARACTER
)
3203 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3205 gfc_conv_expr (&rse
, expr
);
3207 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3208 gfc_add_expr_to_block (&body
, tmp
);
3210 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3212 /* Generate the copying loops. */
3213 gfc_trans_scalarizing_loops (&loop
, &body
);
3215 /* Wrap the whole thing up. */
3216 gfc_add_block_to_block (&block
, &loop
.pre
);
3217 gfc_add_block_to_block (&block
, &loop
.post
);
3219 for (n
= 0; n
< cm
->as
->rank
; n
++)
3220 mpz_clear (lss
->shape
[n
]);
3221 gfc_free (lss
->shape
);
3223 gfc_cleanup_loop (&loop
);
3225 return gfc_finish_block (&block
);
3229 /* Assign a single component of a derived type constructor. */
3232 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3242 gfc_start_block (&block
);
3246 gfc_init_se (&se
, NULL
);
3247 /* Pointer component. */
3250 /* Array pointer. */
3251 if (expr
->expr_type
== EXPR_NULL
)
3252 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3255 rss
= gfc_walk_expr (expr
);
3256 se
.direct_byref
= 1;
3258 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3259 gfc_add_block_to_block (&block
, &se
.pre
);
3260 gfc_add_block_to_block (&block
, &se
.post
);
3265 /* Scalar pointers. */
3266 se
.want_pointer
= 1;
3267 gfc_conv_expr (&se
, expr
);
3268 gfc_add_block_to_block (&block
, &se
.pre
);
3269 gfc_add_modify_expr (&block
, dest
,
3270 fold_convert (TREE_TYPE (dest
), se
.expr
));
3271 gfc_add_block_to_block (&block
, &se
.post
);
3274 else if (cm
->dimension
)
3276 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
3277 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3278 else if (cm
->allocatable
)
3282 gfc_init_se (&se
, NULL
);
3284 rss
= gfc_walk_expr (expr
);
3285 se
.want_pointer
= 0;
3286 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3287 gfc_add_block_to_block (&block
, &se
.pre
);
3289 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3290 gfc_add_modify_expr (&block
, dest
, tmp
);
3292 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3293 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3296 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3297 TREE_TYPE(cm
->backend_decl
),
3300 gfc_add_expr_to_block (&block
, tmp
);
3302 gfc_add_block_to_block (&block
, &se
.post
);
3303 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3305 /* Shift the lbound and ubound of temporaries to being unity, rather
3306 than zero, based. Calculate the offset for all cases. */
3307 offset
= gfc_conv_descriptor_offset (dest
);
3308 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
3309 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3310 for (n
= 0; n
< expr
->rank
; n
++)
3312 if (expr
->expr_type
!= EXPR_VARIABLE
3313 && expr
->expr_type
!= EXPR_CONSTANT
)
3316 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
3317 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3318 gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]));
3319 gfc_add_modify_expr (&block
, tmp
,
3320 fold_build2 (PLUS_EXPR
,
3321 gfc_array_index_type
,
3322 span
, gfc_index_one_node
));
3323 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
3324 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
3326 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3327 gfc_conv_descriptor_lbound (dest
,
3329 gfc_conv_descriptor_stride (dest
,
3331 gfc_add_modify_expr (&block
, tmp2
, tmp
);
3332 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3333 gfc_add_modify_expr (&block
, offset
, tmp
);
3338 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3339 gfc_add_expr_to_block (&block
, tmp
);
3342 else if (expr
->ts
.type
== BT_DERIVED
)
3344 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3346 gfc_init_se (&se
, NULL
);
3347 gfc_conv_expr (&se
, expr
);
3348 gfc_add_modify_expr (&block
, dest
,
3349 fold_convert (TREE_TYPE (dest
), se
.expr
));
3353 /* Nested constructors. */
3354 tmp
= gfc_trans_structure_assign (dest
, expr
);
3355 gfc_add_expr_to_block (&block
, tmp
);
3360 /* Scalar component. */
3361 gfc_init_se (&se
, NULL
);
3362 gfc_init_se (&lse
, NULL
);
3364 gfc_conv_expr (&se
, expr
);
3365 if (cm
->ts
.type
== BT_CHARACTER
)
3366 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3368 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3369 gfc_add_expr_to_block (&block
, tmp
);
3371 return gfc_finish_block (&block
);
3374 /* Assign a derived type constructor to a variable. */
3377 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3385 gfc_start_block (&block
);
3386 cm
= expr
->ts
.derived
->components
;
3387 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3389 /* Skip absent members in default initializers. */
3393 /* Update the type/kind of the expression if it represents either
3394 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3395 be the first place reached for initializing output variables that
3396 have components of type C_PTR/C_FUNPTR that are initialized. */
3397 if (c
->expr
->ts
.type
== BT_DERIVED
&& c
->expr
->ts
.derived
3398 && c
->expr
->ts
.derived
->attr
.is_iso_c
)
3400 c
->expr
->expr_type
= EXPR_NULL
;
3401 c
->expr
->ts
.type
= c
->expr
->ts
.derived
->ts
.type
;
3402 c
->expr
->ts
.f90_type
= c
->expr
->ts
.derived
->ts
.f90_type
;
3403 c
->expr
->ts
.kind
= c
->expr
->ts
.derived
->ts
.kind
;
3406 field
= cm
->backend_decl
;
3407 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3408 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3409 gfc_add_expr_to_block (&block
, tmp
);
3411 return gfc_finish_block (&block
);
3414 /* Build an expression for a constructor. If init is nonzero then
3415 this is part of a static variable initializer. */
3418 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3425 VEC(constructor_elt
,gc
) *v
= NULL
;
3427 gcc_assert (se
->ss
== NULL
);
3428 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3429 type
= gfc_typenode_for_spec (&expr
->ts
);
3433 /* Create a temporary variable and fill it in. */
3434 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3435 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3436 gfc_add_expr_to_block (&se
->pre
, tmp
);
3440 cm
= expr
->ts
.derived
->components
;
3442 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3444 /* Skip absent members in default initializers and allocatable
3445 components. Although the latter have a default initializer
3446 of EXPR_NULL,... by default, the static nullify is not needed
3447 since this is done every time we come into scope. */
3448 if (!c
->expr
|| cm
->allocatable
)
3451 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3452 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3454 /* Append it to the constructor list. */
3455 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3457 se
->expr
= build_constructor (type
, v
);
3460 TREE_CONSTANT(se
->expr
) = 1;
3461 TREE_INVARIANT(se
->expr
) = 1;
3466 /* Translate a substring expression. */
3469 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3475 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3477 se
->expr
= gfc_build_string_const (expr
->value
.character
.length
,
3478 expr
->value
.character
.string
);
3479 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3480 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3483 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3487 /* Entry point for expression translation. Evaluates a scalar quantity.
3488 EXPR is the expression to be translated, and SE is the state structure if
3489 called from within the scalarized. */
3492 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3494 if (se
->ss
&& se
->ss
->expr
== expr
3495 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3497 /* Substitute a scalar expression evaluated outside the scalarization
3499 se
->expr
= se
->ss
->data
.scalar
.expr
;
3500 se
->string_length
= se
->ss
->string_length
;
3501 gfc_advance_se_ss_chain (se
);
3505 /* We need to convert the expressions for the iso_c_binding derived types.
3506 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3507 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3508 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3509 updated to be an integer with a kind equal to the size of a (void *). */
3510 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3511 && expr
->ts
.derived
->attr
.is_iso_c
)
3513 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3514 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3516 /* Set expr_type to EXPR_NULL, which will result in
3517 null_pointer_node being used below. */
3518 expr
->expr_type
= EXPR_NULL
;
3522 /* Update the type/kind of the expression to be what the new
3523 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3524 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3525 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3526 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3530 switch (expr
->expr_type
)
3533 gfc_conv_expr_op (se
, expr
);
3537 gfc_conv_function_expr (se
, expr
);
3541 gfc_conv_constant (se
, expr
);
3545 gfc_conv_variable (se
, expr
);
3549 se
->expr
= null_pointer_node
;
3552 case EXPR_SUBSTRING
:
3553 gfc_conv_substring_expr (se
, expr
);
3556 case EXPR_STRUCTURE
:
3557 gfc_conv_structure (se
, expr
, 0);
3561 gfc_conv_array_constructor_expr (se
, expr
);
3570 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3571 of an assignment. */
3573 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3575 gfc_conv_expr (se
, expr
);
3576 /* All numeric lvalues should have empty post chains. If not we need to
3577 figure out a way of rewriting an lvalue so that it has no post chain. */
3578 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3581 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3582 numeric expressions. Used for scalar values where inserting cleanup code
3585 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3589 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3590 gfc_conv_expr (se
, expr
);
3593 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3594 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3596 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3600 /* Helper to translate an expression and convert it to a particular type. */
3602 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3604 gfc_conv_expr_val (se
, expr
);
3605 se
->expr
= convert (type
, se
->expr
);
3609 /* Converts an expression so that it can be passed by reference. Scalar
3613 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3617 if (se
->ss
&& se
->ss
->expr
== expr
3618 && se
->ss
->type
== GFC_SS_REFERENCE
)
3620 se
->expr
= se
->ss
->data
.scalar
.expr
;
3621 se
->string_length
= se
->ss
->string_length
;
3622 gfc_advance_se_ss_chain (se
);
3626 if (expr
->ts
.type
== BT_CHARACTER
)
3628 gfc_conv_expr (se
, expr
);
3629 gfc_conv_string_parameter (se
);
3633 if (expr
->expr_type
== EXPR_VARIABLE
)
3635 se
->want_pointer
= 1;
3636 gfc_conv_expr (se
, expr
);
3639 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3640 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3641 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3647 if (expr
->expr_type
== EXPR_FUNCTION
3648 && expr
->symtree
->n
.sym
->attr
.pointer
3649 && !expr
->symtree
->n
.sym
->attr
.dimension
)
3651 se
->want_pointer
= 1;
3652 gfc_conv_expr (se
, expr
);
3653 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3654 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3660 gfc_conv_expr (se
, expr
);
3662 /* Create a temporary var to hold the value. */
3663 if (TREE_CONSTANT (se
->expr
))
3665 tree tmp
= se
->expr
;
3666 STRIP_TYPE_NOPS (tmp
);
3667 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3668 DECL_INITIAL (var
) = tmp
;
3669 TREE_STATIC (var
) = 1;
3674 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3675 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3677 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3679 /* Take the address of that value. */
3680 se
->expr
= build_fold_addr_expr (var
);
3685 gfc_trans_pointer_assign (gfc_code
* code
)
3687 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3691 /* Generate code for a pointer assignment. */
3694 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3706 gfc_start_block (&block
);
3708 gfc_init_se (&lse
, NULL
);
3710 lss
= gfc_walk_expr (expr1
);
3711 rss
= gfc_walk_expr (expr2
);
3712 if (lss
== gfc_ss_terminator
)
3714 /* Scalar pointers. */
3715 lse
.want_pointer
= 1;
3716 gfc_conv_expr (&lse
, expr1
);
3717 gcc_assert (rss
== gfc_ss_terminator
);
3718 gfc_init_se (&rse
, NULL
);
3719 rse
.want_pointer
= 1;
3720 gfc_conv_expr (&rse
, expr2
);
3721 gfc_add_block_to_block (&block
, &lse
.pre
);
3722 gfc_add_block_to_block (&block
, &rse
.pre
);
3723 gfc_add_modify_expr (&block
, lse
.expr
,
3724 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3725 gfc_add_block_to_block (&block
, &rse
.post
);
3726 gfc_add_block_to_block (&block
, &lse
.post
);
3730 /* Array pointer. */
3731 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3732 switch (expr2
->expr_type
)
3735 /* Just set the data pointer to null. */
3736 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3740 /* Assign directly to the pointer's descriptor. */
3741 lse
.direct_byref
= 1;
3742 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3744 /* If this is a subreference array pointer assignment, use the rhs
3745 descriptor element size for the lhs span. */
3746 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
3748 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
3749 gfc_init_se (&rse
, NULL
);
3750 rse
.descriptor_only
= 1;
3751 gfc_conv_expr (&rse
, expr2
);
3752 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
3753 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
3754 if (!INTEGER_CST_P (tmp
))
3755 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
3756 gfc_add_modify_expr (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
3762 /* Assign to a temporary descriptor and then copy that
3763 temporary to the pointer. */
3765 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3768 lse
.direct_byref
= 1;
3769 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3770 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3773 gfc_add_block_to_block (&block
, &lse
.pre
);
3774 gfc_add_block_to_block (&block
, &lse
.post
);
3776 return gfc_finish_block (&block
);
3780 /* Makes sure se is suitable for passing as a function string parameter. */
3781 /* TODO: Need to check all callers fo this function. It may be abused. */
3784 gfc_conv_string_parameter (gfc_se
* se
)
3788 if (TREE_CODE (se
->expr
) == STRING_CST
)
3790 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3794 type
= TREE_TYPE (se
->expr
);
3795 if (TYPE_STRING_FLAG (type
))
3797 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
3798 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3801 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3803 type
= build_pointer_type (type
);
3804 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
3808 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3809 gcc_assert (se
->string_length
3810 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3814 /* Generate code for assignment of scalar variables. Includes character
3815 strings and derived types with allocatable components. */
3818 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3819 bool l_is_temp
, bool r_is_var
)
3825 gfc_init_block (&block
);
3827 if (ts
.type
== BT_CHARACTER
)
3832 if (lse
->string_length
!= NULL_TREE
)
3834 gfc_conv_string_parameter (lse
);
3835 gfc_add_block_to_block (&block
, &lse
->pre
);
3836 llen
= lse
->string_length
;
3839 if (rse
->string_length
!= NULL_TREE
)
3841 gcc_assert (rse
->string_length
!= NULL_TREE
);
3842 gfc_conv_string_parameter (rse
);
3843 gfc_add_block_to_block (&block
, &rse
->pre
);
3844 rlen
= rse
->string_length
;
3847 gfc_trans_string_copy (&block
, llen
, lse
->expr
, rlen
, rse
->expr
);
3849 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3853 /* Are the rhs and the lhs the same? */
3856 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3857 build_fold_addr_expr (lse
->expr
),
3858 build_fold_addr_expr (rse
->expr
));
3859 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3862 /* Deallocate the lhs allocated components as long as it is not
3863 the same as the rhs. This must be done following the assignment
3864 to prevent deallocating data that could be used in the rhs
3868 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
3869 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
3871 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3872 gfc_add_expr_to_block (&lse
->post
, tmp
);
3875 gfc_add_block_to_block (&block
, &rse
->pre
);
3876 gfc_add_block_to_block (&block
, &lse
->pre
);
3878 gfc_add_modify_expr (&block
, lse
->expr
,
3879 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3881 /* Do a deep copy if the rhs is a variable, if it is not the
3885 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3886 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3887 gfc_add_expr_to_block (&block
, tmp
);
3892 gfc_add_block_to_block (&block
, &lse
->pre
);
3893 gfc_add_block_to_block (&block
, &rse
->pre
);
3895 gfc_add_modify_expr (&block
, lse
->expr
,
3896 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3899 gfc_add_block_to_block (&block
, &lse
->post
);
3900 gfc_add_block_to_block (&block
, &rse
->post
);
3902 return gfc_finish_block (&block
);
3906 /* Try to translate array(:) = func (...), where func is a transformational
3907 array function, without using a temporary. Returns NULL is this isn't the
3911 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3916 bool seen_array_ref
;
3918 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3919 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3922 /* Elemental functions don't need a temporary anyway. */
3923 if (expr2
->value
.function
.esym
!= NULL
3924 && expr2
->value
.function
.esym
->attr
.elemental
)
3927 /* Fail if EXPR1 can't be expressed as a descriptor. */
3928 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3931 /* Functions returning pointers need temporaries. */
3932 if (expr2
->symtree
->n
.sym
->attr
.pointer
3933 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3936 /* Character array functions need temporaries unless the
3937 character lengths are the same. */
3938 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3940 if (expr1
->ts
.cl
->length
== NULL
3941 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3944 if (expr2
->ts
.cl
->length
== NULL
3945 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3948 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3949 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3953 /* Check that no LHS component references appear during an array
3954 reference. This is needed because we do not have the means to
3955 span any arbitrary stride with an array descriptor. This check
3956 is not needed for the rhs because the function result has to be
3958 seen_array_ref
= false;
3959 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3961 if (ref
->type
== REF_ARRAY
)
3962 seen_array_ref
= true;
3963 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3967 /* Check for a dependency. */
3968 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3969 expr2
->value
.function
.esym
,
3970 expr2
->value
.function
.actual
))
3973 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3975 gcc_assert (expr2
->value
.function
.isym
3976 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3977 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3979 ss
= gfc_walk_expr (expr1
);
3980 gcc_assert (ss
!= gfc_ss_terminator
);
3981 gfc_init_se (&se
, NULL
);
3982 gfc_start_block (&se
.pre
);
3983 se
.want_pointer
= 1;
3985 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3987 se
.direct_byref
= 1;
3988 se
.ss
= gfc_walk_expr (expr2
);
3989 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3990 gfc_conv_function_expr (&se
, expr2
);
3991 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3993 return gfc_finish_block (&se
.pre
);
3996 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3999 is_zero_initializer_p (gfc_expr
* expr
)
4001 if (expr
->expr_type
!= EXPR_CONSTANT
)
4004 /* We ignore constants with prescribed memory representations for now. */
4005 if (expr
->representation
.string
)
4008 switch (expr
->ts
.type
)
4011 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4014 return mpfr_zero_p (expr
->value
.real
)
4015 && MPFR_SIGN (expr
->value
.real
) >= 0;
4018 return expr
->value
.logical
== 0;
4021 return mpfr_zero_p (expr
->value
.complex.r
)
4022 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
4023 && mpfr_zero_p (expr
->value
.complex.i
)
4024 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
4032 /* Try to efficiently translate array(:) = 0. Return NULL if this
4036 gfc_trans_zero_assign (gfc_expr
* expr
)
4038 tree dest
, len
, type
;
4042 sym
= expr
->symtree
->n
.sym
;
4043 dest
= gfc_get_symbol_decl (sym
);
4045 type
= TREE_TYPE (dest
);
4046 if (POINTER_TYPE_P (type
))
4047 type
= TREE_TYPE (type
);
4048 if (!GFC_ARRAY_TYPE_P (type
))
4051 /* Determine the length of the array. */
4052 len
= GFC_TYPE_ARRAY_SIZE (type
);
4053 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4056 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4057 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4058 fold_convert (gfc_array_index_type
, tmp
));
4060 /* Convert arguments to the correct types. */
4061 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4062 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
4064 dest
= fold_convert (pvoid_type_node
, dest
);
4065 len
= fold_convert (size_type_node
, len
);
4067 /* Construct call to __builtin_memset. */
4068 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4069 3, dest
, integer_zero_node
, len
);
4070 return fold_convert (void_type_node
, tmp
);
4074 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4075 that constructs the call to __builtin_memcpy. */
4078 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4082 /* Convert arguments to the correct types. */
4083 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4084 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4086 dst
= fold_convert (pvoid_type_node
, dst
);
4088 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4089 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4091 src
= fold_convert (pvoid_type_node
, src
);
4093 len
= fold_convert (size_type_node
, len
);
4095 /* Construct call to __builtin_memcpy. */
4096 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4097 return fold_convert (void_type_node
, tmp
);
4101 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4102 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4103 source/rhs, both are gfc_full_array_ref_p which have been checked for
4107 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4109 tree dst
, dlen
, dtype
;
4110 tree src
, slen
, stype
;
4113 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4114 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4116 dtype
= TREE_TYPE (dst
);
4117 if (POINTER_TYPE_P (dtype
))
4118 dtype
= TREE_TYPE (dtype
);
4119 stype
= TREE_TYPE (src
);
4120 if (POINTER_TYPE_P (stype
))
4121 stype
= TREE_TYPE (stype
);
4123 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4126 /* Determine the lengths of the arrays. */
4127 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4128 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4130 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4131 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4132 fold_convert (gfc_array_index_type
, tmp
));
4134 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4135 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4137 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4138 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4139 fold_convert (gfc_array_index_type
, tmp
));
4141 /* Sanity check that they are the same. This should always be
4142 the case, as we should already have checked for conformance. */
4143 if (!tree_int_cst_equal (slen
, dlen
))
4146 return gfc_build_memcpy_call (dst
, src
, dlen
);
4150 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4151 this can't be done. EXPR1 is the destination/lhs for which
4152 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4155 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4157 unsigned HOST_WIDE_INT nelem
;
4163 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4167 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4168 dtype
= TREE_TYPE (dst
);
4169 if (POINTER_TYPE_P (dtype
))
4170 dtype
= TREE_TYPE (dtype
);
4171 if (!GFC_ARRAY_TYPE_P (dtype
))
4174 /* Determine the lengths of the array. */
4175 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4176 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4179 /* Confirm that the constructor is the same size. */
4180 if (compare_tree_int (len
, nelem
) != 0)
4183 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4184 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4185 fold_convert (gfc_array_index_type
, tmp
));
4187 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4188 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4190 stype
= TREE_TYPE (src
);
4191 if (POINTER_TYPE_P (stype
))
4192 stype
= TREE_TYPE (stype
);
4194 return gfc_build_memcpy_call (dst
, src
, len
);
4198 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4199 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4202 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4207 gfc_ss
*lss_section
;
4215 /* Assignment of the form lhs = rhs. */
4216 gfc_start_block (&block
);
4218 gfc_init_se (&lse
, NULL
);
4219 gfc_init_se (&rse
, NULL
);
4222 lss
= gfc_walk_expr (expr1
);
4224 if (lss
!= gfc_ss_terminator
)
4226 /* The assignment needs scalarization. */
4229 /* Find a non-scalar SS from the lhs. */
4230 while (lss_section
!= gfc_ss_terminator
4231 && lss_section
->type
!= GFC_SS_SECTION
)
4232 lss_section
= lss_section
->next
;
4234 gcc_assert (lss_section
!= gfc_ss_terminator
);
4236 /* Initialize the scalarizer. */
4237 gfc_init_loopinfo (&loop
);
4240 rss
= gfc_walk_expr (expr2
);
4241 if (rss
== gfc_ss_terminator
)
4243 /* The rhs is scalar. Add a ss for the expression. */
4244 rss
= gfc_get_ss ();
4245 rss
->next
= gfc_ss_terminator
;
4246 rss
->type
= GFC_SS_SCALAR
;
4249 /* Associate the SS with the loop. */
4250 gfc_add_ss_to_loop (&loop
, lss
);
4251 gfc_add_ss_to_loop (&loop
, rss
);
4253 /* Calculate the bounds of the scalarization. */
4254 gfc_conv_ss_startstride (&loop
);
4255 /* Resolve any data dependencies in the statement. */
4256 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4257 /* Setup the scalarizing loops. */
4258 gfc_conv_loop_setup (&loop
);
4260 /* Setup the gfc_se structures. */
4261 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4262 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4265 gfc_mark_ss_chain_used (rss
, 1);
4266 if (loop
.temp_ss
== NULL
)
4269 gfc_mark_ss_chain_used (lss
, 1);
4273 lse
.ss
= loop
.temp_ss
;
4274 gfc_mark_ss_chain_used (lss
, 3);
4275 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4278 /* Start the scalarized loop body. */
4279 gfc_start_scalarized_body (&loop
, &body
);
4282 gfc_init_block (&body
);
4284 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4286 /* Translate the expression. */
4287 gfc_conv_expr (&rse
, expr2
);
4291 gfc_conv_tmp_array_ref (&lse
);
4292 gfc_advance_se_ss_chain (&lse
);
4295 gfc_conv_expr (&lse
, expr1
);
4297 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4298 l_is_temp
|| init_flag
,
4299 expr2
->expr_type
== EXPR_VARIABLE
);
4300 gfc_add_expr_to_block (&body
, tmp
);
4302 if (lss
== gfc_ss_terminator
)
4304 /* Use the scalar assignment as is. */
4305 gfc_add_block_to_block (&block
, &body
);
4309 gcc_assert (lse
.ss
== gfc_ss_terminator
4310 && rse
.ss
== gfc_ss_terminator
);
4314 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4316 /* We need to copy the temporary to the actual lhs. */
4317 gfc_init_se (&lse
, NULL
);
4318 gfc_init_se (&rse
, NULL
);
4319 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4320 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4322 rse
.ss
= loop
.temp_ss
;
4325 gfc_conv_tmp_array_ref (&rse
);
4326 gfc_advance_se_ss_chain (&rse
);
4327 gfc_conv_expr (&lse
, expr1
);
4329 gcc_assert (lse
.ss
== gfc_ss_terminator
4330 && rse
.ss
== gfc_ss_terminator
);
4332 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4334 gfc_add_expr_to_block (&body
, tmp
);
4337 /* Generate the copying loops. */
4338 gfc_trans_scalarizing_loops (&loop
, &body
);
4340 /* Wrap the whole thing up. */
4341 gfc_add_block_to_block (&block
, &loop
.pre
);
4342 gfc_add_block_to_block (&block
, &loop
.post
);
4344 gfc_cleanup_loop (&loop
);
4347 return gfc_finish_block (&block
);
4351 /* Check whether EXPR is a copyable array. */
4354 copyable_array_p (gfc_expr
* expr
)
4356 if (expr
->expr_type
!= EXPR_VARIABLE
)
4359 /* First check it's an array. */
4360 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4363 if (!gfc_full_array_ref_p (expr
->ref
))
4366 /* Next check that it's of a simple enough type. */
4367 switch (expr
->ts
.type
)
4379 return !expr
->ts
.derived
->attr
.alloc_comp
;
4388 /* Translate an assignment. */
4391 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4395 /* Special case a single function returning an array. */
4396 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4398 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4403 /* Special case assigning an array to zero. */
4404 if (copyable_array_p (expr1
)
4405 && is_zero_initializer_p (expr2
))
4407 tmp
= gfc_trans_zero_assign (expr1
);
4412 /* Special case copying one array to another. */
4413 if (copyable_array_p (expr1
)
4414 && copyable_array_p (expr2
)
4415 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4416 && !gfc_check_dependency (expr1
, expr2
, 0))
4418 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4423 /* Special case initializing an array from a constant array constructor. */
4424 if (copyable_array_p (expr1
)
4425 && expr2
->expr_type
== EXPR_ARRAY
4426 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4428 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4433 /* Fallback to the scalarizer to generate explicit loops. */
4434 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4438 gfc_trans_init_assign (gfc_code
* code
)
4440 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
4444 gfc_trans_assign (gfc_code
* code
)
4446 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);