1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004 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, 59 Temple Place - Suite 330, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
34 #include "tree-gimple.h"
40 #include "trans-const.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
53 dest
->loop
= src
->loop
;
57 /* Initialise a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
66 memset (se
, 0, sizeof (gfc_se
));
67 gfc_init_block (&se
->pre
);
68 gfc_init_block (&se
->post
);
73 gfc_copy_se_loopvars (se
, parent
);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parent needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se
* se
)
86 assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
89 /* Walk down the parent chain. */
92 /* Simple consistancy check. */
93 assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se
* se
)
110 if (TREE_CODE_CLASS (TREE_CODE (se
->expr
)) == 'c')
113 /* we need a temporary for this result */
114 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
115 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
120 /* Return an expression which determines if a dummy parameter is present. */
123 gfc_conv_expr_present (gfc_symbol
* sym
)
127 assert (sym
->attr
.dummy
&& sym
->attr
.optional
);
129 decl
= gfc_get_symbol_decl (sym
);
130 if (TREE_CODE (decl
) != PARM_DECL
)
132 /* Array parameters use a temporary descriptor, we want the real
134 assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
135 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
136 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
138 return build (NE_EXPR
, boolean_type_node
, decl
, null_pointer_node
);
142 /* Generate code to initialize a string length variable. Returns the
146 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
151 gfc_init_se (&se
, NULL
);
152 gfc_conv_expr_type (&se
, cl
->length
, gfc_strlen_type_node
);
153 gfc_add_block_to_block (pblock
, &se
.pre
);
155 tmp
= cl
->backend_decl
;
156 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
160 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
)
168 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
169 type
= build_pointer_type (type
);
172 gfc_init_se (&start
, se
);
173 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_strlen_type_node
);
174 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
176 if (integer_onep (start
.expr
))
178 gfc_conv_string_parameter (se
);
182 /* Change the start of the string. */
183 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
186 tmp
= gfc_build_indirect_ref (se
->expr
);
187 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
188 se
->expr
= gfc_build_addr_expr (type
, tmp
);
191 /* Length = end + 1 - start. */
192 gfc_init_se (&end
, se
);
193 if (ref
->u
.ss
.end
== NULL
)
194 end
.expr
= se
->string_length
;
197 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_strlen_type_node
);
198 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
201 build (MINUS_EXPR
, gfc_strlen_type_node
, integer_one_node
, start
.expr
);
202 tmp
= build (PLUS_EXPR
, gfc_strlen_type_node
, end
.expr
, tmp
);
203 se
->string_length
= fold (tmp
);
207 /* Convert a derived type component reference. */
210 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
217 c
= ref
->u
.c
.component
;
219 assert (c
->backend_decl
);
221 field
= c
->backend_decl
;
222 assert (TREE_CODE (field
) == FIELD_DECL
);
224 tmp
= build (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
);
228 if (c
->ts
.type
== BT_CHARACTER
)
230 tmp
= c
->ts
.cl
->backend_decl
;
232 if (!INTEGER_CST_P (tmp
))
233 gfc_todo_error ("Unknown length character component");
234 se
->string_length
= tmp
;
237 if (c
->pointer
&& c
->dimension
== 0)
238 se
->expr
= gfc_build_indirect_ref (se
->expr
);
242 /* Return the contents of a variable. Also handles reference/pointer
243 variables (all Fortran pointer references are implicit). */
246 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
251 sym
= expr
->symtree
->n
.sym
;
254 /* Check that something hasn't gone horribly wrong. */
255 assert (se
->ss
!= gfc_ss_terminator
);
256 assert (se
->ss
->expr
== expr
);
258 /* A scalarized term. We already know the descriptor. */
259 se
->expr
= se
->ss
->data
.info
.descriptor
;
260 ref
= se
->ss
->data
.info
.ref
;
264 se
->expr
= gfc_get_symbol_decl (sym
);
266 /* Procedure actual arguments. */
267 if (sym
->attr
.flavor
== FL_PROCEDURE
268 && se
->expr
!= current_function_decl
)
270 assert (se
->want_pointer
);
271 if (!sym
->attr
.dummy
)
273 assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
274 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
279 /* Special case for assigning the return value of a function.
280 Self recursive functions must have an explicit return value. */
281 if (se
->expr
== current_function_decl
&& sym
->attr
.function
282 && (sym
->result
== sym
))
284 se
->expr
= gfc_get_fake_result_decl (sym
);
287 /* Dereference scalar dummy variables. */
289 && sym
->ts
.type
!= BT_CHARACTER
290 && !sym
->attr
.dimension
)
291 se
->expr
= gfc_build_indirect_ref (se
->expr
);
293 /* Dereference pointer variables. */
294 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
297 || sym
->attr
.function
298 || !sym
->attr
.dimension
)
299 && sym
->ts
.type
!= BT_CHARACTER
)
300 se
->expr
= gfc_build_indirect_ref (se
->expr
);
305 /* For character variables, also get the length. */
306 if (sym
->ts
.type
== BT_CHARACTER
)
308 se
->string_length
= sym
->ts
.cl
->backend_decl
;
309 assert (se
->string_length
);
317 /* Return the descriptor if that's what we want and this is an array
318 section reference. */
319 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
321 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
322 /* Return the descriptor for array pointers and allocations. */
324 && ref
->next
== NULL
&& (se
->descriptor_only
))
327 gfc_conv_array_ref (se
, &ref
->u
.ar
);
328 /* Return a pointer to an element. */
332 gfc_conv_component_ref (se
, ref
);
336 gfc_conv_substring (se
, ref
, expr
->ts
.kind
);
345 /* Pointer assignment, allocation or pass by reference. Arrays are handled
347 if (se
->want_pointer
)
349 if (expr
->ts
.type
== BT_CHARACTER
)
350 gfc_conv_string_parameter (se
);
352 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
355 gfc_advance_se_ss_chain (se
);
359 /* Unary ops are easy... Or they would be if ! was a valid op. */
362 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
367 assert (expr
->ts
.type
!= BT_CHARACTER
);
368 /* Initialize the operand. */
369 gfc_init_se (&operand
, se
);
370 gfc_conv_expr_val (&operand
, expr
->op1
);
371 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
373 type
= gfc_typenode_for_spec (&expr
->ts
);
375 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
376 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
377 All other unary operators have an equivalent GIMPLE unary operator */
378 if (code
== TRUTH_NOT_EXPR
)
379 se
->expr
= build (EQ_EXPR
, type
, operand
.expr
, integer_zero_node
);
381 se
->expr
= build1 (code
, type
, operand
.expr
);
385 /* Expand power operator to optimal multiplications when a value is raised
386 to an constant integer n. See section 4.6.3, "Evaluation of Powers" of
387 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
388 Programming", 3rd Edition, 1998. */
390 /* This code is mostly duplicated from expand_powi in the backend.
391 We establish the "optimal power tree" lookup table with the defined size.
392 The items in the table are the exponents used to calculate the index
393 exponents. Any integer n less than the value can get an "addition chain",
394 with the first node being one. */
395 #define POWI_TABLE_SIZE 256
397 /* The table is from Builtins.c. */
398 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
400 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
401 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
402 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
403 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
404 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
405 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
406 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
407 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
408 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
409 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
410 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
411 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
412 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
413 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
414 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
415 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
416 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
417 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
418 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
419 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
420 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
421 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
422 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
423 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
424 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
425 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
426 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
427 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
428 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
429 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
430 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
431 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
434 /* If n is larger than lookup table's max index, we use "window method". */
435 #define POWI_WINDOW_SIZE 3
437 /* Recursive function to expand power operator. The temporary values are put
438 in tmpvar. The function return tmpvar[1] ** n. */
440 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
447 if (n
< POWI_TABLE_SIZE
)
452 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
453 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
457 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
458 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
459 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
463 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
467 tmp
= fold (build (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
));
468 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
470 if (n
< POWI_TABLE_SIZE
)
476 /* Expand lhs ** rhs. rhs is an constant integer. If expand successfully,
477 return 1. Else return 0 and will call runtime library functions. */
479 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
484 tree vartmp
[POWI_TABLE_SIZE
];
488 type
= TREE_TYPE (lhs
);
489 n
= abs (TREE_INT_CST_LOW (rhs
));
490 sgn
= tree_int_cst_sgn (rhs
);
492 if ((!flag_unsafe_math_optimizations
|| optimize_size
) && (n
> 2 || n
< -1))
498 se
->expr
= gfc_build_const (type
, integer_one_node
);
501 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
502 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
504 tmp
= build (EQ_EXPR
, boolean_type_node
, lhs
,
505 integer_minus_one_node
);
506 cond
= build (EQ_EXPR
, boolean_type_node
, lhs
,
509 /* If rhs is an even,
510 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
513 tmp
= build (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
514 se
->expr
= build (COND_EXPR
, type
, tmp
, integer_one_node
,
519 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
520 tmp
= build (COND_EXPR
, type
, tmp
, integer_minus_one_node
,
522 se
->expr
= build (COND_EXPR
, type
, cond
, integer_one_node
,
527 memset (vartmp
, 0, sizeof (vartmp
));
530 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
533 tmp
= gfc_build_const (type
, integer_one_node
);
534 se
->expr
= build (RDIV_EXPR
, type
, tmp
, se
->expr
);
540 /* Power op (**). Constant integer exponent has special handling. */
543 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
552 gfc_init_se (&lse
, se
);
553 gfc_conv_expr_val (&lse
, expr
->op1
);
554 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
556 gfc_init_se (&rse
, se
);
557 gfc_conv_expr_val (&rse
, expr
->op2
);
558 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
560 if (expr
->op2
->ts
.type
== BT_INTEGER
561 && expr
->op2
->expr_type
== EXPR_CONSTANT
)
562 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
565 kind
= expr
->op1
->ts
.kind
;
566 switch (expr
->op2
->ts
.type
)
569 ikind
= expr
->op2
->ts
.kind
;
574 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
592 if (expr
->op1
->ts
.type
== BT_INTEGER
)
593 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
610 switch (expr
->op1
->ts
.type
)
613 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
617 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
621 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
633 fndecl
= built_in_decls
[BUILT_IN_POWF
];
636 fndecl
= built_in_decls
[BUILT_IN_POW
];
647 fndecl
= gfor_fndecl_math_cpowf
;
650 fndecl
= gfor_fndecl_math_cpow
;
662 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
663 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
664 se
->expr
= fold (gfc_build_function_call (fndecl
, tmp
));
668 /* Generate code to allocate a string temporary. */
671 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
677 if (gfc_can_put_var_on_stack (len
))
679 /* Create a temporary variable to hold the result. */
680 tmp
= fold (build (MINUS_EXPR
, TREE_TYPE (len
), len
, integer_one_node
));
681 tmp
= build_range_type (gfc_array_index_type
, integer_zero_node
, tmp
);
682 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
683 var
= gfc_create_var (tmp
, "str");
684 var
= gfc_build_addr_expr (type
, var
);
688 /* Allocate a temporary to hold the result. */
689 var
= gfc_create_var (type
, "pstr");
690 args
= gfc_chainon_list (NULL_TREE
, len
);
691 tmp
= gfc_build_function_call (gfor_fndecl_internal_malloc
, args
);
692 tmp
= convert (type
, tmp
);
693 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
695 /* Free the temporary afterwards. */
696 tmp
= convert (pvoid_type_node
, var
);
697 args
= gfc_chainon_list (NULL_TREE
, tmp
);
698 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
699 gfc_add_expr_to_block (&se
->post
, tmp
);
706 /* Handle a string concatenation operation. A temporary will be allocated to
710 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
720 assert (expr
->op1
->ts
.type
== BT_CHARACTER
721 && expr
->op2
->ts
.type
== BT_CHARACTER
);
723 gfc_init_se (&lse
, se
);
724 gfc_conv_expr (&lse
, expr
->op1
);
725 gfc_conv_string_parameter (&lse
);
726 gfc_init_se (&rse
, se
);
727 gfc_conv_expr (&rse
, expr
->op2
);
728 gfc_conv_string_parameter (&rse
);
730 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
731 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
733 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
734 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
735 if (len
== NULL_TREE
)
737 len
= fold (build (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
738 lse
.string_length
, rse
.string_length
));
741 type
= build_pointer_type (type
);
743 var
= gfc_conv_string_tmp (se
, type
, len
);
745 /* Do the actual concatenation. */
747 args
= gfc_chainon_list (args
, len
);
748 args
= gfc_chainon_list (args
, var
);
749 args
= gfc_chainon_list (args
, lse
.string_length
);
750 args
= gfc_chainon_list (args
, lse
.expr
);
751 args
= gfc_chainon_list (args
, rse
.string_length
);
752 args
= gfc_chainon_list (args
, rse
.expr
);
753 tmp
= gfc_build_function_call (gfor_fndecl_concat_string
, args
);
754 gfc_add_expr_to_block (&se
->pre
, tmp
);
756 /* Add the cleanup for the operands. */
757 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
758 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
761 se
->string_length
= len
;
765 /* Translates an op expression. Common (binary) cases are handled by this
766 function, others are passed on. Recursion is used in either case.
767 We use the fact that (op1.ts == op2.ts) (except for the power
769 Operators need no special handling for scalarized expressions as long as
770 they call gfc_conv_siple_val to get their operands.
771 Character strings get special handling. */
774 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
786 switch (expr
->operator)
788 case INTRINSIC_UPLUS
:
789 gfc_conv_expr (se
, expr
->op1
);
792 case INTRINSIC_UMINUS
:
793 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
797 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
804 case INTRINSIC_MINUS
:
808 case INTRINSIC_TIMES
:
812 case INTRINSIC_DIVIDE
:
813 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
814 an integer, we must round towards zero, so we use a
816 if (expr
->ts
.type
== BT_INTEGER
)
817 code
= TRUNC_DIV_EXPR
;
822 case INTRINSIC_POWER
:
823 gfc_conv_power_op (se
, expr
);
826 case INTRINSIC_CONCAT
:
827 gfc_conv_concat_op (se
, expr
);
831 code
= TRUTH_ANDIF_EXPR
;
836 code
= TRUTH_ORIF_EXPR
;
840 /* EQV and NEQV only work on logicals, but since we represent them
841 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
881 case INTRINSIC_ASSIGN
:
882 /* These should be converted into function calls by the frontend. */
887 fatal_error ("Unknown intrinsic op");
891 /* The only exception to this is **, which is handled seperately anyway. */
892 assert (expr
->op1
->ts
.type
== expr
->op2
->ts
.type
);
894 if (checkstring
&& expr
->op1
->ts
.type
!= BT_CHARACTER
)
898 gfc_init_se (&lse
, se
);
899 gfc_conv_expr (&lse
, expr
->op1
);
900 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
903 gfc_init_se (&rse
, se
);
904 gfc_conv_expr (&rse
, expr
->op2
);
905 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
907 /* For string comparisons we generate a library call, and compare the return
911 gfc_conv_string_parameter (&lse
);
912 gfc_conv_string_parameter (&rse
);
914 tmp
= gfc_chainon_list (tmp
, lse
.string_length
);
915 tmp
= gfc_chainon_list (tmp
, lse
.expr
);
916 tmp
= gfc_chainon_list (tmp
, rse
.string_length
);
917 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
919 /* Build a call for the comparison. */
920 lse
.expr
= gfc_build_function_call (gfor_fndecl_compare_string
, tmp
);
921 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
923 rse
.expr
= integer_zero_node
;
926 type
= gfc_typenode_for_spec (&expr
->ts
);
930 /* The result of logical ops is always boolean_type_node. */
931 tmp
= fold (build (code
, type
, lse
.expr
, rse
.expr
));
932 se
->expr
= convert (type
, tmp
);
935 se
->expr
= fold (build (code
, type
, lse
.expr
, rse
.expr
));
938 /* Add the post blocks. */
939 gfc_add_block_to_block (&se
->post
, &rse
.post
);
940 gfc_add_block_to_block (&se
->post
, &lse
.post
);
944 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
950 tmp
= gfc_get_symbol_decl (sym
);
951 assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
952 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
958 if (!sym
->backend_decl
)
959 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
961 tmp
= sym
->backend_decl
;
962 assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
963 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
968 /* Generate code for a procedure call. Note can return se->post != NULL.
969 If se->direct_byref is set then se->expr contains the return parameter. */
972 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
973 gfc_actual_arglist
* arg
)
986 gfc_formal_arglist
*formal
;
989 stringargs
= NULL_TREE
;
995 if (!sym
->attr
.elemental
)
997 assert (se
->ss
->type
== GFC_SS_FUNCTION
);
998 if (se
->ss
->useflags
)
1000 assert (gfc_return_by_reference (sym
)
1001 && sym
->result
->attr
.dimension
);
1002 assert (se
->loop
!= NULL
);
1004 /* Access the previously obtained result. */
1005 gfc_conv_tmp_array_ref (se
);
1006 gfc_advance_se_ss_chain (se
);
1010 info
= &se
->ss
->data
.info
;
1015 byref
= gfc_return_by_reference (sym
);
1018 if (se
->direct_byref
)
1019 arglist
= gfc_chainon_list (arglist
, se
->expr
);
1020 else if (sym
->result
->attr
.dimension
)
1022 assert (se
->loop
&& se
->ss
);
1023 /* Set the type of the array. */
1024 tmp
= gfc_typenode_for_spec (&sym
->ts
);
1025 info
->dimen
= se
->loop
->dimen
;
1026 /* Allocate a temporary to store the result. */
1027 gfc_trans_allocate_temp_array (se
->loop
, info
, tmp
, NULL_TREE
);
1029 /* Zero the first stride to indicate a temporary. */
1031 gfc_conv_descriptor_stride (info
->descriptor
, gfc_rank_cst
[0]);
1032 gfc_add_modify_expr (&se
->pre
, tmp
, integer_zero_node
);
1033 /* Pass the temporary as the first argument. */
1034 tmp
= info
->descriptor
;
1035 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1036 arglist
= gfc_chainon_list (arglist
, tmp
);
1038 else if (sym
->ts
.type
== BT_CHARACTER
)
1040 assert (sym
->ts
.cl
&& sym
->ts
.cl
->length
1041 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1042 len
= gfc_conv_mpz_to_tree
1043 (sym
->ts
.cl
->length
->value
.integer
, sym
->ts
.cl
->length
->ts
.kind
);
1044 sym
->ts
.cl
->backend_decl
= len
;
1045 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
1046 type
= build_pointer_type (type
);
1048 var
= gfc_conv_string_tmp (se
, type
, len
);
1049 arglist
= gfc_chainon_list (arglist
, var
);
1050 arglist
= gfc_chainon_list (arglist
, convert (gfc_strlen_type_node
,
1053 else /* TODO: derived type function return values. */
1057 formal
= sym
->formal
;
1058 /* Evaluate the arguments. */
1059 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1061 if (arg
->expr
== NULL
)
1064 if (se
->ignore_optional
)
1066 /* Some intrinsics have already been resolved to the correct
1070 else if (arg
->label
)
1072 has_alternate_specifier
= 1;
1077 /* Pass a NULL pointer for an absent arg. */
1078 gfc_init_se (&parmse
, NULL
);
1079 parmse
.expr
= null_pointer_node
;
1080 if (arg
->missing_arg_type
== BT_CHARACTER
)
1082 stringargs
= gfc_chainon_list (stringargs
,
1083 convert (gfc_strlen_type_node
, integer_zero_node
));
1087 else if (se
->ss
&& se
->ss
->useflags
)
1089 /* An elemental function inside a scalarized loop. */
1090 gfc_init_se (&parmse
, se
);
1091 gfc_conv_expr_reference (&parmse
, arg
->expr
);
1095 /* A scalar or transformational function. */
1096 gfc_init_se (&parmse
, NULL
);
1097 argss
= gfc_walk_expr (arg
->expr
);
1099 if (argss
== gfc_ss_terminator
)
1101 gfc_conv_expr_reference (&parmse
, arg
->expr
);
1102 if (formal
&& formal
->sym
->attr
.pointer
)
1104 /* Scalar pointer dummy args require an extra level of
1106 parmse
.expr
= gfc_build_addr_expr (NULL
, parmse
.expr
);
1111 /* If the procedure requires explicit interface, actual argument
1112 is passed according to corresponing formal argument. We
1113 do not use g77 method and the address of array descriptor
1114 is passed if corresponing formal is pointer or
1115 assumed-shape, Otherwise use g77 method. */
1117 f
= (formal
!= NULL
)
1118 && !formal
->sym
->attr
.pointer
1119 && formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
;
1120 f
= f
|| !sym
->attr
.always_explicit
;
1121 gfc_conv_array_parameter (&parmse
, arg
->expr
, argss
, f
);
1125 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
1126 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
1128 /* Character strings are passed as two paramarers, a length and a
1130 if (parmse
.string_length
!= NULL_TREE
)
1131 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
1133 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
1136 /* Add the hidden string length parameters to the arguments. */
1137 arglist
= chainon (arglist
, stringargs
);
1139 /* Generate the actual call. */
1140 gfc_conv_function_val (se
, sym
);
1141 /* If there are alternate return labels, function type should be
1143 if (has_alternate_specifier
)
1144 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
1146 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
1147 se
->expr
= build (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
1148 arglist
, NULL_TREE
);
1150 /* A pure function may still have side-effects - it may modify its
1152 TREE_SIDE_EFFECTS (se
->expr
) = 1;
1154 if (!sym
->attr
.pure
)
1155 TREE_SIDE_EFFECTS (se
->expr
) = 1;
1158 if (byref
&& !se
->direct_byref
)
1160 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
1162 if (sym
->result
->attr
.dimension
)
1164 if (flag_bounds_check
)
1166 /* Check the data pointer hasn't been modified. This would happen
1167 in a function returning a pointer. */
1168 tmp
= gfc_conv_descriptor_data (info
->descriptor
);
1169 tmp
= build (NE_EXPR
, boolean_type_node
, tmp
, info
->data
);
1170 gfc_trans_runtime_check (tmp
, gfc_strconst_fault
, &se
->pre
);
1172 se
->expr
= info
->descriptor
;
1174 else if (sym
->ts
.type
== BT_CHARACTER
)
1177 se
->string_length
= len
;
1185 /* Generate code to copy a string. */
1188 gfc_trans_string_copy (stmtblock_t
* block
, tree dlen
, tree dest
,
1189 tree slen
, tree src
)
1194 tmp
= gfc_chainon_list (tmp
, dlen
);
1195 tmp
= gfc_chainon_list (tmp
, dest
);
1196 tmp
= gfc_chainon_list (tmp
, slen
);
1197 tmp
= gfc_chainon_list (tmp
, src
);
1198 tmp
= gfc_build_function_call (gfor_fndecl_copy_string
, tmp
);
1199 gfc_add_expr_to_block (block
, tmp
);
1203 /* Translate a statement function.
1204 The value of a statement function reference is obtained by evaluating the
1205 expression using the values of the actual arguments for the values of the
1206 corresponding dummy arguments. */
1209 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
1213 gfc_formal_arglist
*fargs
;
1214 gfc_actual_arglist
*args
;
1217 gfc_saved_var
*saved_vars
;
1223 sym
= expr
->symtree
->n
.sym
;
1224 args
= expr
->value
.function
.actual
;
1225 gfc_init_se (&lse
, NULL
);
1226 gfc_init_se (&rse
, NULL
);
1229 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
1231 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
1232 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
1234 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1236 /* Each dummy shall be specified, explicitly or implicitly, to be
1238 assert (fargs
->sym
->attr
.dimension
== 0);
1241 /* Create a temporary to hold the value. */
1242 type
= gfc_typenode_for_spec (&fsym
->ts
);
1243 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
1245 if (fsym
->ts
.type
== BT_CHARACTER
)
1247 /* Copy string arguments. */
1250 assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
1251 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1253 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1254 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
1257 gfc_conv_expr (&rse
, args
->expr
);
1258 gfc_conv_string_parameter (&rse
);
1259 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1260 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1262 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
1264 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1265 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1269 /* For everything else, just evaluate the expression. */
1270 gfc_conv_expr (&lse
, args
->expr
);
1272 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1273 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
1274 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1280 /* Use the temporary variables in place of the real ones. */
1281 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1282 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
1284 gfc_conv_expr (se
, sym
->value
);
1286 if (sym
->ts
.type
== BT_CHARACTER
)
1288 gfc_conv_const_charlen (sym
->ts
.cl
);
1290 /* Force the expression to the correct length. */
1291 if (!INTEGER_CST_P (se
->string_length
)
1292 || tree_int_cst_lt (se
->string_length
,
1293 sym
->ts
.cl
->backend_decl
))
1295 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
1296 tmp
= gfc_create_var (type
, sym
->name
);
1297 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
1298 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
1299 se
->string_length
, se
->expr
);
1302 se
->string_length
= sym
->ts
.cl
->backend_decl
;
1305 /* Resore the original variables. */
1306 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1307 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
1308 gfc_free (saved_vars
);
1312 /* Translate a function expression. */
1315 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
1319 if (expr
->value
.function
.isym
)
1321 gfc_conv_intrinsic_function (se
, expr
);
1325 /* We distinguish the statement function from general function to improve
1326 runtime performance. */
1327 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1329 gfc_conv_statement_function (se
, expr
);
1333 /* expr.value.function.esym is the resolved (specific) function symbol for
1334 most functions. However this isn't set for dummy procedures. */
1335 sym
= expr
->value
.function
.esym
;
1337 sym
= expr
->symtree
->n
.sym
;
1338 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1342 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
1344 assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1345 assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
1347 gfc_conv_tmp_array_ref (se
);
1348 gfc_advance_se_ss_chain (se
);
1353 /* Build an expression for a constructor. If init is nonzero then
1354 this is part of a static variable initializer. */
1357 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
1368 assert (expr
->expr_type
== EXPR_STRUCTURE
);
1369 type
= gfc_typenode_for_spec (&expr
->ts
);
1370 head
= build1 (CONSTRUCTOR
, type
, NULL_TREE
);
1373 cm
= expr
->ts
.derived
->components
;
1374 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
1376 /* Skip absent members in default initializers. */
1380 gfc_init_se (&cse
, se
);
1381 /* Evaluate the expression for this component. */
1386 arraytype
= TREE_TYPE (cm
->backend_decl
);
1387 cse
.expr
= gfc_conv_array_initializer (arraytype
, c
->expr
);
1389 else if (cm
->ts
.type
== BT_DERIVED
)
1390 gfc_conv_structure (&cse
, c
->expr
, 1);
1392 gfc_conv_expr (&cse
, c
->expr
);
1396 gfc_conv_expr (&cse
, c
->expr
);
1397 gfc_add_block_to_block (&se
->pre
, &cse
.pre
);
1398 gfc_add_block_to_block (&se
->post
, &cse
.post
);
1401 /* Build a TREE_CHAIN to hold it. */
1402 val
= tree_cons (cm
->backend_decl
, cse
.expr
, NULL_TREE
);
1404 /* Add it to the list. */
1405 if (tail
== NULL_TREE
)
1406 TREE_OPERAND(head
, 0) = tail
= val
;
1409 TREE_CHAIN (tail
) = val
;
1417 /*translate a substring expression */
1420 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
1426 assert(ref
->type
== REF_SUBSTRING
);
1428 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
1429 expr
->value
.character
.string
);
1430 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
1431 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
1433 gfc_conv_substring(se
,ref
,expr
->ts
.kind
);
1437 /* Entry point for expression translation. */
1440 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
1442 if (se
->ss
&& se
->ss
->expr
== expr
1443 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
1445 /* Substiture a scalar expression evaluated outside the scalarization
1447 se
->expr
= se
->ss
->data
.scalar
.expr
;
1448 se
->string_length
= se
->ss
->data
.scalar
.string_length
;
1449 gfc_advance_se_ss_chain (se
);
1453 switch (expr
->expr_type
)
1456 gfc_conv_expr_op (se
, expr
);
1460 gfc_conv_function_expr (se
, expr
);
1464 gfc_conv_constant (se
, expr
);
1468 gfc_conv_variable (se
, expr
);
1472 se
->expr
= null_pointer_node
;
1475 case EXPR_SUBSTRING
:
1476 gfc_conv_substring_expr (se
, expr
);
1479 case EXPR_STRUCTURE
:
1480 gfc_conv_structure (se
, expr
, 0);
1484 gfc_conv_array_constructor_expr (se
, expr
);
1494 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
1496 gfc_conv_expr (se
, expr
);
1497 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1498 figure out a way of rewriting an lvalue so that it has no post chain. */
1499 assert (expr
->ts
.type
!= BT_CHARACTER
|| !se
->post
.head
);
1503 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
1507 assert (expr
->ts
.type
!= BT_CHARACTER
);
1508 gfc_conv_expr (se
, expr
);
1511 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1512 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
1517 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
1519 gfc_conv_expr_val (se
, expr
);
1520 se
->expr
= convert (type
, se
->expr
);
1524 /* Converts an expression so that it can be passed by refernece. Scalar
1528 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
1532 if (se
->ss
&& se
->ss
->expr
== expr
1533 && se
->ss
->type
== GFC_SS_REFERENCE
)
1535 se
->expr
= se
->ss
->data
.scalar
.expr
;
1536 se
->string_length
= se
->ss
->data
.scalar
.string_length
;
1537 gfc_advance_se_ss_chain (se
);
1541 if (expr
->ts
.type
== BT_CHARACTER
)
1543 gfc_conv_expr (se
, expr
);
1544 gfc_conv_string_parameter (se
);
1548 if (expr
->expr_type
== EXPR_VARIABLE
)
1550 se
->want_pointer
= 1;
1551 gfc_conv_expr (se
, expr
);
1554 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1555 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
1556 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1562 gfc_conv_expr (se
, expr
);
1564 /* Create a temporary var to hold the value. */
1565 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1566 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
1567 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1569 /* Take the address of that value. */
1570 se
->expr
= gfc_build_addr_expr (NULL
, var
);
1575 gfc_trans_pointer_assign (gfc_code
* code
)
1577 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
1582 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
1591 gfc_start_block (&block
);
1593 gfc_init_se (&lse
, NULL
);
1595 lss
= gfc_walk_expr (expr1
);
1596 rss
= gfc_walk_expr (expr2
);
1597 if (lss
== gfc_ss_terminator
)
1599 lse
.want_pointer
= 1;
1600 gfc_conv_expr (&lse
, expr1
);
1601 assert (rss
== gfc_ss_terminator
);
1602 gfc_init_se (&rse
, NULL
);
1603 rse
.want_pointer
= 1;
1604 gfc_conv_expr (&rse
, expr2
);
1605 gfc_add_block_to_block (&block
, &lse
.pre
);
1606 gfc_add_block_to_block (&block
, &rse
.pre
);
1607 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
1608 gfc_add_block_to_block (&block
, &rse
.post
);
1609 gfc_add_block_to_block (&block
, &lse
.post
);
1613 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
1614 /* Implement Nullify. */
1615 if (expr2
->expr_type
== EXPR_NULL
)
1617 lse
.expr
= gfc_conv_descriptor_data (lse
.expr
);
1618 rse
.expr
= null_pointer_node
;
1619 tmp
= build_v (MODIFY_EXPR
, lse
.expr
, rse
.expr
);
1620 gfc_add_expr_to_block (&block
, tmp
);
1624 lse
.direct_byref
= 1;
1625 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
1627 gfc_add_block_to_block (&block
, &lse
.pre
);
1628 gfc_add_block_to_block (&block
, &lse
.post
);
1630 return gfc_finish_block (&block
);
1634 /* Makes sure se is suitable for passing as a function string parameter. */
1635 /* TODO: Need to check all callers fo this function. It may be abused. */
1638 gfc_conv_string_parameter (gfc_se
* se
)
1642 if (TREE_CODE (se
->expr
) == STRING_CST
)
1644 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
1648 type
= TREE_TYPE (se
->expr
);
1649 if (TYPE_STRING_FLAG (type
))
1651 assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
1652 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
1655 assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
1656 assert (se
->string_length
1657 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
1661 /* Generate code for assignment of scalar variables. Includes character
1665 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, bt type
)
1669 gfc_init_block (&block
);
1671 if (type
== BT_CHARACTER
)
1673 assert (lse
->string_length
!= NULL_TREE
1674 && rse
->string_length
!= NULL_TREE
);
1676 gfc_conv_string_parameter (lse
);
1677 gfc_conv_string_parameter (rse
);
1679 gfc_add_block_to_block (&block
, &lse
->pre
);
1680 gfc_add_block_to_block (&block
, &rse
->pre
);
1682 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
1683 rse
->string_length
, rse
->expr
);
1687 gfc_add_block_to_block (&block
, &lse
->pre
);
1688 gfc_add_block_to_block (&block
, &rse
->pre
);
1690 gfc_add_modify_expr (&block
, lse
->expr
, rse
->expr
);
1693 gfc_add_block_to_block (&block
, &lse
->post
);
1694 gfc_add_block_to_block (&block
, &rse
->post
);
1696 return gfc_finish_block (&block
);
1700 /* Try to translate array(:) = func (...), where func is a transformational
1701 array function, without using a temporary. Returns NULL is this isn't the
1705 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
1710 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1711 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
1714 /* Elemental functions don't need a temporary anyway. */
1715 if (expr2
->symtree
->n
.sym
->attr
.elemental
)
1718 /* Check for a dependency. */
1719 if (gfc_check_fncall_dependency (expr1
, expr2
))
1722 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
1724 assert (expr2
->value
.function
.isym
1725 || (gfc_return_by_reference (expr2
->symtree
->n
.sym
)
1726 && expr2
->symtree
->n
.sym
->result
->attr
.dimension
));
1728 ss
= gfc_walk_expr (expr1
);
1729 assert (ss
!= gfc_ss_terminator
);
1730 gfc_init_se (&se
, NULL
);
1731 gfc_start_block (&se
.pre
);
1732 se
.want_pointer
= 1;
1734 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
1736 se
.direct_byref
= 1;
1737 se
.ss
= gfc_walk_expr (expr2
);
1738 assert (se
.ss
!= gfc_ss_terminator
);
1739 gfc_conv_function_expr (&se
, expr2
);
1740 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
1741 gfc_add_block_to_block (&se
.pre
, &se
.post
);
1743 return gfc_finish_block (&se
.pre
);
1747 /* Translate an assignment. Most of the code is concerned with
1748 setting up the scalarizer. */
1751 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
1756 gfc_ss
*lss_section
;
1763 /* Special case a single function returning an array. */
1764 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
1766 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
1771 /* Assignment of the form lhs = rhs. */
1772 gfc_start_block (&block
);
1774 gfc_init_se (&lse
, NULL
);
1775 gfc_init_se (&rse
, NULL
);
1778 lss
= gfc_walk_expr (expr1
);
1780 if (lss
!= gfc_ss_terminator
)
1782 /* The assignment needs scalarization. */
1785 /* Find a non-scalar SS from the lhs. */
1786 while (lss_section
!= gfc_ss_terminator
1787 && lss_section
->type
!= GFC_SS_SECTION
)
1788 lss_section
= lss_section
->next
;
1790 assert (lss_section
!= gfc_ss_terminator
);
1792 /* Initialize the scalarizer. */
1793 gfc_init_loopinfo (&loop
);
1796 rss
= gfc_walk_expr (expr2
);
1797 if (rss
== gfc_ss_terminator
)
1799 /* The rhs is scalar. Add a ss for the expression. */
1800 rss
= gfc_get_ss ();
1801 rss
->next
= gfc_ss_terminator
;
1802 rss
->type
= GFC_SS_SCALAR
;
1805 /* Associate the SS with the loop. */
1806 gfc_add_ss_to_loop (&loop
, lss
);
1807 gfc_add_ss_to_loop (&loop
, rss
);
1809 /* Calculate the bounds of the scalarization. */
1810 gfc_conv_ss_startstride (&loop
);
1811 /* Resolve any data dependencies in the statement. */
1812 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
1813 /* Setup the scalarizing loops. */
1814 gfc_conv_loop_setup (&loop
);
1816 /* Setup the gfc_se structures. */
1817 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1818 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1821 gfc_mark_ss_chain_used (rss
, 1);
1822 if (loop
.temp_ss
== NULL
)
1825 gfc_mark_ss_chain_used (lss
, 1);
1829 lse
.ss
= loop
.temp_ss
;
1830 gfc_mark_ss_chain_used (lss
, 3);
1831 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
1834 /* Start the scalarized loop body. */
1835 gfc_start_scalarized_body (&loop
, &body
);
1838 gfc_init_block (&body
);
1840 /* Translate the expression. */
1841 gfc_conv_expr (&rse
, expr2
);
1843 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
1845 gfc_conv_tmp_array_ref (&lse
);
1846 gfc_advance_se_ss_chain (&lse
);
1849 gfc_conv_expr (&lse
, expr1
);
1851 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
1852 gfc_add_expr_to_block (&body
, tmp
);
1854 if (lss
== gfc_ss_terminator
)
1856 /* Use the scalar assignment as is. */
1857 gfc_add_block_to_block (&block
, &body
);
1861 if (lse
.ss
!= gfc_ss_terminator
)
1863 if (rse
.ss
!= gfc_ss_terminator
)
1866 if (loop
.temp_ss
!= NULL
)
1868 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
1870 /* We need to copy the temporary to the actual lhs. */
1871 gfc_init_se (&lse
, NULL
);
1872 gfc_init_se (&rse
, NULL
);
1873 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1874 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1876 rse
.ss
= loop
.temp_ss
;
1879 gfc_conv_tmp_array_ref (&rse
);
1880 gfc_advance_se_ss_chain (&rse
);
1881 gfc_conv_expr (&lse
, expr1
);
1883 if (lse
.ss
!= gfc_ss_terminator
)
1886 if (rse
.ss
!= gfc_ss_terminator
)
1889 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
1890 gfc_add_expr_to_block (&body
, tmp
);
1892 /* Generate the copying loops. */
1893 gfc_trans_scalarizing_loops (&loop
, &body
);
1895 /* Wrap the whole thing up. */
1896 gfc_add_block_to_block (&block
, &loop
.pre
);
1897 gfc_add_block_to_block (&block
, &loop
.post
);
1899 gfc_cleanup_loop (&loop
);
1902 return gfc_finish_block (&block
);
1906 gfc_trans_assign (gfc_code
* code
)
1908 return gfc_trans_assignment (code
->expr
, code
->expr2
);