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, NULL_TREE);
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));
531 tmp = gfc_build_const (type, integer_one_node);
532 vartmp[1] = build (RDIV_EXPR, type, tmp, vartmp[1]);
535 se->expr = gfc_conv_powi (se, n, vartmp);
541 /* Power op (**). Constant integer exponent has special handling. */
544 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
553 gfc_init_se (&lse, se);
554 gfc_conv_expr_val (&lse, expr->op1);
555 gfc_add_block_to_block (&se->pre, &lse.pre);
557 gfc_init_se (&rse, se);
558 gfc_conv_expr_val (&rse, expr->op2);
559 gfc_add_block_to_block (&se->pre, &rse.pre);
561 if (expr->op2->ts.type == BT_INTEGER
562 && expr->op2->expr_type == EXPR_CONSTANT)
563 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
566 kind = expr->op1->ts.kind;
567 switch (expr->op2->ts.type)
570 ikind = expr->op2->ts.kind;
575 rse.expr = convert (gfc_int4_type_node, rse.expr);
593 if (expr->op1->ts.type == BT_INTEGER)
594 lse.expr = convert (gfc_int4_type_node, lse.expr);
611 switch (expr->op1->ts.type)
614 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
618 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
622 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
634 fndecl = built_in_decls[BUILT_IN_POWF];
637 fndecl = built_in_decls[BUILT_IN_POW];
648 fndecl = gfor_fndecl_math_cpowf;
651 fndecl = gfor_fndecl_math_cpow;
663 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
664 tmp = gfc_chainon_list (tmp, rse.expr);
665 se->expr = fold (gfc_build_function_call (fndecl, tmp));
669 /* Generate code to allocate a string temporary. */
672 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
678 if (gfc_can_put_var_on_stack (len))
680 /* Create a temporary variable to hold the result. */
681 tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node));
682 tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
683 tmp = build_array_type (gfc_character1_type_node, tmp);
684 var = gfc_create_var (tmp, "str");
685 var = gfc_build_addr_expr (type, var);
689 /* Allocate a temporary to hold the result. */
690 var = gfc_create_var (type, "pstr");
691 args = gfc_chainon_list (NULL_TREE, len);
692 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
693 tmp = convert (type, tmp);
694 gfc_add_modify_expr (&se->pre, var, tmp);
696 /* Free the temporary afterwards. */
697 tmp = convert (pvoid_type_node, var);
698 args = gfc_chainon_list (NULL_TREE, tmp);
699 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
700 gfc_add_expr_to_block (&se->post, tmp);
707 /* Handle a string concatenation operation. A temporary will be allocated to
711 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
721 assert (expr->op1->ts.type == BT_CHARACTER
722 && expr->op2->ts.type == BT_CHARACTER);
724 gfc_init_se (&lse, se);
725 gfc_conv_expr (&lse, expr->op1);
726 gfc_conv_string_parameter (&lse);
727 gfc_init_se (&rse, se);
728 gfc_conv_expr (&rse, expr->op2);
729 gfc_conv_string_parameter (&rse);
731 gfc_add_block_to_block (&se->pre, &lse.pre);
732 gfc_add_block_to_block (&se->pre, &rse.pre);
734 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
735 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
736 if (len == NULL_TREE)
738 len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
739 lse.string_length, rse.string_length));
742 type = build_pointer_type (type);
744 var = gfc_conv_string_tmp (se, type, len);
746 /* Do the actual concatenation. */
748 args = gfc_chainon_list (args, len);
749 args = gfc_chainon_list (args, var);
750 args = gfc_chainon_list (args, lse.string_length);
751 args = gfc_chainon_list (args, lse.expr);
752 args = gfc_chainon_list (args, rse.string_length);
753 args = gfc_chainon_list (args, rse.expr);
754 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
755 gfc_add_expr_to_block (&se->pre, tmp);
757 /* Add the cleanup for the operands. */
758 gfc_add_block_to_block (&se->pre, &rse.post);
759 gfc_add_block_to_block (&se->pre, &lse.post);
762 se->string_length = len;
766 /* Translates an op expression. Common (binary) cases are handled by this
767 function, others are passed on. Recursion is used in either case.
768 We use the fact that (op1.ts == op2.ts) (except for the power
770 Operators need no special handling for scalarized expressions as long as
771 they call gfc_conv_siple_val to get their operands.
772 Character strings get special handling. */
775 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
787 switch (expr->operator)
789 case INTRINSIC_UPLUS:
790 gfc_conv_expr (se, expr->op1);
793 case INTRINSIC_UMINUS:
794 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
798 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
805 case INTRINSIC_MINUS:
809 case INTRINSIC_TIMES:
813 case INTRINSIC_DIVIDE:
814 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
815 an integer, we must round towards zero, so we use a
817 if (expr->ts.type == BT_INTEGER)
818 code = TRUNC_DIV_EXPR;
823 case INTRINSIC_POWER:
824 gfc_conv_power_op (se, expr);
827 case INTRINSIC_CONCAT:
828 gfc_conv_concat_op (se, expr);
832 code = TRUTH_ANDIF_EXPR;
837 code = TRUTH_ORIF_EXPR;
841 /* EQV and NEQV only work on logicals, but since we represent them
842 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
882 case INTRINSIC_ASSIGN:
883 /* These should be converted into function calls by the frontend. */
888 fatal_error ("Unknown intrinsic op");
892 /* The only exception to this is **, which is handled seperately anyway. */
893 assert (expr->op1->ts.type == expr->op2->ts.type);
895 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
899 gfc_init_se (&lse, se);
900 gfc_conv_expr (&lse, expr->op1);
901 gfc_add_block_to_block (&se->pre, &lse.pre);
904 gfc_init_se (&rse, se);
905 gfc_conv_expr (&rse, expr->op2);
906 gfc_add_block_to_block (&se->pre, &rse.pre);
908 /* For string comparisons we generate a library call, and compare the return
912 gfc_conv_string_parameter (&lse);
913 gfc_conv_string_parameter (&rse);
915 tmp = gfc_chainon_list (tmp, lse.string_length);
916 tmp = gfc_chainon_list (tmp, lse.expr);
917 tmp = gfc_chainon_list (tmp, rse.string_length);
918 tmp = gfc_chainon_list (tmp, rse.expr);
920 /* Build a call for the comparison. */
921 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
922 gfc_add_block_to_block (&lse.post, &rse.post);
924 rse.expr = integer_zero_node;
927 type = gfc_typenode_for_spec (&expr->ts);
931 /* The result of logical ops is always boolean_type_node. */
932 tmp = fold (build (code, type, lse.expr, rse.expr));
933 se->expr = convert (type, tmp);
936 se->expr = fold (build (code, type, lse.expr, rse.expr));
939 /* Add the post blocks. */
940 gfc_add_block_to_block (&se->post, &rse.post);
941 gfc_add_block_to_block (&se->post, &lse.post);
945 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
951 tmp = gfc_get_symbol_decl (sym);
952 assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
953 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
959 if (!sym->backend_decl)
960 sym->backend_decl = gfc_get_extern_function_decl (sym);
962 tmp = sym->backend_decl;
963 assert (TREE_CODE (tmp) == FUNCTION_DECL);
964 se->expr = gfc_build_addr_expr (NULL, tmp);
969 /* Generate code for a procedure call. Note can return se->post != NULL.
970 If se->direct_byref is set then se->expr contains the return parameter. */
973 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
974 gfc_actual_arglist * arg)
987 gfc_formal_arglist *formal;
990 stringargs = NULL_TREE;
996 if (!sym->attr.elemental)
998 assert (se->ss->type == GFC_SS_FUNCTION);
999 if (se->ss->useflags)
1001 assert (gfc_return_by_reference (sym)
1002 && sym->result->attr.dimension);
1003 assert (se->loop != NULL);
1005 /* Access the previously obtained result. */
1006 gfc_conv_tmp_array_ref (se);
1007 gfc_advance_se_ss_chain (se);
1011 info = &se->ss->data.info;
1016 byref = gfc_return_by_reference (sym);
1019 if (se->direct_byref)
1020 arglist = gfc_chainon_list (arglist, se->expr);
1021 else if (sym->result->attr.dimension)
1023 assert (se->loop && se->ss);
1024 /* Set the type of the array. */
1025 tmp = gfc_typenode_for_spec (&sym->ts);
1026 info->dimen = se->loop->dimen;
1027 /* Allocate a temporary to store the result. */
1028 gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
1030 /* Zero the first stride to indicate a temporary. */
1032 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1033 gfc_add_modify_expr (&se->pre, tmp, integer_zero_node);
1034 /* Pass the temporary as the first argument. */
1035 tmp = info->descriptor;
1036 tmp = gfc_build_addr_expr (NULL, tmp);
1037 arglist = gfc_chainon_list (arglist, tmp);
1039 else if (sym->ts.type == BT_CHARACTER)
1041 assert (sym->ts.cl && sym->ts.cl->length
1042 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1043 len = gfc_conv_mpz_to_tree
1044 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1045 sym->ts.cl->backend_decl = len;
1046 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1047 type = build_pointer_type (type);
1049 var = gfc_conv_string_tmp (se, type, len);
1050 arglist = gfc_chainon_list (arglist, var);
1051 arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
1054 else /* TODO: derived type function return values. */
1058 formal = sym->formal;
1059 /* Evaluate the arguments. */
1060 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1062 if (arg->expr == NULL)
1065 if (se->ignore_optional)
1067 /* Some intrinsics have already been resolved to the correct
1071 else if (arg->label)
1073 has_alternate_specifier = 1;
1078 /* Pass a NULL pointer for an absent arg. */
1079 gfc_init_se (&parmse, NULL);
1080 parmse.expr = null_pointer_node;
1081 if (arg->missing_arg_type == BT_CHARACTER)
1083 stringargs = gfc_chainon_list (stringargs,
1084 convert (gfc_strlen_type_node, integer_zero_node));
1088 else if (se->ss && se->ss->useflags)
1090 /* An elemental function inside a scalarized loop. */
1091 gfc_init_se (&parmse, se);
1092 gfc_conv_expr_reference (&parmse, arg->expr);
1096 /* A scalar or transformational function. */
1097 gfc_init_se (&parmse, NULL);
1098 argss = gfc_walk_expr (arg->expr);
1100 if (argss == gfc_ss_terminator)
1102 gfc_conv_expr_reference (&parmse, arg->expr);
1103 if (formal && formal->sym->attr.pointer
1104 && arg->expr->expr_type != EXPR_NULL)
1106 /* Scalar pointer dummy args require an extra level of
1107 indirection. The null pointer already contains
1108 this level of indirection. */
1109 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1114 /* If the procedure requires explicit interface, actual argument
1115 is passed according to corresponing formal argument. We
1116 do not use g77 method and the address of array descriptor
1117 is passed if corresponing formal is pointer or
1118 assumed-shape, Otherwise use g77 method. */
1120 f = (formal != NULL)
1121 && !formal->sym->attr.pointer
1122 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1123 f = f || !sym->attr.always_explicit;
1124 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1128 gfc_add_block_to_block (&se->pre, &parmse.pre);
1129 gfc_add_block_to_block (&se->post, &parmse.post);
1131 /* Character strings are passed as two paramarers, a length and a
1133 if (parmse.string_length != NULL_TREE)
1134 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1136 arglist = gfc_chainon_list (arglist, parmse.expr);
1139 /* Add the hidden string length parameters to the arguments. */
1140 arglist = chainon (arglist, stringargs);
1142 /* Generate the actual call. */
1143 gfc_conv_function_val (se, sym);
1144 /* If there are alternate return labels, function type should be
1146 if (has_alternate_specifier)
1147 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1149 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1150 se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1151 arglist, NULL_TREE);
1153 /* A pure function may still have side-effects - it may modify its
1155 TREE_SIDE_EFFECTS (se->expr) = 1;
1157 if (!sym->attr.pure)
1158 TREE_SIDE_EFFECTS (se->expr) = 1;
1161 if (byref && !se->direct_byref)
1163 gfc_add_expr_to_block (&se->pre, se->expr);
1165 if (sym->result->attr.dimension)
1167 if (flag_bounds_check)
1169 /* Check the data pointer hasn't been modified. This would happen
1170 in a function returning a pointer. */
1171 tmp = gfc_conv_descriptor_data (info->descriptor);
1172 tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
1173 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1175 se->expr = info->descriptor;
1177 else if (sym->ts.type == BT_CHARACTER)
1180 se->string_length = len;
1188 /* Generate code to copy a string. */
1191 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1192 tree slen, tree src)
1197 tmp = gfc_chainon_list (tmp, dlen);
1198 tmp = gfc_chainon_list (tmp, dest);
1199 tmp = gfc_chainon_list (tmp, slen);
1200 tmp = gfc_chainon_list (tmp, src);
1201 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1202 gfc_add_expr_to_block (block, tmp);
1206 /* Translate a statement function.
1207 The value of a statement function reference is obtained by evaluating the
1208 expression using the values of the actual arguments for the values of the
1209 corresponding dummy arguments. */
1212 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1216 gfc_formal_arglist *fargs;
1217 gfc_actual_arglist *args;
1220 gfc_saved_var *saved_vars;
1226 sym = expr->symtree->n.sym;
1227 args = expr->value.function.actual;
1228 gfc_init_se (&lse, NULL);
1229 gfc_init_se (&rse, NULL);
1232 for (fargs = sym->formal; fargs; fargs = fargs->next)
1234 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1235 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1237 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1239 /* Each dummy shall be specified, explicitly or implicitly, to be
1241 assert (fargs->sym->attr.dimension == 0);
1244 /* Create a temporary to hold the value. */
1245 type = gfc_typenode_for_spec (&fsym->ts);
1246 temp_vars[n] = gfc_create_var (type, fsym->name);
1248 if (fsym->ts.type == BT_CHARACTER)
1250 /* Copy string arguments. */
1253 assert (fsym->ts.cl && fsym->ts.cl->length
1254 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1256 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1257 tmp = gfc_build_addr_expr (build_pointer_type (type),
1260 gfc_conv_expr (&rse, args->expr);
1261 gfc_conv_string_parameter (&rse);
1262 gfc_add_block_to_block (&se->pre, &lse.pre);
1263 gfc_add_block_to_block (&se->pre, &rse.pre);
1265 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1267 gfc_add_block_to_block (&se->pre, &lse.post);
1268 gfc_add_block_to_block (&se->pre, &rse.post);
1272 /* For everything else, just evaluate the expression. */
1273 gfc_conv_expr (&lse, args->expr);
1275 gfc_add_block_to_block (&se->pre, &lse.pre);
1276 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1277 gfc_add_block_to_block (&se->pre, &lse.post);
1283 /* Use the temporary variables in place of the real ones. */
1284 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1285 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1287 gfc_conv_expr (se, sym->value);
1289 if (sym->ts.type == BT_CHARACTER)
1291 gfc_conv_const_charlen (sym->ts.cl);
1293 /* Force the expression to the correct length. */
1294 if (!INTEGER_CST_P (se->string_length)
1295 || tree_int_cst_lt (se->string_length,
1296 sym->ts.cl->backend_decl))
1298 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1299 tmp = gfc_create_var (type, sym->name);
1300 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1301 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1302 se->string_length, se->expr);
1305 se->string_length = sym->ts.cl->backend_decl;
1308 /* Resore the original variables. */
1309 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1310 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1311 gfc_free (saved_vars);
1315 /* Translate a function expression. */
1318 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1322 if (expr->value.function.isym)
1324 gfc_conv_intrinsic_function (se, expr);
1328 /* We distinguish the statement function from general function to improve
1329 runtime performance. */
1330 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1332 gfc_conv_statement_function (se, expr);
1336 /* expr.value.function.esym is the resolved (specific) function symbol for
1337 most functions. However this isn't set for dummy procedures. */
1338 sym = expr->value.function.esym;
1340 sym = expr->symtree->n.sym;
1341 gfc_conv_function_call (se, sym, expr->value.function.actual);
1345 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1347 assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1348 assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1350 gfc_conv_tmp_array_ref (se);
1351 gfc_advance_se_ss_chain (se);
1356 /* Build an expression for a constructor. If init is nonzero then
1357 this is part of a static variable initializer. */
1360 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1371 assert (expr->expr_type == EXPR_STRUCTURE);
1372 type = gfc_typenode_for_spec (&expr->ts);
1373 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1376 cm = expr->ts.derived->components;
1377 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1379 /* Skip absent members in default initializers. */
1383 gfc_init_se (&cse, se);
1384 /* Evaluate the expression for this component. */
1389 arraytype = TREE_TYPE (cm->backend_decl);
1390 cse.expr = gfc_conv_array_initializer (arraytype, c->expr);
1392 else if (cm->ts.type == BT_DERIVED)
1393 gfc_conv_structure (&cse, c->expr, 1);
1395 gfc_conv_expr (&cse, c->expr);
1399 gfc_conv_expr (&cse, c->expr);
1400 gfc_add_block_to_block (&se->pre, &cse.pre);
1401 gfc_add_block_to_block (&se->post, &cse.post);
1404 /* Build a TREE_CHAIN to hold it. */
1405 val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
1407 /* Add it to the list. */
1408 if (tail == NULL_TREE)
1409 TREE_OPERAND(head, 0) = tail = val;
1412 TREE_CHAIN (tail) = val;
1420 /*translate a substring expression */
1423 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1429 assert(ref->type == REF_SUBSTRING);
1431 se->expr = gfc_build_string_const(expr->value.character.length,
1432 expr->value.character.string);
1433 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1434 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1436 gfc_conv_substring(se,ref,expr->ts.kind);
1440 /* Entry point for expression translation. */
1443 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1445 if (se->ss && se->ss->expr == expr
1446 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1448 /* Substiture a scalar expression evaluated outside the scalarization
1450 se->expr = se->ss->data.scalar.expr;
1451 se->string_length = se->ss->data.scalar.string_length;
1452 gfc_advance_se_ss_chain (se);
1456 switch (expr->expr_type)
1459 gfc_conv_expr_op (se, expr);
1463 gfc_conv_function_expr (se, expr);
1467 gfc_conv_constant (se, expr);
1471 gfc_conv_variable (se, expr);
1475 se->expr = null_pointer_node;
1478 case EXPR_SUBSTRING:
1479 gfc_conv_substring_expr (se, expr);
1482 case EXPR_STRUCTURE:
1483 gfc_conv_structure (se, expr, 0);
1487 gfc_conv_array_constructor_expr (se, expr);
1497 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1499 gfc_conv_expr (se, expr);
1500 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1501 figure out a way of rewriting an lvalue so that it has no post chain. */
1502 assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1506 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1510 assert (expr->ts.type != BT_CHARACTER);
1511 gfc_conv_expr (se, expr);
1514 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1515 gfc_add_modify_expr (&se->pre, val, se->expr);
1520 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1522 gfc_conv_expr_val (se, expr);
1523 se->expr = convert (type, se->expr);
1527 /* Converts an expression so that it can be passed by refernece. Scalar
1531 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1535 if (se->ss && se->ss->expr == expr
1536 && se->ss->type == GFC_SS_REFERENCE)
1538 se->expr = se->ss->data.scalar.expr;
1539 se->string_length = se->ss->data.scalar.string_length;
1540 gfc_advance_se_ss_chain (se);
1544 if (expr->ts.type == BT_CHARACTER)
1546 gfc_conv_expr (se, expr);
1547 gfc_conv_string_parameter (se);
1551 if (expr->expr_type == EXPR_VARIABLE)
1553 se->want_pointer = 1;
1554 gfc_conv_expr (se, expr);
1557 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1558 gfc_add_modify_expr (&se->pre, var, se->expr);
1559 gfc_add_block_to_block (&se->pre, &se->post);
1565 gfc_conv_expr (se, expr);
1567 /* Create a temporary var to hold the value. */
1568 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1569 gfc_add_modify_expr (&se->pre, var, se->expr);
1570 gfc_add_block_to_block (&se->pre, &se->post);
1572 /* Take the address of that value. */
1573 se->expr = gfc_build_addr_expr (NULL, var);
1578 gfc_trans_pointer_assign (gfc_code * code)
1580 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1585 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1594 gfc_start_block (&block);
1596 gfc_init_se (&lse, NULL);
1598 lss = gfc_walk_expr (expr1);
1599 rss = gfc_walk_expr (expr2);
1600 if (lss == gfc_ss_terminator)
1602 lse.want_pointer = 1;
1603 gfc_conv_expr (&lse, expr1);
1604 assert (rss == gfc_ss_terminator);
1605 gfc_init_se (&rse, NULL);
1606 rse.want_pointer = 1;
1607 gfc_conv_expr (&rse, expr2);
1608 gfc_add_block_to_block (&block, &lse.pre);
1609 gfc_add_block_to_block (&block, &rse.pre);
1610 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1611 gfc_add_block_to_block (&block, &rse.post);
1612 gfc_add_block_to_block (&block, &lse.post);
1616 gfc_conv_expr_descriptor (&lse, expr1, lss);
1617 /* Implement Nullify. */
1618 if (expr2->expr_type == EXPR_NULL)
1620 lse.expr = gfc_conv_descriptor_data (lse.expr);
1621 rse.expr = null_pointer_node;
1622 tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr);
1623 gfc_add_expr_to_block (&block, tmp);
1627 lse.direct_byref = 1;
1628 gfc_conv_expr_descriptor (&lse, expr2, rss);
1630 gfc_add_block_to_block (&block, &lse.pre);
1631 gfc_add_block_to_block (&block, &lse.post);
1633 return gfc_finish_block (&block);
1637 /* Makes sure se is suitable for passing as a function string parameter. */
1638 /* TODO: Need to check all callers fo this function. It may be abused. */
1641 gfc_conv_string_parameter (gfc_se * se)
1645 if (TREE_CODE (se->expr) == STRING_CST)
1647 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1651 type = TREE_TYPE (se->expr);
1652 if (TYPE_STRING_FLAG (type))
1654 assert (TREE_CODE (se->expr) != INDIRECT_REF);
1655 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1658 assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1659 assert (se->string_length
1660 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1664 /* Generate code for assignment of scalar variables. Includes character
1668 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1672 gfc_init_block (&block);
1674 if (type == BT_CHARACTER)
1676 assert (lse->string_length != NULL_TREE
1677 && rse->string_length != NULL_TREE);
1679 gfc_conv_string_parameter (lse);
1680 gfc_conv_string_parameter (rse);
1682 gfc_add_block_to_block (&block, &lse->pre);
1683 gfc_add_block_to_block (&block, &rse->pre);
1685 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1686 rse->string_length, rse->expr);
1690 gfc_add_block_to_block (&block, &lse->pre);
1691 gfc_add_block_to_block (&block, &rse->pre);
1693 gfc_add_modify_expr (&block, lse->expr, rse->expr);
1696 gfc_add_block_to_block (&block, &lse->post);
1697 gfc_add_block_to_block (&block, &rse->post);
1699 return gfc_finish_block (&block);
1703 /* Try to translate array(:) = func (...), where func is a transformational
1704 array function, without using a temporary. Returns NULL is this isn't the
1708 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1713 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1714 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1717 /* Elemental functions don't need a temporary anyway. */
1718 if (expr2->symtree->n.sym->attr.elemental)
1721 /* Check for a dependency. */
1722 if (gfc_check_fncall_dependency (expr1, expr2))
1725 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
1727 assert (expr2->value.function.isym
1728 || (gfc_return_by_reference (expr2->symtree->n.sym)
1729 && expr2->symtree->n.sym->result->attr.dimension));
1731 ss = gfc_walk_expr (expr1);
1732 assert (ss != gfc_ss_terminator);
1733 gfc_init_se (&se, NULL);
1734 gfc_start_block (&se.pre);
1735 se.want_pointer = 1;
1737 gfc_conv_array_parameter (&se, expr1, ss, 0);
1739 se.direct_byref = 1;
1740 se.ss = gfc_walk_expr (expr2);
1741 assert (se.ss != gfc_ss_terminator);
1742 gfc_conv_function_expr (&se, expr2);
1743 gfc_add_expr_to_block (&se.pre, se.expr);
1744 gfc_add_block_to_block (&se.pre, &se.post);
1746 return gfc_finish_block (&se.pre);
1750 /* Translate an assignment. Most of the code is concerned with
1751 setting up the scalarizer. */
1754 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
1759 gfc_ss *lss_section;
1766 /* Special case a single function returning an array. */
1767 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
1769 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
1774 /* Assignment of the form lhs = rhs. */
1775 gfc_start_block (&block);
1777 gfc_init_se (&lse, NULL);
1778 gfc_init_se (&rse, NULL);
1781 lss = gfc_walk_expr (expr1);
1783 if (lss != gfc_ss_terminator)
1785 /* The assignment needs scalarization. */
1788 /* Find a non-scalar SS from the lhs. */
1789 while (lss_section != gfc_ss_terminator
1790 && lss_section->type != GFC_SS_SECTION)
1791 lss_section = lss_section->next;
1793 assert (lss_section != gfc_ss_terminator);
1795 /* Initialize the scalarizer. */
1796 gfc_init_loopinfo (&loop);
1799 rss = gfc_walk_expr (expr2);
1800 if (rss == gfc_ss_terminator)
1802 /* The rhs is scalar. Add a ss for the expression. */
1803 rss = gfc_get_ss ();
1804 rss->next = gfc_ss_terminator;
1805 rss->type = GFC_SS_SCALAR;
1808 /* Associate the SS with the loop. */
1809 gfc_add_ss_to_loop (&loop, lss);
1810 gfc_add_ss_to_loop (&loop, rss);
1812 /* Calculate the bounds of the scalarization. */
1813 gfc_conv_ss_startstride (&loop);
1814 /* Resolve any data dependencies in the statement. */
1815 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
1816 /* Setup the scalarizing loops. */
1817 gfc_conv_loop_setup (&loop);
1819 /* Setup the gfc_se structures. */
1820 gfc_copy_loopinfo_to_se (&lse, &loop);
1821 gfc_copy_loopinfo_to_se (&rse, &loop);
1824 gfc_mark_ss_chain_used (rss, 1);
1825 if (loop.temp_ss == NULL)
1828 gfc_mark_ss_chain_used (lss, 1);
1832 lse.ss = loop.temp_ss;
1833 gfc_mark_ss_chain_used (lss, 3);
1834 gfc_mark_ss_chain_used (loop.temp_ss, 3);
1837 /* Start the scalarized loop body. */
1838 gfc_start_scalarized_body (&loop, &body);
1841 gfc_init_block (&body);
1843 /* Translate the expression. */
1844 gfc_conv_expr (&rse, expr2);
1846 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
1848 gfc_conv_tmp_array_ref (&lse);
1849 gfc_advance_se_ss_chain (&lse);
1852 gfc_conv_expr (&lse, expr1);
1854 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1855 gfc_add_expr_to_block (&body, tmp);
1857 if (lss == gfc_ss_terminator)
1859 /* Use the scalar assignment as is. */
1860 gfc_add_block_to_block (&block, &body);
1864 if (lse.ss != gfc_ss_terminator)
1866 if (rse.ss != gfc_ss_terminator)
1869 if (loop.temp_ss != NULL)
1871 gfc_trans_scalarized_loop_boundary (&loop, &body);
1873 /* We need to copy the temporary to the actual lhs. */
1874 gfc_init_se (&lse, NULL);
1875 gfc_init_se (&rse, NULL);
1876 gfc_copy_loopinfo_to_se (&lse, &loop);
1877 gfc_copy_loopinfo_to_se (&rse, &loop);
1879 rse.ss = loop.temp_ss;
1882 gfc_conv_tmp_array_ref (&rse);
1883 gfc_advance_se_ss_chain (&rse);
1884 gfc_conv_expr (&lse, expr1);
1886 if (lse.ss != gfc_ss_terminator)
1889 if (rse.ss != gfc_ss_terminator)
1892 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
1893 gfc_add_expr_to_block (&body, tmp);
1895 /* Generate the copying loops. */
1896 gfc_trans_scalarizing_loops (&loop, &body);
1898 /* Wrap the whole thing up. */
1899 gfc_add_block_to_block (&block, &loop.pre);
1900 gfc_add_block_to_block (&block, &loop.post);
1902 gfc_cleanup_loop (&loop);
1905 return gfc_finish_block (&block);
1909 gfc_trans_assign (gfc_code * code)
1911 return gfc_trans_assignment (code->expr, code->expr2);