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,
139 fold_convert (TREE_TYPE (decl), null_pointer_node));
143 /* Generate code to initialize a string length variable. Returns the
147 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
152 gfc_init_se (&se, NULL);
153 gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node);
154 gfc_add_block_to_block (pblock, &se.pre);
156 tmp = cl->backend_decl;
157 gfc_add_modify_expr (pblock, tmp, se.expr);
161 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
169 type = gfc_get_character_type (kind, ref->u.ss.length);
170 type = build_pointer_type (type);
173 gfc_init_se (&start, se);
174 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node);
175 gfc_add_block_to_block (&se->pre, &start.pre);
177 if (integer_onep (start.expr))
178 gfc_conv_string_parameter (se);
181 /* Change the start of the string. */
182 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
185 tmp = gfc_build_indirect_ref (se->expr);
186 tmp = gfc_build_array_ref (tmp, start.expr);
187 se->expr = gfc_build_addr_expr (type, tmp);
190 /* Length = end + 1 - start. */
191 gfc_init_se (&end, se);
192 if (ref->u.ss.end == NULL)
193 end.expr = se->string_length;
196 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node);
197 gfc_add_block_to_block (&se->pre, &end.pre);
200 build (MINUS_EXPR, gfc_strlen_type_node,
201 fold_convert (gfc_strlen_type_node, integer_one_node),
203 tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
204 se->string_length = fold (tmp);
208 /* Convert a derived type component reference. */
211 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
218 c = ref->u.c.component;
220 assert (c->backend_decl);
222 field = c->backend_decl;
223 assert (TREE_CODE (field) == FIELD_DECL);
225 tmp = build (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
229 if (c->ts.type == BT_CHARACTER)
231 tmp = c->ts.cl->backend_decl;
233 if (!INTEGER_CST_P (tmp))
234 gfc_todo_error ("Unknown length character component");
235 se->string_length = tmp;
238 if (c->pointer && c->dimension == 0)
239 se->expr = gfc_build_indirect_ref (se->expr);
243 /* Return the contents of a variable. Also handles reference/pointer
244 variables (all Fortran pointer references are implicit). */
247 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
252 sym = expr->symtree->n.sym;
255 /* Check that something hasn't gone horribly wrong. */
256 assert (se->ss != gfc_ss_terminator);
257 assert (se->ss->expr == expr);
259 /* A scalarized term. We already know the descriptor. */
260 se->expr = se->ss->data.info.descriptor;
261 ref = se->ss->data.info.ref;
265 se->expr = gfc_get_symbol_decl (sym);
267 /* Procedure actual arguments. */
268 if (sym->attr.flavor == FL_PROCEDURE
269 && se->expr != current_function_decl)
271 assert (se->want_pointer);
272 if (!sym->attr.dummy)
274 assert (TREE_CODE (se->expr) == FUNCTION_DECL);
275 se->expr = gfc_build_addr_expr (NULL, se->expr);
280 /* Special case for assigning the return value of a function.
281 Self recursive functions must have an explicit return value. */
282 if (se->expr == current_function_decl && sym->attr.function
283 && (sym->result == sym))
285 se->expr = gfc_get_fake_result_decl (sym);
288 /* Dereference scalar dummy variables. */
290 && sym->ts.type != BT_CHARACTER
291 && !sym->attr.dimension)
292 se->expr = gfc_build_indirect_ref (se->expr);
294 /* Dereference pointer variables. */
295 if ((sym->attr.pointer || sym->attr.allocatable)
298 || sym->attr.function
299 || !sym->attr.dimension)
300 && sym->ts.type != BT_CHARACTER)
301 se->expr = gfc_build_indirect_ref (se->expr);
306 /* For character variables, also get the length. */
307 if (sym->ts.type == BT_CHARACTER)
309 se->string_length = sym->ts.cl->backend_decl;
310 assert (se->string_length);
318 /* Return the descriptor if that's what we want and this is an array
319 section reference. */
320 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
322 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
323 /* Return the descriptor for array pointers and allocations. */
325 && ref->next == NULL && (se->descriptor_only))
328 gfc_conv_array_ref (se, &ref->u.ar);
329 /* Return a pointer to an element. */
333 gfc_conv_component_ref (se, ref);
337 gfc_conv_substring (se, ref, expr->ts.kind);
346 /* Pointer assignment, allocation or pass by reference. Arrays are handled
348 if (se->want_pointer)
350 if (expr->ts.type == BT_CHARACTER)
351 gfc_conv_string_parameter (se);
353 se->expr = gfc_build_addr_expr (NULL, se->expr);
356 gfc_advance_se_ss_chain (se);
360 /* Unary ops are easy... Or they would be if ! was a valid op. */
363 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
368 assert (expr->ts.type != BT_CHARACTER);
369 /* Initialize the operand. */
370 gfc_init_se (&operand, se);
371 gfc_conv_expr_val (&operand, expr->op1);
372 gfc_add_block_to_block (&se->pre, &operand.pre);
374 type = gfc_typenode_for_spec (&expr->ts);
376 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
377 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
378 All other unary operators have an equivalent GIMPLE unary operator */
379 if (code == TRUTH_NOT_EXPR)
380 se->expr = build (EQ_EXPR, type, operand.expr,
381 convert (type, integer_zero_node));
383 se->expr = build1 (code, type, operand.expr);
387 /* Expand power operator to optimal multiplications when a value is raised
388 to an constant integer n. See section 4.6.3, "Evaluation of Powers" of
389 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
390 Programming", 3rd Edition, 1998. */
392 /* This code is mostly duplicated from expand_powi in the backend.
393 We establish the "optimal power tree" lookup table with the defined size.
394 The items in the table are the exponents used to calculate the index
395 exponents. Any integer n less than the value can get an "addition chain",
396 with the first node being one. */
397 #define POWI_TABLE_SIZE 256
399 /* The table is from Builtins.c. */
400 static const unsigned char powi_table[POWI_TABLE_SIZE] =
402 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
403 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
404 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
405 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
406 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
407 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
408 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
409 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
410 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
411 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
412 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
413 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
414 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
415 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
416 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
417 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
418 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
419 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
420 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
421 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
422 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
423 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
424 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
425 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
426 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
427 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
428 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
429 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
430 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
431 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
432 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
433 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
436 /* If n is larger than lookup table's max index, we use "window method". */
437 #define POWI_WINDOW_SIZE 3
439 /* Recursive function to expand power operator. The temporary values are put
440 in tmpvar. The function return tmpvar[1] ** n. */
442 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
449 if (n < POWI_TABLE_SIZE)
454 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
455 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
459 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
460 op0 = gfc_conv_powi (se, n - digit, tmpvar);
461 op1 = gfc_conv_powi (se, digit, tmpvar);
465 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
469 tmp = fold (build (MULT_EXPR, TREE_TYPE (op0), op0, op1));
470 tmp = gfc_evaluate_now (tmp, &se->pre);
472 if (n < POWI_TABLE_SIZE)
478 /* Expand lhs ** rhs. rhs is an constant integer. If expand successfully,
479 return 1. Else return 0 and will call runtime library functions. */
481 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
486 tree vartmp[POWI_TABLE_SIZE];
490 type = TREE_TYPE (lhs);
491 n = abs (TREE_INT_CST_LOW (rhs));
492 sgn = tree_int_cst_sgn (rhs);
494 if ((!flag_unsafe_math_optimizations || optimize_size) && (n > 2 || n < -1))
500 se->expr = gfc_build_const (type, integer_one_node);
503 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
504 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
506 tmp = build (EQ_EXPR, boolean_type_node, lhs,
507 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
508 cond = build (EQ_EXPR, boolean_type_node, lhs,
509 convert (TREE_TYPE (lhs), integer_one_node));
511 /* If rhs is an even,
512 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
515 tmp = build (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
516 se->expr = build (COND_EXPR, type, tmp,
517 convert (type, integer_one_node),
518 convert (type, integer_zero_node));
522 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
523 tmp = build (COND_EXPR, type, tmp,
524 convert (type, integer_minus_one_node),
525 convert (type, integer_zero_node));
526 se->expr = build (COND_EXPR, type, cond,
527 convert (type, integer_one_node),
532 memset (vartmp, 0, sizeof (vartmp));
536 tmp = gfc_build_const (type, integer_one_node);
537 vartmp[1] = build (RDIV_EXPR, type, tmp, vartmp[1]);
540 se->expr = gfc_conv_powi (se, n, vartmp);
546 /* Power op (**). Constant integer exponent has special handling. */
549 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
558 gfc_init_se (&lse, se);
559 gfc_conv_expr_val (&lse, expr->op1);
560 gfc_add_block_to_block (&se->pre, &lse.pre);
562 gfc_init_se (&rse, se);
563 gfc_conv_expr_val (&rse, expr->op2);
564 gfc_add_block_to_block (&se->pre, &rse.pre);
566 if (expr->op2->ts.type == BT_INTEGER
567 && expr->op2->expr_type == EXPR_CONSTANT)
568 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
571 kind = expr->op1->ts.kind;
572 switch (expr->op2->ts.type)
575 ikind = expr->op2->ts.kind;
580 rse.expr = convert (gfc_int4_type_node, rse.expr);
598 if (expr->op1->ts.type == BT_INTEGER)
599 lse.expr = convert (gfc_int4_type_node, lse.expr);
616 switch (expr->op1->ts.type)
619 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
623 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
627 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
639 fndecl = built_in_decls[BUILT_IN_POWF];
642 fndecl = built_in_decls[BUILT_IN_POW];
653 fndecl = gfor_fndecl_math_cpowf;
656 fndecl = gfor_fndecl_math_cpow;
668 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
669 tmp = gfc_chainon_list (tmp, rse.expr);
670 se->expr = fold (gfc_build_function_call (fndecl, tmp));
674 /* Generate code to allocate a string temporary. */
677 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
683 if (TREE_TYPE (len) != gfc_strlen_type_node)
686 if (gfc_can_put_var_on_stack (len))
688 /* Create a temporary variable to hold the result. */
689 tmp = fold (build (MINUS_EXPR, gfc_strlen_type_node, len,
690 convert (gfc_strlen_type_node,
692 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
693 tmp = build_array_type (gfc_character1_type_node, tmp);
694 var = gfc_create_var (tmp, "str");
695 var = gfc_build_addr_expr (type, var);
699 /* Allocate a temporary to hold the result. */
700 var = gfc_create_var (type, "pstr");
701 args = gfc_chainon_list (NULL_TREE, len);
702 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
703 tmp = convert (type, tmp);
704 gfc_add_modify_expr (&se->pre, var, tmp);
706 /* Free the temporary afterwards. */
707 tmp = convert (pvoid_type_node, var);
708 args = gfc_chainon_list (NULL_TREE, tmp);
709 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
710 gfc_add_expr_to_block (&se->post, tmp);
717 /* Handle a string concatenation operation. A temporary will be allocated to
721 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
731 assert (expr->op1->ts.type == BT_CHARACTER
732 && expr->op2->ts.type == BT_CHARACTER);
734 gfc_init_se (&lse, se);
735 gfc_conv_expr (&lse, expr->op1);
736 gfc_conv_string_parameter (&lse);
737 gfc_init_se (&rse, se);
738 gfc_conv_expr (&rse, expr->op2);
739 gfc_conv_string_parameter (&rse);
741 gfc_add_block_to_block (&se->pre, &lse.pre);
742 gfc_add_block_to_block (&se->pre, &rse.pre);
744 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
745 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
746 if (len == NULL_TREE)
748 len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
749 lse.string_length, rse.string_length));
752 type = build_pointer_type (type);
754 var = gfc_conv_string_tmp (se, type, len);
756 /* Do the actual concatenation. */
758 args = gfc_chainon_list (args, len);
759 args = gfc_chainon_list (args, var);
760 args = gfc_chainon_list (args, lse.string_length);
761 args = gfc_chainon_list (args, lse.expr);
762 args = gfc_chainon_list (args, rse.string_length);
763 args = gfc_chainon_list (args, rse.expr);
764 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
765 gfc_add_expr_to_block (&se->pre, tmp);
767 /* Add the cleanup for the operands. */
768 gfc_add_block_to_block (&se->pre, &rse.post);
769 gfc_add_block_to_block (&se->pre, &lse.post);
772 se->string_length = len;
776 /* Translates an op expression. Common (binary) cases are handled by this
777 function, others are passed on. Recursion is used in either case.
778 We use the fact that (op1.ts == op2.ts) (except for the power
780 Operators need no special handling for scalarized expressions as long as
781 they call gfc_conv_siple_val to get their operands.
782 Character strings get special handling. */
785 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
797 switch (expr->operator)
799 case INTRINSIC_UPLUS:
800 gfc_conv_expr (se, expr->op1);
803 case INTRINSIC_UMINUS:
804 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
808 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
815 case INTRINSIC_MINUS:
819 case INTRINSIC_TIMES:
823 case INTRINSIC_DIVIDE:
824 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
825 an integer, we must round towards zero, so we use a
827 if (expr->ts.type == BT_INTEGER)
828 code = TRUNC_DIV_EXPR;
833 case INTRINSIC_POWER:
834 gfc_conv_power_op (se, expr);
837 case INTRINSIC_CONCAT:
838 gfc_conv_concat_op (se, expr);
842 code = TRUTH_ANDIF_EXPR;
847 code = TRUTH_ORIF_EXPR;
851 /* EQV and NEQV only work on logicals, but since we represent them
852 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
892 case INTRINSIC_ASSIGN:
893 /* These should be converted into function calls by the frontend. */
898 fatal_error ("Unknown intrinsic op");
902 /* The only exception to this is **, which is handled seperately anyway. */
903 assert (expr->op1->ts.type == expr->op2->ts.type);
905 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
909 gfc_init_se (&lse, se);
910 gfc_conv_expr (&lse, expr->op1);
911 gfc_add_block_to_block (&se->pre, &lse.pre);
914 gfc_init_se (&rse, se);
915 gfc_conv_expr (&rse, expr->op2);
916 gfc_add_block_to_block (&se->pre, &rse.pre);
918 /* For string comparisons we generate a library call, and compare the return
922 gfc_conv_string_parameter (&lse);
923 gfc_conv_string_parameter (&rse);
925 tmp = gfc_chainon_list (tmp, lse.string_length);
926 tmp = gfc_chainon_list (tmp, lse.expr);
927 tmp = gfc_chainon_list (tmp, rse.string_length);
928 tmp = gfc_chainon_list (tmp, rse.expr);
930 /* Build a call for the comparison. */
931 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
932 gfc_add_block_to_block (&lse.post, &rse.post);
934 rse.expr = integer_zero_node;
937 type = gfc_typenode_for_spec (&expr->ts);
941 /* The result of logical ops is always boolean_type_node. */
942 tmp = fold (build (code, type, lse.expr, rse.expr));
943 se->expr = convert (type, tmp);
946 se->expr = fold (build (code, type, lse.expr, rse.expr));
949 /* Add the post blocks. */
950 gfc_add_block_to_block (&se->post, &rse.post);
951 gfc_add_block_to_block (&se->post, &lse.post);
955 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
961 tmp = gfc_get_symbol_decl (sym);
962 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
963 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
969 if (!sym->backend_decl)
970 sym->backend_decl = gfc_get_extern_function_decl (sym);
972 tmp = sym->backend_decl;
973 assert (TREE_CODE (tmp) == FUNCTION_DECL);
974 se->expr = gfc_build_addr_expr (NULL, tmp);
979 /* Generate code for a procedure call. Note can return se->post != NULL.
980 If se->direct_byref is set then se->expr contains the return parameter. */
983 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
984 gfc_actual_arglist * arg)
997 gfc_formal_arglist *formal;
1000 stringargs = NULL_TREE;
1006 if (!sym->attr.elemental)
1008 assert (se->ss->type == GFC_SS_FUNCTION);
1009 if (se->ss->useflags)
1011 assert (gfc_return_by_reference (sym)
1012 && sym->result->attr.dimension);
1013 assert (se->loop != NULL);
1015 /* Access the previously obtained result. */
1016 gfc_conv_tmp_array_ref (se);
1017 gfc_advance_se_ss_chain (se);
1021 info = &se->ss->data.info;
1026 byref = gfc_return_by_reference (sym);
1029 if (se->direct_byref)
1030 arglist = gfc_chainon_list (arglist, se->expr);
1031 else if (sym->result->attr.dimension)
1033 assert (se->loop && se->ss);
1034 /* Set the type of the array. */
1035 tmp = gfc_typenode_for_spec (&sym->ts);
1036 info->dimen = se->loop->dimen;
1037 /* Allocate a temporary to store the result. */
1038 gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
1040 /* Zero the first stride to indicate a temporary. */
1042 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1043 gfc_add_modify_expr (&se->pre, tmp,
1044 convert (TREE_TYPE (tmp), integer_zero_node));
1045 /* Pass the temporary as the first argument. */
1046 tmp = info->descriptor;
1047 tmp = gfc_build_addr_expr (NULL, tmp);
1048 arglist = gfc_chainon_list (arglist, tmp);
1050 else if (sym->ts.type == BT_CHARACTER)
1052 assert (sym->ts.cl && sym->ts.cl->length
1053 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1054 len = gfc_conv_mpz_to_tree
1055 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1056 sym->ts.cl->backend_decl = len;
1057 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1058 type = build_pointer_type (type);
1060 var = gfc_conv_string_tmp (se, type, len);
1061 arglist = gfc_chainon_list (arglist, var);
1062 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1065 else /* TODO: derived type function return values. */
1069 formal = sym->formal;
1070 /* Evaluate the arguments. */
1071 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1073 if (arg->expr == NULL)
1076 if (se->ignore_optional)
1078 /* Some intrinsics have already been resolved to the correct
1082 else if (arg->label)
1084 has_alternate_specifier = 1;
1089 /* Pass a NULL pointer for an absent arg. */
1090 gfc_init_se (&parmse, NULL);
1091 parmse.expr = null_pointer_node;
1092 if (arg->missing_arg_type == BT_CHARACTER)
1095 gfc_chainon_list (stringargs,
1096 convert (gfc_strlen_type_node,
1097 integer_zero_node));
1101 else if (se->ss && se->ss->useflags)
1103 /* An elemental function inside a scalarized loop. */
1104 gfc_init_se (&parmse, se);
1105 gfc_conv_expr_reference (&parmse, arg->expr);
1109 /* A scalar or transformational function. */
1110 gfc_init_se (&parmse, NULL);
1111 argss = gfc_walk_expr (arg->expr);
1113 if (argss == gfc_ss_terminator)
1115 gfc_conv_expr_reference (&parmse, arg->expr);
1116 if (formal && formal->sym->attr.pointer
1117 && arg->expr->expr_type != EXPR_NULL)
1119 /* Scalar pointer dummy args require an extra level of
1120 indirection. The null pointer already contains
1121 this level of indirection. */
1122 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1127 /* If the procedure requires explicit interface, actual argument
1128 is passed according to corresponing formal argument. We
1129 do not use g77 method and the address of array descriptor
1130 is passed if corresponing formal is pointer or
1131 assumed-shape, Otherwise use g77 method. */
1133 f = (formal != NULL)
1134 && !formal->sym->attr.pointer
1135 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1136 f = f || !sym->attr.always_explicit;
1137 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1141 gfc_add_block_to_block (&se->pre, &parmse.pre);
1142 gfc_add_block_to_block (&se->post, &parmse.post);
1144 /* Character strings are passed as two paramarers, a length and a
1146 if (parmse.string_length != NULL_TREE)
1147 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1149 arglist = gfc_chainon_list (arglist, parmse.expr);
1152 /* Add the hidden string length parameters to the arguments. */
1153 arglist = chainon (arglist, stringargs);
1155 /* Generate the actual call. */
1156 gfc_conv_function_val (se, sym);
1157 /* If there are alternate return labels, function type should be
1159 if (has_alternate_specifier)
1160 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1162 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1163 se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1164 arglist, NULL_TREE);
1166 /* A pure function may still have side-effects - it may modify its
1168 TREE_SIDE_EFFECTS (se->expr) = 1;
1170 if (!sym->attr.pure)
1171 TREE_SIDE_EFFECTS (se->expr) = 1;
1174 if (byref && !se->direct_byref)
1176 gfc_add_expr_to_block (&se->pre, se->expr);
1178 if (sym->result->attr.dimension)
1180 if (flag_bounds_check)
1182 /* Check the data pointer hasn't been modified. This would happen
1183 in a function returning a pointer. */
1184 tmp = gfc_conv_descriptor_data (info->descriptor);
1185 tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
1186 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1188 se->expr = info->descriptor;
1190 else if (sym->ts.type == BT_CHARACTER)
1193 se->string_length = len;
1201 /* Generate code to copy a string. */
1204 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1205 tree slen, tree src)
1210 tmp = gfc_chainon_list (tmp, dlen);
1211 tmp = gfc_chainon_list (tmp, dest);
1212 tmp = gfc_chainon_list (tmp, slen);
1213 tmp = gfc_chainon_list (tmp, src);
1214 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1215 gfc_add_expr_to_block (block, tmp);
1219 /* Translate a statement function.
1220 The value of a statement function reference is obtained by evaluating the
1221 expression using the values of the actual arguments for the values of the
1222 corresponding dummy arguments. */
1225 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1229 gfc_formal_arglist *fargs;
1230 gfc_actual_arglist *args;
1233 gfc_saved_var *saved_vars;
1239 sym = expr->symtree->n.sym;
1240 args = expr->value.function.actual;
1241 gfc_init_se (&lse, NULL);
1242 gfc_init_se (&rse, NULL);
1245 for (fargs = sym->formal; fargs; fargs = fargs->next)
1247 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1248 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1250 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1252 /* Each dummy shall be specified, explicitly or implicitly, to be
1254 assert (fargs->sym->attr.dimension == 0);
1257 /* Create a temporary to hold the value. */
1258 type = gfc_typenode_for_spec (&fsym->ts);
1259 temp_vars[n] = gfc_create_var (type, fsym->name);
1261 if (fsym->ts.type == BT_CHARACTER)
1263 /* Copy string arguments. */
1266 assert (fsym->ts.cl && fsym->ts.cl->length
1267 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1269 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1270 tmp = gfc_build_addr_expr (build_pointer_type (type),
1273 gfc_conv_expr (&rse, args->expr);
1274 gfc_conv_string_parameter (&rse);
1275 gfc_add_block_to_block (&se->pre, &lse.pre);
1276 gfc_add_block_to_block (&se->pre, &rse.pre);
1278 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1280 gfc_add_block_to_block (&se->pre, &lse.post);
1281 gfc_add_block_to_block (&se->pre, &rse.post);
1285 /* For everything else, just evaluate the expression. */
1286 gfc_conv_expr (&lse, args->expr);
1288 gfc_add_block_to_block (&se->pre, &lse.pre);
1289 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1290 gfc_add_block_to_block (&se->pre, &lse.post);
1296 /* Use the temporary variables in place of the real ones. */
1297 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1298 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1300 gfc_conv_expr (se, sym->value);
1302 if (sym->ts.type == BT_CHARACTER)
1304 gfc_conv_const_charlen (sym->ts.cl);
1306 /* Force the expression to the correct length. */
1307 if (!INTEGER_CST_P (se->string_length)
1308 || tree_int_cst_lt (se->string_length,
1309 sym->ts.cl->backend_decl))
1311 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1312 tmp = gfc_create_var (type, sym->name);
1313 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1314 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1315 se->string_length, se->expr);
1318 se->string_length = sym->ts.cl->backend_decl;
1321 /* Resore the original variables. */
1322 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1323 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1324 gfc_free (saved_vars);
1328 /* Translate a function expression. */
1331 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1335 if (expr->value.function.isym)
1337 gfc_conv_intrinsic_function (se, expr);
1341 /* We distinguish the statement function from general function to improve
1342 runtime performance. */
1343 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1345 gfc_conv_statement_function (se, expr);
1349 /* expr.value.function.esym is the resolved (specific) function symbol for
1350 most functions. However this isn't set for dummy procedures. */
1351 sym = expr->value.function.esym;
1353 sym = expr->symtree->n.sym;
1354 gfc_conv_function_call (se, sym, expr->value.function.actual);
1358 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1360 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1361 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1363 gfc_conv_tmp_array_ref (se);
1364 gfc_advance_se_ss_chain (se);
1369 /* Build an expression for a constructor. If init is nonzero then
1370 this is part of a static variable initializer. */
1373 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1383 assert (expr->expr_type == EXPR_STRUCTURE || expr->expr_type == EXPR_NULL);
1384 type = gfc_typenode_for_spec (&expr->ts);
1385 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1388 cm = expr->ts.derived->components;
1389 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1391 /* Skip absent members in default initializers. */
1395 gfc_init_se (&cse, se);
1396 /* Evaluate the expression for this component. */
1402 arraytype = TREE_TYPE (cm->backend_decl);
1404 /* Arrays need special handling. */
1406 cse.expr = gfc_build_null_descriptor (arraytype);
1408 cse.expr = gfc_conv_array_initializer (arraytype, c->expr);
1410 else if (cm->pointer)
1412 /* Pointer components may only be initialized to NULL. */
1413 assert (c->expr->expr_type == EXPR_NULL);
1414 cse.expr = fold_convert (TREE_TYPE (cm->backend_decl),
1417 else if (cm->ts.type == BT_DERIVED)
1418 gfc_conv_structure (&cse, c->expr, 1);
1420 gfc_conv_expr (&cse, c->expr);
1424 gfc_conv_expr (&cse, c->expr);
1425 gfc_add_block_to_block (&se->pre, &cse.pre);
1426 gfc_add_block_to_block (&se->post, &cse.post);
1429 /* Build a TREE_CHAIN to hold it. */
1430 val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
1432 /* Add it to the list. */
1433 if (tail == NULL_TREE)
1434 TREE_OPERAND(head, 0) = tail = val;
1437 TREE_CHAIN (tail) = val;
1445 /*translate a substring expression */
1448 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1454 assert(ref->type == REF_SUBSTRING);
1456 se->expr = gfc_build_string_const(expr->value.character.length,
1457 expr->value.character.string);
1458 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1459 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1461 gfc_conv_substring(se,ref,expr->ts.kind);
1465 /* Entry point for expression translation. */
1468 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1470 if (se->ss && se->ss->expr == expr
1471 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1473 /* Substiture a scalar expression evaluated outside the scalarization
1475 se->expr = se->ss->data.scalar.expr;
1476 se->string_length = se->ss->data.scalar.string_length;
1477 gfc_advance_se_ss_chain (se);
1481 switch (expr->expr_type)
1484 gfc_conv_expr_op (se, expr);
1488 gfc_conv_function_expr (se, expr);
1492 gfc_conv_constant (se, expr);
1496 gfc_conv_variable (se, expr);
1500 se->expr = null_pointer_node;
1503 case EXPR_SUBSTRING:
1504 gfc_conv_substring_expr (se, expr);
1507 case EXPR_STRUCTURE:
1508 gfc_conv_structure (se, expr, 0);
1512 gfc_conv_array_constructor_expr (se, expr);
1522 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1524 gfc_conv_expr (se, expr);
1525 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1526 figure out a way of rewriting an lvalue so that it has no post chain. */
1527 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1531 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1535 assert (expr->ts.type != BT_CHARACTER);
1536 gfc_conv_expr (se, expr);
1539 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1540 gfc_add_modify_expr (&se->pre, val, se->expr);
1545 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1547 gfc_conv_expr_val (se, expr);
1548 se->expr = convert (type, se->expr);
1552 /* Converts an expression so that it can be passed by refernece. Scalar
1556 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1560 if (se->ss && se->ss->expr == expr
1561 && se->ss->type == GFC_SS_REFERENCE)
1563 se->expr = se->ss->data.scalar.expr;
1564 se->string_length = se->ss->data.scalar.string_length;
1565 gfc_advance_se_ss_chain (se);
1569 if (expr->ts.type == BT_CHARACTER)
1571 gfc_conv_expr (se, expr);
1572 gfc_conv_string_parameter (se);
1576 if (expr->expr_type == EXPR_VARIABLE)
1578 se->want_pointer = 1;
1579 gfc_conv_expr (se, expr);
1582 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1583 gfc_add_modify_expr (&se->pre, var, se->expr);
1584 gfc_add_block_to_block (&se->pre, &se->post);
1590 gfc_conv_expr (se, expr);
1592 /* Create a temporary var to hold the value. */
1593 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1594 gfc_add_modify_expr (&se->pre, var, se->expr);
1595 gfc_add_block_to_block (&se->pre, &se->post);
1597 /* Take the address of that value. */
1598 se->expr = gfc_build_addr_expr (NULL, var);
1603 gfc_trans_pointer_assign (gfc_code * code)
1605 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1610 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1618 gfc_start_block (&block);
1620 gfc_init_se (&lse, NULL);
1622 lss = gfc_walk_expr (expr1);
1623 rss = gfc_walk_expr (expr2);
1624 if (lss == gfc_ss_terminator)
1626 lse.want_pointer = 1;
1627 gfc_conv_expr (&lse, expr1);
1628 assert (rss == gfc_ss_terminator);
1629 gfc_init_se (&rse, NULL);
1630 rse.want_pointer = 1;
1631 gfc_conv_expr (&rse, expr2);
1632 gfc_add_block_to_block (&block, &lse.pre);
1633 gfc_add_block_to_block (&block, &rse.pre);
1634 gfc_add_modify_expr (&block, lse.expr,
1635 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1636 gfc_add_block_to_block (&block, &rse.post);
1637 gfc_add_block_to_block (&block, &lse.post);
1641 gfc_conv_expr_descriptor (&lse, expr1, lss);
1642 /* Implement Nullify. */
1643 if (expr2->expr_type == EXPR_NULL)
1645 lse.expr = gfc_conv_descriptor_data (lse.expr);
1646 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1647 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1651 lse.direct_byref = 1;
1652 gfc_conv_expr_descriptor (&lse, expr2, rss);
1654 gfc_add_block_to_block (&block, &lse.pre);
1655 gfc_add_block_to_block (&block, &lse.post);
1657 return gfc_finish_block (&block);
1661 /* Makes sure se is suitable for passing as a function string parameter. */
1662 /* TODO: Need to check all callers fo this function. It may be abused. */
1665 gfc_conv_string_parameter (gfc_se * se)
1669 if (TREE_CODE (se->expr) == STRING_CST)
1671 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1675 type = TREE_TYPE (se->expr);
1676 if (TYPE_STRING_FLAG (type))
1678 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1679 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1682 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1683 assert (se->string_length
1684 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1688 /* Generate code for assignment of scalar variables. Includes character
1692 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1696 gfc_init_block (&block);
1698 if (type == BT_CHARACTER)
1700 assert (lse->string_length != NULL_TREE
1701 && rse->string_length != NULL_TREE);
1703 gfc_conv_string_parameter (lse);
1704 gfc_conv_string_parameter (rse);
1706 gfc_add_block_to_block (&block, &lse->pre);
1707 gfc_add_block_to_block (&block, &rse->pre);
1709 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1710 rse->string_length, rse->expr);
1714 gfc_add_block_to_block (&block, &lse->pre);
1715 gfc_add_block_to_block (&block, &rse->pre);
1717 gfc_add_modify_expr (&block, lse->expr,
1718 fold_convert (TREE_TYPE (lse->expr), rse->expr));
1721 gfc_add_block_to_block (&block, &lse->post);
1722 gfc_add_block_to_block (&block, &rse->post);
1724 return gfc_finish_block (&block);
1728 /* Try to translate array(:) = func (...), where func is a transformational
1729 array function, without using a temporary. Returns NULL is this isn't the
1733 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1738 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1739 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1742 /* Elemental functions don't need a temporary anyway. */
1743 if (expr2->symtree->n.sym->attr.elemental)
1746 /* Check for a dependency. */
1747 if (gfc_check_fncall_dependency (expr1, expr2))
1750 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
1752 assert (expr2->value.function.isym
1753 || (gfc_return_by_reference (expr2->symtree->n.sym)
1754 && expr2->symtree->n.sym->result->attr.dimension));
1756 ss = gfc_walk_expr (expr1);
1757 assert (ss != gfc_ss_terminator);
1758 gfc_init_se (&se, NULL);
1759 gfc_start_block (&se.pre);
1760 se.want_pointer = 1;
1762 gfc_conv_array_parameter (&se, expr1, ss, 0);
1764 se.direct_byref = 1;
1765 se.ss = gfc_walk_expr (expr2);
1766 assert (se.ss != gfc_ss_terminator);
1767 gfc_conv_function_expr (&se, expr2);
1768 gfc_add_expr_to_block (&se.pre, se.expr);
1769 gfc_add_block_to_block (&se.pre, &se.post);
1771 return gfc_finish_block (&se.pre);
1775 /* Translate an assignment. Most of the code is concerned with
1776 setting up the scalarizer. */
1779 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
1784 gfc_ss *lss_section;
1791 /* Special case a single function returning an array. */
1792 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
1794 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
1799 /* Assignment of the form lhs = rhs. */
1800 gfc_start_block (&block);
1802 gfc_init_se (&lse, NULL);
1803 gfc_init_se (&rse, NULL);
1806 lss = gfc_walk_expr (expr1);
1808 if (lss != gfc_ss_terminator)
1810 /* The assignment needs scalarization. */
1813 /* Find a non-scalar SS from the lhs. */
1814 while (lss_section != gfc_ss_terminator
1815 && lss_section->type != GFC_SS_SECTION)
1816 lss_section = lss_section->next;
1818 assert (lss_section != gfc_ss_terminator);
1820 /* Initialize the scalarizer. */
1821 gfc_init_loopinfo (&loop);
1824 rss = gfc_walk_expr (expr2);
1825 if (rss == gfc_ss_terminator)
1827 /* The rhs is scalar. Add a ss for the expression. */
1828 rss = gfc_get_ss ();
1829 rss->next = gfc_ss_terminator;
1830 rss->type = GFC_SS_SCALAR;
1833 /* Associate the SS with the loop. */
1834 gfc_add_ss_to_loop (&loop, lss);
1835 gfc_add_ss_to_loop (&loop, rss);
1837 /* Calculate the bounds of the scalarization. */
1838 gfc_conv_ss_startstride (&loop);
1839 /* Resolve any data dependencies in the statement. */
1840 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
1841 /* Setup the scalarizing loops. */
1842 gfc_conv_loop_setup (&loop);
1844 /* Setup the gfc_se structures. */
1845 gfc_copy_loopinfo_to_se (&lse, &loop);
1846 gfc_copy_loopinfo_to_se (&rse, &loop);
1849 gfc_mark_ss_chain_used (rss, 1);
1850 if (loop.temp_ss == NULL)
1853 gfc_mark_ss_chain_used (lss, 1);
1857 lse.ss = loop.temp_ss;
1858 gfc_mark_ss_chain_used (lss, 3);
1859 gfc_mark_ss_chain_used (loop.temp_ss, 3);
1862 /* Start the scalarized loop body. */
1863 gfc_start_scalarized_body (&loop, &body);
1866 gfc_init_block (&body);
1868 /* Translate the expression. */
1869 gfc_conv_expr (&rse, expr2);
1871 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
1873 gfc_conv_tmp_array_ref (&lse);
1874 gfc_advance_se_ss_chain (&lse);
1877 gfc_conv_expr (&lse, expr1);
1879 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1880 gfc_add_expr_to_block (&body, tmp);
1882 if (lss == gfc_ss_terminator)
1884 /* Use the scalar assignment as is. */
1885 gfc_add_block_to_block (&block, &body);
1889 if (lse.ss != gfc_ss_terminator)
1891 if (rse.ss != gfc_ss_terminator)
1894 if (loop.temp_ss != NULL)
1896 gfc_trans_scalarized_loop_boundary (&loop, &body);
1898 /* We need to copy the temporary to the actual lhs. */
1899 gfc_init_se (&lse, NULL);
1900 gfc_init_se (&rse, NULL);
1901 gfc_copy_loopinfo_to_se (&lse, &loop);
1902 gfc_copy_loopinfo_to_se (&rse, &loop);
1904 rse.ss = loop.temp_ss;
1907 gfc_conv_tmp_array_ref (&rse);
1908 gfc_advance_se_ss_chain (&rse);
1909 gfc_conv_expr (&lse, expr1);
1911 if (lse.ss != gfc_ss_terminator)
1914 if (rse.ss != gfc_ss_terminator)
1917 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1918 gfc_add_expr_to_block (&body, tmp);
1920 /* Generate the copying loops. */
1921 gfc_trans_scalarizing_loops (&loop, &body);
1923 /* Wrap the whole thing up. */
1924 gfc_add_block_to_block (&block, &loop.pre);
1925 gfc_add_block_to_block (&block, &loop.post);
1927 gfc_cleanup_loop (&loop);
1930 return gfc_finish_block (&block);
1934 gfc_trans_assign (gfc_code * code)
1936 return gfc_trans_assignment (code->expr, code->expr2);