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"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
53 dest->loop = src->loop;
57 /* Initialize 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 parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se * se)
86 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_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 gcc_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 gcc_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 build2 (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_charlen_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);
162 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
170 type = gfc_get_character_type (kind, ref->u.ss.length);
171 type = build_pointer_type (type);
174 gfc_init_se (&start, se);
175 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
176 gfc_add_block_to_block (&se->pre, &start.pre);
178 if (integer_onep (start.expr))
179 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_charlen_type_node);
198 gfc_add_block_to_block (&se->pre, &end.pre);
201 build2 (MINUS_EXPR, gfc_charlen_type_node,
202 fold_convert (gfc_charlen_type_node, integer_one_node),
204 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
205 se->string_length = fold (tmp);
209 /* Convert a derived type component reference. */
212 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
219 c = ref->u.c.component;
221 gcc_assert (c->backend_decl);
223 field = c->backend_decl;
224 gcc_assert (TREE_CODE (field) == FIELD_DECL);
226 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
230 if (c->ts.type == BT_CHARACTER)
232 tmp = c->ts.cl->backend_decl;
233 /* Components must always be constant length. */
234 gcc_assert (tmp && INTEGER_CST_P (tmp));
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 gcc_assert (se->ss != gfc_ss_terminator);
257 gcc_assert (se->ss->expr == expr);
259 /* A scalarized term. We already know the descriptor. */
260 se->expr = se->ss->data.info.descriptor;
261 se->string_length = se->ss->string_length;
262 ref = se->ss->data.info.ref;
266 se->expr = gfc_get_symbol_decl (sym);
268 /* Procedure actual arguments. */
269 if (sym->attr.flavor == FL_PROCEDURE
270 && se->expr != current_function_decl)
272 gcc_assert (se->want_pointer);
273 if (!sym->attr.dummy)
275 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
276 se->expr = gfc_build_addr_expr (NULL, se->expr);
281 /* Special case for assigning the return value of a function.
282 Self recursive functions must have an explicit return value. */
283 if (se->expr == current_function_decl && sym->attr.function
284 && (sym->result == sym))
286 se->expr = gfc_get_fake_result_decl (sym);
289 /* Dereference scalar dummy variables. */
291 && sym->ts.type != BT_CHARACTER
292 && !sym->attr.dimension)
293 se->expr = gfc_build_indirect_ref (se->expr);
295 /* Dereference pointer variables. */
296 if ((sym->attr.pointer || sym->attr.allocatable)
299 || sym->attr.function
300 || !sym->attr.dimension)
301 && sym->ts.type != BT_CHARACTER)
302 se->expr = gfc_build_indirect_ref (se->expr);
307 /* For character variables, also get the length. */
308 if (sym->ts.type == BT_CHARACTER)
310 se->string_length = sym->ts.cl->backend_decl;
311 gcc_assert (se->string_length);
319 /* Return the descriptor if that's what we want and this is an array
320 section reference. */
321 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
323 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
324 /* Return the descriptor for array pointers and allocations. */
326 && ref->next == NULL && (se->descriptor_only))
329 gfc_conv_array_ref (se, &ref->u.ar);
330 /* Return a pointer to an element. */
334 gfc_conv_component_ref (se, ref);
338 gfc_conv_substring (se, ref, expr->ts.kind);
347 /* Pointer assignment, allocation or pass by reference. Arrays are handled
349 if (se->want_pointer)
351 if (expr->ts.type == BT_CHARACTER)
352 gfc_conv_string_parameter (se);
354 se->expr = gfc_build_addr_expr (NULL, se->expr);
357 gfc_advance_se_ss_chain (se);
361 /* Unary ops are easy... Or they would be if ! was a valid op. */
364 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
369 gcc_assert (expr->ts.type != BT_CHARACTER);
370 /* Initialize the operand. */
371 gfc_init_se (&operand, se);
372 gfc_conv_expr_val (&operand, expr->op1);
373 gfc_add_block_to_block (&se->pre, &operand.pre);
375 type = gfc_typenode_for_spec (&expr->ts);
377 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
378 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
379 All other unary operators have an equivalent GIMPLE unary operator. */
380 if (code == TRUTH_NOT_EXPR)
381 se->expr = build2 (EQ_EXPR, type, operand.expr,
382 convert (type, integer_zero_node));
384 se->expr = build1 (code, type, operand.expr);
388 /* Expand power operator to optimal multiplications when a value is raised
389 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
390 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
391 Programming", 3rd Edition, 1998. */
393 /* This code is mostly duplicated from expand_powi in the backend.
394 We establish the "optimal power tree" lookup table with the defined size.
395 The items in the table are the exponents used to calculate the index
396 exponents. Any integer n less than the value can get an "addition chain",
397 with the first node being one. */
398 #define POWI_TABLE_SIZE 256
400 /* The table is from builtins.c. */
401 static const unsigned char powi_table[POWI_TABLE_SIZE] =
403 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
404 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
405 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
406 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
407 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
408 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
409 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
410 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
411 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
412 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
413 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
414 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
415 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
416 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
417 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
418 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
419 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
420 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
421 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
422 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
423 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
424 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
425 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
426 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
427 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
428 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
429 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
430 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
431 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
432 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
433 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
434 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
437 /* If n is larger than lookup table's max index, we use the "window
439 #define POWI_WINDOW_SIZE 3
441 /* Recursive function to expand the power operator. The temporary
442 values are put in tmpvar. The function returns tmpvar[1] ** n. */
444 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
451 if (n < POWI_TABLE_SIZE)
456 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
457 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
461 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
462 op0 = gfc_conv_powi (se, n - digit, tmpvar);
463 op1 = gfc_conv_powi (se, digit, tmpvar);
467 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
471 tmp = fold (build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1));
472 tmp = gfc_evaluate_now (tmp, &se->pre);
474 if (n < POWI_TABLE_SIZE)
481 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
482 return 1. Else return 0 and a call to runtime library functions
483 will have to be built. */
485 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
490 tree vartmp[POWI_TABLE_SIZE];
494 type = TREE_TYPE (lhs);
495 n = abs (TREE_INT_CST_LOW (rhs));
496 sgn = tree_int_cst_sgn (rhs);
498 if ((!flag_unsafe_math_optimizations || optimize_size) && (n > 2 || n < -1))
504 se->expr = gfc_build_const (type, integer_one_node);
507 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
508 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
510 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
511 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
512 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
513 convert (TREE_TYPE (lhs), integer_one_node));
516 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
519 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
520 se->expr = build3 (COND_EXPR, type, tmp,
521 convert (type, integer_one_node),
522 convert (type, integer_zero_node));
526 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
527 tmp = build3 (COND_EXPR, type, tmp,
528 convert (type, integer_minus_one_node),
529 convert (type, integer_zero_node));
530 se->expr = build3 (COND_EXPR, type, cond,
531 convert (type, integer_one_node),
536 memset (vartmp, 0, sizeof (vartmp));
540 tmp = gfc_build_const (type, integer_one_node);
541 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
544 se->expr = gfc_conv_powi (se, n, vartmp);
550 /* Power op (**). Constant integer exponent has special handling. */
553 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
555 tree gfc_int4_type_node;
563 gfc_init_se (&lse, se);
564 gfc_conv_expr_val (&lse, expr->op1);
565 gfc_add_block_to_block (&se->pre, &lse.pre);
567 gfc_init_se (&rse, se);
568 gfc_conv_expr_val (&rse, expr->op2);
569 gfc_add_block_to_block (&se->pre, &rse.pre);
571 if (expr->op2->ts.type == BT_INTEGER
572 && expr->op2->expr_type == EXPR_CONSTANT)
573 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
576 gfc_int4_type_node = gfc_get_int_type (4);
578 kind = expr->op1->ts.kind;
579 switch (expr->op2->ts.type)
582 ikind = expr->op2->ts.kind;
587 rse.expr = convert (gfc_int4_type_node, rse.expr);
605 if (expr->op1->ts.type == BT_INTEGER)
606 lse.expr = convert (gfc_int4_type_node, lse.expr);
623 switch (expr->op1->ts.type)
626 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
630 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
634 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
646 fndecl = built_in_decls[BUILT_IN_POWF];
649 fndecl = built_in_decls[BUILT_IN_POW];
660 fndecl = gfor_fndecl_math_cpowf;
663 fndecl = gfor_fndecl_math_cpow;
675 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
676 tmp = gfc_chainon_list (tmp, rse.expr);
677 se->expr = fold (gfc_build_function_call (fndecl, tmp));
681 /* Generate code to allocate a string temporary. */
684 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
690 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
692 if (gfc_can_put_var_on_stack (len))
694 /* Create a temporary variable to hold the result. */
695 tmp = fold (build2 (MINUS_EXPR, gfc_charlen_type_node, len,
696 convert (gfc_charlen_type_node,
698 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
699 tmp = build_array_type (gfc_character1_type_node, tmp);
700 var = gfc_create_var (tmp, "str");
701 var = gfc_build_addr_expr (type, var);
705 /* Allocate a temporary to hold the result. */
706 var = gfc_create_var (type, "pstr");
707 args = gfc_chainon_list (NULL_TREE, len);
708 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
709 tmp = convert (type, tmp);
710 gfc_add_modify_expr (&se->pre, var, tmp);
712 /* Free the temporary afterwards. */
713 tmp = convert (pvoid_type_node, var);
714 args = gfc_chainon_list (NULL_TREE, tmp);
715 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
716 gfc_add_expr_to_block (&se->post, tmp);
723 /* Handle a string concatenation operation. A temporary will be allocated to
727 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
737 gcc_assert (expr->op1->ts.type == BT_CHARACTER
738 && expr->op2->ts.type == BT_CHARACTER);
740 gfc_init_se (&lse, se);
741 gfc_conv_expr (&lse, expr->op1);
742 gfc_conv_string_parameter (&lse);
743 gfc_init_se (&rse, se);
744 gfc_conv_expr (&rse, expr->op2);
745 gfc_conv_string_parameter (&rse);
747 gfc_add_block_to_block (&se->pre, &lse.pre);
748 gfc_add_block_to_block (&se->pre, &rse.pre);
750 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
751 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
752 if (len == NULL_TREE)
754 len = fold (build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
755 lse.string_length, rse.string_length));
758 type = build_pointer_type (type);
760 var = gfc_conv_string_tmp (se, type, len);
762 /* Do the actual concatenation. */
764 args = gfc_chainon_list (args, len);
765 args = gfc_chainon_list (args, var);
766 args = gfc_chainon_list (args, lse.string_length);
767 args = gfc_chainon_list (args, lse.expr);
768 args = gfc_chainon_list (args, rse.string_length);
769 args = gfc_chainon_list (args, rse.expr);
770 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
771 gfc_add_expr_to_block (&se->pre, tmp);
773 /* Add the cleanup for the operands. */
774 gfc_add_block_to_block (&se->pre, &rse.post);
775 gfc_add_block_to_block (&se->pre, &lse.post);
778 se->string_length = len;
782 /* Translates an op expression. Common (binary) cases are handled by this
783 function, others are passed on. Recursion is used in either case.
784 We use the fact that (op1.ts == op2.ts) (except for the power
786 Operators need no special handling for scalarized expressions as long as
787 they call gfc_conv_simple_val to get their operands.
788 Character strings get special handling. */
791 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
803 switch (expr->operator)
805 case INTRINSIC_UPLUS:
806 gfc_conv_expr (se, expr->op1);
809 case INTRINSIC_UMINUS:
810 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
814 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
821 case INTRINSIC_MINUS:
825 case INTRINSIC_TIMES:
829 case INTRINSIC_DIVIDE:
830 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
831 an integer, we must round towards zero, so we use a
833 if (expr->ts.type == BT_INTEGER)
834 code = TRUNC_DIV_EXPR;
839 case INTRINSIC_POWER:
840 gfc_conv_power_op (se, expr);
843 case INTRINSIC_CONCAT:
844 gfc_conv_concat_op (se, expr);
848 code = TRUTH_ANDIF_EXPR;
853 code = TRUTH_ORIF_EXPR;
857 /* EQV and NEQV only work on logicals, but since we represent them
858 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
898 case INTRINSIC_ASSIGN:
899 /* These should be converted into function calls by the frontend. */
903 fatal_error ("Unknown intrinsic op");
907 /* The only exception to this is **, which is handled separately anyway. */
908 gcc_assert (expr->op1->ts.type == expr->op2->ts.type);
910 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
914 gfc_init_se (&lse, se);
915 gfc_conv_expr (&lse, expr->op1);
916 gfc_add_block_to_block (&se->pre, &lse.pre);
919 gfc_init_se (&rse, se);
920 gfc_conv_expr (&rse, expr->op2);
921 gfc_add_block_to_block (&se->pre, &rse.pre);
923 /* For string comparisons we generate a library call, and compare the return
927 gfc_conv_string_parameter (&lse);
928 gfc_conv_string_parameter (&rse);
930 tmp = gfc_chainon_list (tmp, lse.string_length);
931 tmp = gfc_chainon_list (tmp, lse.expr);
932 tmp = gfc_chainon_list (tmp, rse.string_length);
933 tmp = gfc_chainon_list (tmp, rse.expr);
935 /* Build a call for the comparison. */
936 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
937 gfc_add_block_to_block (&lse.post, &rse.post);
939 rse.expr = integer_zero_node;
942 type = gfc_typenode_for_spec (&expr->ts);
946 /* The result of logical ops is always boolean_type_node. */
947 tmp = fold (build2 (code, type, lse.expr, rse.expr));
948 se->expr = convert (type, tmp);
951 se->expr = fold (build2 (code, type, lse.expr, rse.expr));
953 /* Add the post blocks. */
954 gfc_add_block_to_block (&se->post, &rse.post);
955 gfc_add_block_to_block (&se->post, &lse.post);
960 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
966 tmp = gfc_get_symbol_decl (sym);
967 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
968 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
974 if (!sym->backend_decl)
975 sym->backend_decl = gfc_get_extern_function_decl (sym);
977 tmp = sym->backend_decl;
978 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
979 se->expr = gfc_build_addr_expr (NULL, tmp);
984 /* Generate code for a procedure call. Note can return se->post != NULL.
985 If se->direct_byref is set then se->expr contains the return parameter. */
988 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
989 gfc_actual_arglist * arg)
1002 gfc_formal_arglist *formal;
1004 arglist = NULL_TREE;
1005 stringargs = NULL_TREE;
1011 if (!sym->attr.elemental)
1013 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1014 if (se->ss->useflags)
1016 gcc_assert (gfc_return_by_reference (sym)
1017 && sym->result->attr.dimension);
1018 gcc_assert (se->loop != NULL);
1020 /* Access the previously obtained result. */
1021 gfc_conv_tmp_array_ref (se);
1022 gfc_advance_se_ss_chain (se);
1026 info = &se->ss->data.info;
1031 byref = gfc_return_by_reference (sym);
1034 if (se->direct_byref)
1035 arglist = gfc_chainon_list (arglist, se->expr);
1036 else if (sym->result->attr.dimension)
1038 gcc_assert (se->loop && se->ss);
1039 /* Set the type of the array. */
1040 tmp = gfc_typenode_for_spec (&sym->ts);
1041 info->dimen = se->loop->dimen;
1042 /* Allocate a temporary to store the result. */
1043 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1045 /* Zero the first stride to indicate a temporary. */
1047 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1048 gfc_add_modify_expr (&se->pre, tmp,
1049 convert (TREE_TYPE (tmp), integer_zero_node));
1050 /* Pass the temporary as the first argument. */
1051 tmp = info->descriptor;
1052 tmp = gfc_build_addr_expr (NULL, tmp);
1053 arglist = gfc_chainon_list (arglist, tmp);
1055 else if (sym->ts.type == BT_CHARACTER)
1057 gcc_assert (sym->ts.cl && sym->ts.cl->length
1058 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1059 len = gfc_conv_mpz_to_tree
1060 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1061 sym->ts.cl->backend_decl = len;
1062 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1063 type = build_pointer_type (type);
1065 var = gfc_conv_string_tmp (se, type, len);
1066 arglist = gfc_chainon_list (arglist, var);
1067 arglist = gfc_chainon_list (arglist,
1068 convert (gfc_charlen_type_node, len));
1070 else /* TODO: derived type function return values. */
1074 formal = sym->formal;
1075 /* Evaluate the arguments. */
1076 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1078 if (arg->expr == NULL)
1081 if (se->ignore_optional)
1083 /* Some intrinsics have already been resolved to the correct
1087 else if (arg->label)
1089 has_alternate_specifier = 1;
1094 /* Pass a NULL pointer for an absent arg. */
1095 gfc_init_se (&parmse, NULL);
1096 parmse.expr = null_pointer_node;
1097 if (arg->missing_arg_type == BT_CHARACTER)
1100 gfc_chainon_list (stringargs,
1101 convert (gfc_charlen_type_node,
1102 integer_zero_node));
1106 else if (se->ss && se->ss->useflags)
1108 /* An elemental function inside a scalarized loop. */
1109 gfc_init_se (&parmse, se);
1110 gfc_conv_expr_reference (&parmse, arg->expr);
1114 /* A scalar or transformational function. */
1115 gfc_init_se (&parmse, NULL);
1116 argss = gfc_walk_expr (arg->expr);
1118 if (argss == gfc_ss_terminator)
1120 gfc_conv_expr_reference (&parmse, arg->expr);
1121 if (formal && formal->sym->attr.pointer
1122 && arg->expr->expr_type != EXPR_NULL)
1124 /* Scalar pointer dummy args require an extra level of
1125 indirection. The null pointer already contains
1126 this level of indirection. */
1127 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1132 /* If the procedure requires an explicit interface, the
1133 actual argument is passed according to the
1134 corresponding formal argument. If the corresponding
1135 formal argument is a POINTER or assumed shape, we do
1136 not use g77's calling aonvention, and pass the
1137 address of the array descriptor instead. Otherwise we
1138 use g77's calling convention. */
1140 f = (formal != NULL)
1141 && !formal->sym->attr.pointer
1142 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1143 f = f || !sym->attr.always_explicit;
1144 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1148 gfc_add_block_to_block (&se->pre, &parmse.pre);
1149 gfc_add_block_to_block (&se->post, &parmse.post);
1151 /* Character strings are passed as two paramarers, a length and a
1153 if (parmse.string_length != NULL_TREE)
1154 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1156 arglist = gfc_chainon_list (arglist, parmse.expr);
1159 /* Add the hidden string length parameters to the arguments. */
1160 arglist = chainon (arglist, stringargs);
1162 /* Generate the actual call. */
1163 gfc_conv_function_val (se, sym);
1164 /* If there are alternate return labels, function type should be
1166 if (has_alternate_specifier)
1167 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1169 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1170 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1171 arglist, NULL_TREE);
1173 /* If we have a pointer function, but we don't want a pointer, e.g.
1176 where f is pointer valued, we have to dereference the result. */
1177 if (sym->attr.pointer && !se->want_pointer && !byref)
1178 se->expr = gfc_build_indirect_ref (se->expr);
1180 /* A pure function may still have side-effects - it may modify its
1182 TREE_SIDE_EFFECTS (se->expr) = 1;
1184 if (!sym->attr.pure)
1185 TREE_SIDE_EFFECTS (se->expr) = 1;
1190 /* Add the function call to the pre chain. There is no expression. */
1191 gfc_add_expr_to_block (&se->pre, se->expr);
1192 se->expr = NULL_TREE;
1194 if (!se->direct_byref)
1196 if (sym->result->attr.dimension)
1198 if (flag_bounds_check)
1200 /* Check the data pointer hasn't been modified. This would
1201 happen in a function returning a pointer. */
1202 tmp = gfc_conv_descriptor_data (info->descriptor);
1203 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1204 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1206 se->expr = info->descriptor;
1208 else if (sym->ts.type == BT_CHARACTER)
1211 se->string_length = len;
1220 /* Generate code to copy a string. */
1223 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1224 tree slen, tree src)
1229 tmp = gfc_chainon_list (tmp, dlen);
1230 tmp = gfc_chainon_list (tmp, dest);
1231 tmp = gfc_chainon_list (tmp, slen);
1232 tmp = gfc_chainon_list (tmp, src);
1233 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1234 gfc_add_expr_to_block (block, tmp);
1238 /* Translate a statement function.
1239 The value of a statement function reference is obtained by evaluating the
1240 expression using the values of the actual arguments for the values of the
1241 corresponding dummy arguments. */
1244 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1248 gfc_formal_arglist *fargs;
1249 gfc_actual_arglist *args;
1252 gfc_saved_var *saved_vars;
1258 sym = expr->symtree->n.sym;
1259 args = expr->value.function.actual;
1260 gfc_init_se (&lse, NULL);
1261 gfc_init_se (&rse, NULL);
1264 for (fargs = sym->formal; fargs; fargs = fargs->next)
1266 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1267 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1269 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1271 /* Each dummy shall be specified, explicitly or implicitly, to be
1273 gcc_assert (fargs->sym->attr.dimension == 0);
1276 /* Create a temporary to hold the value. */
1277 type = gfc_typenode_for_spec (&fsym->ts);
1278 temp_vars[n] = gfc_create_var (type, fsym->name);
1280 if (fsym->ts.type == BT_CHARACTER)
1282 /* Copy string arguments. */
1285 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1286 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1288 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1289 tmp = gfc_build_addr_expr (build_pointer_type (type),
1292 gfc_conv_expr (&rse, args->expr);
1293 gfc_conv_string_parameter (&rse);
1294 gfc_add_block_to_block (&se->pre, &lse.pre);
1295 gfc_add_block_to_block (&se->pre, &rse.pre);
1297 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1299 gfc_add_block_to_block (&se->pre, &lse.post);
1300 gfc_add_block_to_block (&se->pre, &rse.post);
1304 /* For everything else, just evaluate the expression. */
1305 gfc_conv_expr (&lse, args->expr);
1307 gfc_add_block_to_block (&se->pre, &lse.pre);
1308 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1309 gfc_add_block_to_block (&se->pre, &lse.post);
1315 /* Use the temporary variables in place of the real ones. */
1316 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1317 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1319 gfc_conv_expr (se, sym->value);
1321 if (sym->ts.type == BT_CHARACTER)
1323 gfc_conv_const_charlen (sym->ts.cl);
1325 /* Force the expression to the correct length. */
1326 if (!INTEGER_CST_P (se->string_length)
1327 || tree_int_cst_lt (se->string_length,
1328 sym->ts.cl->backend_decl))
1330 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1331 tmp = gfc_create_var (type, sym->name);
1332 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1333 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1334 se->string_length, se->expr);
1337 se->string_length = sym->ts.cl->backend_decl;
1340 /* Restore the original variables. */
1341 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1342 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1343 gfc_free (saved_vars);
1347 /* Translate a function expression. */
1350 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1354 if (expr->value.function.isym)
1356 gfc_conv_intrinsic_function (se, expr);
1360 /* We distinguish statement functions from general functions to improve
1361 runtime performance. */
1362 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1364 gfc_conv_statement_function (se, expr);
1368 /* expr.value.function.esym is the resolved (specific) function symbol for
1369 most functions. However this isn't set for dummy procedures. */
1370 sym = expr->value.function.esym;
1372 sym = expr->symtree->n.sym;
1373 gfc_conv_function_call (se, sym, expr->value.function.actual);
1378 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1380 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1381 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1383 gfc_conv_tmp_array_ref (se);
1384 gfc_advance_se_ss_chain (se);
1388 /* Build a static initializer. EXPR is the expression for the initial value.
1389 The other parameters describe the variable of the component being
1390 initialized. EXPR may be null. */
1393 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1394 bool array, bool pointer)
1398 if (!(expr || pointer))
1403 /* Arrays need special handling. */
1405 return gfc_build_null_descriptor (type);
1407 return gfc_conv_array_initializer (type, expr);
1410 return fold_convert (type, null_pointer_node);
1416 gfc_init_se (&se, NULL);
1417 gfc_conv_structure (&se, expr, 1);
1421 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1424 gfc_init_se (&se, NULL);
1425 gfc_conv_constant (&se, expr);
1432 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1444 gfc_start_block (&block);
1446 /* Initialize the scalarizer. */
1447 gfc_init_loopinfo (&loop);
1449 gfc_init_se (&lse, NULL);
1450 gfc_init_se (&rse, NULL);
1453 rss = gfc_walk_expr (expr);
1454 if (rss == gfc_ss_terminator)
1456 /* The rhs is scalar. Add a ss for the expression. */
1457 rss = gfc_get_ss ();
1458 rss->next = gfc_ss_terminator;
1459 rss->type = GFC_SS_SCALAR;
1463 /* Create a SS for the destination. */
1464 lss = gfc_get_ss ();
1465 lss->type = GFC_SS_COMPONENT;
1467 lss->shape = gfc_get_shape (cm->as->rank);
1468 lss->next = gfc_ss_terminator;
1469 lss->data.info.dimen = cm->as->rank;
1470 lss->data.info.descriptor = dest;
1471 lss->data.info.data = gfc_conv_array_data (dest);
1472 lss->data.info.offset = gfc_conv_array_offset (dest);
1473 for (n = 0; n < cm->as->rank; n++)
1475 lss->data.info.dim[n] = n;
1476 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1477 lss->data.info.stride[n] = gfc_index_one_node;
1479 mpz_init (lss->shape[n]);
1480 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1481 cm->as->lower[n]->value.integer);
1482 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1485 /* Associate the SS with the loop. */
1486 gfc_add_ss_to_loop (&loop, lss);
1487 gfc_add_ss_to_loop (&loop, rss);
1489 /* Calculate the bounds of the scalarization. */
1490 gfc_conv_ss_startstride (&loop);
1492 /* Setup the scalarizing loops. */
1493 gfc_conv_loop_setup (&loop);
1495 /* Setup the gfc_se structures. */
1496 gfc_copy_loopinfo_to_se (&lse, &loop);
1497 gfc_copy_loopinfo_to_se (&rse, &loop);
1500 gfc_mark_ss_chain_used (rss, 1);
1502 gfc_mark_ss_chain_used (lss, 1);
1504 /* Start the scalarized loop body. */
1505 gfc_start_scalarized_body (&loop, &body);
1507 gfc_conv_tmp_array_ref (&lse);
1508 gfc_conv_expr (&rse, expr);
1510 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1511 gfc_add_expr_to_block (&body, tmp);
1513 gcc_assert (rse.ss == gfc_ss_terminator);
1515 /* Generate the copying loops. */
1516 gfc_trans_scalarizing_loops (&loop, &body);
1518 /* Wrap the whole thing up. */
1519 gfc_add_block_to_block (&block, &loop.pre);
1520 gfc_add_block_to_block (&block, &loop.post);
1522 gfc_cleanup_loop (&loop);
1524 for (n = 0; n < cm->as->rank; n++)
1525 mpz_clear (lss->shape[n]);
1526 gfc_free (lss->shape);
1528 return gfc_finish_block (&block);
1531 /* Assign a single component of a derived type constructor. */
1534 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1541 gfc_start_block (&block);
1544 gfc_init_se (&se, NULL);
1545 /* Pointer component. */
1548 /* Array pointer. */
1549 if (expr->expr_type == EXPR_NULL)
1551 dest = gfc_conv_descriptor_data (dest);
1552 tmp = fold_convert (TREE_TYPE (se.expr),
1554 gfc_add_modify_expr (&block, dest, tmp);
1558 rss = gfc_walk_expr (expr);
1559 se.direct_byref = 1;
1561 gfc_conv_expr_descriptor (&se, expr, rss);
1562 gfc_add_block_to_block (&block, &se.pre);
1563 gfc_add_block_to_block (&block, &se.post);
1568 /* Scalar pointers. */
1569 se.want_pointer = 1;
1570 gfc_conv_expr (&se, expr);
1571 gfc_add_block_to_block (&block, &se.pre);
1572 gfc_add_modify_expr (&block, dest,
1573 fold_convert (TREE_TYPE (dest), se.expr));
1574 gfc_add_block_to_block (&block, &se.post);
1577 else if (cm->dimension)
1579 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1580 gfc_add_expr_to_block (&block, tmp);
1582 else if (expr->ts.type == BT_DERIVED)
1584 /* Nested dervived type. */
1585 tmp = gfc_trans_structure_assign (dest, expr);
1586 gfc_add_expr_to_block (&block, tmp);
1590 /* Scalar component. */
1593 gfc_init_se (&se, NULL);
1594 gfc_init_se (&lse, NULL);
1596 gfc_conv_expr (&se, expr);
1597 if (cm->ts.type == BT_CHARACTER)
1598 lse.string_length = cm->ts.cl->backend_decl;
1600 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1601 gfc_add_expr_to_block (&block, tmp);
1603 return gfc_finish_block (&block);
1606 /* Assign a derived type contructor to a variable. */
1609 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1617 gfc_start_block (&block);
1618 cm = expr->ts.derived->components;
1619 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1621 /* Skip absent members in default initializers. */
1625 field = cm->backend_decl;
1626 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1627 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1628 gfc_add_expr_to_block (&block, tmp);
1630 return gfc_finish_block (&block);
1633 /* Build an expression for a constructor. If init is nonzero then
1634 this is part of a static variable initializer. */
1637 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1647 gcc_assert (se->ss == NULL);
1648 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1649 type = gfc_typenode_for_spec (&expr->ts);
1653 /* Create a temporary variable and fill it in. */
1654 se->expr = gfc_create_var (type, expr->ts.derived->name);
1655 tmp = gfc_trans_structure_assign (se->expr, expr);
1656 gfc_add_expr_to_block (&se->pre, tmp);
1660 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1663 cm = expr->ts.derived->components;
1664 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1666 /* Skip absent members in default initializers. */
1670 val = gfc_conv_initializer (c->expr, &cm->ts,
1671 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1673 /* Build a TREE_CHAIN to hold it. */
1674 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1676 /* Add it to the list. */
1677 if (tail == NULL_TREE)
1678 TREE_OPERAND(head, 0) = tail = val;
1681 TREE_CHAIN (tail) = val;
1689 /* Translate a substring expression. */
1692 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1698 gcc_assert (ref->type == REF_SUBSTRING);
1700 se->expr = gfc_build_string_const(expr->value.character.length,
1701 expr->value.character.string);
1702 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1703 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1705 gfc_conv_substring(se,ref,expr->ts.kind);
1709 /* Entry point for expression translation. */
1712 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1714 if (se->ss && se->ss->expr == expr
1715 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1717 /* Substitute a scalar expression evaluated outside the scalarization
1719 se->expr = se->ss->data.scalar.expr;
1720 se->string_length = se->ss->string_length;
1721 gfc_advance_se_ss_chain (se);
1725 switch (expr->expr_type)
1728 gfc_conv_expr_op (se, expr);
1732 gfc_conv_function_expr (se, expr);
1736 gfc_conv_constant (se, expr);
1740 gfc_conv_variable (se, expr);
1744 se->expr = null_pointer_node;
1747 case EXPR_SUBSTRING:
1748 gfc_conv_substring_expr (se, expr);
1751 case EXPR_STRUCTURE:
1752 gfc_conv_structure (se, expr, 0);
1756 gfc_conv_array_constructor_expr (se, expr);
1766 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1768 gfc_conv_expr (se, expr);
1769 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1770 figure out a way of rewriting an lvalue so that it has no post chain. */
1771 gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1775 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1779 gcc_assert (expr->ts.type != BT_CHARACTER);
1780 gfc_conv_expr (se, expr);
1783 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1784 gfc_add_modify_expr (&se->pre, val, se->expr);
1789 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1791 gfc_conv_expr_val (se, expr);
1792 se->expr = convert (type, se->expr);
1796 /* Converts an expression so that it can be passed by reference. Scalar
1800 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1804 if (se->ss && se->ss->expr == expr
1805 && se->ss->type == GFC_SS_REFERENCE)
1807 se->expr = se->ss->data.scalar.expr;
1808 se->string_length = se->ss->string_length;
1809 gfc_advance_se_ss_chain (se);
1813 if (expr->ts.type == BT_CHARACTER)
1815 gfc_conv_expr (se, expr);
1816 gfc_conv_string_parameter (se);
1820 if (expr->expr_type == EXPR_VARIABLE)
1822 se->want_pointer = 1;
1823 gfc_conv_expr (se, expr);
1826 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1827 gfc_add_modify_expr (&se->pre, var, se->expr);
1828 gfc_add_block_to_block (&se->pre, &se->post);
1834 gfc_conv_expr (se, expr);
1836 /* Create a temporary var to hold the value. */
1837 if (TREE_CONSTANT (se->expr))
1839 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1840 DECL_INITIAL (var) = se->expr;
1845 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1846 gfc_add_modify_expr (&se->pre, var, se->expr);
1848 gfc_add_block_to_block (&se->pre, &se->post);
1850 /* Take the address of that value. */
1851 se->expr = gfc_build_addr_expr (NULL, var);
1856 gfc_trans_pointer_assign (gfc_code * code)
1858 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1862 /* Generate code for a pointer assignment. */
1865 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1873 gfc_start_block (&block);
1875 gfc_init_se (&lse, NULL);
1877 lss = gfc_walk_expr (expr1);
1878 rss = gfc_walk_expr (expr2);
1879 if (lss == gfc_ss_terminator)
1881 /* Scalar pointers. */
1882 lse.want_pointer = 1;
1883 gfc_conv_expr (&lse, expr1);
1884 gcc_assert (rss == gfc_ss_terminator);
1885 gfc_init_se (&rse, NULL);
1886 rse.want_pointer = 1;
1887 gfc_conv_expr (&rse, expr2);
1888 gfc_add_block_to_block (&block, &lse.pre);
1889 gfc_add_block_to_block (&block, &rse.pre);
1890 gfc_add_modify_expr (&block, lse.expr,
1891 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1892 gfc_add_block_to_block (&block, &rse.post);
1893 gfc_add_block_to_block (&block, &lse.post);
1897 /* Array pointer. */
1898 gfc_conv_expr_descriptor (&lse, expr1, lss);
1899 /* Implement Nullify. */
1900 if (expr2->expr_type == EXPR_NULL)
1902 lse.expr = gfc_conv_descriptor_data (lse.expr);
1903 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1904 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1908 lse.direct_byref = 1;
1909 gfc_conv_expr_descriptor (&lse, expr2, rss);
1911 gfc_add_block_to_block (&block, &lse.pre);
1912 gfc_add_block_to_block (&block, &lse.post);
1914 return gfc_finish_block (&block);
1918 /* Makes sure se is suitable for passing as a function string parameter. */
1919 /* TODO: Need to check all callers fo this function. It may be abused. */
1922 gfc_conv_string_parameter (gfc_se * se)
1926 if (TREE_CODE (se->expr) == STRING_CST)
1928 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1932 type = TREE_TYPE (se->expr);
1933 if (TYPE_STRING_FLAG (type))
1935 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
1936 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1939 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1940 gcc_assert (se->string_length
1941 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1945 /* Generate code for assignment of scalar variables. Includes character
1949 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
1953 gfc_init_block (&block);
1955 if (type == BT_CHARACTER)
1957 gcc_assert (lse->string_length != NULL_TREE
1958 && rse->string_length != NULL_TREE);
1960 gfc_conv_string_parameter (lse);
1961 gfc_conv_string_parameter (rse);
1963 gfc_add_block_to_block (&block, &lse->pre);
1964 gfc_add_block_to_block (&block, &rse->pre);
1966 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
1967 rse->string_length, rse->expr);
1971 gfc_add_block_to_block (&block, &lse->pre);
1972 gfc_add_block_to_block (&block, &rse->pre);
1974 gfc_add_modify_expr (&block, lse->expr,
1975 fold_convert (TREE_TYPE (lse->expr), rse->expr));
1978 gfc_add_block_to_block (&block, &lse->post);
1979 gfc_add_block_to_block (&block, &rse->post);
1981 return gfc_finish_block (&block);
1985 /* Try to translate array(:) = func (...), where func is a transformational
1986 array function, without using a temporary. Returns NULL is this isn't the
1990 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
1995 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
1996 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
1999 /* Elemental functions don't need a temporary anyway. */
2000 if (expr2->symtree->n.sym->attr.elemental)
2003 /* Check for a dependency. */
2004 if (gfc_check_fncall_dependency (expr1, expr2))
2007 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2009 gcc_assert (expr2->value.function.isym
2010 || (gfc_return_by_reference (expr2->symtree->n.sym)
2011 && expr2->symtree->n.sym->result->attr.dimension));
2013 ss = gfc_walk_expr (expr1);
2014 gcc_assert (ss != gfc_ss_terminator);
2015 gfc_init_se (&se, NULL);
2016 gfc_start_block (&se.pre);
2017 se.want_pointer = 1;
2019 gfc_conv_array_parameter (&se, expr1, ss, 0);
2021 se.direct_byref = 1;
2022 se.ss = gfc_walk_expr (expr2);
2023 gcc_assert (se.ss != gfc_ss_terminator);
2024 gfc_conv_function_expr (&se, expr2);
2025 gfc_add_block_to_block (&se.pre, &se.post);
2027 return gfc_finish_block (&se.pre);
2031 /* Translate an assignment. Most of the code is concerned with
2032 setting up the scalarizer. */
2035 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2040 gfc_ss *lss_section;
2047 /* Special case a single function returning an array. */
2048 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2050 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2055 /* Assignment of the form lhs = rhs. */
2056 gfc_start_block (&block);
2058 gfc_init_se (&lse, NULL);
2059 gfc_init_se (&rse, NULL);
2062 lss = gfc_walk_expr (expr1);
2064 if (lss != gfc_ss_terminator)
2066 /* The assignment needs scalarization. */
2069 /* Find a non-scalar SS from the lhs. */
2070 while (lss_section != gfc_ss_terminator
2071 && lss_section->type != GFC_SS_SECTION)
2072 lss_section = lss_section->next;
2074 gcc_assert (lss_section != gfc_ss_terminator);
2076 /* Initialize the scalarizer. */
2077 gfc_init_loopinfo (&loop);
2080 rss = gfc_walk_expr (expr2);
2081 if (rss == gfc_ss_terminator)
2083 /* The rhs is scalar. Add a ss for the expression. */
2084 rss = gfc_get_ss ();
2085 rss->next = gfc_ss_terminator;
2086 rss->type = GFC_SS_SCALAR;
2089 /* Associate the SS with the loop. */
2090 gfc_add_ss_to_loop (&loop, lss);
2091 gfc_add_ss_to_loop (&loop, rss);
2093 /* Calculate the bounds of the scalarization. */
2094 gfc_conv_ss_startstride (&loop);
2095 /* Resolve any data dependencies in the statement. */
2096 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2097 /* Setup the scalarizing loops. */
2098 gfc_conv_loop_setup (&loop);
2100 /* Setup the gfc_se structures. */
2101 gfc_copy_loopinfo_to_se (&lse, &loop);
2102 gfc_copy_loopinfo_to_se (&rse, &loop);
2105 gfc_mark_ss_chain_used (rss, 1);
2106 if (loop.temp_ss == NULL)
2109 gfc_mark_ss_chain_used (lss, 1);
2113 lse.ss = loop.temp_ss;
2114 gfc_mark_ss_chain_used (lss, 3);
2115 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2118 /* Start the scalarized loop body. */
2119 gfc_start_scalarized_body (&loop, &body);
2122 gfc_init_block (&body);
2124 /* Translate the expression. */
2125 gfc_conv_expr (&rse, expr2);
2127 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2129 gfc_conv_tmp_array_ref (&lse);
2130 gfc_advance_se_ss_chain (&lse);
2133 gfc_conv_expr (&lse, expr1);
2135 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2136 gfc_add_expr_to_block (&body, tmp);
2138 if (lss == gfc_ss_terminator)
2140 /* Use the scalar assignment as is. */
2141 gfc_add_block_to_block (&block, &body);
2145 gcc_assert (lse.ss == gfc_ss_terminator
2146 && rse.ss == gfc_ss_terminator);
2148 if (loop.temp_ss != NULL)
2150 gfc_trans_scalarized_loop_boundary (&loop, &body);
2152 /* We need to copy the temporary to the actual lhs. */
2153 gfc_init_se (&lse, NULL);
2154 gfc_init_se (&rse, NULL);
2155 gfc_copy_loopinfo_to_se (&lse, &loop);
2156 gfc_copy_loopinfo_to_se (&rse, &loop);
2158 rse.ss = loop.temp_ss;
2161 gfc_conv_tmp_array_ref (&rse);
2162 gfc_advance_se_ss_chain (&rse);
2163 gfc_conv_expr (&lse, expr1);
2165 gcc_assert (lse.ss == gfc_ss_terminator
2166 && rse.ss == gfc_ss_terminator);
2168 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2169 gfc_add_expr_to_block (&body, tmp);
2171 /* Generate the copying loops. */
2172 gfc_trans_scalarizing_loops (&loop, &body);
2174 /* Wrap the whole thing up. */
2175 gfc_add_block_to_block (&block, &loop.pre);
2176 gfc_add_block_to_block (&block, &loop.post);
2178 gfc_cleanup_loop (&loop);
2181 return gfc_finish_block (&block);
2185 gfc_trans_assign (gfc_code * code)
2187 return gfc_trans_assignment (code->expr, code->expr2);