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 (CONSTANT_CLASS_P (se->expr))
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 /* Get the character length of an expression, looking through gfc_refs
147 gfc_get_expr_charlen (gfc_expr *e)
152 gcc_assert (e->expr_type == EXPR_VARIABLE
153 && e->ts.type == BT_CHARACTER);
155 length = NULL; /* To silence compiler warning. */
157 /* First candidate: if the variable is of type CHARACTER, the
158 expression's length could be the length of the character
160 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
161 length = e->symtree->n.sym->ts.cl->backend_decl;
163 /* Look through the reference chain for component references. */
164 for (r = e->ref; r; r = r->next)
169 if (r->u.c.component->ts.type == BT_CHARACTER)
170 length = r->u.c.component->ts.cl->backend_decl;
178 /* We should never got substring references here. These will be
179 broken down by the scalarizer. */
184 gcc_assert (length != NULL);
190 /* Generate code to initialize a string length variable. Returns the
194 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
199 gfc_init_se (&se, NULL);
200 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
201 gfc_add_block_to_block (pblock, &se.pre);
203 tmp = cl->backend_decl;
204 gfc_add_modify_expr (pblock, tmp, se.expr);
209 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
217 type = gfc_get_character_type (kind, ref->u.ss.length);
218 type = build_pointer_type (type);
221 gfc_init_se (&start, se);
222 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
223 gfc_add_block_to_block (&se->pre, &start.pre);
225 if (integer_onep (start.expr))
226 gfc_conv_string_parameter (se);
229 /* Change the start of the string. */
230 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
233 tmp = gfc_build_indirect_ref (se->expr);
234 tmp = gfc_build_array_ref (tmp, start.expr);
235 se->expr = gfc_build_addr_expr (type, tmp);
238 /* Length = end + 1 - start. */
239 gfc_init_se (&end, se);
240 if (ref->u.ss.end == NULL)
241 end.expr = se->string_length;
244 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
245 gfc_add_block_to_block (&se->pre, &end.pre);
248 build2 (MINUS_EXPR, gfc_charlen_type_node,
249 fold_convert (gfc_charlen_type_node, integer_one_node),
251 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
252 se->string_length = fold (tmp);
256 /* Convert a derived type component reference. */
259 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
266 c = ref->u.c.component;
268 gcc_assert (c->backend_decl);
270 field = c->backend_decl;
271 gcc_assert (TREE_CODE (field) == FIELD_DECL);
273 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
277 if (c->ts.type == BT_CHARACTER)
279 tmp = c->ts.cl->backend_decl;
280 /* Components must always be constant length. */
281 gcc_assert (tmp && INTEGER_CST_P (tmp));
282 se->string_length = tmp;
285 if (c->pointer && c->dimension == 0)
286 se->expr = gfc_build_indirect_ref (se->expr);
290 /* Return the contents of a variable. Also handles reference/pointer
291 variables (all Fortran pointer references are implicit). */
294 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
299 sym = expr->symtree->n.sym;
302 /* Check that something hasn't gone horribly wrong. */
303 gcc_assert (se->ss != gfc_ss_terminator);
304 gcc_assert (se->ss->expr == expr);
306 /* A scalarized term. We already know the descriptor. */
307 se->expr = se->ss->data.info.descriptor;
308 se->string_length = se->ss->string_length;
309 ref = se->ss->data.info.ref;
313 se->expr = gfc_get_symbol_decl (sym);
315 /* Procedure actual arguments. */
316 if (sym->attr.flavor == FL_PROCEDURE
317 && se->expr != current_function_decl)
319 gcc_assert (se->want_pointer);
320 if (!sym->attr.dummy)
322 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
323 se->expr = gfc_build_addr_expr (NULL, se->expr);
328 /* Special case for assigning the return value of a function.
329 Self recursive functions must have an explicit return value. */
330 if (se->expr == current_function_decl && sym->attr.function
331 && (sym->result == sym))
333 se->expr = gfc_get_fake_result_decl (sym);
336 /* Dereference scalar dummy variables. */
338 && sym->ts.type != BT_CHARACTER
339 && !sym->attr.dimension)
340 se->expr = gfc_build_indirect_ref (se->expr);
342 /* Dereference pointer variables. */
343 if ((sym->attr.pointer || sym->attr.allocatable)
346 || sym->attr.function
347 || !sym->attr.dimension)
348 && sym->ts.type != BT_CHARACTER)
349 se->expr = gfc_build_indirect_ref (se->expr);
354 /* For character variables, also get the length. */
355 if (sym->ts.type == BT_CHARACTER)
357 se->string_length = sym->ts.cl->backend_decl;
358 gcc_assert (se->string_length);
366 /* Return the descriptor if that's what we want and this is an array
367 section reference. */
368 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
370 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
371 /* Return the descriptor for array pointers and allocations. */
373 && ref->next == NULL && (se->descriptor_only))
376 gfc_conv_array_ref (se, &ref->u.ar);
377 /* Return a pointer to an element. */
381 gfc_conv_component_ref (se, ref);
385 gfc_conv_substring (se, ref, expr->ts.kind);
394 /* Pointer assignment, allocation or pass by reference. Arrays are handled
396 if (se->want_pointer)
398 if (expr->ts.type == BT_CHARACTER)
399 gfc_conv_string_parameter (se);
401 se->expr = gfc_build_addr_expr (NULL, se->expr);
404 gfc_advance_se_ss_chain (se);
408 /* Unary ops are easy... Or they would be if ! was a valid op. */
411 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
416 gcc_assert (expr->ts.type != BT_CHARACTER);
417 /* Initialize the operand. */
418 gfc_init_se (&operand, se);
419 gfc_conv_expr_val (&operand, expr->op1);
420 gfc_add_block_to_block (&se->pre, &operand.pre);
422 type = gfc_typenode_for_spec (&expr->ts);
424 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
425 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
426 All other unary operators have an equivalent GIMPLE unary operator. */
427 if (code == TRUTH_NOT_EXPR)
428 se->expr = build2 (EQ_EXPR, type, operand.expr,
429 convert (type, integer_zero_node));
431 se->expr = build1 (code, type, operand.expr);
435 /* Expand power operator to optimal multiplications when a value is raised
436 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
437 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
438 Programming", 3rd Edition, 1998. */
440 /* This code is mostly duplicated from expand_powi in the backend.
441 We establish the "optimal power tree" lookup table with the defined size.
442 The items in the table are the exponents used to calculate the index
443 exponents. Any integer n less than the value can get an "addition chain",
444 with the first node being one. */
445 #define POWI_TABLE_SIZE 256
447 /* The table is from builtins.c. */
448 static const unsigned char powi_table[POWI_TABLE_SIZE] =
450 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
451 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
452 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
453 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
454 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
455 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
456 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
457 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
458 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
459 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
460 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
461 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
462 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
463 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
464 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
465 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
466 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
467 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
468 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
469 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
470 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
471 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
472 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
473 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
474 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
475 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
476 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
477 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
478 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
479 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
480 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
481 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
484 /* If n is larger than lookup table's max index, we use the "window
486 #define POWI_WINDOW_SIZE 3
488 /* Recursive function to expand the power operator. The temporary
489 values are put in tmpvar. The function returns tmpvar[1] ** n. */
491 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
498 if (n < POWI_TABLE_SIZE)
503 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
504 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
508 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
509 op0 = gfc_conv_powi (se, n - digit, tmpvar);
510 op1 = gfc_conv_powi (se, digit, tmpvar);
514 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
518 tmp = fold (build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1));
519 tmp = gfc_evaluate_now (tmp, &se->pre);
521 if (n < POWI_TABLE_SIZE)
528 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
529 return 1. Else return 0 and a call to runtime library functions
530 will have to be built. */
532 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
537 tree vartmp[POWI_TABLE_SIZE];
541 type = TREE_TYPE (lhs);
542 n = abs (TREE_INT_CST_LOW (rhs));
543 sgn = tree_int_cst_sgn (rhs);
545 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
546 && (n > 2 || n < -1))
552 se->expr = gfc_build_const (type, integer_one_node);
555 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
556 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
558 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
559 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
560 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
561 convert (TREE_TYPE (lhs), integer_one_node));
564 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
567 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
568 se->expr = build3 (COND_EXPR, type, tmp,
569 convert (type, integer_one_node),
570 convert (type, integer_zero_node));
574 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
575 tmp = build3 (COND_EXPR, type, tmp,
576 convert (type, integer_minus_one_node),
577 convert (type, integer_zero_node));
578 se->expr = build3 (COND_EXPR, type, cond,
579 convert (type, integer_one_node),
584 memset (vartmp, 0, sizeof (vartmp));
588 tmp = gfc_build_const (type, integer_one_node);
589 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
592 se->expr = gfc_conv_powi (se, n, vartmp);
598 /* Power op (**). Constant integer exponent has special handling. */
601 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
603 tree gfc_int4_type_node;
611 gfc_init_se (&lse, se);
612 gfc_conv_expr_val (&lse, expr->op1);
613 gfc_add_block_to_block (&se->pre, &lse.pre);
615 gfc_init_se (&rse, se);
616 gfc_conv_expr_val (&rse, expr->op2);
617 gfc_add_block_to_block (&se->pre, &rse.pre);
619 if (expr->op2->ts.type == BT_INTEGER
620 && expr->op2->expr_type == EXPR_CONSTANT)
621 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
624 gfc_int4_type_node = gfc_get_int_type (4);
626 kind = expr->op1->ts.kind;
627 switch (expr->op2->ts.type)
630 ikind = expr->op2->ts.kind;
635 rse.expr = convert (gfc_int4_type_node, rse.expr);
653 if (expr->op1->ts.type == BT_INTEGER)
654 lse.expr = convert (gfc_int4_type_node, lse.expr);
671 switch (expr->op1->ts.type)
674 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
678 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
682 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
694 fndecl = built_in_decls[BUILT_IN_POWF];
697 fndecl = built_in_decls[BUILT_IN_POW];
708 fndecl = gfor_fndecl_math_cpowf;
711 fndecl = gfor_fndecl_math_cpow;
723 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
724 tmp = gfc_chainon_list (tmp, rse.expr);
725 se->expr = fold (gfc_build_function_call (fndecl, tmp));
729 /* Generate code to allocate a string temporary. */
732 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
738 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
740 if (gfc_can_put_var_on_stack (len))
742 /* Create a temporary variable to hold the result. */
743 tmp = fold (build2 (MINUS_EXPR, gfc_charlen_type_node, len,
744 convert (gfc_charlen_type_node,
746 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
747 tmp = build_array_type (gfc_character1_type_node, tmp);
748 var = gfc_create_var (tmp, "str");
749 var = gfc_build_addr_expr (type, var);
753 /* Allocate a temporary to hold the result. */
754 var = gfc_create_var (type, "pstr");
755 args = gfc_chainon_list (NULL_TREE, len);
756 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
757 tmp = convert (type, tmp);
758 gfc_add_modify_expr (&se->pre, var, tmp);
760 /* Free the temporary afterwards. */
761 tmp = convert (pvoid_type_node, var);
762 args = gfc_chainon_list (NULL_TREE, tmp);
763 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
764 gfc_add_expr_to_block (&se->post, tmp);
771 /* Handle a string concatenation operation. A temporary will be allocated to
775 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
785 gcc_assert (expr->op1->ts.type == BT_CHARACTER
786 && expr->op2->ts.type == BT_CHARACTER);
788 gfc_init_se (&lse, se);
789 gfc_conv_expr (&lse, expr->op1);
790 gfc_conv_string_parameter (&lse);
791 gfc_init_se (&rse, se);
792 gfc_conv_expr (&rse, expr->op2);
793 gfc_conv_string_parameter (&rse);
795 gfc_add_block_to_block (&se->pre, &lse.pre);
796 gfc_add_block_to_block (&se->pre, &rse.pre);
798 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
799 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
800 if (len == NULL_TREE)
802 len = fold (build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
803 lse.string_length, rse.string_length));
806 type = build_pointer_type (type);
808 var = gfc_conv_string_tmp (se, type, len);
810 /* Do the actual concatenation. */
812 args = gfc_chainon_list (args, len);
813 args = gfc_chainon_list (args, var);
814 args = gfc_chainon_list (args, lse.string_length);
815 args = gfc_chainon_list (args, lse.expr);
816 args = gfc_chainon_list (args, rse.string_length);
817 args = gfc_chainon_list (args, rse.expr);
818 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
819 gfc_add_expr_to_block (&se->pre, tmp);
821 /* Add the cleanup for the operands. */
822 gfc_add_block_to_block (&se->pre, &rse.post);
823 gfc_add_block_to_block (&se->pre, &lse.post);
826 se->string_length = len;
830 /* Translates an op expression. Common (binary) cases are handled by this
831 function, others are passed on. Recursion is used in either case.
832 We use the fact that (op1.ts == op2.ts) (except for the power
834 Operators need no special handling for scalarized expressions as long as
835 they call gfc_conv_simple_val to get their operands.
836 Character strings get special handling. */
839 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
851 switch (expr->operator)
853 case INTRINSIC_UPLUS:
854 gfc_conv_expr (se, expr->op1);
857 case INTRINSIC_UMINUS:
858 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
862 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
869 case INTRINSIC_MINUS:
873 case INTRINSIC_TIMES:
877 case INTRINSIC_DIVIDE:
878 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
879 an integer, we must round towards zero, so we use a
881 if (expr->ts.type == BT_INTEGER)
882 code = TRUNC_DIV_EXPR;
887 case INTRINSIC_POWER:
888 gfc_conv_power_op (se, expr);
891 case INTRINSIC_CONCAT:
892 gfc_conv_concat_op (se, expr);
896 code = TRUTH_ANDIF_EXPR;
901 code = TRUTH_ORIF_EXPR;
905 /* EQV and NEQV only work on logicals, but since we represent them
906 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
946 case INTRINSIC_ASSIGN:
947 /* These should be converted into function calls by the frontend. */
951 fatal_error ("Unknown intrinsic op");
955 /* The only exception to this is **, which is handled separately anyway. */
956 gcc_assert (expr->op1->ts.type == expr->op2->ts.type);
958 if (checkstring && expr->op1->ts.type != BT_CHARACTER)
962 gfc_init_se (&lse, se);
963 gfc_conv_expr (&lse, expr->op1);
964 gfc_add_block_to_block (&se->pre, &lse.pre);
967 gfc_init_se (&rse, se);
968 gfc_conv_expr (&rse, expr->op2);
969 gfc_add_block_to_block (&se->pre, &rse.pre);
971 /* For string comparisons we generate a library call, and compare the return
975 gfc_conv_string_parameter (&lse);
976 gfc_conv_string_parameter (&rse);
978 tmp = gfc_chainon_list (tmp, lse.string_length);
979 tmp = gfc_chainon_list (tmp, lse.expr);
980 tmp = gfc_chainon_list (tmp, rse.string_length);
981 tmp = gfc_chainon_list (tmp, rse.expr);
983 /* Build a call for the comparison. */
984 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
985 gfc_add_block_to_block (&lse.post, &rse.post);
987 rse.expr = integer_zero_node;
990 type = gfc_typenode_for_spec (&expr->ts);
994 /* The result of logical ops is always boolean_type_node. */
995 tmp = fold (build2 (code, type, lse.expr, rse.expr));
996 se->expr = convert (type, tmp);
999 se->expr = fold (build2 (code, type, lse.expr, rse.expr));
1001 /* Add the post blocks. */
1002 gfc_add_block_to_block (&se->post, &rse.post);
1003 gfc_add_block_to_block (&se->post, &lse.post);
1008 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1012 if (sym->attr.dummy)
1014 tmp = gfc_get_symbol_decl (sym);
1015 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1016 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1022 if (!sym->backend_decl)
1023 sym->backend_decl = gfc_get_extern_function_decl (sym);
1025 tmp = sym->backend_decl;
1026 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1027 se->expr = gfc_build_addr_expr (NULL, tmp);
1032 /* Generate code for a procedure call. Note can return se->post != NULL.
1033 If se->direct_byref is set then se->expr contains the return parameter. */
1036 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1037 gfc_actual_arglist * arg)
1050 gfc_formal_arglist *formal;
1052 arglist = NULL_TREE;
1053 stringargs = NULL_TREE;
1059 if (!sym->attr.elemental)
1061 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1062 if (se->ss->useflags)
1064 gcc_assert (gfc_return_by_reference (sym)
1065 && sym->result->attr.dimension);
1066 gcc_assert (se->loop != NULL);
1068 /* Access the previously obtained result. */
1069 gfc_conv_tmp_array_ref (se);
1070 gfc_advance_se_ss_chain (se);
1074 info = &se->ss->data.info;
1079 byref = gfc_return_by_reference (sym);
1082 if (se->direct_byref)
1083 arglist = gfc_chainon_list (arglist, se->expr);
1084 else if (sym->result->attr.dimension)
1086 gcc_assert (se->loop && se->ss);
1087 /* Set the type of the array. */
1088 tmp = gfc_typenode_for_spec (&sym->ts);
1089 info->dimen = se->loop->dimen;
1090 /* Allocate a temporary to store the result. */
1091 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1093 /* Zero the first stride to indicate a temporary. */
1095 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1096 gfc_add_modify_expr (&se->pre, tmp,
1097 convert (TREE_TYPE (tmp), integer_zero_node));
1098 /* Pass the temporary as the first argument. */
1099 tmp = info->descriptor;
1100 tmp = gfc_build_addr_expr (NULL, tmp);
1101 arglist = gfc_chainon_list (arglist, tmp);
1103 else if (sym->ts.type == BT_CHARACTER)
1105 gcc_assert (sym->ts.cl && sym->ts.cl->length
1106 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1107 len = gfc_conv_mpz_to_tree
1108 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1109 sym->ts.cl->backend_decl = len;
1110 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1111 type = build_pointer_type (type);
1113 var = gfc_conv_string_tmp (se, type, len);
1114 arglist = gfc_chainon_list (arglist, var);
1115 arglist = gfc_chainon_list (arglist,
1116 convert (gfc_charlen_type_node, len));
1118 else /* TODO: derived type function return values. */
1122 formal = sym->formal;
1123 /* Evaluate the arguments. */
1124 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1126 if (arg->expr == NULL)
1129 if (se->ignore_optional)
1131 /* Some intrinsics have already been resolved to the correct
1135 else if (arg->label)
1137 has_alternate_specifier = 1;
1142 /* Pass a NULL pointer for an absent arg. */
1143 gfc_init_se (&parmse, NULL);
1144 parmse.expr = null_pointer_node;
1145 if (arg->missing_arg_type == BT_CHARACTER)
1148 gfc_chainon_list (stringargs,
1149 convert (gfc_charlen_type_node,
1150 integer_zero_node));
1154 else if (se->ss && se->ss->useflags)
1156 /* An elemental function inside a scalarized loop. */
1157 gfc_init_se (&parmse, se);
1158 gfc_conv_expr_reference (&parmse, arg->expr);
1162 /* A scalar or transformational function. */
1163 gfc_init_se (&parmse, NULL);
1164 argss = gfc_walk_expr (arg->expr);
1166 if (argss == gfc_ss_terminator)
1168 gfc_conv_expr_reference (&parmse, arg->expr);
1169 if (formal && formal->sym->attr.pointer
1170 && arg->expr->expr_type != EXPR_NULL)
1172 /* Scalar pointer dummy args require an extra level of
1173 indirection. The null pointer already contains
1174 this level of indirection. */
1175 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1180 /* If the procedure requires an explicit interface, the
1181 actual argument is passed according to the
1182 corresponding formal argument. If the corresponding
1183 formal argument is a POINTER or assumed shape, we do
1184 not use g77's calling convention, and pass the
1185 address of the array descriptor instead. Otherwise we
1186 use g77's calling convention. */
1188 f = (formal != NULL)
1189 && !formal->sym->attr.pointer
1190 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1191 f = f || !sym->attr.always_explicit;
1192 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1196 gfc_add_block_to_block (&se->pre, &parmse.pre);
1197 gfc_add_block_to_block (&se->post, &parmse.post);
1199 /* Character strings are passed as two paramarers, a length and a
1201 if (parmse.string_length != NULL_TREE)
1202 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1204 arglist = gfc_chainon_list (arglist, parmse.expr);
1207 /* Add the hidden string length parameters to the arguments. */
1208 arglist = chainon (arglist, stringargs);
1210 /* Generate the actual call. */
1211 gfc_conv_function_val (se, sym);
1212 /* If there are alternate return labels, function type should be
1214 if (has_alternate_specifier)
1215 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1217 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1218 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1219 arglist, NULL_TREE);
1221 /* If we have a pointer function, but we don't want a pointer, e.g.
1224 where f is pointer valued, we have to dereference the result. */
1225 if (sym->attr.pointer && !se->want_pointer && !byref)
1226 se->expr = gfc_build_indirect_ref (se->expr);
1228 /* A pure function may still have side-effects - it may modify its
1230 TREE_SIDE_EFFECTS (se->expr) = 1;
1232 if (!sym->attr.pure)
1233 TREE_SIDE_EFFECTS (se->expr) = 1;
1238 /* Add the function call to the pre chain. There is no expression. */
1239 gfc_add_expr_to_block (&se->pre, se->expr);
1240 se->expr = NULL_TREE;
1242 if (!se->direct_byref)
1244 if (sym->result->attr.dimension)
1246 if (flag_bounds_check)
1248 /* Check the data pointer hasn't been modified. This would
1249 happen in a function returning a pointer. */
1250 tmp = gfc_conv_descriptor_data (info->descriptor);
1251 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1252 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1254 se->expr = info->descriptor;
1256 else if (sym->ts.type == BT_CHARACTER)
1259 se->string_length = len;
1268 /* Generate code to copy a string. */
1271 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1272 tree slen, tree src)
1277 tmp = gfc_chainon_list (tmp, dlen);
1278 tmp = gfc_chainon_list (tmp, dest);
1279 tmp = gfc_chainon_list (tmp, slen);
1280 tmp = gfc_chainon_list (tmp, src);
1281 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1282 gfc_add_expr_to_block (block, tmp);
1286 /* Translate a statement function.
1287 The value of a statement function reference is obtained by evaluating the
1288 expression using the values of the actual arguments for the values of the
1289 corresponding dummy arguments. */
1292 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1296 gfc_formal_arglist *fargs;
1297 gfc_actual_arglist *args;
1300 gfc_saved_var *saved_vars;
1306 sym = expr->symtree->n.sym;
1307 args = expr->value.function.actual;
1308 gfc_init_se (&lse, NULL);
1309 gfc_init_se (&rse, NULL);
1312 for (fargs = sym->formal; fargs; fargs = fargs->next)
1314 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1315 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1317 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1319 /* Each dummy shall be specified, explicitly or implicitly, to be
1321 gcc_assert (fargs->sym->attr.dimension == 0);
1324 /* Create a temporary to hold the value. */
1325 type = gfc_typenode_for_spec (&fsym->ts);
1326 temp_vars[n] = gfc_create_var (type, fsym->name);
1328 if (fsym->ts.type == BT_CHARACTER)
1330 /* Copy string arguments. */
1333 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1334 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1336 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1337 tmp = gfc_build_addr_expr (build_pointer_type (type),
1340 gfc_conv_expr (&rse, args->expr);
1341 gfc_conv_string_parameter (&rse);
1342 gfc_add_block_to_block (&se->pre, &lse.pre);
1343 gfc_add_block_to_block (&se->pre, &rse.pre);
1345 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1347 gfc_add_block_to_block (&se->pre, &lse.post);
1348 gfc_add_block_to_block (&se->pre, &rse.post);
1352 /* For everything else, just evaluate the expression. */
1353 gfc_conv_expr (&lse, args->expr);
1355 gfc_add_block_to_block (&se->pre, &lse.pre);
1356 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1357 gfc_add_block_to_block (&se->pre, &lse.post);
1363 /* Use the temporary variables in place of the real ones. */
1364 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1365 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1367 gfc_conv_expr (se, sym->value);
1369 if (sym->ts.type == BT_CHARACTER)
1371 gfc_conv_const_charlen (sym->ts.cl);
1373 /* Force the expression to the correct length. */
1374 if (!INTEGER_CST_P (se->string_length)
1375 || tree_int_cst_lt (se->string_length,
1376 sym->ts.cl->backend_decl))
1378 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1379 tmp = gfc_create_var (type, sym->name);
1380 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1381 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1382 se->string_length, se->expr);
1385 se->string_length = sym->ts.cl->backend_decl;
1388 /* Restore the original variables. */
1389 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1390 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1391 gfc_free (saved_vars);
1395 /* Translate a function expression. */
1398 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1402 if (expr->value.function.isym)
1404 gfc_conv_intrinsic_function (se, expr);
1408 /* We distinguish statement functions from general functions to improve
1409 runtime performance. */
1410 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1412 gfc_conv_statement_function (se, expr);
1416 /* expr.value.function.esym is the resolved (specific) function symbol for
1417 most functions. However this isn't set for dummy procedures. */
1418 sym = expr->value.function.esym;
1420 sym = expr->symtree->n.sym;
1421 gfc_conv_function_call (se, sym, expr->value.function.actual);
1426 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1428 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1429 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1431 gfc_conv_tmp_array_ref (se);
1432 gfc_advance_se_ss_chain (se);
1436 /* Build a static initializer. EXPR is the expression for the initial value.
1437 The other parameters describe the variable of the component being
1438 initialized. EXPR may be null. */
1441 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1442 bool array, bool pointer)
1446 if (!(expr || pointer))
1451 /* Arrays need special handling. */
1453 return gfc_build_null_descriptor (type);
1455 return gfc_conv_array_initializer (type, expr);
1458 return fold_convert (type, null_pointer_node);
1464 gfc_init_se (&se, NULL);
1465 gfc_conv_structure (&se, expr, 1);
1469 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1472 gfc_init_se (&se, NULL);
1473 gfc_conv_constant (&se, expr);
1480 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1492 gfc_start_block (&block);
1494 /* Initialize the scalarizer. */
1495 gfc_init_loopinfo (&loop);
1497 gfc_init_se (&lse, NULL);
1498 gfc_init_se (&rse, NULL);
1501 rss = gfc_walk_expr (expr);
1502 if (rss == gfc_ss_terminator)
1504 /* The rhs is scalar. Add a ss for the expression. */
1505 rss = gfc_get_ss ();
1506 rss->next = gfc_ss_terminator;
1507 rss->type = GFC_SS_SCALAR;
1511 /* Create a SS for the destination. */
1512 lss = gfc_get_ss ();
1513 lss->type = GFC_SS_COMPONENT;
1515 lss->shape = gfc_get_shape (cm->as->rank);
1516 lss->next = gfc_ss_terminator;
1517 lss->data.info.dimen = cm->as->rank;
1518 lss->data.info.descriptor = dest;
1519 lss->data.info.data = gfc_conv_array_data (dest);
1520 lss->data.info.offset = gfc_conv_array_offset (dest);
1521 for (n = 0; n < cm->as->rank; n++)
1523 lss->data.info.dim[n] = n;
1524 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1525 lss->data.info.stride[n] = gfc_index_one_node;
1527 mpz_init (lss->shape[n]);
1528 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1529 cm->as->lower[n]->value.integer);
1530 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1533 /* Associate the SS with the loop. */
1534 gfc_add_ss_to_loop (&loop, lss);
1535 gfc_add_ss_to_loop (&loop, rss);
1537 /* Calculate the bounds of the scalarization. */
1538 gfc_conv_ss_startstride (&loop);
1540 /* Setup the scalarizing loops. */
1541 gfc_conv_loop_setup (&loop);
1543 /* Setup the gfc_se structures. */
1544 gfc_copy_loopinfo_to_se (&lse, &loop);
1545 gfc_copy_loopinfo_to_se (&rse, &loop);
1548 gfc_mark_ss_chain_used (rss, 1);
1550 gfc_mark_ss_chain_used (lss, 1);
1552 /* Start the scalarized loop body. */
1553 gfc_start_scalarized_body (&loop, &body);
1555 gfc_conv_tmp_array_ref (&lse);
1556 gfc_conv_expr (&rse, expr);
1558 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1559 gfc_add_expr_to_block (&body, tmp);
1561 gcc_assert (rse.ss == gfc_ss_terminator);
1563 /* Generate the copying loops. */
1564 gfc_trans_scalarizing_loops (&loop, &body);
1566 /* Wrap the whole thing up. */
1567 gfc_add_block_to_block (&block, &loop.pre);
1568 gfc_add_block_to_block (&block, &loop.post);
1570 for (n = 0; n < cm->as->rank; n++)
1571 mpz_clear (lss->shape[n]);
1572 gfc_free (lss->shape);
1574 gfc_cleanup_loop (&loop);
1576 return gfc_finish_block (&block);
1579 /* Assign a single component of a derived type constructor. */
1582 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1589 gfc_start_block (&block);
1592 gfc_init_se (&se, NULL);
1593 /* Pointer component. */
1596 /* Array pointer. */
1597 if (expr->expr_type == EXPR_NULL)
1599 dest = gfc_conv_descriptor_data (dest);
1600 tmp = fold_convert (TREE_TYPE (se.expr),
1602 gfc_add_modify_expr (&block, dest, tmp);
1606 rss = gfc_walk_expr (expr);
1607 se.direct_byref = 1;
1609 gfc_conv_expr_descriptor (&se, expr, rss);
1610 gfc_add_block_to_block (&block, &se.pre);
1611 gfc_add_block_to_block (&block, &se.post);
1616 /* Scalar pointers. */
1617 se.want_pointer = 1;
1618 gfc_conv_expr (&se, expr);
1619 gfc_add_block_to_block (&block, &se.pre);
1620 gfc_add_modify_expr (&block, dest,
1621 fold_convert (TREE_TYPE (dest), se.expr));
1622 gfc_add_block_to_block (&block, &se.post);
1625 else if (cm->dimension)
1627 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1628 gfc_add_expr_to_block (&block, tmp);
1630 else if (expr->ts.type == BT_DERIVED)
1632 /* Nested derived type. */
1633 tmp = gfc_trans_structure_assign (dest, expr);
1634 gfc_add_expr_to_block (&block, tmp);
1638 /* Scalar component. */
1641 gfc_init_se (&se, NULL);
1642 gfc_init_se (&lse, NULL);
1644 gfc_conv_expr (&se, expr);
1645 if (cm->ts.type == BT_CHARACTER)
1646 lse.string_length = cm->ts.cl->backend_decl;
1648 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1649 gfc_add_expr_to_block (&block, tmp);
1651 return gfc_finish_block (&block);
1654 /* Assign a derived type constructor to a variable. */
1657 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1665 gfc_start_block (&block);
1666 cm = expr->ts.derived->components;
1667 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1669 /* Skip absent members in default initializers. */
1673 field = cm->backend_decl;
1674 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1675 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1676 gfc_add_expr_to_block (&block, tmp);
1678 return gfc_finish_block (&block);
1681 /* Build an expression for a constructor. If init is nonzero then
1682 this is part of a static variable initializer. */
1685 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1695 gcc_assert (se->ss == NULL);
1696 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1697 type = gfc_typenode_for_spec (&expr->ts);
1701 /* Create a temporary variable and fill it in. */
1702 se->expr = gfc_create_var (type, expr->ts.derived->name);
1703 tmp = gfc_trans_structure_assign (se->expr, expr);
1704 gfc_add_expr_to_block (&se->pre, tmp);
1708 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1711 cm = expr->ts.derived->components;
1712 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1714 /* Skip absent members in default initializers. */
1718 val = gfc_conv_initializer (c->expr, &cm->ts,
1719 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1721 /* Build a TREE_CHAIN to hold it. */
1722 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1724 /* Add it to the list. */
1725 if (tail == NULL_TREE)
1726 TREE_OPERAND(head, 0) = tail = val;
1729 TREE_CHAIN (tail) = val;
1737 /* Translate a substring expression. */
1740 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1746 gcc_assert (ref->type == REF_SUBSTRING);
1748 se->expr = gfc_build_string_const(expr->value.character.length,
1749 expr->value.character.string);
1750 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1751 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1753 gfc_conv_substring(se,ref,expr->ts.kind);
1757 /* Entry point for expression translation. */
1760 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1762 if (se->ss && se->ss->expr == expr
1763 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1765 /* Substitute a scalar expression evaluated outside the scalarization
1767 se->expr = se->ss->data.scalar.expr;
1768 se->string_length = se->ss->string_length;
1769 gfc_advance_se_ss_chain (se);
1773 switch (expr->expr_type)
1776 gfc_conv_expr_op (se, expr);
1780 gfc_conv_function_expr (se, expr);
1784 gfc_conv_constant (se, expr);
1788 gfc_conv_variable (se, expr);
1792 se->expr = null_pointer_node;
1795 case EXPR_SUBSTRING:
1796 gfc_conv_substring_expr (se, expr);
1799 case EXPR_STRUCTURE:
1800 gfc_conv_structure (se, expr, 0);
1804 gfc_conv_array_constructor_expr (se, expr);
1814 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1816 gfc_conv_expr (se, expr);
1817 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1818 figure out a way of rewriting an lvalue so that it has no post chain. */
1819 gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1823 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1827 gcc_assert (expr->ts.type != BT_CHARACTER);
1828 gfc_conv_expr (se, expr);
1831 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1832 gfc_add_modify_expr (&se->pre, val, se->expr);
1837 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1839 gfc_conv_expr_val (se, expr);
1840 se->expr = convert (type, se->expr);
1844 /* Converts an expression so that it can be passed by reference. Scalar
1848 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1852 if (se->ss && se->ss->expr == expr
1853 && se->ss->type == GFC_SS_REFERENCE)
1855 se->expr = se->ss->data.scalar.expr;
1856 se->string_length = se->ss->string_length;
1857 gfc_advance_se_ss_chain (se);
1861 if (expr->ts.type == BT_CHARACTER)
1863 gfc_conv_expr (se, expr);
1864 gfc_conv_string_parameter (se);
1868 if (expr->expr_type == EXPR_VARIABLE)
1870 se->want_pointer = 1;
1871 gfc_conv_expr (se, expr);
1874 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1875 gfc_add_modify_expr (&se->pre, var, se->expr);
1876 gfc_add_block_to_block (&se->pre, &se->post);
1882 gfc_conv_expr (se, expr);
1884 /* Create a temporary var to hold the value. */
1885 if (TREE_CONSTANT (se->expr))
1887 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1888 DECL_INITIAL (var) = se->expr;
1893 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1894 gfc_add_modify_expr (&se->pre, var, se->expr);
1896 gfc_add_block_to_block (&se->pre, &se->post);
1898 /* Take the address of that value. */
1899 se->expr = gfc_build_addr_expr (NULL, var);
1904 gfc_trans_pointer_assign (gfc_code * code)
1906 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1910 /* Generate code for a pointer assignment. */
1913 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1921 gfc_start_block (&block);
1923 gfc_init_se (&lse, NULL);
1925 lss = gfc_walk_expr (expr1);
1926 rss = gfc_walk_expr (expr2);
1927 if (lss == gfc_ss_terminator)
1929 /* Scalar pointers. */
1930 lse.want_pointer = 1;
1931 gfc_conv_expr (&lse, expr1);
1932 gcc_assert (rss == gfc_ss_terminator);
1933 gfc_init_se (&rse, NULL);
1934 rse.want_pointer = 1;
1935 gfc_conv_expr (&rse, expr2);
1936 gfc_add_block_to_block (&block, &lse.pre);
1937 gfc_add_block_to_block (&block, &rse.pre);
1938 gfc_add_modify_expr (&block, lse.expr,
1939 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1940 gfc_add_block_to_block (&block, &rse.post);
1941 gfc_add_block_to_block (&block, &lse.post);
1945 /* Array pointer. */
1946 gfc_conv_expr_descriptor (&lse, expr1, lss);
1947 /* Implement Nullify. */
1948 if (expr2->expr_type == EXPR_NULL)
1950 lse.expr = gfc_conv_descriptor_data (lse.expr);
1951 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
1952 gfc_add_modify_expr (&block, lse.expr, rse.expr);
1956 lse.direct_byref = 1;
1957 gfc_conv_expr_descriptor (&lse, expr2, rss);
1959 gfc_add_block_to_block (&block, &lse.pre);
1960 gfc_add_block_to_block (&block, &lse.post);
1962 return gfc_finish_block (&block);
1966 /* Makes sure se is suitable for passing as a function string parameter. */
1967 /* TODO: Need to check all callers fo this function. It may be abused. */
1970 gfc_conv_string_parameter (gfc_se * se)
1974 if (TREE_CODE (se->expr) == STRING_CST)
1976 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1980 type = TREE_TYPE (se->expr);
1981 if (TYPE_STRING_FLAG (type))
1983 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
1984 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
1987 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
1988 gcc_assert (se->string_length
1989 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
1993 /* Generate code for assignment of scalar variables. Includes character
1997 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2001 gfc_init_block (&block);
2003 if (type == BT_CHARACTER)
2005 gcc_assert (lse->string_length != NULL_TREE
2006 && rse->string_length != NULL_TREE);
2008 gfc_conv_string_parameter (lse);
2009 gfc_conv_string_parameter (rse);
2011 gfc_add_block_to_block (&block, &lse->pre);
2012 gfc_add_block_to_block (&block, &rse->pre);
2014 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2015 rse->string_length, rse->expr);
2019 gfc_add_block_to_block (&block, &lse->pre);
2020 gfc_add_block_to_block (&block, &rse->pre);
2022 gfc_add_modify_expr (&block, lse->expr,
2023 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2026 gfc_add_block_to_block (&block, &lse->post);
2027 gfc_add_block_to_block (&block, &rse->post);
2029 return gfc_finish_block (&block);
2033 /* Try to translate array(:) = func (...), where func is a transformational
2034 array function, without using a temporary. Returns NULL is this isn't the
2038 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2043 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2044 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2047 /* Elemental functions don't need a temporary anyway. */
2048 if (expr2->symtree->n.sym->attr.elemental)
2051 /* Check for a dependency. */
2052 if (gfc_check_fncall_dependency (expr1, expr2))
2055 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2057 gcc_assert (expr2->value.function.isym
2058 || (gfc_return_by_reference (expr2->value.function.esym)
2059 && expr2->value.function.esym->result->attr.dimension));
2061 ss = gfc_walk_expr (expr1);
2062 gcc_assert (ss != gfc_ss_terminator);
2063 gfc_init_se (&se, NULL);
2064 gfc_start_block (&se.pre);
2065 se.want_pointer = 1;
2067 gfc_conv_array_parameter (&se, expr1, ss, 0);
2069 se.direct_byref = 1;
2070 se.ss = gfc_walk_expr (expr2);
2071 gcc_assert (se.ss != gfc_ss_terminator);
2072 gfc_conv_function_expr (&se, expr2);
2073 gfc_add_block_to_block (&se.pre, &se.post);
2075 return gfc_finish_block (&se.pre);
2079 /* Translate an assignment. Most of the code is concerned with
2080 setting up the scalarizer. */
2083 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2088 gfc_ss *lss_section;
2095 /* Special case a single function returning an array. */
2096 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2098 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2103 /* Assignment of the form lhs = rhs. */
2104 gfc_start_block (&block);
2106 gfc_init_se (&lse, NULL);
2107 gfc_init_se (&rse, NULL);
2110 lss = gfc_walk_expr (expr1);
2112 if (lss != gfc_ss_terminator)
2114 /* The assignment needs scalarization. */
2117 /* Find a non-scalar SS from the lhs. */
2118 while (lss_section != gfc_ss_terminator
2119 && lss_section->type != GFC_SS_SECTION)
2120 lss_section = lss_section->next;
2122 gcc_assert (lss_section != gfc_ss_terminator);
2124 /* Initialize the scalarizer. */
2125 gfc_init_loopinfo (&loop);
2128 rss = gfc_walk_expr (expr2);
2129 if (rss == gfc_ss_terminator)
2131 /* The rhs is scalar. Add a ss for the expression. */
2132 rss = gfc_get_ss ();
2133 rss->next = gfc_ss_terminator;
2134 rss->type = GFC_SS_SCALAR;
2137 /* Associate the SS with the loop. */
2138 gfc_add_ss_to_loop (&loop, lss);
2139 gfc_add_ss_to_loop (&loop, rss);
2141 /* Calculate the bounds of the scalarization. */
2142 gfc_conv_ss_startstride (&loop);
2143 /* Resolve any data dependencies in the statement. */
2144 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2145 /* Setup the scalarizing loops. */
2146 gfc_conv_loop_setup (&loop);
2148 /* Setup the gfc_se structures. */
2149 gfc_copy_loopinfo_to_se (&lse, &loop);
2150 gfc_copy_loopinfo_to_se (&rse, &loop);
2153 gfc_mark_ss_chain_used (rss, 1);
2154 if (loop.temp_ss == NULL)
2157 gfc_mark_ss_chain_used (lss, 1);
2161 lse.ss = loop.temp_ss;
2162 gfc_mark_ss_chain_used (lss, 3);
2163 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2166 /* Start the scalarized loop body. */
2167 gfc_start_scalarized_body (&loop, &body);
2170 gfc_init_block (&body);
2172 /* Translate the expression. */
2173 gfc_conv_expr (&rse, expr2);
2175 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2177 gfc_conv_tmp_array_ref (&lse);
2178 gfc_advance_se_ss_chain (&lse);
2181 gfc_conv_expr (&lse, expr1);
2183 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2184 gfc_add_expr_to_block (&body, tmp);
2186 if (lss == gfc_ss_terminator)
2188 /* Use the scalar assignment as is. */
2189 gfc_add_block_to_block (&block, &body);
2193 gcc_assert (lse.ss == gfc_ss_terminator
2194 && rse.ss == gfc_ss_terminator);
2196 if (loop.temp_ss != NULL)
2198 gfc_trans_scalarized_loop_boundary (&loop, &body);
2200 /* We need to copy the temporary to the actual lhs. */
2201 gfc_init_se (&lse, NULL);
2202 gfc_init_se (&rse, NULL);
2203 gfc_copy_loopinfo_to_se (&lse, &loop);
2204 gfc_copy_loopinfo_to_se (&rse, &loop);
2206 rse.ss = loop.temp_ss;
2209 gfc_conv_tmp_array_ref (&rse);
2210 gfc_advance_se_ss_chain (&rse);
2211 gfc_conv_expr (&lse, expr1);
2213 gcc_assert (lse.ss == gfc_ss_terminator
2214 && rse.ss == gfc_ss_terminator);
2216 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2217 gfc_add_expr_to_block (&body, tmp);
2219 /* Generate the copying loops. */
2220 gfc_trans_scalarizing_loops (&loop, &body);
2222 /* Wrap the whole thing up. */
2223 gfc_add_block_to_block (&block, &loop.pre);
2224 gfc_add_block_to_block (&block, &loop.post);
2226 gfc_cleanup_loop (&loop);
2229 return gfc_finish_block (&block);
2233 gfc_trans_assign (gfc_code * code)
2235 return gfc_trans_assignment (code->expr, code->expr2);