1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
54 dest
->loop
= src
->loop
;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
67 memset (se
, 0, sizeof (gfc_se
));
68 gfc_init_block (&se
->pre
);
69 gfc_init_block (&se
->post
);
74 gfc_copy_se_loopvars (se
, parent
);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se
* se
)
87 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se
* se
)
111 if (CONSTANT_CLASS_P (se
->expr
))
114 /* We need a temporary for this result. */
115 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
116 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol
* sym
)
129 gcc_assert (sym
->attr
.dummy
);
131 decl
= gfc_get_symbol_decl (sym
);
132 if (TREE_CODE (decl
) != PARM_DECL
)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
138 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
140 return build2 (NE_EXPR
, boolean_type_node
, decl
,
141 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
145 /* Converts a missing, dummy argument into a null or zero. */
148 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
153 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
154 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
155 build_int_cst (TREE_TYPE (se
->expr
), 0));
156 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
158 if (ts
.type
== BT_CHARACTER
)
160 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
161 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
162 se
->string_length
, tmp
);
163 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
164 se
->string_length
= tmp
;
170 /* Get the character length of an expression, looking through gfc_refs
174 gfc_get_expr_charlen (gfc_expr
*e
)
179 gcc_assert (e
->expr_type
== EXPR_VARIABLE
180 && e
->ts
.type
== BT_CHARACTER
);
182 length
= NULL
; /* To silence compiler warning. */
184 /* First candidate: if the variable is of type CHARACTER, the
185 expression's length could be the length of the character
187 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
188 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
190 /* Look through the reference chain for component references. */
191 for (r
= e
->ref
; r
; r
= r
->next
)
196 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
197 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
205 /* We should never got substring references here. These will be
206 broken down by the scalarizer. */
211 gcc_assert (length
!= NULL
);
217 /* Generate code to initialize a string length variable. Returns the
221 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
226 gfc_init_se (&se
, NULL
);
227 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
228 gfc_add_block_to_block (pblock
, &se
.pre
);
230 tmp
= cl
->backend_decl
;
231 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
236 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
)
244 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
245 type
= build_pointer_type (type
);
248 gfc_init_se (&start
, se
);
249 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
250 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
252 if (integer_onep (start
.expr
))
253 gfc_conv_string_parameter (se
);
256 /* Change the start of the string. */
257 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
260 tmp
= build_fold_indirect_ref (se
->expr
);
261 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
262 se
->expr
= gfc_build_addr_expr (type
, tmp
);
265 /* Length = end + 1 - start. */
266 gfc_init_se (&end
, se
);
267 if (ref
->u
.ss
.end
== NULL
)
268 end
.expr
= se
->string_length
;
271 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
272 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
274 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
275 build_int_cst (gfc_charlen_type_node
, 1),
277 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
278 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
279 build_int_cst (gfc_charlen_type_node
, 0));
280 se
->string_length
= tmp
;
284 /* Convert a derived type component reference. */
287 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
294 c
= ref
->u
.c
.component
;
296 gcc_assert (c
->backend_decl
);
298 field
= c
->backend_decl
;
299 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
301 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
305 if (c
->ts
.type
== BT_CHARACTER
)
307 tmp
= c
->ts
.cl
->backend_decl
;
308 /* Components must always be constant length. */
309 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
310 se
->string_length
= tmp
;
313 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
314 se
->expr
= build_fold_indirect_ref (se
->expr
);
318 /* Return the contents of a variable. Also handles reference/pointer
319 variables (all Fortran pointer references are implicit). */
322 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
329 bool alternate_entry
;
332 sym
= expr
->symtree
->n
.sym
;
335 /* Check that something hasn't gone horribly wrong. */
336 gcc_assert (se
->ss
!= gfc_ss_terminator
);
337 gcc_assert (se
->ss
->expr
== expr
);
339 /* A scalarized term. We already know the descriptor. */
340 se
->expr
= se
->ss
->data
.info
.descriptor
;
341 se
->string_length
= se
->ss
->string_length
;
342 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
343 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
348 tree se_expr
= NULL_TREE
;
350 se
->expr
= gfc_get_symbol_decl (sym
);
352 /* Deal with references to a parent results or entries by storing
353 the current_function_decl and moving to the parent_decl. */
354 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
355 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
356 && sym
->result
== sym
;
357 entry_master
= sym
->attr
.result
358 && sym
->ns
->proc_name
->attr
.entry_master
359 && !gfc_return_by_reference (sym
->ns
->proc_name
);
360 parent_decl
= DECL_CONTEXT (current_function_decl
);
362 if ((se
->expr
== parent_decl
&& return_value
)
363 || (sym
->ns
&& sym
->ns
->proc_name
365 && sym
->ns
->proc_name
->backend_decl
== parent_decl
366 && (alternate_entry
|| entry_master
)))
371 /* Special case for assigning the return value of a function.
372 Self recursive functions must have an explicit return value. */
373 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
374 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
376 /* Similarly for alternate entry points. */
377 else if (alternate_entry
378 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
381 gfc_entry_list
*el
= NULL
;
383 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
386 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
391 else if (entry_master
392 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
394 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
399 /* Procedure actual arguments. */
400 else if (sym
->attr
.flavor
== FL_PROCEDURE
401 && se
->expr
!= current_function_decl
)
403 gcc_assert (se
->want_pointer
);
404 if (!sym
->attr
.dummy
)
406 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
407 se
->expr
= build_fold_addr_expr (se
->expr
);
413 /* Dereference the expression, where needed. Since characters
414 are entirely different from other types, they are treated
416 if (sym
->ts
.type
== BT_CHARACTER
)
418 /* Dereference character pointer dummy arguments
420 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
422 || sym
->attr
.function
423 || sym
->attr
.result
))
424 se
->expr
= build_fold_indirect_ref (se
->expr
);
428 /* Dereference non-character scalar dummy arguments. */
429 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
430 se
->expr
= build_fold_indirect_ref (se
->expr
);
432 /* Dereference scalar hidden result. */
433 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
434 && (sym
->attr
.function
|| sym
->attr
.result
)
435 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
436 se
->expr
= build_fold_indirect_ref (se
->expr
);
438 /* Dereference non-character pointer variables.
439 These must be dummies, results, or scalars. */
440 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
442 || sym
->attr
.function
444 || !sym
->attr
.dimension
))
445 se
->expr
= build_fold_indirect_ref (se
->expr
);
451 /* For character variables, also get the length. */
452 if (sym
->ts
.type
== BT_CHARACTER
)
454 /* If the character length of an entry isn't set, get the length from
455 the master function instead. */
456 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
457 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
459 se
->string_length
= sym
->ts
.cl
->backend_decl
;
460 gcc_assert (se
->string_length
);
468 /* Return the descriptor if that's what we want and this is an array
469 section reference. */
470 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
472 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
473 /* Return the descriptor for array pointers and allocations. */
475 && ref
->next
== NULL
&& (se
->descriptor_only
))
478 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
479 /* Return a pointer to an element. */
483 gfc_conv_component_ref (se
, ref
);
487 gfc_conv_substring (se
, ref
, expr
->ts
.kind
);
496 /* Pointer assignment, allocation or pass by reference. Arrays are handled
498 if (se
->want_pointer
)
500 if (expr
->ts
.type
== BT_CHARACTER
)
501 gfc_conv_string_parameter (se
);
503 se
->expr
= build_fold_addr_expr (se
->expr
);
508 /* Unary ops are easy... Or they would be if ! was a valid op. */
511 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
516 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
517 /* Initialize the operand. */
518 gfc_init_se (&operand
, se
);
519 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
520 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
522 type
= gfc_typenode_for_spec (&expr
->ts
);
524 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
525 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
526 All other unary operators have an equivalent GIMPLE unary operator. */
527 if (code
== TRUTH_NOT_EXPR
)
528 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
529 build_int_cst (type
, 0));
531 se
->expr
= build1 (code
, type
, operand
.expr
);
535 /* Expand power operator to optimal multiplications when a value is raised
536 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
537 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
538 Programming", 3rd Edition, 1998. */
540 /* This code is mostly duplicated from expand_powi in the backend.
541 We establish the "optimal power tree" lookup table with the defined size.
542 The items in the table are the exponents used to calculate the index
543 exponents. Any integer n less than the value can get an "addition chain",
544 with the first node being one. */
545 #define POWI_TABLE_SIZE 256
547 /* The table is from builtins.c. */
548 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
550 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
551 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
552 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
553 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
554 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
555 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
556 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
557 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
558 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
559 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
560 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
561 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
562 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
563 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
564 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
565 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
566 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
567 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
568 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
569 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
570 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
571 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
572 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
573 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
574 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
575 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
576 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
577 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
578 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
579 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
580 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
581 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
584 /* If n is larger than lookup table's max index, we use the "window
586 #define POWI_WINDOW_SIZE 3
588 /* Recursive function to expand the power operator. The temporary
589 values are put in tmpvar. The function returns tmpvar[1] ** n. */
591 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
598 if (n
< POWI_TABLE_SIZE
)
603 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
604 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
608 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
609 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
610 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
614 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
618 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
619 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
621 if (n
< POWI_TABLE_SIZE
)
628 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
629 return 1. Else return 0 and a call to runtime library functions
630 will have to be built. */
632 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
637 tree vartmp
[POWI_TABLE_SIZE
];
641 type
= TREE_TYPE (lhs
);
642 n
= abs (TREE_INT_CST_LOW (rhs
));
643 sgn
= tree_int_cst_sgn (rhs
);
645 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
646 && (n
> 2 || n
< -1))
652 se
->expr
= gfc_build_const (type
, integer_one_node
);
655 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
656 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
658 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
659 build_int_cst (TREE_TYPE (lhs
), -1));
660 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
661 build_int_cst (TREE_TYPE (lhs
), 1));
664 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
667 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
668 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
669 build_int_cst (type
, 0));
673 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
674 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
675 build_int_cst (type
, 0));
676 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
680 memset (vartmp
, 0, sizeof (vartmp
));
684 tmp
= gfc_build_const (type
, integer_one_node
);
685 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
688 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
694 /* Power op (**). Constant integer exponent has special handling. */
697 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
699 tree gfc_int4_type_node
;
707 gfc_init_se (&lse
, se
);
708 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
709 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
710 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
712 gfc_init_se (&rse
, se
);
713 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
714 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
716 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
717 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
718 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
721 gfc_int4_type_node
= gfc_get_int_type (4);
723 kind
= expr
->value
.op
.op1
->ts
.kind
;
724 switch (expr
->value
.op
.op2
->ts
.type
)
727 ikind
= expr
->value
.op
.op2
->ts
.kind
;
732 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
754 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
755 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
780 switch (expr
->value
.op
.op1
->ts
.type
)
783 if (kind
== 3) /* Case 16 was not handled properly above. */
785 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
789 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
793 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
805 fndecl
= built_in_decls
[BUILT_IN_POWF
];
808 fndecl
= built_in_decls
[BUILT_IN_POW
];
812 fndecl
= built_in_decls
[BUILT_IN_POWL
];
823 fndecl
= gfor_fndecl_math_cpowf
;
826 fndecl
= gfor_fndecl_math_cpow
;
829 fndecl
= gfor_fndecl_math_cpowl10
;
832 fndecl
= gfor_fndecl_math_cpowl16
;
844 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
845 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
846 se
->expr
= build_function_call_expr (fndecl
, tmp
);
850 /* Generate code to allocate a string temporary. */
853 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
859 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
861 if (gfc_can_put_var_on_stack (len
))
863 /* Create a temporary variable to hold the result. */
864 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
865 build_int_cst (gfc_charlen_type_node
, 1));
866 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
867 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
868 var
= gfc_create_var (tmp
, "str");
869 var
= gfc_build_addr_expr (type
, var
);
873 /* Allocate a temporary to hold the result. */
874 var
= gfc_create_var (type
, "pstr");
875 args
= gfc_chainon_list (NULL_TREE
, len
);
876 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, args
);
877 tmp
= convert (type
, tmp
);
878 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
880 /* Free the temporary afterwards. */
881 tmp
= convert (pvoid_type_node
, var
);
882 args
= gfc_chainon_list (NULL_TREE
, tmp
);
883 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
884 gfc_add_expr_to_block (&se
->post
, tmp
);
891 /* Handle a string concatenation operation. A temporary will be allocated to
895 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
905 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
906 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
908 gfc_init_se (&lse
, se
);
909 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
910 gfc_conv_string_parameter (&lse
);
911 gfc_init_se (&rse
, se
);
912 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
913 gfc_conv_string_parameter (&rse
);
915 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
916 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
918 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
919 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
920 if (len
== NULL_TREE
)
922 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
923 lse
.string_length
, rse
.string_length
);
926 type
= build_pointer_type (type
);
928 var
= gfc_conv_string_tmp (se
, type
, len
);
930 /* Do the actual concatenation. */
932 args
= gfc_chainon_list (args
, len
);
933 args
= gfc_chainon_list (args
, var
);
934 args
= gfc_chainon_list (args
, lse
.string_length
);
935 args
= gfc_chainon_list (args
, lse
.expr
);
936 args
= gfc_chainon_list (args
, rse
.string_length
);
937 args
= gfc_chainon_list (args
, rse
.expr
);
938 tmp
= build_function_call_expr (gfor_fndecl_concat_string
, args
);
939 gfc_add_expr_to_block (&se
->pre
, tmp
);
941 /* Add the cleanup for the operands. */
942 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
943 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
946 se
->string_length
= len
;
949 /* Translates an op expression. Common (binary) cases are handled by this
950 function, others are passed on. Recursion is used in either case.
951 We use the fact that (op1.ts == op2.ts) (except for the power
953 Operators need no special handling for scalarized expressions as long as
954 they call gfc_conv_simple_val to get their operands.
955 Character strings get special handling. */
958 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
970 switch (expr
->value
.op
.operator)
972 case INTRINSIC_UPLUS
:
973 case INTRINSIC_PARENTHESES
:
974 gfc_conv_expr (se
, expr
->value
.op
.op1
);
977 case INTRINSIC_UMINUS
:
978 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
982 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
989 case INTRINSIC_MINUS
:
993 case INTRINSIC_TIMES
:
997 case INTRINSIC_DIVIDE
:
998 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
999 an integer, we must round towards zero, so we use a
1001 if (expr
->ts
.type
== BT_INTEGER
)
1002 code
= TRUNC_DIV_EXPR
;
1007 case INTRINSIC_POWER
:
1008 gfc_conv_power_op (se
, expr
);
1011 case INTRINSIC_CONCAT
:
1012 gfc_conv_concat_op (se
, expr
);
1016 code
= TRUTH_ANDIF_EXPR
;
1021 code
= TRUTH_ORIF_EXPR
;
1025 /* EQV and NEQV only work on logicals, but since we represent them
1026 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1035 case INTRINSIC_NEQV
:
1065 case INTRINSIC_USER
:
1066 case INTRINSIC_ASSIGN
:
1067 /* These should be converted into function calls by the frontend. */
1071 fatal_error ("Unknown intrinsic op");
1075 /* The only exception to this is **, which is handled separately anyway. */
1076 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1078 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1082 gfc_init_se (&lse
, se
);
1083 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1084 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1087 gfc_init_se (&rse
, se
);
1088 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1089 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1093 gfc_conv_string_parameter (&lse
);
1094 gfc_conv_string_parameter (&rse
);
1096 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1097 rse
.string_length
, rse
.expr
);
1098 rse
.expr
= integer_zero_node
;
1099 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1102 type
= gfc_typenode_for_spec (&expr
->ts
);
1106 /* The result of logical ops is always boolean_type_node. */
1107 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1108 se
->expr
= convert (type
, tmp
);
1111 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1113 /* Add the post blocks. */
1114 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1115 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1118 /* If a string's length is one, we convert it to a single character. */
1121 gfc_to_single_character (tree len
, tree str
)
1123 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1125 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1126 && TREE_INT_CST_HIGH (len
) == 0)
1128 str
= fold_convert (pchar_type_node
, str
);
1129 return build_fold_indirect_ref (str
);
1135 /* Compare two strings. If they are all single characters, the result is the
1136 subtraction of them. Otherwise, we build a library call. */
1139 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1146 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1147 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1149 type
= gfc_get_int_type (gfc_default_integer_kind
);
1151 sc1
= gfc_to_single_character (len1
, str1
);
1152 sc2
= gfc_to_single_character (len2
, str2
);
1154 /* Deal with single character specially. */
1155 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1157 sc1
= fold_convert (type
, sc1
);
1158 sc2
= fold_convert (type
, sc2
);
1159 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1164 tmp
= gfc_chainon_list (tmp
, len1
);
1165 tmp
= gfc_chainon_list (tmp
, str1
);
1166 tmp
= gfc_chainon_list (tmp
, len2
);
1167 tmp
= gfc_chainon_list (tmp
, str2
);
1169 /* Build a call for the comparison. */
1170 tmp
= build_function_call_expr (gfor_fndecl_compare_string
, tmp
);
1177 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1181 if (sym
->attr
.dummy
)
1183 tmp
= gfc_get_symbol_decl (sym
);
1184 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1185 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1189 if (!sym
->backend_decl
)
1190 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1192 tmp
= sym
->backend_decl
;
1193 if (sym
->attr
.cray_pointee
)
1194 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1195 gfc_get_symbol_decl (sym
->cp_pointer
));
1196 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1198 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1199 tmp
= build_fold_addr_expr (tmp
);
1206 /* Initialize MAPPING. */
1209 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1211 mapping
->syms
= NULL
;
1212 mapping
->charlens
= NULL
;
1216 /* Free all memory held by MAPPING (but not MAPPING itself). */
1219 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1221 gfc_interface_sym_mapping
*sym
;
1222 gfc_interface_sym_mapping
*nextsym
;
1224 gfc_charlen
*nextcl
;
1226 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1228 nextsym
= sym
->next
;
1229 gfc_free_symbol (sym
->new->n
.sym
);
1230 gfc_free (sym
->new);
1233 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1236 gfc_free_expr (cl
->length
);
1242 /* Return a copy of gfc_charlen CL. Add the returned structure to
1243 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1245 static gfc_charlen
*
1246 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1251 new = gfc_get_charlen ();
1252 new->next
= mapping
->charlens
;
1253 new->length
= gfc_copy_expr (cl
->length
);
1255 mapping
->charlens
= new;
1260 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1261 array variable that can be used as the actual argument for dummy
1262 argument SYM. Add any initialization code to BLOCK. PACKED is as
1263 for gfc_get_nodesc_array_type and DATA points to the first element
1264 in the passed array. */
1267 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1268 int packed
, tree data
)
1273 type
= gfc_typenode_for_spec (&sym
->ts
);
1274 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1276 var
= gfc_create_var (type
, "ifm");
1277 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1283 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1284 and offset of descriptorless array type TYPE given that it has the same
1285 size as DESC. Add any set-up code to BLOCK. */
1288 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1295 offset
= gfc_index_zero_node
;
1296 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1298 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1299 if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1301 dim
= gfc_rank_cst
[n
];
1302 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1303 gfc_conv_descriptor_ubound (desc
, dim
),
1304 gfc_conv_descriptor_lbound (desc
, dim
));
1305 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1306 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1308 tmp
= gfc_evaluate_now (tmp
, block
);
1309 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1311 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1312 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1313 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1314 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1316 offset
= gfc_evaluate_now (offset
, block
);
1317 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1321 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1322 in SE. The caller may still use se->expr and se->string_length after
1323 calling this function. */
1326 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1327 gfc_symbol
* sym
, gfc_se
* se
)
1329 gfc_interface_sym_mapping
*sm
;
1333 gfc_symbol
*new_sym
;
1335 gfc_symtree
*new_symtree
;
1337 /* Create a new symbol to represent the actual argument. */
1338 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1339 new_sym
->ts
= sym
->ts
;
1340 new_sym
->attr
.referenced
= 1;
1341 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1342 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1343 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1344 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1346 /* Create a fake symtree for it. */
1348 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1349 new_symtree
->n
.sym
= new_sym
;
1350 gcc_assert (new_symtree
== root
);
1352 /* Create a dummy->actual mapping. */
1353 sm
= gfc_getmem (sizeof (*sm
));
1354 sm
->next
= mapping
->syms
;
1356 sm
->new = new_symtree
;
1359 /* Stabilize the argument's value. */
1360 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1362 if (sym
->ts
.type
== BT_CHARACTER
)
1364 /* Create a copy of the dummy argument's length. */
1365 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1367 /* If the length is specified as "*", record the length that
1368 the caller is passing. We should use the callee's length
1369 in all other cases. */
1370 if (!new_sym
->ts
.cl
->length
)
1372 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1373 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1377 /* Use the passed value as-is if the argument is a function. */
1378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1381 /* If the argument is either a string or a pointer to a string,
1382 convert it to a boundless character type. */
1383 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1385 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1386 tmp
= build_pointer_type (tmp
);
1387 if (sym
->attr
.pointer
)
1388 tmp
= build_pointer_type (tmp
);
1390 value
= fold_convert (tmp
, se
->expr
);
1391 if (sym
->attr
.pointer
)
1392 value
= build_fold_indirect_ref (value
);
1395 /* If the argument is a scalar, a pointer to an array or an allocatable,
1397 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1398 value
= build_fold_indirect_ref (se
->expr
);
1400 /* For character(*), use the actual argument's descriptor. */
1401 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1402 value
= build_fold_indirect_ref (se
->expr
);
1404 /* If the argument is an array descriptor, use it to determine
1405 information about the actual argument's shape. */
1406 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1407 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1409 /* Get the actual argument's descriptor. */
1410 desc
= build_fold_indirect_ref (se
->expr
);
1412 /* Create the replacement variable. */
1413 tmp
= gfc_conv_descriptor_data_get (desc
);
1414 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1416 /* Use DESC to work out the upper bounds, strides and offset. */
1417 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1420 /* Otherwise we have a packed array. */
1421 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1423 new_sym
->backend_decl
= value
;
1427 /* Called once all dummy argument mappings have been added to MAPPING,
1428 but before the mapping is used to evaluate expressions. Pre-evaluate
1429 the length of each argument, adding any initialization code to PRE and
1430 any finalization code to POST. */
1433 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1434 stmtblock_t
* pre
, stmtblock_t
* post
)
1436 gfc_interface_sym_mapping
*sym
;
1440 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1441 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1442 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1444 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1445 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1446 gfc_init_se (&se
, NULL
);
1447 gfc_conv_expr (&se
, expr
);
1449 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1450 gfc_add_block_to_block (pre
, &se
.pre
);
1451 gfc_add_block_to_block (post
, &se
.post
);
1453 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1458 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1462 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1463 gfc_constructor
* c
)
1465 for (; c
; c
= c
->next
)
1467 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1470 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1471 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1472 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1478 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1482 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1487 for (; ref
; ref
= ref
->next
)
1491 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1493 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1494 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1495 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1497 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1504 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1505 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1511 /* EXPR is a copy of an expression that appeared in the interface
1512 associated with MAPPING. Walk it recursively looking for references to
1513 dummy arguments that MAPPING maps to actual arguments. Replace each such
1514 reference with a reference to the associated actual argument. */
1517 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1520 gfc_interface_sym_mapping
*sym
;
1521 gfc_actual_arglist
*actual
;
1526 /* Copying an expression does not copy its length, so do that here. */
1527 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1529 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1530 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1533 /* Apply the mapping to any references. */
1534 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1536 /* ...and to the expression's symbol, if it has one. */
1538 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1539 if (sym
->old
== expr
->symtree
->n
.sym
)
1540 expr
->symtree
= sym
->new;
1542 /* ...and to subexpressions in expr->value. */
1543 switch (expr
->expr_type
)
1548 case EXPR_SUBSTRING
:
1552 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1553 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1557 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1558 if (sym
->old
== expr
->value
.function
.esym
)
1559 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1561 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1562 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1566 case EXPR_STRUCTURE
:
1567 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1573 /* Evaluate interface expression EXPR using MAPPING. Store the result
1577 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1578 gfc_se
* se
, gfc_expr
* expr
)
1580 expr
= gfc_copy_expr (expr
);
1581 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1582 gfc_conv_expr (se
, expr
);
1583 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1584 gfc_free_expr (expr
);
1587 /* Returns a reference to a temporary array into which a component of
1588 an actual argument derived type array is copied and then returned
1589 after the function call.
1590 TODO Get rid of this kludge, when array descriptors are capable of
1591 handling aliased arrays. */
1594 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
)
1610 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1612 gfc_init_se (&lse
, NULL
);
1613 gfc_init_se (&rse
, NULL
);
1615 /* Walk the argument expression. */
1616 rss
= gfc_walk_expr (expr
);
1618 gcc_assert (rss
!= gfc_ss_terminator
);
1620 /* Initialize the scalarizer. */
1621 gfc_init_loopinfo (&loop
);
1622 gfc_add_ss_to_loop (&loop
, rss
);
1624 /* Calculate the bounds of the scalarization. */
1625 gfc_conv_ss_startstride (&loop
);
1627 /* Build an ss for the temporary. */
1628 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1629 if (GFC_ARRAY_TYPE_P (base_type
)
1630 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1631 base_type
= gfc_get_element_type (base_type
);
1633 loop
.temp_ss
= gfc_get_ss ();;
1634 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1635 loop
.temp_ss
->data
.temp
.type
= base_type
;
1637 if (expr
->ts
.type
== BT_CHARACTER
)
1638 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1640 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1641 loop
.temp_ss
->next
= gfc_ss_terminator
;
1643 /* Associate the SS with the loop. */
1644 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1646 /* Setup the scalarizing loops. */
1647 gfc_conv_loop_setup (&loop
);
1649 /* Pass the temporary descriptor back to the caller. */
1650 info
= &loop
.temp_ss
->data
.info
;
1651 parmse
->expr
= info
->descriptor
;
1653 /* Setup the gfc_se structures. */
1654 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1655 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1658 lse
.ss
= loop
.temp_ss
;
1659 gfc_mark_ss_chain_used (rss
, 1);
1660 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1662 /* Start the scalarized loop body. */
1663 gfc_start_scalarized_body (&loop
, &body
);
1665 /* Translate the expression. */
1666 gfc_conv_expr (&rse
, expr
);
1668 gfc_conv_tmp_array_ref (&lse
);
1669 gfc_advance_se_ss_chain (&lse
);
1671 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1672 gfc_add_expr_to_block (&body
, tmp
);
1674 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1676 gfc_trans_scalarizing_loops (&loop
, &body
);
1678 /* Add the post block after the second loop, so that any
1679 freeing of allocated memory is done at the right time. */
1680 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1682 /**********Copy the temporary back again.*********/
1684 gfc_init_se (&lse
, NULL
);
1685 gfc_init_se (&rse
, NULL
);
1687 /* Walk the argument expression. */
1688 lss
= gfc_walk_expr (expr
);
1689 rse
.ss
= loop
.temp_ss
;
1692 /* Initialize the scalarizer. */
1693 gfc_init_loopinfo (&loop2
);
1694 gfc_add_ss_to_loop (&loop2
, lss
);
1696 /* Calculate the bounds of the scalarization. */
1697 gfc_conv_ss_startstride (&loop2
);
1699 /* Setup the scalarizing loops. */
1700 gfc_conv_loop_setup (&loop2
);
1702 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1703 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1705 gfc_mark_ss_chain_used (lss
, 1);
1706 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1708 /* Declare the variable to hold the temporary offset and start the
1709 scalarized loop body. */
1710 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1711 gfc_start_scalarized_body (&loop2
, &body
);
1713 /* Build the offsets for the temporary from the loop variables. The
1714 temporary array has lbounds of zero and strides of one in all
1715 dimensions, so this is very simple. The offset is only computed
1716 outside the innermost loop, so the overall transfer could be
1717 optimized further. */
1718 info
= &rse
.ss
->data
.info
;
1720 tmp_index
= gfc_index_zero_node
;
1721 for (n
= info
->dimen
- 1; n
> 0; n
--)
1724 tmp
= rse
.loop
->loopvar
[n
];
1725 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1726 tmp
, rse
.loop
->from
[n
]);
1727 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1730 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1731 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1732 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1733 tmp_str
, gfc_index_one_node
);
1735 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1739 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1740 tmp_index
, rse
.loop
->from
[0]);
1741 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1743 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1744 rse
.loop
->loopvar
[0], offset
);
1746 /* Now use the offset for the reference. */
1747 tmp
= build_fold_indirect_ref (info
->data
);
1748 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1750 if (expr
->ts
.type
== BT_CHARACTER
)
1751 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1753 gfc_conv_expr (&lse
, expr
);
1755 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1757 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1758 gfc_add_expr_to_block (&body
, tmp
);
1760 /* Generate the copying loops. */
1761 gfc_trans_scalarizing_loops (&loop2
, &body
);
1763 /* Wrap the whole thing up by adding the second loop to the post-block
1764 and following it by the post-block of the fist loop. In this way,
1765 if the temporary needs freeing, it is done after use! */
1766 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1767 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1769 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1771 gfc_cleanup_loop (&loop
);
1772 gfc_cleanup_loop (&loop2
);
1774 /* Pass the string length to the argument expression. */
1775 if (expr
->ts
.type
== BT_CHARACTER
)
1776 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1778 /* We want either the address for the data or the address of the descriptor,
1779 depending on the mode of passing array arguments. */
1781 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1783 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1788 /* Is true if the last array reference is followed by a component reference. */
1791 is_aliased_array (gfc_expr
* e
)
1797 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1799 if (ref
->type
== REF_ARRAY
)
1802 if (ref
->next
== NULL
&& ref
->type
== REF_COMPONENT
)
1808 /* Generate code for a procedure call. Note can return se->post != NULL.
1809 If se->direct_byref is set then se->expr contains the return parameter.
1810 Return nonzero, if the call has alternate specifiers. */
1813 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1814 gfc_actual_arglist
* arg
)
1816 gfc_interface_mapping mapping
;
1829 gfc_formal_arglist
*formal
;
1830 int has_alternate_specifier
= 0;
1831 bool need_interface_mapping
;
1839 arglist
= NULL_TREE
;
1840 retargs
= NULL_TREE
;
1841 stringargs
= NULL_TREE
;
1847 if (!sym
->attr
.elemental
)
1849 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1850 if (se
->ss
->useflags
)
1852 gcc_assert (gfc_return_by_reference (sym
)
1853 && sym
->result
->attr
.dimension
);
1854 gcc_assert (se
->loop
!= NULL
);
1856 /* Access the previously obtained result. */
1857 gfc_conv_tmp_array_ref (se
);
1858 gfc_advance_se_ss_chain (se
);
1862 info
= &se
->ss
->data
.info
;
1867 gfc_init_block (&post
);
1868 gfc_init_interface_mapping (&mapping
);
1869 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
1870 && sym
->ts
.cl
->length
1871 && sym
->ts
.cl
->length
->expr_type
1873 || sym
->attr
.dimension
);
1874 formal
= sym
->formal
;
1875 /* Evaluate the arguments. */
1876 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1879 fsym
= formal
? formal
->sym
: NULL
;
1883 if (se
->ignore_optional
)
1885 /* Some intrinsics have already been resolved to the correct
1889 else if (arg
->label
)
1891 has_alternate_specifier
= 1;
1896 /* Pass a NULL pointer for an absent arg. */
1897 gfc_init_se (&parmse
, NULL
);
1898 parmse
.expr
= null_pointer_node
;
1899 if (arg
->missing_arg_type
== BT_CHARACTER
)
1900 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
1903 else if (se
->ss
&& se
->ss
->useflags
)
1905 /* An elemental function inside a scalarized loop. */
1906 gfc_init_se (&parmse
, se
);
1907 gfc_conv_expr_reference (&parmse
, e
);
1911 /* A scalar or transformational function. */
1912 gfc_init_se (&parmse
, NULL
);
1913 argss
= gfc_walk_expr (e
);
1915 if (argss
== gfc_ss_terminator
)
1917 gfc_conv_expr_reference (&parmse
, e
);
1918 if (fsym
&& fsym
->attr
.pointer
1919 && e
->expr_type
!= EXPR_NULL
)
1921 /* Scalar pointer dummy args require an extra level of
1922 indirection. The null pointer already contains
1923 this level of indirection. */
1924 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
1929 /* If the procedure requires an explicit interface, the actual
1930 argument is passed according to the corresponding formal
1931 argument. If the corresponding formal argument is a POINTER,
1932 ALLOCATABLE or assumed shape, we do not use g77's calling
1933 convention, and pass the address of the array descriptor
1934 instead. Otherwise we use g77's calling convention. */
1937 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
1938 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
1939 f
= f
|| !sym
->attr
.always_explicit
;
1940 if (e
->expr_type
== EXPR_VARIABLE
1941 && is_aliased_array (e
))
1942 /* The actual argument is a component reference to an
1943 array of derived types. In this case, the argument
1944 is converted to a temporary, which is passed and then
1945 written back after the procedure call. */
1946 gfc_conv_aliased_arg (&parmse
, e
, f
);
1948 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
1950 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
1951 allocated on entry, it must be deallocated. */
1952 if (fsym
&& fsym
->attr
.allocatable
1953 && fsym
->attr
.intent
== INTENT_OUT
)
1955 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1956 if (e
->symtree
->n
.sym
->attr
.dummy
)
1957 tmp
= build_fold_indirect_ref (tmp
);
1958 tmp
= gfc_trans_dealloc_allocated (tmp
);
1959 gfc_add_expr_to_block (&se
->pre
, tmp
);
1965 /* If an optional argument is itself an optional dummy argument,
1966 check its presence and substitute a null if absent. */
1967 if (e
&& e
->expr_type
== EXPR_VARIABLE
1968 && e
->symtree
->n
.sym
->attr
.optional
1969 && fsym
&& fsym
->attr
.optional
)
1970 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
1972 if (fsym
&& need_interface_mapping
)
1973 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
1975 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
1976 gfc_add_block_to_block (&post
, &parmse
.post
);
1978 /* Character strings are passed as two parameters, a length and a
1980 if (parmse
.string_length
!= NULL_TREE
)
1981 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
1983 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
1985 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
1988 if (ts
.type
== BT_CHARACTER
)
1990 if (sym
->ts
.cl
->length
== NULL
)
1992 /* Assumed character length results are not allowed by 5.1.1.5 of the
1993 standard and are trapped in resolve.c; except in the case of SPREAD
1994 (and other intrinsics?). In this case, we take the character length
1995 of the first argument for the result. */
1996 cl
.backend_decl
= TREE_VALUE (stringargs
);
2000 /* Calculate the length of the returned string. */
2001 gfc_init_se (&parmse
, NULL
);
2002 if (need_interface_mapping
)
2003 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2005 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2006 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2007 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2008 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2011 /* Set up a charlen structure for it. */
2016 len
= cl
.backend_decl
;
2019 byref
= gfc_return_by_reference (sym
);
2022 if (se
->direct_byref
)
2023 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2024 else if (sym
->result
->attr
.dimension
)
2026 gcc_assert (se
->loop
&& info
);
2028 /* Set the type of the array. */
2029 tmp
= gfc_typenode_for_spec (&ts
);
2030 info
->dimen
= se
->loop
->dimen
;
2032 /* Evaluate the bounds of the result, if known. */
2033 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2035 /* Create a temporary to store the result. In case the function
2036 returns a pointer, the temporary will be a shallow copy and
2037 mustn't be deallocated. */
2038 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2039 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2040 false, !sym
->attr
.pointer
, callee_alloc
,
2043 /* Pass the temporary as the first argument. */
2044 tmp
= info
->descriptor
;
2045 tmp
= build_fold_addr_expr (tmp
);
2046 retargs
= gfc_chainon_list (retargs
, tmp
);
2048 else if (ts
.type
== BT_CHARACTER
)
2050 /* Pass the string length. */
2051 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2052 type
= build_pointer_type (type
);
2054 /* Return an address to a char[0:len-1]* temporary for
2055 character pointers. */
2056 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2058 /* Build char[0:len-1] * pstr. */
2059 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2060 build_int_cst (gfc_charlen_type_node
, 1));
2061 tmp
= build_range_type (gfc_array_index_type
,
2062 gfc_index_zero_node
, tmp
);
2063 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2064 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2066 /* Provide an address expression for the function arguments. */
2067 var
= build_fold_addr_expr (var
);
2070 var
= gfc_conv_string_tmp (se
, type
, len
);
2072 retargs
= gfc_chainon_list (retargs
, var
);
2076 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2078 type
= gfc_get_complex_type (ts
.kind
);
2079 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2080 retargs
= gfc_chainon_list (retargs
, var
);
2083 /* Add the string length to the argument list. */
2084 if (ts
.type
== BT_CHARACTER
)
2085 retargs
= gfc_chainon_list (retargs
, len
);
2087 gfc_free_interface_mapping (&mapping
);
2089 /* Add the return arguments. */
2090 arglist
= chainon (retargs
, arglist
);
2092 /* Add the hidden string length parameters to the arguments. */
2093 arglist
= chainon (arglist
, stringargs
);
2095 /* Generate the actual call. */
2096 gfc_conv_function_val (se
, sym
);
2097 /* If there are alternate return labels, function type should be
2098 integer. Can't modify the type in place though, since it can be shared
2099 with other functions. */
2100 if (has_alternate_specifier
2101 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2103 gcc_assert (! sym
->attr
.dummy
);
2104 TREE_TYPE (sym
->backend_decl
)
2105 = build_function_type (integer_type_node
,
2106 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2107 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2110 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2111 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2112 arglist
, NULL_TREE
);
2114 /* If we have a pointer function, but we don't want a pointer, e.g.
2117 where f is pointer valued, we have to dereference the result. */
2118 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2119 se
->expr
= build_fold_indirect_ref (se
->expr
);
2121 /* f2c calling conventions require a scalar default real function to
2122 return a double precision result. Convert this back to default
2123 real. We only care about the cases that can happen in Fortran 77.
2125 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2126 && sym
->ts
.kind
== gfc_default_real_kind
2127 && !sym
->attr
.always_explicit
)
2128 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2130 /* A pure function may still have side-effects - it may modify its
2132 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2134 if (!sym
->attr
.pure
)
2135 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2140 /* Add the function call to the pre chain. There is no expression. */
2141 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2142 se
->expr
= NULL_TREE
;
2144 if (!se
->direct_byref
)
2146 if (sym
->attr
.dimension
)
2148 if (flag_bounds_check
)
2150 /* Check the data pointer hasn't been modified. This would
2151 happen in a function returning a pointer. */
2152 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2153 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2155 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2157 se
->expr
= info
->descriptor
;
2158 /* Bundle in the string length. */
2159 se
->string_length
= len
;
2161 else if (sym
->ts
.type
== BT_CHARACTER
)
2163 /* Dereference for character pointer results. */
2164 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2165 se
->expr
= build_fold_indirect_ref (var
);
2169 se
->string_length
= len
;
2173 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2174 se
->expr
= build_fold_indirect_ref (var
);
2179 /* Follow the function call with the argument post block. */
2181 gfc_add_block_to_block (&se
->pre
, &post
);
2183 gfc_add_block_to_block (&se
->post
, &post
);
2185 return has_alternate_specifier
;
2189 /* Generate code to copy a string. */
2192 gfc_trans_string_copy (stmtblock_t
* block
, tree dlen
, tree dest
,
2193 tree slen
, tree src
)
2200 /* Deal with single character specially. */
2201 dsc
= gfc_to_single_character (dlen
, dest
);
2202 ssc
= gfc_to_single_character (slen
, src
);
2203 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2205 gfc_add_modify_expr (block
, dsc
, ssc
);
2209 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2210 build_int_cst (gfc_charlen_type_node
, 0));
2213 tmp
= gfc_chainon_list (tmp
, dlen
);
2214 tmp
= gfc_chainon_list (tmp
, dest
);
2215 tmp
= gfc_chainon_list (tmp
, slen
);
2216 tmp
= gfc_chainon_list (tmp
, src
);
2217 tmp
= build_function_call_expr (gfor_fndecl_copy_string
, tmp
);
2218 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2219 gfc_add_expr_to_block (block
, tmp
);
2223 /* Translate a statement function.
2224 The value of a statement function reference is obtained by evaluating the
2225 expression using the values of the actual arguments for the values of the
2226 corresponding dummy arguments. */
2229 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2233 gfc_formal_arglist
*fargs
;
2234 gfc_actual_arglist
*args
;
2237 gfc_saved_var
*saved_vars
;
2243 sym
= expr
->symtree
->n
.sym
;
2244 args
= expr
->value
.function
.actual
;
2245 gfc_init_se (&lse
, NULL
);
2246 gfc_init_se (&rse
, NULL
);
2249 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2251 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2252 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2254 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2256 /* Each dummy shall be specified, explicitly or implicitly, to be
2258 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2261 /* Create a temporary to hold the value. */
2262 type
= gfc_typenode_for_spec (&fsym
->ts
);
2263 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2265 if (fsym
->ts
.type
== BT_CHARACTER
)
2267 /* Copy string arguments. */
2270 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2271 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2273 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2274 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2277 gfc_conv_expr (&rse
, args
->expr
);
2278 gfc_conv_string_parameter (&rse
);
2279 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2280 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2282 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2284 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2285 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2289 /* For everything else, just evaluate the expression. */
2290 gfc_conv_expr (&lse
, args
->expr
);
2292 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2293 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2294 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2300 /* Use the temporary variables in place of the real ones. */
2301 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2302 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2304 gfc_conv_expr (se
, sym
->value
);
2306 if (sym
->ts
.type
== BT_CHARACTER
)
2308 gfc_conv_const_charlen (sym
->ts
.cl
);
2310 /* Force the expression to the correct length. */
2311 if (!INTEGER_CST_P (se
->string_length
)
2312 || tree_int_cst_lt (se
->string_length
,
2313 sym
->ts
.cl
->backend_decl
))
2315 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2316 tmp
= gfc_create_var (type
, sym
->name
);
2317 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2318 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2319 se
->string_length
, se
->expr
);
2322 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2325 /* Restore the original variables. */
2326 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2327 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2328 gfc_free (saved_vars
);
2332 /* Translate a function expression. */
2335 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2339 if (expr
->value
.function
.isym
)
2341 gfc_conv_intrinsic_function (se
, expr
);
2345 /* We distinguish statement functions from general functions to improve
2346 runtime performance. */
2347 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2349 gfc_conv_statement_function (se
, expr
);
2353 /* expr.value.function.esym is the resolved (specific) function symbol for
2354 most functions. However this isn't set for dummy procedures. */
2355 sym
= expr
->value
.function
.esym
;
2357 sym
= expr
->symtree
->n
.sym
;
2358 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
2363 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2365 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2366 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2368 gfc_conv_tmp_array_ref (se
);
2369 gfc_advance_se_ss_chain (se
);
2373 /* Build a static initializer. EXPR is the expression for the initial value.
2374 The other parameters describe the variable of the component being
2375 initialized. EXPR may be null. */
2378 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2379 bool array
, bool pointer
)
2383 if (!(expr
|| pointer
))
2388 /* Arrays need special handling. */
2390 return gfc_build_null_descriptor (type
);
2392 return gfc_conv_array_initializer (type
, expr
);
2395 return fold_convert (type
, null_pointer_node
);
2401 gfc_init_se (&se
, NULL
);
2402 gfc_conv_structure (&se
, expr
, 1);
2406 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2409 gfc_init_se (&se
, NULL
);
2410 gfc_conv_constant (&se
, expr
);
2417 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2429 gfc_start_block (&block
);
2431 /* Initialize the scalarizer. */
2432 gfc_init_loopinfo (&loop
);
2434 gfc_init_se (&lse
, NULL
);
2435 gfc_init_se (&rse
, NULL
);
2438 rss
= gfc_walk_expr (expr
);
2439 if (rss
== gfc_ss_terminator
)
2441 /* The rhs is scalar. Add a ss for the expression. */
2442 rss
= gfc_get_ss ();
2443 rss
->next
= gfc_ss_terminator
;
2444 rss
->type
= GFC_SS_SCALAR
;
2448 /* Create a SS for the destination. */
2449 lss
= gfc_get_ss ();
2450 lss
->type
= GFC_SS_COMPONENT
;
2452 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2453 lss
->next
= gfc_ss_terminator
;
2454 lss
->data
.info
.dimen
= cm
->as
->rank
;
2455 lss
->data
.info
.descriptor
= dest
;
2456 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2457 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2458 for (n
= 0; n
< cm
->as
->rank
; n
++)
2460 lss
->data
.info
.dim
[n
] = n
;
2461 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2462 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2464 mpz_init (lss
->shape
[n
]);
2465 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2466 cm
->as
->lower
[n
]->value
.integer
);
2467 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2470 /* Associate the SS with the loop. */
2471 gfc_add_ss_to_loop (&loop
, lss
);
2472 gfc_add_ss_to_loop (&loop
, rss
);
2474 /* Calculate the bounds of the scalarization. */
2475 gfc_conv_ss_startstride (&loop
);
2477 /* Setup the scalarizing loops. */
2478 gfc_conv_loop_setup (&loop
);
2480 /* Setup the gfc_se structures. */
2481 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2482 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2485 gfc_mark_ss_chain_used (rss
, 1);
2487 gfc_mark_ss_chain_used (lss
, 1);
2489 /* Start the scalarized loop body. */
2490 gfc_start_scalarized_body (&loop
, &body
);
2492 gfc_conv_tmp_array_ref (&lse
);
2493 if (cm
->ts
.type
== BT_CHARACTER
)
2494 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2496 gfc_conv_expr (&rse
, expr
);
2498 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
.type
);
2499 gfc_add_expr_to_block (&body
, tmp
);
2501 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2503 /* Generate the copying loops. */
2504 gfc_trans_scalarizing_loops (&loop
, &body
);
2506 /* Wrap the whole thing up. */
2507 gfc_add_block_to_block (&block
, &loop
.pre
);
2508 gfc_add_block_to_block (&block
, &loop
.post
);
2510 for (n
= 0; n
< cm
->as
->rank
; n
++)
2511 mpz_clear (lss
->shape
[n
]);
2512 gfc_free (lss
->shape
);
2514 gfc_cleanup_loop (&loop
);
2516 return gfc_finish_block (&block
);
2519 /* Assign a single component of a derived type constructor. */
2522 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2529 gfc_start_block (&block
);
2532 gfc_init_se (&se
, NULL
);
2533 /* Pointer component. */
2536 /* Array pointer. */
2537 if (expr
->expr_type
== EXPR_NULL
)
2538 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2541 rss
= gfc_walk_expr (expr
);
2542 se
.direct_byref
= 1;
2544 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2545 gfc_add_block_to_block (&block
, &se
.pre
);
2546 gfc_add_block_to_block (&block
, &se
.post
);
2551 /* Scalar pointers. */
2552 se
.want_pointer
= 1;
2553 gfc_conv_expr (&se
, expr
);
2554 gfc_add_block_to_block (&block
, &se
.pre
);
2555 gfc_add_modify_expr (&block
, dest
,
2556 fold_convert (TREE_TYPE (dest
), se
.expr
));
2557 gfc_add_block_to_block (&block
, &se
.post
);
2560 else if (cm
->dimension
)
2562 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2563 gfc_add_expr_to_block (&block
, tmp
);
2565 else if (expr
->ts
.type
== BT_DERIVED
)
2567 /* Nested derived type. */
2568 tmp
= gfc_trans_structure_assign (dest
, expr
);
2569 gfc_add_expr_to_block (&block
, tmp
);
2573 /* Scalar component. */
2576 gfc_init_se (&se
, NULL
);
2577 gfc_init_se (&lse
, NULL
);
2579 gfc_conv_expr (&se
, expr
);
2580 if (cm
->ts
.type
== BT_CHARACTER
)
2581 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2583 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
.type
);
2584 gfc_add_expr_to_block (&block
, tmp
);
2586 return gfc_finish_block (&block
);
2589 /* Assign a derived type constructor to a variable. */
2592 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2600 gfc_start_block (&block
);
2601 cm
= expr
->ts
.derived
->components
;
2602 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2604 /* Skip absent members in default initializers. */
2608 field
= cm
->backend_decl
;
2609 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
2610 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
2611 gfc_add_expr_to_block (&block
, tmp
);
2613 return gfc_finish_block (&block
);
2616 /* Build an expression for a constructor. If init is nonzero then
2617 this is part of a static variable initializer. */
2620 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
2627 VEC(constructor_elt
,gc
) *v
= NULL
;
2629 gcc_assert (se
->ss
== NULL
);
2630 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
2631 type
= gfc_typenode_for_spec (&expr
->ts
);
2635 /* Create a temporary variable and fill it in. */
2636 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
2637 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
2638 gfc_add_expr_to_block (&se
->pre
, tmp
);
2642 cm
= expr
->ts
.derived
->components
;
2643 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2645 /* Skip absent members in default initializers. */
2649 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
2650 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
2652 /* Append it to the constructor list. */
2653 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
2655 se
->expr
= build_constructor (type
, v
);
2659 /* Translate a substring expression. */
2662 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
2668 gcc_assert (ref
->type
== REF_SUBSTRING
);
2670 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
2671 expr
->value
.character
.string
);
2672 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
2673 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
2675 gfc_conv_substring(se
,ref
,expr
->ts
.kind
);
2679 /* Entry point for expression translation. Evaluates a scalar quantity.
2680 EXPR is the expression to be translated, and SE is the state structure if
2681 called from within the scalarized. */
2684 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
2686 if (se
->ss
&& se
->ss
->expr
== expr
2687 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
2689 /* Substitute a scalar expression evaluated outside the scalarization
2691 se
->expr
= se
->ss
->data
.scalar
.expr
;
2692 se
->string_length
= se
->ss
->string_length
;
2693 gfc_advance_se_ss_chain (se
);
2697 switch (expr
->expr_type
)
2700 gfc_conv_expr_op (se
, expr
);
2704 gfc_conv_function_expr (se
, expr
);
2708 gfc_conv_constant (se
, expr
);
2712 gfc_conv_variable (se
, expr
);
2716 se
->expr
= null_pointer_node
;
2719 case EXPR_SUBSTRING
:
2720 gfc_conv_substring_expr (se
, expr
);
2723 case EXPR_STRUCTURE
:
2724 gfc_conv_structure (se
, expr
, 0);
2728 gfc_conv_array_constructor_expr (se
, expr
);
2737 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2738 of an assignment. */
2740 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
2742 gfc_conv_expr (se
, expr
);
2743 /* All numeric lvalues should have empty post chains. If not we need to
2744 figure out a way of rewriting an lvalue so that it has no post chain. */
2745 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
2748 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2749 numeric expressions. Used for scalar values where inserting cleanup code
2752 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
2756 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2757 gfc_conv_expr (se
, expr
);
2760 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2761 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
2763 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2767 /* Helper to translate and expression and convert it to a particular type. */
2769 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
2771 gfc_conv_expr_val (se
, expr
);
2772 se
->expr
= convert (type
, se
->expr
);
2776 /* Converts an expression so that it can be passed by reference. Scalar
2780 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
2784 if (se
->ss
&& se
->ss
->expr
== expr
2785 && se
->ss
->type
== GFC_SS_REFERENCE
)
2787 se
->expr
= se
->ss
->data
.scalar
.expr
;
2788 se
->string_length
= se
->ss
->string_length
;
2789 gfc_advance_se_ss_chain (se
);
2793 if (expr
->ts
.type
== BT_CHARACTER
)
2795 gfc_conv_expr (se
, expr
);
2796 gfc_conv_string_parameter (se
);
2800 if (expr
->expr_type
== EXPR_VARIABLE
)
2802 se
->want_pointer
= 1;
2803 gfc_conv_expr (se
, expr
);
2806 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2807 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
2808 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2814 gfc_conv_expr (se
, expr
);
2816 /* Create a temporary var to hold the value. */
2817 if (TREE_CONSTANT (se
->expr
))
2819 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (se
->expr
));
2820 DECL_INITIAL (var
) = se
->expr
;
2825 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2826 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
2828 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2830 /* Take the address of that value. */
2831 se
->expr
= build_fold_addr_expr (var
);
2836 gfc_trans_pointer_assign (gfc_code
* code
)
2838 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
2842 /* Generate code for a pointer assignment. */
2845 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
2855 gfc_start_block (&block
);
2857 gfc_init_se (&lse
, NULL
);
2859 lss
= gfc_walk_expr (expr1
);
2860 rss
= gfc_walk_expr (expr2
);
2861 if (lss
== gfc_ss_terminator
)
2863 /* Scalar pointers. */
2864 lse
.want_pointer
= 1;
2865 gfc_conv_expr (&lse
, expr1
);
2866 gcc_assert (rss
== gfc_ss_terminator
);
2867 gfc_init_se (&rse
, NULL
);
2868 rse
.want_pointer
= 1;
2869 gfc_conv_expr (&rse
, expr2
);
2870 gfc_add_block_to_block (&block
, &lse
.pre
);
2871 gfc_add_block_to_block (&block
, &rse
.pre
);
2872 gfc_add_modify_expr (&block
, lse
.expr
,
2873 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
2874 gfc_add_block_to_block (&block
, &rse
.post
);
2875 gfc_add_block_to_block (&block
, &lse
.post
);
2879 /* Array pointer. */
2880 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2881 switch (expr2
->expr_type
)
2884 /* Just set the data pointer to null. */
2885 gfc_conv_descriptor_data_set (&block
, lse
.expr
, null_pointer_node
);
2889 /* Assign directly to the pointer's descriptor. */
2890 lse
.direct_byref
= 1;
2891 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2895 /* Assign to a temporary descriptor and then copy that
2896 temporary to the pointer. */
2898 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
2901 lse
.direct_byref
= 1;
2902 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2903 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
2906 gfc_add_block_to_block (&block
, &lse
.pre
);
2907 gfc_add_block_to_block (&block
, &lse
.post
);
2909 return gfc_finish_block (&block
);
2913 /* Makes sure se is suitable for passing as a function string parameter. */
2914 /* TODO: Need to check all callers fo this function. It may be abused. */
2917 gfc_conv_string_parameter (gfc_se
* se
)
2921 if (TREE_CODE (se
->expr
) == STRING_CST
)
2923 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2927 type
= TREE_TYPE (se
->expr
);
2928 if (TYPE_STRING_FLAG (type
))
2930 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
2931 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2934 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
2935 gcc_assert (se
->string_length
2936 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
2940 /* Generate code for assignment of scalar variables. Includes character
2944 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, bt type
)
2948 gfc_init_block (&block
);
2950 if (type
== BT_CHARACTER
)
2952 gcc_assert (lse
->string_length
!= NULL_TREE
2953 && rse
->string_length
!= NULL_TREE
);
2955 gfc_conv_string_parameter (lse
);
2956 gfc_conv_string_parameter (rse
);
2958 gfc_add_block_to_block (&block
, &lse
->pre
);
2959 gfc_add_block_to_block (&block
, &rse
->pre
);
2961 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
2962 rse
->string_length
, rse
->expr
);
2966 gfc_add_block_to_block (&block
, &lse
->pre
);
2967 gfc_add_block_to_block (&block
, &rse
->pre
);
2969 gfc_add_modify_expr (&block
, lse
->expr
,
2970 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
2973 gfc_add_block_to_block (&block
, &lse
->post
);
2974 gfc_add_block_to_block (&block
, &rse
->post
);
2976 return gfc_finish_block (&block
);
2980 /* Try to translate array(:) = func (...), where func is a transformational
2981 array function, without using a temporary. Returns NULL is this isn't the
2985 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
2990 bool seen_array_ref
;
2992 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2993 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
2996 /* Elemental functions don't need a temporary anyway. */
2997 if (expr2
->value
.function
.esym
!= NULL
2998 && expr2
->value
.function
.esym
->attr
.elemental
)
3001 /* Fail if EXPR1 can't be expressed as a descriptor. */
3002 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3005 /* Functions returning pointers need temporaries. */
3006 if (expr2
->symtree
->n
.sym
->attr
.pointer
3007 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3010 /* Check that no LHS component references appear during an array
3011 reference. This is needed because we do not have the means to
3012 span any arbitrary stride with an array descriptor. This check
3013 is not needed for the rhs because the function result has to be
3015 seen_array_ref
= false;
3016 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3018 if (ref
->type
== REF_ARRAY
)
3019 seen_array_ref
= true;
3020 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3024 /* Check for a dependency. */
3025 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3026 expr2
->value
.function
.esym
,
3027 expr2
->value
.function
.actual
))
3030 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3032 gcc_assert (expr2
->value
.function
.isym
3033 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3034 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3036 ss
= gfc_walk_expr (expr1
);
3037 gcc_assert (ss
!= gfc_ss_terminator
);
3038 gfc_init_se (&se
, NULL
);
3039 gfc_start_block (&se
.pre
);
3040 se
.want_pointer
= 1;
3042 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3044 se
.direct_byref
= 1;
3045 se
.ss
= gfc_walk_expr (expr2
);
3046 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3047 gfc_conv_function_expr (&se
, expr2
);
3048 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3050 return gfc_finish_block (&se
.pre
);
3054 /* Translate an assignment. Most of the code is concerned with
3055 setting up the scalarizer. */
3058 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3063 gfc_ss
*lss_section
;
3070 /* Special case a single function returning an array. */
3071 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3073 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3078 /* Assignment of the form lhs = rhs. */
3079 gfc_start_block (&block
);
3081 gfc_init_se (&lse
, NULL
);
3082 gfc_init_se (&rse
, NULL
);
3085 lss
= gfc_walk_expr (expr1
);
3087 if (lss
!= gfc_ss_terminator
)
3089 /* The assignment needs scalarization. */
3092 /* Find a non-scalar SS from the lhs. */
3093 while (lss_section
!= gfc_ss_terminator
3094 && lss_section
->type
!= GFC_SS_SECTION
)
3095 lss_section
= lss_section
->next
;
3097 gcc_assert (lss_section
!= gfc_ss_terminator
);
3099 /* Initialize the scalarizer. */
3100 gfc_init_loopinfo (&loop
);
3103 rss
= gfc_walk_expr (expr2
);
3104 if (rss
== gfc_ss_terminator
)
3106 /* The rhs is scalar. Add a ss for the expression. */
3107 rss
= gfc_get_ss ();
3108 rss
->next
= gfc_ss_terminator
;
3109 rss
->type
= GFC_SS_SCALAR
;
3112 /* Associate the SS with the loop. */
3113 gfc_add_ss_to_loop (&loop
, lss
);
3114 gfc_add_ss_to_loop (&loop
, rss
);
3116 /* Calculate the bounds of the scalarization. */
3117 gfc_conv_ss_startstride (&loop
);
3118 /* Resolve any data dependencies in the statement. */
3119 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3120 /* Setup the scalarizing loops. */
3121 gfc_conv_loop_setup (&loop
);
3123 /* Setup the gfc_se structures. */
3124 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3125 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3128 gfc_mark_ss_chain_used (rss
, 1);
3129 if (loop
.temp_ss
== NULL
)
3132 gfc_mark_ss_chain_used (lss
, 1);
3136 lse
.ss
= loop
.temp_ss
;
3137 gfc_mark_ss_chain_used (lss
, 3);
3138 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3141 /* Start the scalarized loop body. */
3142 gfc_start_scalarized_body (&loop
, &body
);
3145 gfc_init_block (&body
);
3147 /* Translate the expression. */
3148 gfc_conv_expr (&rse
, expr2
);
3150 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
3152 gfc_conv_tmp_array_ref (&lse
);
3153 gfc_advance_se_ss_chain (&lse
);
3156 gfc_conv_expr (&lse
, expr1
);
3158 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
3159 gfc_add_expr_to_block (&body
, tmp
);
3161 if (lss
== gfc_ss_terminator
)
3163 /* Use the scalar assignment as is. */
3164 gfc_add_block_to_block (&block
, &body
);
3168 gcc_assert (lse
.ss
== gfc_ss_terminator
3169 && rse
.ss
== gfc_ss_terminator
);
3171 if (loop
.temp_ss
!= NULL
)
3173 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3175 /* We need to copy the temporary to the actual lhs. */
3176 gfc_init_se (&lse
, NULL
);
3177 gfc_init_se (&rse
, NULL
);
3178 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3179 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3181 rse
.ss
= loop
.temp_ss
;
3184 gfc_conv_tmp_array_ref (&rse
);
3185 gfc_advance_se_ss_chain (&rse
);
3186 gfc_conv_expr (&lse
, expr1
);
3188 gcc_assert (lse
.ss
== gfc_ss_terminator
3189 && rse
.ss
== gfc_ss_terminator
);
3191 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
3192 gfc_add_expr_to_block (&body
, tmp
);
3194 /* Generate the copying loops. */
3195 gfc_trans_scalarizing_loops (&loop
, &body
);
3197 /* Wrap the whole thing up. */
3198 gfc_add_block_to_block (&block
, &loop
.pre
);
3199 gfc_add_block_to_block (&block
, &loop
.post
);
3201 gfc_cleanup_loop (&loop
);
3204 return gfc_finish_block (&block
);
3208 gfc_trans_assign (gfc_code
* code
)
3210 return gfc_trans_assignment (code
->expr
, code
->expr2
);