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 convert (TREE_TYPE (se
->expr
), integer_zero_node
));
156 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
158 if (ts
.type
== BT_CHARACTER
)
160 tmp
= convert (gfc_charlen_type_node
, integer_zero_node
);
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 se
->string_length
= tmp
;
282 /* Convert a derived type component reference. */
285 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
292 c
= ref
->u
.c
.component
;
294 gcc_assert (c
->backend_decl
);
296 field
= c
->backend_decl
;
297 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
299 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
303 if (c
->ts
.type
== BT_CHARACTER
)
305 tmp
= c
->ts
.cl
->backend_decl
;
306 /* Components must always be constant length. */
307 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
308 se
->string_length
= tmp
;
311 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
312 se
->expr
= build_fold_indirect_ref (se
->expr
);
316 /* Return the contents of a variable. Also handles reference/pointer
317 variables (all Fortran pointer references are implicit). */
320 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
327 bool alternate_entry
;
330 sym
= expr
->symtree
->n
.sym
;
333 /* Check that something hasn't gone horribly wrong. */
334 gcc_assert (se
->ss
!= gfc_ss_terminator
);
335 gcc_assert (se
->ss
->expr
== expr
);
337 /* A scalarized term. We already know the descriptor. */
338 se
->expr
= se
->ss
->data
.info
.descriptor
;
339 se
->string_length
= se
->ss
->string_length
;
340 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
341 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
346 tree se_expr
= NULL_TREE
;
348 se
->expr
= gfc_get_symbol_decl (sym
);
350 /* Deal with references to a parent results or entries by storing
351 the current_function_decl and moving to the parent_decl. */
352 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
353 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
354 && sym
->result
== sym
;
355 entry_master
= sym
->attr
.result
356 && sym
->ns
->proc_name
->attr
.entry_master
357 && !gfc_return_by_reference (sym
->ns
->proc_name
);
358 parent_decl
= DECL_CONTEXT (current_function_decl
);
360 if ((se
->expr
== parent_decl
&& return_value
)
361 || (sym
->ns
&& sym
->ns
->proc_name
362 && sym
->ns
->proc_name
->backend_decl
== parent_decl
363 && (alternate_entry
|| entry_master
)))
368 /* Special case for assigning the return value of a function.
369 Self recursive functions must have an explicit return value. */
370 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
371 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
373 /* Similarly for alternate entry points. */
374 else if (alternate_entry
375 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
378 gfc_entry_list
*el
= NULL
;
380 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
383 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
388 else if (entry_master
389 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
391 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
396 /* Procedure actual arguments. */
397 else if (sym
->attr
.flavor
== FL_PROCEDURE
398 && se
->expr
!= current_function_decl
)
400 gcc_assert (se
->want_pointer
);
401 if (!sym
->attr
.dummy
)
403 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
404 se
->expr
= build_fold_addr_expr (se
->expr
);
410 /* Dereference the expression, where needed. Since characters
411 are entirely different from other types, they are treated
413 if (sym
->ts
.type
== BT_CHARACTER
)
415 /* Dereference character pointer dummy arguments
417 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
419 || sym
->attr
.function
420 || sym
->attr
.result
))
421 se
->expr
= build_fold_indirect_ref (se
->expr
);
425 /* Dereference non-character scalar dummy arguments. */
426 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
427 se
->expr
= build_fold_indirect_ref (se
->expr
);
429 /* Dereference scalar hidden result. */
430 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
431 && (sym
->attr
.function
|| sym
->attr
.result
)
432 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
433 se
->expr
= build_fold_indirect_ref (se
->expr
);
435 /* Dereference non-character pointer variables.
436 These must be dummies, results, or scalars. */
437 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
439 || sym
->attr
.function
441 || !sym
->attr
.dimension
))
442 se
->expr
= build_fold_indirect_ref (se
->expr
);
448 /* For character variables, also get the length. */
449 if (sym
->ts
.type
== BT_CHARACTER
)
451 /* If the character length of an entry isn't set, get the length from
452 the master function instead. */
453 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
454 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
456 se
->string_length
= sym
->ts
.cl
->backend_decl
;
457 gcc_assert (se
->string_length
);
465 /* Return the descriptor if that's what we want and this is an array
466 section reference. */
467 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
469 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
470 /* Return the descriptor for array pointers and allocations. */
472 && ref
->next
== NULL
&& (se
->descriptor_only
))
475 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
476 /* Return a pointer to an element. */
480 gfc_conv_component_ref (se
, ref
);
484 gfc_conv_substring (se
, ref
, expr
->ts
.kind
);
493 /* Pointer assignment, allocation or pass by reference. Arrays are handled
495 if (se
->want_pointer
)
497 if (expr
->ts
.type
== BT_CHARACTER
)
498 gfc_conv_string_parameter (se
);
500 se
->expr
= build_fold_addr_expr (se
->expr
);
505 /* Unary ops are easy... Or they would be if ! was a valid op. */
508 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
513 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
514 /* Initialize the operand. */
515 gfc_init_se (&operand
, se
);
516 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
517 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
519 type
= gfc_typenode_for_spec (&expr
->ts
);
521 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
522 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
523 All other unary operators have an equivalent GIMPLE unary operator. */
524 if (code
== TRUTH_NOT_EXPR
)
525 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
526 convert (type
, integer_zero_node
));
528 se
->expr
= build1 (code
, type
, operand
.expr
);
532 /* Expand power operator to optimal multiplications when a value is raised
533 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
534 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
535 Programming", 3rd Edition, 1998. */
537 /* This code is mostly duplicated from expand_powi in the backend.
538 We establish the "optimal power tree" lookup table with the defined size.
539 The items in the table are the exponents used to calculate the index
540 exponents. Any integer n less than the value can get an "addition chain",
541 with the first node being one. */
542 #define POWI_TABLE_SIZE 256
544 /* The table is from builtins.c. */
545 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
547 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
548 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
549 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
550 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
551 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
552 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
553 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
554 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
555 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
556 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
557 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
558 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
559 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
560 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
561 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
562 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
563 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
564 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
565 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
566 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
567 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
568 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
569 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
570 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
571 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
572 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
573 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
574 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
575 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
576 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
577 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
578 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
581 /* If n is larger than lookup table's max index, we use the "window
583 #define POWI_WINDOW_SIZE 3
585 /* Recursive function to expand the power operator. The temporary
586 values are put in tmpvar. The function returns tmpvar[1] ** n. */
588 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
595 if (n
< POWI_TABLE_SIZE
)
600 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
601 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
605 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
606 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
607 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
611 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
615 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
616 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
618 if (n
< POWI_TABLE_SIZE
)
625 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
626 return 1. Else return 0 and a call to runtime library functions
627 will have to be built. */
629 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
634 tree vartmp
[POWI_TABLE_SIZE
];
638 type
= TREE_TYPE (lhs
);
639 n
= abs (TREE_INT_CST_LOW (rhs
));
640 sgn
= tree_int_cst_sgn (rhs
);
642 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
643 && (n
> 2 || n
< -1))
649 se
->expr
= gfc_build_const (type
, integer_one_node
);
652 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
653 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
655 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
656 fold_convert (TREE_TYPE (lhs
), integer_minus_one_node
));
657 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
658 convert (TREE_TYPE (lhs
), integer_one_node
));
661 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
664 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
665 se
->expr
= build3 (COND_EXPR
, type
, tmp
,
666 convert (type
, integer_one_node
),
667 convert (type
, integer_zero_node
));
671 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
672 tmp
= build3 (COND_EXPR
, type
, tmp
,
673 convert (type
, integer_minus_one_node
),
674 convert (type
, integer_zero_node
));
675 se
->expr
= build3 (COND_EXPR
, type
, cond
,
676 convert (type
, integer_one_node
),
681 memset (vartmp
, 0, sizeof (vartmp
));
685 tmp
= gfc_build_const (type
, integer_one_node
);
686 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
689 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
695 /* Power op (**). Constant integer exponent has special handling. */
698 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
700 tree gfc_int4_type_node
;
708 gfc_init_se (&lse
, se
);
709 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
710 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
711 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
713 gfc_init_se (&rse
, se
);
714 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
715 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
717 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
718 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
719 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
722 gfc_int4_type_node
= gfc_get_int_type (4);
724 kind
= expr
->value
.op
.op1
->ts
.kind
;
725 switch (expr
->value
.op
.op2
->ts
.type
)
728 ikind
= expr
->value
.op
.op2
->ts
.kind
;
733 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
755 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
756 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
781 switch (expr
->value
.op
.op1
->ts
.type
)
784 if (kind
== 3) /* Case 16 was not handled properly above. */
786 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
790 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
794 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
806 fndecl
= built_in_decls
[BUILT_IN_POWF
];
809 fndecl
= built_in_decls
[BUILT_IN_POW
];
813 fndecl
= built_in_decls
[BUILT_IN_POWL
];
824 fndecl
= gfor_fndecl_math_cpowf
;
827 fndecl
= gfor_fndecl_math_cpow
;
830 fndecl
= gfor_fndecl_math_cpowl10
;
833 fndecl
= gfor_fndecl_math_cpowl16
;
845 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
846 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
847 se
->expr
= build_function_call_expr (fndecl
, tmp
);
851 /* Generate code to allocate a string temporary. */
854 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
860 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
862 if (gfc_can_put_var_on_stack (len
))
864 /* Create a temporary variable to hold the result. */
865 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
866 convert (gfc_charlen_type_node
, integer_one_node
));
867 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
868 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
869 var
= gfc_create_var (tmp
, "str");
870 var
= gfc_build_addr_expr (type
, var
);
874 /* Allocate a temporary to hold the result. */
875 var
= gfc_create_var (type
, "pstr");
876 args
= gfc_chainon_list (NULL_TREE
, len
);
877 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, args
);
878 tmp
= convert (type
, tmp
);
879 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
881 /* Free the temporary afterwards. */
882 tmp
= convert (pvoid_type_node
, var
);
883 args
= gfc_chainon_list (NULL_TREE
, tmp
);
884 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
885 gfc_add_expr_to_block (&se
->post
, tmp
);
892 /* Handle a string concatenation operation. A temporary will be allocated to
896 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
906 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
907 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
909 gfc_init_se (&lse
, se
);
910 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
911 gfc_conv_string_parameter (&lse
);
912 gfc_init_se (&rse
, se
);
913 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
914 gfc_conv_string_parameter (&rse
);
916 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
917 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
919 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
920 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
921 if (len
== NULL_TREE
)
923 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
924 lse
.string_length
, rse
.string_length
);
927 type
= build_pointer_type (type
);
929 var
= gfc_conv_string_tmp (se
, type
, len
);
931 /* Do the actual concatenation. */
933 args
= gfc_chainon_list (args
, len
);
934 args
= gfc_chainon_list (args
, var
);
935 args
= gfc_chainon_list (args
, lse
.string_length
);
936 args
= gfc_chainon_list (args
, lse
.expr
);
937 args
= gfc_chainon_list (args
, rse
.string_length
);
938 args
= gfc_chainon_list (args
, rse
.expr
);
939 tmp
= build_function_call_expr (gfor_fndecl_concat_string
, args
);
940 gfc_add_expr_to_block (&se
->pre
, tmp
);
942 /* Add the cleanup for the operands. */
943 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
944 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
947 se
->string_length
= len
;
950 /* Translates an op expression. Common (binary) cases are handled by this
951 function, others are passed on. Recursion is used in either case.
952 We use the fact that (op1.ts == op2.ts) (except for the power
954 Operators need no special handling for scalarized expressions as long as
955 they call gfc_conv_simple_val to get their operands.
956 Character strings get special handling. */
959 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
971 switch (expr
->value
.op
.operator)
973 case INTRINSIC_UPLUS
:
974 case INTRINSIC_PARENTHESES
:
975 gfc_conv_expr (se
, expr
->value
.op
.op1
);
978 case INTRINSIC_UMINUS
:
979 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
983 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
990 case INTRINSIC_MINUS
:
994 case INTRINSIC_TIMES
:
998 case INTRINSIC_DIVIDE
:
999 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1000 an integer, we must round towards zero, so we use a
1002 if (expr
->ts
.type
== BT_INTEGER
)
1003 code
= TRUNC_DIV_EXPR
;
1008 case INTRINSIC_POWER
:
1009 gfc_conv_power_op (se
, expr
);
1012 case INTRINSIC_CONCAT
:
1013 gfc_conv_concat_op (se
, expr
);
1017 code
= TRUTH_ANDIF_EXPR
;
1022 code
= TRUTH_ORIF_EXPR
;
1026 /* EQV and NEQV only work on logicals, but since we represent them
1027 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1036 case INTRINSIC_NEQV
:
1066 case INTRINSIC_USER
:
1067 case INTRINSIC_ASSIGN
:
1068 /* These should be converted into function calls by the frontend. */
1072 fatal_error ("Unknown intrinsic op");
1076 /* The only exception to this is **, which is handled separately anyway. */
1077 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1079 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1083 gfc_init_se (&lse
, se
);
1084 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1085 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1088 gfc_init_se (&rse
, se
);
1089 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1090 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1094 gfc_conv_string_parameter (&lse
);
1095 gfc_conv_string_parameter (&rse
);
1097 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1098 rse
.string_length
, rse
.expr
);
1099 rse
.expr
= integer_zero_node
;
1100 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1103 type
= gfc_typenode_for_spec (&expr
->ts
);
1107 /* The result of logical ops is always boolean_type_node. */
1108 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1109 se
->expr
= convert (type
, tmp
);
1112 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1114 /* Add the post blocks. */
1115 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1116 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1119 /* If a string's length is one, we convert it to a single character. */
1122 gfc_to_single_character (tree len
, tree str
)
1124 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1126 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1127 && TREE_INT_CST_HIGH (len
) == 0)
1129 str
= fold_convert (pchar_type_node
, str
);
1130 return build_fold_indirect_ref (str
);
1136 /* Compare two strings. If they are all single characters, the result is the
1137 subtraction of them. Otherwise, we build a library call. */
1140 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1147 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1148 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1150 type
= gfc_get_int_type (gfc_default_integer_kind
);
1152 sc1
= gfc_to_single_character (len1
, str1
);
1153 sc2
= gfc_to_single_character (len2
, str2
);
1155 /* Deal with single character specially. */
1156 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1158 sc1
= fold_convert (type
, sc1
);
1159 sc2
= fold_convert (type
, sc2
);
1160 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1165 tmp
= gfc_chainon_list (tmp
, len1
);
1166 tmp
= gfc_chainon_list (tmp
, str1
);
1167 tmp
= gfc_chainon_list (tmp
, len2
);
1168 tmp
= gfc_chainon_list (tmp
, str2
);
1170 /* Build a call for the comparison. */
1171 tmp
= build_function_call_expr (gfor_fndecl_compare_string
, tmp
);
1178 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1182 if (sym
->attr
.dummy
)
1184 tmp
= gfc_get_symbol_decl (sym
);
1185 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1186 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1190 if (!sym
->backend_decl
)
1191 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1193 tmp
= sym
->backend_decl
;
1194 if (sym
->attr
.cray_pointee
)
1195 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1196 gfc_get_symbol_decl (sym
->cp_pointer
));
1197 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1199 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1200 tmp
= build_fold_addr_expr (tmp
);
1207 /* Initialize MAPPING. */
1210 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1212 mapping
->syms
= NULL
;
1213 mapping
->charlens
= NULL
;
1217 /* Free all memory held by MAPPING (but not MAPPING itself). */
1220 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1222 gfc_interface_sym_mapping
*sym
;
1223 gfc_interface_sym_mapping
*nextsym
;
1225 gfc_charlen
*nextcl
;
1227 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1229 nextsym
= sym
->next
;
1230 gfc_free_symbol (sym
->new->n
.sym
);
1231 gfc_free (sym
->new);
1234 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1237 gfc_free_expr (cl
->length
);
1243 /* Return a copy of gfc_charlen CL. Add the returned structure to
1244 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1246 static gfc_charlen
*
1247 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1252 new = gfc_get_charlen ();
1253 new->next
= mapping
->charlens
;
1254 new->length
= gfc_copy_expr (cl
->length
);
1256 mapping
->charlens
= new;
1261 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1262 array variable that can be used as the actual argument for dummy
1263 argument SYM. Add any initialization code to BLOCK. PACKED is as
1264 for gfc_get_nodesc_array_type and DATA points to the first element
1265 in the passed array. */
1268 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1269 int packed
, tree data
)
1274 type
= gfc_typenode_for_spec (&sym
->ts
);
1275 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1277 var
= gfc_create_var (type
, "ifm");
1278 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1284 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1285 and offset of descriptorless array type TYPE given that it has the same
1286 size as DESC. Add any set-up code to BLOCK. */
1289 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1296 offset
= gfc_index_zero_node
;
1297 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1299 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1300 if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1302 dim
= gfc_rank_cst
[n
];
1303 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1304 gfc_conv_descriptor_ubound (desc
, dim
),
1305 gfc_conv_descriptor_lbound (desc
, dim
));
1306 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1307 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1309 tmp
= gfc_evaluate_now (tmp
, block
);
1310 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1312 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1313 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1314 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1315 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1317 offset
= gfc_evaluate_now (offset
, block
);
1318 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1322 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1323 in SE. The caller may still use se->expr and se->string_length after
1324 calling this function. */
1327 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1328 gfc_symbol
* sym
, gfc_se
* se
)
1330 gfc_interface_sym_mapping
*sm
;
1334 gfc_symbol
*new_sym
;
1336 gfc_symtree
*new_symtree
;
1338 /* Create a new symbol to represent the actual argument. */
1339 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1340 new_sym
->ts
= sym
->ts
;
1341 new_sym
->attr
.referenced
= 1;
1342 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1343 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1344 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1345 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1347 /* Create a fake symtree for it. */
1349 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1350 new_symtree
->n
.sym
= new_sym
;
1351 gcc_assert (new_symtree
== root
);
1353 /* Create a dummy->actual mapping. */
1354 sm
= gfc_getmem (sizeof (*sm
));
1355 sm
->next
= mapping
->syms
;
1357 sm
->new = new_symtree
;
1360 /* Stabilize the argument's value. */
1361 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1363 if (sym
->ts
.type
== BT_CHARACTER
)
1365 /* Create a copy of the dummy argument's length. */
1366 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1368 /* If the length is specified as "*", record the length that
1369 the caller is passing. We should use the callee's length
1370 in all other cases. */
1371 if (!new_sym
->ts
.cl
->length
)
1373 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1374 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1378 /* Use the passed value as-is if the argument is a function. */
1379 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1382 /* If the argument is either a string or a pointer to a string,
1383 convert it to a boundless character type. */
1384 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1386 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1387 tmp
= build_pointer_type (tmp
);
1388 if (sym
->attr
.pointer
)
1389 tmp
= build_pointer_type (tmp
);
1391 value
= fold_convert (tmp
, se
->expr
);
1392 if (sym
->attr
.pointer
)
1393 value
= build_fold_indirect_ref (value
);
1396 /* If the argument is a scalar, a pointer to an array or an allocatable,
1398 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1399 value
= build_fold_indirect_ref (se
->expr
);
1401 /* For character(*), use the actual argument's descriptor. */
1402 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1403 value
= build_fold_indirect_ref (se
->expr
);
1405 /* If the argument is an array descriptor, use it to determine
1406 information about the actual argument's shape. */
1407 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1408 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1410 /* Get the actual argument's descriptor. */
1411 desc
= build_fold_indirect_ref (se
->expr
);
1413 /* Create the replacement variable. */
1414 tmp
= gfc_conv_descriptor_data_get (desc
);
1415 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1417 /* Use DESC to work out the upper bounds, strides and offset. */
1418 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1421 /* Otherwise we have a packed array. */
1422 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1424 new_sym
->backend_decl
= value
;
1428 /* Called once all dummy argument mappings have been added to MAPPING,
1429 but before the mapping is used to evaluate expressions. Pre-evaluate
1430 the length of each argument, adding any initialization code to PRE and
1431 any finalization code to POST. */
1434 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1435 stmtblock_t
* pre
, stmtblock_t
* post
)
1437 gfc_interface_sym_mapping
*sym
;
1441 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1442 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1443 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1445 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1446 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1447 gfc_init_se (&se
, NULL
);
1448 gfc_conv_expr (&se
, expr
);
1450 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1451 gfc_add_block_to_block (pre
, &se
.pre
);
1452 gfc_add_block_to_block (post
, &se
.post
);
1454 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1459 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1463 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1464 gfc_constructor
* c
)
1466 for (; c
; c
= c
->next
)
1468 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1471 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1472 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1473 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1479 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1483 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1488 for (; ref
; ref
= ref
->next
)
1492 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1494 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1495 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1496 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1498 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1505 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1506 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1512 /* EXPR is a copy of an expression that appeared in the interface
1513 associated with MAPPING. Walk it recursively looking for references to
1514 dummy arguments that MAPPING maps to actual arguments. Replace each such
1515 reference with a reference to the associated actual argument. */
1518 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1521 gfc_interface_sym_mapping
*sym
;
1522 gfc_actual_arglist
*actual
;
1527 /* Copying an expression does not copy its length, so do that here. */
1528 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1530 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1531 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1534 /* Apply the mapping to any references. */
1535 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1537 /* ...and to the expression's symbol, if it has one. */
1539 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1540 if (sym
->old
== expr
->symtree
->n
.sym
)
1541 expr
->symtree
= sym
->new;
1543 /* ...and to subexpressions in expr->value. */
1544 switch (expr
->expr_type
)
1549 case EXPR_SUBSTRING
:
1553 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1554 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1558 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1559 if (sym
->old
== expr
->value
.function
.esym
)
1560 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1562 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1563 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1567 case EXPR_STRUCTURE
:
1568 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1574 /* Evaluate interface expression EXPR using MAPPING. Store the result
1578 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1579 gfc_se
* se
, gfc_expr
* expr
)
1581 expr
= gfc_copy_expr (expr
);
1582 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1583 gfc_conv_expr (se
, expr
);
1584 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1585 gfc_free_expr (expr
);
1588 /* Returns a reference to a temporary array into which a component of
1589 an actual argument derived type array is copied and then returned
1590 after the function call.
1591 TODO Get rid of this kludge, when array descriptors are capable of
1592 handling aliased arrays. */
1595 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
)
1611 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1613 gfc_init_se (&lse
, NULL
);
1614 gfc_init_se (&rse
, NULL
);
1616 /* Walk the argument expression. */
1617 rss
= gfc_walk_expr (expr
);
1619 gcc_assert (rss
!= gfc_ss_terminator
);
1621 /* Initialize the scalarizer. */
1622 gfc_init_loopinfo (&loop
);
1623 gfc_add_ss_to_loop (&loop
, rss
);
1625 /* Calculate the bounds of the scalarization. */
1626 gfc_conv_ss_startstride (&loop
);
1628 /* Build an ss for the temporary. */
1629 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1630 if (GFC_ARRAY_TYPE_P (base_type
)
1631 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1632 base_type
= gfc_get_element_type (base_type
);
1634 loop
.temp_ss
= gfc_get_ss ();;
1635 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1636 loop
.temp_ss
->data
.temp
.type
= base_type
;
1638 if (expr
->ts
.type
== BT_CHARACTER
)
1639 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1641 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1642 loop
.temp_ss
->next
= gfc_ss_terminator
;
1644 /* Associate the SS with the loop. */
1645 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1647 /* Setup the scalarizing loops. */
1648 gfc_conv_loop_setup (&loop
);
1650 /* Pass the temporary descriptor back to the caller. */
1651 info
= &loop
.temp_ss
->data
.info
;
1652 parmse
->expr
= info
->descriptor
;
1654 /* Setup the gfc_se structures. */
1655 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1656 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1659 lse
.ss
= loop
.temp_ss
;
1660 gfc_mark_ss_chain_used (rss
, 1);
1661 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1663 /* Start the scalarized loop body. */
1664 gfc_start_scalarized_body (&loop
, &body
);
1666 /* Translate the expression. */
1667 gfc_conv_expr (&rse
, expr
);
1669 gfc_conv_tmp_array_ref (&lse
);
1670 gfc_advance_se_ss_chain (&lse
);
1672 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1673 gfc_add_expr_to_block (&body
, tmp
);
1675 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1677 gfc_trans_scalarizing_loops (&loop
, &body
);
1679 /* Add the post block after the second loop, so that any
1680 freeing of allocated memory is done at the right time. */
1681 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1683 /**********Copy the temporary back again.*********/
1685 gfc_init_se (&lse
, NULL
);
1686 gfc_init_se (&rse
, NULL
);
1688 /* Walk the argument expression. */
1689 lss
= gfc_walk_expr (expr
);
1690 rse
.ss
= loop
.temp_ss
;
1693 /* Initialize the scalarizer. */
1694 gfc_init_loopinfo (&loop2
);
1695 gfc_add_ss_to_loop (&loop2
, lss
);
1697 /* Calculate the bounds of the scalarization. */
1698 gfc_conv_ss_startstride (&loop2
);
1700 /* Setup the scalarizing loops. */
1701 gfc_conv_loop_setup (&loop2
);
1703 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1704 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1706 gfc_mark_ss_chain_used (lss
, 1);
1707 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1709 /* Declare the variable to hold the temporary offset and start the
1710 scalarized loop body. */
1711 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1712 gfc_start_scalarized_body (&loop2
, &body
);
1714 /* Build the offsets for the temporary from the loop variables. The
1715 temporary array has lbounds of zero and strides of one in all
1716 dimensions, so this is very simple. The offset is only computed
1717 outside the innermost loop, so the overall transfer could be
1718 optimized further. */
1719 info
= &rse
.ss
->data
.info
;
1721 tmp_index
= gfc_index_zero_node
;
1722 for (n
= info
->dimen
- 1; n
> 0; n
--)
1725 tmp
= rse
.loop
->loopvar
[n
];
1726 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1727 tmp
, rse
.loop
->from
[n
]);
1728 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1731 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1732 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1733 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1734 tmp_str
, gfc_index_one_node
);
1736 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1740 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1741 tmp_index
, rse
.loop
->from
[0]);
1742 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1744 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1745 rse
.loop
->loopvar
[0], offset
);
1747 /* Now use the offset for the reference. */
1748 tmp
= build_fold_indirect_ref (info
->data
);
1749 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1751 if (expr
->ts
.type
== BT_CHARACTER
)
1752 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1754 gfc_conv_expr (&lse
, expr
);
1756 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1758 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1759 gfc_add_expr_to_block (&body
, tmp
);
1761 /* Generate the copying loops. */
1762 gfc_trans_scalarizing_loops (&loop2
, &body
);
1764 /* Wrap the whole thing up by adding the second loop to the post-block
1765 and following it by the post-block of the fist loop. In this way,
1766 if the temporary needs freeing, it is done after use! */
1767 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1768 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1770 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1772 gfc_cleanup_loop (&loop
);
1773 gfc_cleanup_loop (&loop2
);
1775 /* Pass the string length to the argument expression. */
1776 if (expr
->ts
.type
== BT_CHARACTER
)
1777 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1779 /* We want either the address for the data or the address of the descriptor,
1780 depending on the mode of passing array arguments. */
1782 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1784 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1789 /* Is true if the last array reference is followed by a component reference. */
1792 is_aliased_array (gfc_expr
* e
)
1798 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1800 if (ref
->type
== REF_ARRAY
)
1803 if (ref
->next
== NULL
&& ref
->type
== REF_COMPONENT
)
1809 /* Generate code for a procedure call. Note can return se->post != NULL.
1810 If se->direct_byref is set then se->expr contains the return parameter.
1811 Return nonzero, if the call has alternate specifiers. */
1814 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1815 gfc_actual_arglist
* arg
)
1817 gfc_interface_mapping mapping
;
1830 gfc_formal_arglist
*formal
;
1831 int has_alternate_specifier
= 0;
1832 bool need_interface_mapping
;
1840 arglist
= NULL_TREE
;
1841 retargs
= NULL_TREE
;
1842 stringargs
= NULL_TREE
;
1848 if (!sym
->attr
.elemental
)
1850 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1851 if (se
->ss
->useflags
)
1853 gcc_assert (gfc_return_by_reference (sym
)
1854 && sym
->result
->attr
.dimension
);
1855 gcc_assert (se
->loop
!= NULL
);
1857 /* Access the previously obtained result. */
1858 gfc_conv_tmp_array_ref (se
);
1859 gfc_advance_se_ss_chain (se
);
1863 info
= &se
->ss
->data
.info
;
1868 gfc_init_block (&post
);
1869 gfc_init_interface_mapping (&mapping
);
1870 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
1871 && sym
->ts
.cl
->length
1872 && sym
->ts
.cl
->length
->expr_type
1874 || sym
->attr
.dimension
);
1875 formal
= sym
->formal
;
1876 /* Evaluate the arguments. */
1877 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1880 fsym
= formal
? formal
->sym
: NULL
;
1884 if (se
->ignore_optional
)
1886 /* Some intrinsics have already been resolved to the correct
1890 else if (arg
->label
)
1892 has_alternate_specifier
= 1;
1897 /* Pass a NULL pointer for an absent arg. */
1898 gfc_init_se (&parmse
, NULL
);
1899 parmse
.expr
= null_pointer_node
;
1900 if (arg
->missing_arg_type
== BT_CHARACTER
)
1901 parmse
.string_length
= convert (gfc_charlen_type_node
,
1905 else if (se
->ss
&& se
->ss
->useflags
)
1907 /* An elemental function inside a scalarized loop. */
1908 gfc_init_se (&parmse
, se
);
1909 gfc_conv_expr_reference (&parmse
, e
);
1913 /* A scalar or transformational function. */
1914 gfc_init_se (&parmse
, NULL
);
1915 argss
= gfc_walk_expr (e
);
1917 if (argss
== gfc_ss_terminator
)
1919 gfc_conv_expr_reference (&parmse
, e
);
1920 if (fsym
&& fsym
->attr
.pointer
1921 && e
->expr_type
!= EXPR_NULL
)
1923 /* Scalar pointer dummy args require an extra level of
1924 indirection. The null pointer already contains
1925 this level of indirection. */
1926 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
1931 /* If the procedure requires an explicit interface, the actual
1932 argument is passed according to the corresponding formal
1933 argument. If the corresponding formal argument is a POINTER,
1934 ALLOCATABLE or assumed shape, we do not use g77's calling
1935 convention, and pass the address of the array descriptor
1936 instead. Otherwise we use g77's calling convention. */
1939 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
1940 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
1941 f
= f
|| !sym
->attr
.always_explicit
;
1942 if (e
->expr_type
== EXPR_VARIABLE
1943 && is_aliased_array (e
))
1944 /* The actual argument is a component reference to an
1945 array of derived types. In this case, the argument
1946 is converted to a temporary, which is passed and then
1947 written back after the procedure call. */
1948 gfc_conv_aliased_arg (&parmse
, e
, f
);
1950 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
1952 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
1953 allocated on entry, it must be deallocated. */
1954 if (fsym
&& fsym
->attr
.allocatable
1955 && fsym
->attr
.intent
== INTENT_OUT
)
1957 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1958 if (e
->symtree
->n
.sym
->attr
.dummy
)
1959 tmp
= build_fold_indirect_ref (tmp
);
1960 tmp
= gfc_trans_dealloc_allocated (tmp
);
1961 gfc_add_expr_to_block (&se
->pre
, tmp
);
1967 /* If an optional argument is itself an optional dummy argument,
1968 check its presence and substitute a null if absent. */
1969 if (e
&& e
->expr_type
== EXPR_VARIABLE
1970 && e
->symtree
->n
.sym
->attr
.optional
1971 && fsym
&& fsym
->attr
.optional
)
1972 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
1974 if (fsym
&& need_interface_mapping
)
1975 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
1977 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
1978 gfc_add_block_to_block (&post
, &parmse
.post
);
1980 /* Character strings are passed as two parameters, a length and a
1982 if (parmse
.string_length
!= NULL_TREE
)
1983 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
1985 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
1987 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
1990 if (ts
.type
== BT_CHARACTER
)
1992 if (sym
->ts
.cl
->length
== NULL
)
1994 /* Assumed character length results are not allowed by 5.1.1.5 of the
1995 standard and are trapped in resolve.c; except in the case of SPREAD
1996 (and other intrinsics?). In this case, we take the character length
1997 of the first argument for the result. */
1998 cl
.backend_decl
= TREE_VALUE (stringargs
);
2002 /* Calculate the length of the returned string. */
2003 gfc_init_se (&parmse
, NULL
);
2004 if (need_interface_mapping
)
2005 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2007 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2008 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2009 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2010 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2013 /* Set up a charlen structure for it. */
2018 len
= cl
.backend_decl
;
2021 byref
= gfc_return_by_reference (sym
);
2024 if (se
->direct_byref
)
2025 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2026 else if (sym
->result
->attr
.dimension
)
2028 gcc_assert (se
->loop
&& info
);
2030 /* Set the type of the array. */
2031 tmp
= gfc_typenode_for_spec (&ts
);
2032 info
->dimen
= se
->loop
->dimen
;
2034 /* Evaluate the bounds of the result, if known. */
2035 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2037 /* Create a temporary to store the result. In case the function
2038 returns a pointer, the temporary will be a shallow copy and
2039 mustn't be deallocated. */
2040 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2041 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2042 false, !sym
->attr
.pointer
, callee_alloc
);
2044 /* Pass the temporary as the first argument. */
2045 tmp
= info
->descriptor
;
2046 tmp
= build_fold_addr_expr (tmp
);
2047 retargs
= gfc_chainon_list (retargs
, tmp
);
2049 else if (ts
.type
== BT_CHARACTER
)
2051 /* Pass the string length. */
2052 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2053 type
= build_pointer_type (type
);
2055 /* Return an address to a char[0:len-1]* temporary for
2056 character pointers. */
2057 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2059 /* Build char[0:len-1] * pstr. */
2060 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2061 build_int_cst (gfc_charlen_type_node
, 1));
2062 tmp
= build_range_type (gfc_array_index_type
,
2063 gfc_index_zero_node
, tmp
);
2064 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2065 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2067 /* Provide an address expression for the function arguments. */
2068 var
= build_fold_addr_expr (var
);
2071 var
= gfc_conv_string_tmp (se
, type
, len
);
2073 retargs
= gfc_chainon_list (retargs
, var
);
2077 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2079 type
= gfc_get_complex_type (ts
.kind
);
2080 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2081 retargs
= gfc_chainon_list (retargs
, var
);
2084 /* Add the string length to the argument list. */
2085 if (ts
.type
== BT_CHARACTER
)
2086 retargs
= gfc_chainon_list (retargs
, len
);
2088 gfc_free_interface_mapping (&mapping
);
2090 /* Add the return arguments. */
2091 arglist
= chainon (retargs
, arglist
);
2093 /* Add the hidden string length parameters to the arguments. */
2094 arglist
= chainon (arglist
, stringargs
);
2096 /* Generate the actual call. */
2097 gfc_conv_function_val (se
, sym
);
2098 /* If there are alternate return labels, function type should be
2099 integer. Can't modify the type in place though, since it can be shared
2100 with other functions. */
2101 if (has_alternate_specifier
2102 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2104 gcc_assert (! sym
->attr
.dummy
);
2105 TREE_TYPE (sym
->backend_decl
)
2106 = build_function_type (integer_type_node
,
2107 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2108 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2111 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2112 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2113 arglist
, NULL_TREE
);
2115 /* If we have a pointer function, but we don't want a pointer, e.g.
2118 where f is pointer valued, we have to dereference the result. */
2119 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2120 se
->expr
= build_fold_indirect_ref (se
->expr
);
2122 /* f2c calling conventions require a scalar default real function to
2123 return a double precision result. Convert this back to default
2124 real. We only care about the cases that can happen in Fortran 77.
2126 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2127 && sym
->ts
.kind
== gfc_default_real_kind
2128 && !sym
->attr
.always_explicit
)
2129 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2131 /* A pure function may still have side-effects - it may modify its
2133 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2135 if (!sym
->attr
.pure
)
2136 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2141 /* Add the function call to the pre chain. There is no expression. */
2142 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2143 se
->expr
= NULL_TREE
;
2145 if (!se
->direct_byref
)
2147 if (sym
->attr
.dimension
)
2149 if (flag_bounds_check
)
2151 /* Check the data pointer hasn't been modified. This would
2152 happen in a function returning a pointer. */
2153 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2154 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2156 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2158 se
->expr
= info
->descriptor
;
2159 /* Bundle in the string length. */
2160 se
->string_length
= len
;
2162 else if (sym
->ts
.type
== BT_CHARACTER
)
2164 /* Dereference for character pointer results. */
2165 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2166 se
->expr
= build_fold_indirect_ref (var
);
2170 se
->string_length
= len
;
2174 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2175 se
->expr
= build_fold_indirect_ref (var
);
2180 /* Follow the function call with the argument post block. */
2182 gfc_add_block_to_block (&se
->pre
, &post
);
2184 gfc_add_block_to_block (&se
->post
, &post
);
2186 return has_alternate_specifier
;
2190 /* Generate code to copy a string. */
2193 gfc_trans_string_copy (stmtblock_t
* block
, tree dlen
, tree dest
,
2194 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
);
2210 tmp
= gfc_chainon_list (tmp
, dlen
);
2211 tmp
= gfc_chainon_list (tmp
, dest
);
2212 tmp
= gfc_chainon_list (tmp
, slen
);
2213 tmp
= gfc_chainon_list (tmp
, src
);
2214 tmp
= build_function_call_expr (gfor_fndecl_copy_string
, tmp
);
2215 gfc_add_expr_to_block (block
, tmp
);
2219 /* Translate a statement function.
2220 The value of a statement function reference is obtained by evaluating the
2221 expression using the values of the actual arguments for the values of the
2222 corresponding dummy arguments. */
2225 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2229 gfc_formal_arglist
*fargs
;
2230 gfc_actual_arglist
*args
;
2233 gfc_saved_var
*saved_vars
;
2239 sym
= expr
->symtree
->n
.sym
;
2240 args
= expr
->value
.function
.actual
;
2241 gfc_init_se (&lse
, NULL
);
2242 gfc_init_se (&rse
, NULL
);
2245 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2247 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2248 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2250 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2252 /* Each dummy shall be specified, explicitly or implicitly, to be
2254 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2257 /* Create a temporary to hold the value. */
2258 type
= gfc_typenode_for_spec (&fsym
->ts
);
2259 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2261 if (fsym
->ts
.type
== BT_CHARACTER
)
2263 /* Copy string arguments. */
2266 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2267 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2269 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2270 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2273 gfc_conv_expr (&rse
, args
->expr
);
2274 gfc_conv_string_parameter (&rse
);
2275 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2276 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2278 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2280 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2281 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2285 /* For everything else, just evaluate the expression. */
2286 gfc_conv_expr (&lse
, args
->expr
);
2288 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2289 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2290 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2296 /* Use the temporary variables in place of the real ones. */
2297 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2298 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2300 gfc_conv_expr (se
, sym
->value
);
2302 if (sym
->ts
.type
== BT_CHARACTER
)
2304 gfc_conv_const_charlen (sym
->ts
.cl
);
2306 /* Force the expression to the correct length. */
2307 if (!INTEGER_CST_P (se
->string_length
)
2308 || tree_int_cst_lt (se
->string_length
,
2309 sym
->ts
.cl
->backend_decl
))
2311 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2312 tmp
= gfc_create_var (type
, sym
->name
);
2313 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2314 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2315 se
->string_length
, se
->expr
);
2318 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2321 /* Restore the original variables. */
2322 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2323 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2324 gfc_free (saved_vars
);
2328 /* Translate a function expression. */
2331 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2335 if (expr
->value
.function
.isym
)
2337 gfc_conv_intrinsic_function (se
, expr
);
2341 /* We distinguish statement functions from general functions to improve
2342 runtime performance. */
2343 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2345 gfc_conv_statement_function (se
, expr
);
2349 /* expr.value.function.esym is the resolved (specific) function symbol for
2350 most functions. However this isn't set for dummy procedures. */
2351 sym
= expr
->value
.function
.esym
;
2353 sym
= expr
->symtree
->n
.sym
;
2354 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
2359 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2361 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2362 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2364 gfc_conv_tmp_array_ref (se
);
2365 gfc_advance_se_ss_chain (se
);
2369 /* Build a static initializer. EXPR is the expression for the initial value.
2370 The other parameters describe the variable of the component being
2371 initialized. EXPR may be null. */
2374 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2375 bool array
, bool pointer
)
2379 if (!(expr
|| pointer
))
2384 /* Arrays need special handling. */
2386 return gfc_build_null_descriptor (type
);
2388 return gfc_conv_array_initializer (type
, expr
);
2391 return fold_convert (type
, null_pointer_node
);
2397 gfc_init_se (&se
, NULL
);
2398 gfc_conv_structure (&se
, expr
, 1);
2402 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2405 gfc_init_se (&se
, NULL
);
2406 gfc_conv_constant (&se
, expr
);
2413 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2425 gfc_start_block (&block
);
2427 /* Initialize the scalarizer. */
2428 gfc_init_loopinfo (&loop
);
2430 gfc_init_se (&lse
, NULL
);
2431 gfc_init_se (&rse
, NULL
);
2434 rss
= gfc_walk_expr (expr
);
2435 if (rss
== gfc_ss_terminator
)
2437 /* The rhs is scalar. Add a ss for the expression. */
2438 rss
= gfc_get_ss ();
2439 rss
->next
= gfc_ss_terminator
;
2440 rss
->type
= GFC_SS_SCALAR
;
2444 /* Create a SS for the destination. */
2445 lss
= gfc_get_ss ();
2446 lss
->type
= GFC_SS_COMPONENT
;
2448 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2449 lss
->next
= gfc_ss_terminator
;
2450 lss
->data
.info
.dimen
= cm
->as
->rank
;
2451 lss
->data
.info
.descriptor
= dest
;
2452 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2453 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2454 for (n
= 0; n
< cm
->as
->rank
; n
++)
2456 lss
->data
.info
.dim
[n
] = n
;
2457 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2458 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2460 mpz_init (lss
->shape
[n
]);
2461 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2462 cm
->as
->lower
[n
]->value
.integer
);
2463 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2466 /* Associate the SS with the loop. */
2467 gfc_add_ss_to_loop (&loop
, lss
);
2468 gfc_add_ss_to_loop (&loop
, rss
);
2470 /* Calculate the bounds of the scalarization. */
2471 gfc_conv_ss_startstride (&loop
);
2473 /* Setup the scalarizing loops. */
2474 gfc_conv_loop_setup (&loop
);
2476 /* Setup the gfc_se structures. */
2477 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2478 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2481 gfc_mark_ss_chain_used (rss
, 1);
2483 gfc_mark_ss_chain_used (lss
, 1);
2485 /* Start the scalarized loop body. */
2486 gfc_start_scalarized_body (&loop
, &body
);
2488 gfc_conv_tmp_array_ref (&lse
);
2489 if (cm
->ts
.type
== BT_CHARACTER
)
2490 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2492 gfc_conv_expr (&rse
, expr
);
2494 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
.type
);
2495 gfc_add_expr_to_block (&body
, tmp
);
2497 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2499 /* Generate the copying loops. */
2500 gfc_trans_scalarizing_loops (&loop
, &body
);
2502 /* Wrap the whole thing up. */
2503 gfc_add_block_to_block (&block
, &loop
.pre
);
2504 gfc_add_block_to_block (&block
, &loop
.post
);
2506 for (n
= 0; n
< cm
->as
->rank
; n
++)
2507 mpz_clear (lss
->shape
[n
]);
2508 gfc_free (lss
->shape
);
2510 gfc_cleanup_loop (&loop
);
2512 return gfc_finish_block (&block
);
2515 /* Assign a single component of a derived type constructor. */
2518 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2525 gfc_start_block (&block
);
2528 gfc_init_se (&se
, NULL
);
2529 /* Pointer component. */
2532 /* Array pointer. */
2533 if (expr
->expr_type
== EXPR_NULL
)
2534 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2537 rss
= gfc_walk_expr (expr
);
2538 se
.direct_byref
= 1;
2540 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2541 gfc_add_block_to_block (&block
, &se
.pre
);
2542 gfc_add_block_to_block (&block
, &se
.post
);
2547 /* Scalar pointers. */
2548 se
.want_pointer
= 1;
2549 gfc_conv_expr (&se
, expr
);
2550 gfc_add_block_to_block (&block
, &se
.pre
);
2551 gfc_add_modify_expr (&block
, dest
,
2552 fold_convert (TREE_TYPE (dest
), se
.expr
));
2553 gfc_add_block_to_block (&block
, &se
.post
);
2556 else if (cm
->dimension
)
2558 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2559 gfc_add_expr_to_block (&block
, tmp
);
2561 else if (expr
->ts
.type
== BT_DERIVED
)
2563 /* Nested derived type. */
2564 tmp
= gfc_trans_structure_assign (dest
, expr
);
2565 gfc_add_expr_to_block (&block
, tmp
);
2569 /* Scalar component. */
2572 gfc_init_se (&se
, NULL
);
2573 gfc_init_se (&lse
, NULL
);
2575 gfc_conv_expr (&se
, expr
);
2576 if (cm
->ts
.type
== BT_CHARACTER
)
2577 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2579 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
.type
);
2580 gfc_add_expr_to_block (&block
, tmp
);
2582 return gfc_finish_block (&block
);
2585 /* Assign a derived type constructor to a variable. */
2588 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2596 gfc_start_block (&block
);
2597 cm
= expr
->ts
.derived
->components
;
2598 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2600 /* Skip absent members in default initializers. */
2604 field
= cm
->backend_decl
;
2605 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
2606 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
2607 gfc_add_expr_to_block (&block
, tmp
);
2609 return gfc_finish_block (&block
);
2612 /* Build an expression for a constructor. If init is nonzero then
2613 this is part of a static variable initializer. */
2616 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
2623 VEC(constructor_elt
,gc
) *v
= NULL
;
2625 gcc_assert (se
->ss
== NULL
);
2626 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
2627 type
= gfc_typenode_for_spec (&expr
->ts
);
2631 /* Create a temporary variable and fill it in. */
2632 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
2633 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
2634 gfc_add_expr_to_block (&se
->pre
, tmp
);
2638 cm
= expr
->ts
.derived
->components
;
2639 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2641 /* Skip absent members in default initializers. */
2645 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
2646 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
2648 /* Append it to the constructor list. */
2649 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
2651 se
->expr
= build_constructor (type
, v
);
2655 /* Translate a substring expression. */
2658 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
2664 gcc_assert (ref
->type
== REF_SUBSTRING
);
2666 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
2667 expr
->value
.character
.string
);
2668 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
2669 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
2671 gfc_conv_substring(se
,ref
,expr
->ts
.kind
);
2675 /* Entry point for expression translation. Evaluates a scalar quantity.
2676 EXPR is the expression to be translated, and SE is the state structure if
2677 called from within the scalarized. */
2680 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
2682 if (se
->ss
&& se
->ss
->expr
== expr
2683 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
2685 /* Substitute a scalar expression evaluated outside the scalarization
2687 se
->expr
= se
->ss
->data
.scalar
.expr
;
2688 se
->string_length
= se
->ss
->string_length
;
2689 gfc_advance_se_ss_chain (se
);
2693 switch (expr
->expr_type
)
2696 gfc_conv_expr_op (se
, expr
);
2700 gfc_conv_function_expr (se
, expr
);
2704 gfc_conv_constant (se
, expr
);
2708 gfc_conv_variable (se
, expr
);
2712 se
->expr
= null_pointer_node
;
2715 case EXPR_SUBSTRING
:
2716 gfc_conv_substring_expr (se
, expr
);
2719 case EXPR_STRUCTURE
:
2720 gfc_conv_structure (se
, expr
, 0);
2724 gfc_conv_array_constructor_expr (se
, expr
);
2733 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2734 of an assignment. */
2736 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
2738 gfc_conv_expr (se
, expr
);
2739 /* All numeric lvalues should have empty post chains. If not we need to
2740 figure out a way of rewriting an lvalue so that it has no post chain. */
2741 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
2744 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2745 numeric expressions. Used for scalar values where inserting cleanup code
2748 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
2752 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
2753 gfc_conv_expr (se
, expr
);
2756 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2757 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
2759 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2763 /* Helper to translate and expression and convert it to a particular type. */
2765 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
2767 gfc_conv_expr_val (se
, expr
);
2768 se
->expr
= convert (type
, se
->expr
);
2772 /* Converts an expression so that it can be passed by reference. Scalar
2776 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
2780 if (se
->ss
&& se
->ss
->expr
== expr
2781 && se
->ss
->type
== GFC_SS_REFERENCE
)
2783 se
->expr
= se
->ss
->data
.scalar
.expr
;
2784 se
->string_length
= se
->ss
->string_length
;
2785 gfc_advance_se_ss_chain (se
);
2789 if (expr
->ts
.type
== BT_CHARACTER
)
2791 gfc_conv_expr (se
, expr
);
2792 gfc_conv_string_parameter (se
);
2796 if (expr
->expr_type
== EXPR_VARIABLE
)
2798 se
->want_pointer
= 1;
2799 gfc_conv_expr (se
, expr
);
2802 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2803 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
2804 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2810 gfc_conv_expr (se
, expr
);
2812 /* Create a temporary var to hold the value. */
2813 if (TREE_CONSTANT (se
->expr
))
2815 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (se
->expr
));
2816 DECL_INITIAL (var
) = se
->expr
;
2821 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2822 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
2824 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2826 /* Take the address of that value. */
2827 se
->expr
= build_fold_addr_expr (var
);
2832 gfc_trans_pointer_assign (gfc_code
* code
)
2834 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
2838 /* Generate code for a pointer assignment. */
2841 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
2851 gfc_start_block (&block
);
2853 gfc_init_se (&lse
, NULL
);
2855 lss
= gfc_walk_expr (expr1
);
2856 rss
= gfc_walk_expr (expr2
);
2857 if (lss
== gfc_ss_terminator
)
2859 /* Scalar pointers. */
2860 lse
.want_pointer
= 1;
2861 gfc_conv_expr (&lse
, expr1
);
2862 gcc_assert (rss
== gfc_ss_terminator
);
2863 gfc_init_se (&rse
, NULL
);
2864 rse
.want_pointer
= 1;
2865 gfc_conv_expr (&rse
, expr2
);
2866 gfc_add_block_to_block (&block
, &lse
.pre
);
2867 gfc_add_block_to_block (&block
, &rse
.pre
);
2868 gfc_add_modify_expr (&block
, lse
.expr
,
2869 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
2870 gfc_add_block_to_block (&block
, &rse
.post
);
2871 gfc_add_block_to_block (&block
, &lse
.post
);
2875 /* Array pointer. */
2876 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2877 switch (expr2
->expr_type
)
2880 /* Just set the data pointer to null. */
2881 gfc_conv_descriptor_data_set (&block
, lse
.expr
, null_pointer_node
);
2885 /* Assign directly to the pointer's descriptor. */
2886 lse
.direct_byref
= 1;
2887 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2891 /* Assign to a temporary descriptor and then copy that
2892 temporary to the pointer. */
2894 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
2897 lse
.direct_byref
= 1;
2898 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2899 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
2902 gfc_add_block_to_block (&block
, &lse
.pre
);
2903 gfc_add_block_to_block (&block
, &lse
.post
);
2905 return gfc_finish_block (&block
);
2909 /* Makes sure se is suitable for passing as a function string parameter. */
2910 /* TODO: Need to check all callers fo this function. It may be abused. */
2913 gfc_conv_string_parameter (gfc_se
* se
)
2917 if (TREE_CODE (se
->expr
) == STRING_CST
)
2919 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2923 type
= TREE_TYPE (se
->expr
);
2924 if (TYPE_STRING_FLAG (type
))
2926 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
2927 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2930 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
2931 gcc_assert (se
->string_length
2932 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
2936 /* Generate code for assignment of scalar variables. Includes character
2940 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, bt type
)
2944 gfc_init_block (&block
);
2946 if (type
== BT_CHARACTER
)
2948 gcc_assert (lse
->string_length
!= NULL_TREE
2949 && rse
->string_length
!= NULL_TREE
);
2951 gfc_conv_string_parameter (lse
);
2952 gfc_conv_string_parameter (rse
);
2954 gfc_add_block_to_block (&block
, &lse
->pre
);
2955 gfc_add_block_to_block (&block
, &rse
->pre
);
2957 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
2958 rse
->string_length
, rse
->expr
);
2962 gfc_add_block_to_block (&block
, &lse
->pre
);
2963 gfc_add_block_to_block (&block
, &rse
->pre
);
2965 gfc_add_modify_expr (&block
, lse
->expr
,
2966 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
2969 gfc_add_block_to_block (&block
, &lse
->post
);
2970 gfc_add_block_to_block (&block
, &rse
->post
);
2972 return gfc_finish_block (&block
);
2976 /* Try to translate array(:) = func (...), where func is a transformational
2977 array function, without using a temporary. Returns NULL is this isn't the
2981 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
2986 bool seen_array_ref
;
2988 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2989 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
2992 /* Elemental functions don't need a temporary anyway. */
2993 if (expr2
->value
.function
.esym
!= NULL
2994 && expr2
->value
.function
.esym
->attr
.elemental
)
2997 /* Fail if EXPR1 can't be expressed as a descriptor. */
2998 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3001 /* Functions returning pointers need temporaries. */
3002 if (expr2
->symtree
->n
.sym
->attr
.pointer
3003 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3006 /* Check that no LHS component references appear during an array
3007 reference. This is needed because we do not have the means to
3008 span any arbitrary stride with an array descriptor. This check
3009 is not needed for the rhs because the function result has to be
3011 seen_array_ref
= false;
3012 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3014 if (ref
->type
== REF_ARRAY
)
3015 seen_array_ref
= true;
3016 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3020 /* Check for a dependency. */
3021 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3022 expr2
->value
.function
.esym
,
3023 expr2
->value
.function
.actual
))
3026 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3028 gcc_assert (expr2
->value
.function
.isym
3029 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3030 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3032 ss
= gfc_walk_expr (expr1
);
3033 gcc_assert (ss
!= gfc_ss_terminator
);
3034 gfc_init_se (&se
, NULL
);
3035 gfc_start_block (&se
.pre
);
3036 se
.want_pointer
= 1;
3038 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3040 se
.direct_byref
= 1;
3041 se
.ss
= gfc_walk_expr (expr2
);
3042 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3043 gfc_conv_function_expr (&se
, expr2
);
3044 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3046 return gfc_finish_block (&se
.pre
);
3050 /* Translate an assignment. Most of the code is concerned with
3051 setting up the scalarizer. */
3054 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3059 gfc_ss
*lss_section
;
3066 /* Special case a single function returning an array. */
3067 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3069 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3074 /* Assignment of the form lhs = rhs. */
3075 gfc_start_block (&block
);
3077 gfc_init_se (&lse
, NULL
);
3078 gfc_init_se (&rse
, NULL
);
3081 lss
= gfc_walk_expr (expr1
);
3083 if (lss
!= gfc_ss_terminator
)
3085 /* The assignment needs scalarization. */
3088 /* Find a non-scalar SS from the lhs. */
3089 while (lss_section
!= gfc_ss_terminator
3090 && lss_section
->type
!= GFC_SS_SECTION
)
3091 lss_section
= lss_section
->next
;
3093 gcc_assert (lss_section
!= gfc_ss_terminator
);
3095 /* Initialize the scalarizer. */
3096 gfc_init_loopinfo (&loop
);
3099 rss
= gfc_walk_expr (expr2
);
3100 if (rss
== gfc_ss_terminator
)
3102 /* The rhs is scalar. Add a ss for the expression. */
3103 rss
= gfc_get_ss ();
3104 rss
->next
= gfc_ss_terminator
;
3105 rss
->type
= GFC_SS_SCALAR
;
3108 /* Associate the SS with the loop. */
3109 gfc_add_ss_to_loop (&loop
, lss
);
3110 gfc_add_ss_to_loop (&loop
, rss
);
3112 /* Calculate the bounds of the scalarization. */
3113 gfc_conv_ss_startstride (&loop
);
3114 /* Resolve any data dependencies in the statement. */
3115 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3116 /* Setup the scalarizing loops. */
3117 gfc_conv_loop_setup (&loop
);
3119 /* Setup the gfc_se structures. */
3120 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3121 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3124 gfc_mark_ss_chain_used (rss
, 1);
3125 if (loop
.temp_ss
== NULL
)
3128 gfc_mark_ss_chain_used (lss
, 1);
3132 lse
.ss
= loop
.temp_ss
;
3133 gfc_mark_ss_chain_used (lss
, 3);
3134 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3137 /* Start the scalarized loop body. */
3138 gfc_start_scalarized_body (&loop
, &body
);
3141 gfc_init_block (&body
);
3143 /* Translate the expression. */
3144 gfc_conv_expr (&rse
, expr2
);
3146 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
3148 gfc_conv_tmp_array_ref (&lse
);
3149 gfc_advance_se_ss_chain (&lse
);
3152 gfc_conv_expr (&lse
, expr1
);
3154 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
3155 gfc_add_expr_to_block (&body
, tmp
);
3157 if (lss
== gfc_ss_terminator
)
3159 /* Use the scalar assignment as is. */
3160 gfc_add_block_to_block (&block
, &body
);
3164 gcc_assert (lse
.ss
== gfc_ss_terminator
3165 && rse
.ss
== gfc_ss_terminator
);
3167 if (loop
.temp_ss
!= NULL
)
3169 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3171 /* We need to copy the temporary to the actual lhs. */
3172 gfc_init_se (&lse
, NULL
);
3173 gfc_init_se (&rse
, NULL
);
3174 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3175 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3177 rse
.ss
= loop
.temp_ss
;
3180 gfc_conv_tmp_array_ref (&rse
);
3181 gfc_advance_se_ss_chain (&rse
);
3182 gfc_conv_expr (&lse
, expr1
);
3184 gcc_assert (lse
.ss
== gfc_ss_terminator
3185 && rse
.ss
== gfc_ss_terminator
);
3187 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
3188 gfc_add_expr_to_block (&body
, tmp
);
3190 /* Generate the copying loops. */
3191 gfc_trans_scalarizing_loops (&loop
, &body
);
3193 /* Wrap the whole thing up. */
3194 gfc_add_block_to_block (&block
, &loop
.pre
);
3195 gfc_add_block_to_block (&block
, &loop
.post
);
3197 gfc_cleanup_loop (&loop
);
3200 return gfc_finish_block (&block
);
3204 gfc_trans_assign (gfc_code
* code
)
3206 return gfc_trans_assignment (code
->expr
, code
->expr2
);