1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005 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, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 /* Copy the scalarization loop variables. */
48 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
51 dest->loop = src->loop;
55 /* Initialize a simple expression holder.
57 Care must be taken when multiple se are created with the same parent.
58 The child se must be kept in sync. The easiest way is to delay creation
59 of a child se until after after the previous se has been translated. */
62 gfc_init_se (gfc_se * se, gfc_se * parent)
64 memset (se, 0, sizeof (gfc_se));
65 gfc_init_block (&se->pre);
66 gfc_init_block (&se->post);
71 gfc_copy_se_loopvars (se, parent);
75 /* Advances to the next SS in the chain. Use this rather than setting
76 se->ss = se->ss->next because all the parents needs to be kept in sync.
80 gfc_advance_se_ss_chain (gfc_se * se)
84 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
87 /* Walk down the parent chain. */
90 /* Simple consistency check. */
91 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
100 /* Ensures the result of the expression as either a temporary variable
101 or a constant so that it can be used repeatedly. */
104 gfc_make_safe_expr (gfc_se * se)
108 if (CONSTANT_CLASS_P (se->expr))
111 /* We need a temporary for this result. */
112 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
113 gfc_add_modify_expr (&se->pre, var, se->expr);
118 /* Return an expression which determines if a dummy parameter is present.
119 Also used for arguments to procedures with multiple entry points. */
122 gfc_conv_expr_present (gfc_symbol * sym)
126 gcc_assert (sym->attr.dummy);
128 decl = gfc_get_symbol_decl (sym);
129 if (TREE_CODE (decl) != PARM_DECL)
131 /* Array parameters use a temporary descriptor, we want the real
133 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
134 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
135 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
137 return build2 (NE_EXPR, boolean_type_node, decl,
138 fold_convert (TREE_TYPE (decl), null_pointer_node));
142 /* Get the character length of an expression, looking through gfc_refs
146 gfc_get_expr_charlen (gfc_expr *e)
151 gcc_assert (e->expr_type == EXPR_VARIABLE
152 && e->ts.type == BT_CHARACTER);
154 length = NULL; /* To silence compiler warning. */
156 /* First candidate: if the variable is of type CHARACTER, the
157 expression's length could be the length of the character
159 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
160 length = e->symtree->n.sym->ts.cl->backend_decl;
162 /* Look through the reference chain for component references. */
163 for (r = e->ref; r; r = r->next)
168 if (r->u.c.component->ts.type == BT_CHARACTER)
169 length = r->u.c.component->ts.cl->backend_decl;
177 /* We should never got substring references here. These will be
178 broken down by the scalarizer. */
183 gcc_assert (length != NULL);
189 /* Generate code to initialize a string length variable. Returns the
193 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
198 gfc_init_se (&se, NULL);
199 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
200 gfc_add_block_to_block (pblock, &se.pre);
202 tmp = cl->backend_decl;
203 gfc_add_modify_expr (pblock, tmp, se.expr);
208 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
216 type = gfc_get_character_type (kind, ref->u.ss.length);
217 type = build_pointer_type (type);
220 gfc_init_se (&start, se);
221 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
222 gfc_add_block_to_block (&se->pre, &start.pre);
224 if (integer_onep (start.expr))
225 gfc_conv_string_parameter (se);
228 /* Change the start of the string. */
229 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
232 tmp = gfc_build_indirect_ref (se->expr);
233 tmp = gfc_build_array_ref (tmp, start.expr);
234 se->expr = gfc_build_addr_expr (type, tmp);
237 /* Length = end + 1 - start. */
238 gfc_init_se (&end, se);
239 if (ref->u.ss.end == NULL)
240 end.expr = se->string_length;
243 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
244 gfc_add_block_to_block (&se->pre, &end.pre);
247 build2 (MINUS_EXPR, gfc_charlen_type_node,
248 fold_convert (gfc_charlen_type_node, integer_one_node),
250 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
251 se->string_length = fold (tmp);
255 /* Convert a derived type component reference. */
258 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
265 c = ref->u.c.component;
267 gcc_assert (c->backend_decl);
269 field = c->backend_decl;
270 gcc_assert (TREE_CODE (field) == FIELD_DECL);
272 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
276 if (c->ts.type == BT_CHARACTER)
278 tmp = c->ts.cl->backend_decl;
279 /* Components must always be constant length. */
280 gcc_assert (tmp && INTEGER_CST_P (tmp));
281 se->string_length = tmp;
284 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
285 se->expr = gfc_build_indirect_ref (se->expr);
289 /* Return the contents of a variable. Also handles reference/pointer
290 variables (all Fortran pointer references are implicit). */
293 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
298 sym = expr->symtree->n.sym;
301 /* Check that something hasn't gone horribly wrong. */
302 gcc_assert (se->ss != gfc_ss_terminator);
303 gcc_assert (se->ss->expr == expr);
305 /* A scalarized term. We already know the descriptor. */
306 se->expr = se->ss->data.info.descriptor;
307 se->string_length = se->ss->string_length;
308 ref = se->ss->data.info.ref;
312 tree se_expr = NULL_TREE;
314 se->expr = gfc_get_symbol_decl (sym);
316 /* Special case for assigning the return value of a function.
317 Self recursive functions must have an explicit return value. */
318 if (se->expr == current_function_decl && sym->attr.function
319 && (sym->result == sym))
320 se_expr = gfc_get_fake_result_decl (sym);
322 /* Similarly for alternate entry points. */
323 else if (sym->attr.function && sym->attr.entry
324 && (sym->result == sym)
325 && sym->ns->proc_name->backend_decl == current_function_decl)
327 gfc_entry_list *el = NULL;
329 for (el = sym->ns->entries; el; el = el->next)
332 se_expr = gfc_get_fake_result_decl (sym);
337 else if (sym->attr.result
338 && sym->ns->proc_name->backend_decl == current_function_decl
339 && sym->ns->proc_name->attr.entry_master
340 && !gfc_return_by_reference (sym->ns->proc_name))
341 se_expr = gfc_get_fake_result_decl (sym);
346 /* Procedure actual arguments. */
347 else if (sym->attr.flavor == FL_PROCEDURE
348 && se->expr != current_function_decl)
350 gcc_assert (se->want_pointer);
351 if (!sym->attr.dummy)
353 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
354 se->expr = gfc_build_addr_expr (NULL, se->expr);
360 /* Dereference the expression, where needed. Since characters
361 are entirely different from other types, they are treated
363 if (sym->ts.type == BT_CHARACTER)
365 /* Dereference character pointer dummy arguments
367 if ((sym->attr.pointer || sym->attr.allocatable)
369 || sym->attr.function
370 || sym->attr.result))
371 se->expr = gfc_build_indirect_ref (se->expr);
375 /* Dereference non-character scalar dummy arguments. */
376 if (sym->attr.dummy && !sym->attr.dimension)
377 se->expr = gfc_build_indirect_ref (se->expr);
379 /* Dereference scalar hidden result. */
380 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
381 && (sym->attr.function || sym->attr.result)
382 && !sym->attr.dimension && !sym->attr.pointer)
383 se->expr = gfc_build_indirect_ref (se->expr);
385 /* Dereference non-character pointer variables.
386 These must be dummies, results, or scalars. */
387 if ((sym->attr.pointer || sym->attr.allocatable)
389 || sym->attr.function
391 || !sym->attr.dimension))
392 se->expr = gfc_build_indirect_ref (se->expr);
398 /* For character variables, also get the length. */
399 if (sym->ts.type == BT_CHARACTER)
401 se->string_length = sym->ts.cl->backend_decl;
402 gcc_assert (se->string_length);
410 /* Return the descriptor if that's what we want and this is an array
411 section reference. */
412 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
414 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
415 /* Return the descriptor for array pointers and allocations. */
417 && ref->next == NULL && (se->descriptor_only))
420 gfc_conv_array_ref (se, &ref->u.ar);
421 /* Return a pointer to an element. */
425 gfc_conv_component_ref (se, ref);
429 gfc_conv_substring (se, ref, expr->ts.kind);
438 /* Pointer assignment, allocation or pass by reference. Arrays are handled
440 if (se->want_pointer)
442 if (expr->ts.type == BT_CHARACTER)
443 gfc_conv_string_parameter (se);
445 se->expr = gfc_build_addr_expr (NULL, se->expr);
448 gfc_advance_se_ss_chain (se);
452 /* Unary ops are easy... Or they would be if ! was a valid op. */
455 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
460 gcc_assert (expr->ts.type != BT_CHARACTER);
461 /* Initialize the operand. */
462 gfc_init_se (&operand, se);
463 gfc_conv_expr_val (&operand, expr->value.op.op1);
464 gfc_add_block_to_block (&se->pre, &operand.pre);
466 type = gfc_typenode_for_spec (&expr->ts);
468 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
469 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
470 All other unary operators have an equivalent GIMPLE unary operator. */
471 if (code == TRUTH_NOT_EXPR)
472 se->expr = build2 (EQ_EXPR, type, operand.expr,
473 convert (type, integer_zero_node));
475 se->expr = build1 (code, type, operand.expr);
479 /* Expand power operator to optimal multiplications when a value is raised
480 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
481 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
482 Programming", 3rd Edition, 1998. */
484 /* This code is mostly duplicated from expand_powi in the backend.
485 We establish the "optimal power tree" lookup table with the defined size.
486 The items in the table are the exponents used to calculate the index
487 exponents. Any integer n less than the value can get an "addition chain",
488 with the first node being one. */
489 #define POWI_TABLE_SIZE 256
491 /* The table is from builtins.c. */
492 static const unsigned char powi_table[POWI_TABLE_SIZE] =
494 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
495 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
496 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
497 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
498 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
499 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
500 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
501 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
502 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
503 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
504 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
505 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
506 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
507 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
508 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
509 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
510 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
511 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
512 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
513 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
514 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
515 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
516 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
517 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
518 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
519 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
520 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
521 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
522 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
523 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
524 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
525 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
528 /* If n is larger than lookup table's max index, we use the "window
530 #define POWI_WINDOW_SIZE 3
532 /* Recursive function to expand the power operator. The temporary
533 values are put in tmpvar. The function returns tmpvar[1] ** n. */
535 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
542 if (n < POWI_TABLE_SIZE)
547 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
548 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
552 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
553 op0 = gfc_conv_powi (se, n - digit, tmpvar);
554 op1 = gfc_conv_powi (se, digit, tmpvar);
558 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
562 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
563 tmp = gfc_evaluate_now (tmp, &se->pre);
565 if (n < POWI_TABLE_SIZE)
572 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
573 return 1. Else return 0 and a call to runtime library functions
574 will have to be built. */
576 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
581 tree vartmp[POWI_TABLE_SIZE];
585 type = TREE_TYPE (lhs);
586 n = abs (TREE_INT_CST_LOW (rhs));
587 sgn = tree_int_cst_sgn (rhs);
589 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
590 && (n > 2 || n < -1))
596 se->expr = gfc_build_const (type, integer_one_node);
599 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
600 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
602 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
603 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
604 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
605 convert (TREE_TYPE (lhs), integer_one_node));
608 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
611 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
612 se->expr = build3 (COND_EXPR, type, tmp,
613 convert (type, integer_one_node),
614 convert (type, integer_zero_node));
618 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
619 tmp = build3 (COND_EXPR, type, tmp,
620 convert (type, integer_minus_one_node),
621 convert (type, integer_zero_node));
622 se->expr = build3 (COND_EXPR, type, cond,
623 convert (type, integer_one_node),
628 memset (vartmp, 0, sizeof (vartmp));
632 tmp = gfc_build_const (type, integer_one_node);
633 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
636 se->expr = gfc_conv_powi (se, n, vartmp);
642 /* Power op (**). Constant integer exponent has special handling. */
645 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
647 tree gfc_int4_type_node;
655 gfc_init_se (&lse, se);
656 gfc_conv_expr_val (&lse, expr->value.op.op1);
657 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
658 gfc_add_block_to_block (&se->pre, &lse.pre);
660 gfc_init_se (&rse, se);
661 gfc_conv_expr_val (&rse, expr->value.op.op2);
662 gfc_add_block_to_block (&se->pre, &rse.pre);
664 if (expr->value.op.op2->ts.type == BT_INTEGER
665 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
666 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
669 gfc_int4_type_node = gfc_get_int_type (4);
671 kind = expr->value.op.op1->ts.kind;
672 switch (expr->value.op.op2->ts.type)
675 ikind = expr->value.op.op2->ts.kind;
680 rse.expr = convert (gfc_int4_type_node, rse.expr);
698 if (expr->value.op.op1->ts.type == BT_INTEGER)
699 lse.expr = convert (gfc_int4_type_node, lse.expr);
716 switch (expr->value.op.op1->ts.type)
719 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
723 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
727 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
739 fndecl = built_in_decls[BUILT_IN_POWF];
742 fndecl = built_in_decls[BUILT_IN_POW];
753 fndecl = gfor_fndecl_math_cpowf;
756 fndecl = gfor_fndecl_math_cpow;
768 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
769 tmp = gfc_chainon_list (tmp, rse.expr);
770 se->expr = fold (gfc_build_function_call (fndecl, tmp));
774 /* Generate code to allocate a string temporary. */
777 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
783 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
785 if (gfc_can_put_var_on_stack (len))
787 /* Create a temporary variable to hold the result. */
788 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
789 convert (gfc_charlen_type_node, integer_one_node));
790 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
791 tmp = build_array_type (gfc_character1_type_node, tmp);
792 var = gfc_create_var (tmp, "str");
793 var = gfc_build_addr_expr (type, var);
797 /* Allocate a temporary to hold the result. */
798 var = gfc_create_var (type, "pstr");
799 args = gfc_chainon_list (NULL_TREE, len);
800 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
801 tmp = convert (type, tmp);
802 gfc_add_modify_expr (&se->pre, var, tmp);
804 /* Free the temporary afterwards. */
805 tmp = convert (pvoid_type_node, var);
806 args = gfc_chainon_list (NULL_TREE, tmp);
807 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
808 gfc_add_expr_to_block (&se->post, tmp);
815 /* Handle a string concatenation operation. A temporary will be allocated to
819 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
829 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
830 && expr->value.op.op2->ts.type == BT_CHARACTER);
832 gfc_init_se (&lse, se);
833 gfc_conv_expr (&lse, expr->value.op.op1);
834 gfc_conv_string_parameter (&lse);
835 gfc_init_se (&rse, se);
836 gfc_conv_expr (&rse, expr->value.op.op2);
837 gfc_conv_string_parameter (&rse);
839 gfc_add_block_to_block (&se->pre, &lse.pre);
840 gfc_add_block_to_block (&se->pre, &rse.pre);
842 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
843 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
844 if (len == NULL_TREE)
846 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
847 lse.string_length, rse.string_length);
850 type = build_pointer_type (type);
852 var = gfc_conv_string_tmp (se, type, len);
854 /* Do the actual concatenation. */
856 args = gfc_chainon_list (args, len);
857 args = gfc_chainon_list (args, var);
858 args = gfc_chainon_list (args, lse.string_length);
859 args = gfc_chainon_list (args, lse.expr);
860 args = gfc_chainon_list (args, rse.string_length);
861 args = gfc_chainon_list (args, rse.expr);
862 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
863 gfc_add_expr_to_block (&se->pre, tmp);
865 /* Add the cleanup for the operands. */
866 gfc_add_block_to_block (&se->pre, &rse.post);
867 gfc_add_block_to_block (&se->pre, &lse.post);
870 se->string_length = len;
874 /* Translates an op expression. Common (binary) cases are handled by this
875 function, others are passed on. Recursion is used in either case.
876 We use the fact that (op1.ts == op2.ts) (except for the power
878 Operators need no special handling for scalarized expressions as long as
879 they call gfc_conv_simple_val to get their operands.
880 Character strings get special handling. */
883 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
895 switch (expr->value.op.operator)
897 case INTRINSIC_UPLUS:
898 gfc_conv_expr (se, expr->value.op.op1);
901 case INTRINSIC_UMINUS:
902 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
906 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
913 case INTRINSIC_MINUS:
917 case INTRINSIC_TIMES:
921 case INTRINSIC_DIVIDE:
922 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
923 an integer, we must round towards zero, so we use a
925 if (expr->ts.type == BT_INTEGER)
926 code = TRUNC_DIV_EXPR;
931 case INTRINSIC_POWER:
932 gfc_conv_power_op (se, expr);
935 case INTRINSIC_CONCAT:
936 gfc_conv_concat_op (se, expr);
940 code = TRUTH_ANDIF_EXPR;
945 code = TRUTH_ORIF_EXPR;
949 /* EQV and NEQV only work on logicals, but since we represent them
950 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
990 case INTRINSIC_ASSIGN:
991 /* These should be converted into function calls by the frontend. */
995 fatal_error ("Unknown intrinsic op");
999 /* The only exception to this is **, which is handled separately anyway. */
1000 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1002 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1006 gfc_init_se (&lse, se);
1007 gfc_conv_expr (&lse, expr->value.op.op1);
1008 gfc_add_block_to_block (&se->pre, &lse.pre);
1011 gfc_init_se (&rse, se);
1012 gfc_conv_expr (&rse, expr->value.op.op2);
1013 gfc_add_block_to_block (&se->pre, &rse.pre);
1015 /* For string comparisons we generate a library call, and compare the return
1019 gfc_conv_string_parameter (&lse);
1020 gfc_conv_string_parameter (&rse);
1022 tmp = gfc_chainon_list (tmp, lse.string_length);
1023 tmp = gfc_chainon_list (tmp, lse.expr);
1024 tmp = gfc_chainon_list (tmp, rse.string_length);
1025 tmp = gfc_chainon_list (tmp, rse.expr);
1027 /* Build a call for the comparison. */
1028 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1029 gfc_add_block_to_block (&lse.post, &rse.post);
1031 rse.expr = integer_zero_node;
1034 type = gfc_typenode_for_spec (&expr->ts);
1038 /* The result of logical ops is always boolean_type_node. */
1039 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1040 se->expr = convert (type, tmp);
1043 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1045 /* Add the post blocks. */
1046 gfc_add_block_to_block (&se->post, &rse.post);
1047 gfc_add_block_to_block (&se->post, &lse.post);
1052 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1056 if (sym->attr.dummy)
1058 tmp = gfc_get_symbol_decl (sym);
1059 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1060 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1066 if (!sym->backend_decl)
1067 sym->backend_decl = gfc_get_extern_function_decl (sym);
1069 tmp = sym->backend_decl;
1070 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1071 se->expr = gfc_build_addr_expr (NULL, tmp);
1076 /* Generate code for a procedure call. Note can return se->post != NULL.
1077 If se->direct_byref is set then se->expr contains the return parameter.
1078 Return nonzero, if the call has alternate specifiers. */
1081 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1082 gfc_actual_arglist * arg)
1095 gfc_formal_arglist *formal;
1096 int has_alternate_specifier = 0;
1098 arglist = NULL_TREE;
1099 stringargs = NULL_TREE;
1103 /* Obtain the string length now because it is needed often below. */
1104 if (sym->ts.type == BT_CHARACTER)
1106 gcc_assert (sym->ts.cl && sym->ts.cl->length
1107 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1108 len = gfc_conv_mpz_to_tree
1109 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1114 if (!sym->attr.elemental)
1116 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1117 if (se->ss->useflags)
1119 gcc_assert (gfc_return_by_reference (sym)
1120 && sym->result->attr.dimension);
1121 gcc_assert (se->loop != NULL);
1123 /* Access the previously obtained result. */
1124 gfc_conv_tmp_array_ref (se);
1125 gfc_advance_se_ss_chain (se);
1127 /* Bundle in the string length. */
1128 se->string_length = len;
1132 info = &se->ss->data.info;
1137 byref = gfc_return_by_reference (sym);
1140 if (se->direct_byref)
1142 arglist = gfc_chainon_list (arglist, se->expr);
1144 /* Add string length to argument list. */
1145 if (sym->ts.type == BT_CHARACTER)
1147 sym->ts.cl->backend_decl = len;
1148 arglist = gfc_chainon_list (arglist,
1149 convert (gfc_charlen_type_node, len));
1152 else if (sym->result->attr.dimension)
1154 gcc_assert (se->loop && se->ss);
1156 /* Set the type of the array. */
1157 tmp = gfc_typenode_for_spec (&sym->ts);
1158 info->dimen = se->loop->dimen;
1160 /* Allocate a temporary to store the result. */
1161 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1163 /* Zero the first stride to indicate a temporary. */
1165 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1166 gfc_add_modify_expr (&se->pre, tmp,
1167 convert (TREE_TYPE (tmp), integer_zero_node));
1169 /* Pass the temporary as the first argument. */
1170 tmp = info->descriptor;
1171 tmp = gfc_build_addr_expr (NULL, tmp);
1172 arglist = gfc_chainon_list (arglist, tmp);
1174 /* Add string length to argument list. */
1175 if (sym->ts.type == BT_CHARACTER)
1177 sym->ts.cl->backend_decl = len;
1178 arglist = gfc_chainon_list (arglist,
1179 convert (gfc_charlen_type_node, len));
1183 else if (sym->ts.type == BT_CHARACTER)
1186 /* Pass the string length. */
1187 sym->ts.cl->backend_decl = len;
1188 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1189 type = build_pointer_type (type);
1191 /* Return an address to a char[0:len-1]* temporary for character pointers. */
1192 if (sym->attr.pointer || sym->attr.allocatable)
1194 /* Build char[0:len-1] * pstr. */
1195 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1196 build_int_cst (gfc_charlen_type_node, 1));
1197 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1198 tmp = build_array_type (gfc_character1_type_node, tmp);
1199 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1201 /* Provide an address expression for the function arguments. */
1202 var = gfc_build_addr_expr (NULL, var);
1206 var = gfc_conv_string_tmp (se, type, len);
1208 arglist = gfc_chainon_list (arglist, var);
1209 arglist = gfc_chainon_list (arglist,
1210 convert (gfc_charlen_type_node, len));
1214 gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
1216 type = gfc_get_complex_type (sym->ts.kind);
1217 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1218 arglist = gfc_chainon_list (arglist, var);
1222 formal = sym->formal;
1223 /* Evaluate the arguments. */
1224 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1226 if (arg->expr == NULL)
1229 if (se->ignore_optional)
1231 /* Some intrinsics have already been resolved to the correct
1235 else if (arg->label)
1237 has_alternate_specifier = 1;
1242 /* Pass a NULL pointer for an absent arg. */
1243 gfc_init_se (&parmse, NULL);
1244 parmse.expr = null_pointer_node;
1245 if (arg->missing_arg_type == BT_CHARACTER)
1248 gfc_chainon_list (stringargs,
1249 convert (gfc_charlen_type_node,
1250 integer_zero_node));
1254 else if (se->ss && se->ss->useflags)
1256 /* An elemental function inside a scalarized loop. */
1257 gfc_init_se (&parmse, se);
1258 gfc_conv_expr_reference (&parmse, arg->expr);
1262 /* A scalar or transformational function. */
1263 gfc_init_se (&parmse, NULL);
1264 argss = gfc_walk_expr (arg->expr);
1266 if (argss == gfc_ss_terminator)
1268 gfc_conv_expr_reference (&parmse, arg->expr);
1269 if (formal && formal->sym->attr.pointer
1270 && arg->expr->expr_type != EXPR_NULL)
1272 /* Scalar pointer dummy args require an extra level of
1273 indirection. The null pointer already contains
1274 this level of indirection. */
1275 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1280 /* If the procedure requires an explicit interface, the
1281 actual argument is passed according to the
1282 corresponding formal argument. If the corresponding
1283 formal argument is a POINTER or assumed shape, we do
1284 not use g77's calling convention, and pass the
1285 address of the array descriptor instead. Otherwise we
1286 use g77's calling convention. */
1288 f = (formal != NULL)
1289 && !formal->sym->attr.pointer
1290 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1291 f = f || !sym->attr.always_explicit;
1292 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1296 gfc_add_block_to_block (&se->pre, &parmse.pre);
1297 gfc_add_block_to_block (&se->post, &parmse.post);
1299 /* Character strings are passed as two parameters, a length and a
1301 if (parmse.string_length != NULL_TREE)
1302 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1304 arglist = gfc_chainon_list (arglist, parmse.expr);
1307 /* Add the hidden string length parameters to the arguments. */
1308 arglist = chainon (arglist, stringargs);
1310 /* Generate the actual call. */
1311 gfc_conv_function_val (se, sym);
1312 /* If there are alternate return labels, function type should be
1313 integer. Can't modify the type in place though, since it can be shared
1314 with other functions. */
1315 if (has_alternate_specifier
1316 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1318 gcc_assert (! sym->attr.dummy);
1319 TREE_TYPE (sym->backend_decl)
1320 = build_function_type (integer_type_node,
1321 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1322 se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1325 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1326 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1327 arglist, NULL_TREE);
1329 /* If we have a pointer function, but we don't want a pointer, e.g.
1332 where f is pointer valued, we have to dereference the result. */
1333 if (!se->want_pointer && !byref && sym->attr.pointer)
1334 se->expr = gfc_build_indirect_ref (se->expr);
1336 /* f2c calling conventions require a scalar default real function to
1337 return a double precision result. Convert this back to default
1338 real. We only care about the cases that can happen in Fortran 77.
1340 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1341 && sym->ts.kind == gfc_default_real_kind
1342 && !sym->attr.always_explicit)
1343 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1345 /* A pure function may still have side-effects - it may modify its
1347 TREE_SIDE_EFFECTS (se->expr) = 1;
1349 if (!sym->attr.pure)
1350 TREE_SIDE_EFFECTS (se->expr) = 1;
1355 /* Add the function call to the pre chain. There is no expression. */
1356 gfc_add_expr_to_block (&se->pre, se->expr);
1357 se->expr = NULL_TREE;
1359 if (!se->direct_byref)
1361 if (sym->attr.dimension)
1363 if (flag_bounds_check)
1365 /* Check the data pointer hasn't been modified. This would
1366 happen in a function returning a pointer. */
1367 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1368 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1369 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1371 se->expr = info->descriptor;
1372 /* Bundle in the string length. */
1373 se->string_length = len;
1375 else if (sym->ts.type == BT_CHARACTER)
1377 /* Dereference for character pointer results. */
1378 if (sym->attr.pointer || sym->attr.allocatable)
1379 se->expr = gfc_build_indirect_ref (var);
1383 se->string_length = len;
1387 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1388 se->expr = gfc_build_indirect_ref (var);
1393 return has_alternate_specifier;
1397 /* Generate code to copy a string. */
1400 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1401 tree slen, tree src)
1406 tmp = gfc_chainon_list (tmp, dlen);
1407 tmp = gfc_chainon_list (tmp, dest);
1408 tmp = gfc_chainon_list (tmp, slen);
1409 tmp = gfc_chainon_list (tmp, src);
1410 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1411 gfc_add_expr_to_block (block, tmp);
1415 /* Translate a statement function.
1416 The value of a statement function reference is obtained by evaluating the
1417 expression using the values of the actual arguments for the values of the
1418 corresponding dummy arguments. */
1421 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1425 gfc_formal_arglist *fargs;
1426 gfc_actual_arglist *args;
1429 gfc_saved_var *saved_vars;
1435 sym = expr->symtree->n.sym;
1436 args = expr->value.function.actual;
1437 gfc_init_se (&lse, NULL);
1438 gfc_init_se (&rse, NULL);
1441 for (fargs = sym->formal; fargs; fargs = fargs->next)
1443 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1444 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1446 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1448 /* Each dummy shall be specified, explicitly or implicitly, to be
1450 gcc_assert (fargs->sym->attr.dimension == 0);
1453 /* Create a temporary to hold the value. */
1454 type = gfc_typenode_for_spec (&fsym->ts);
1455 temp_vars[n] = gfc_create_var (type, fsym->name);
1457 if (fsym->ts.type == BT_CHARACTER)
1459 /* Copy string arguments. */
1462 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1463 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1465 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1466 tmp = gfc_build_addr_expr (build_pointer_type (type),
1469 gfc_conv_expr (&rse, args->expr);
1470 gfc_conv_string_parameter (&rse);
1471 gfc_add_block_to_block (&se->pre, &lse.pre);
1472 gfc_add_block_to_block (&se->pre, &rse.pre);
1474 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1476 gfc_add_block_to_block (&se->pre, &lse.post);
1477 gfc_add_block_to_block (&se->pre, &rse.post);
1481 /* For everything else, just evaluate the expression. */
1482 gfc_conv_expr (&lse, args->expr);
1484 gfc_add_block_to_block (&se->pre, &lse.pre);
1485 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1486 gfc_add_block_to_block (&se->pre, &lse.post);
1492 /* Use the temporary variables in place of the real ones. */
1493 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1494 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1496 gfc_conv_expr (se, sym->value);
1498 if (sym->ts.type == BT_CHARACTER)
1500 gfc_conv_const_charlen (sym->ts.cl);
1502 /* Force the expression to the correct length. */
1503 if (!INTEGER_CST_P (se->string_length)
1504 || tree_int_cst_lt (se->string_length,
1505 sym->ts.cl->backend_decl))
1507 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1508 tmp = gfc_create_var (type, sym->name);
1509 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1510 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1511 se->string_length, se->expr);
1514 se->string_length = sym->ts.cl->backend_decl;
1517 /* Restore the original variables. */
1518 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1519 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1520 gfc_free (saved_vars);
1524 /* Translate a function expression. */
1527 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1531 if (expr->value.function.isym)
1533 gfc_conv_intrinsic_function (se, expr);
1537 /* We distinguish statement functions from general functions to improve
1538 runtime performance. */
1539 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1541 gfc_conv_statement_function (se, expr);
1545 /* expr.value.function.esym is the resolved (specific) function symbol for
1546 most functions. However this isn't set for dummy procedures. */
1547 sym = expr->value.function.esym;
1549 sym = expr->symtree->n.sym;
1550 gfc_conv_function_call (se, sym, expr->value.function.actual);
1555 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1557 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1558 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1560 gfc_conv_tmp_array_ref (se);
1561 gfc_advance_se_ss_chain (se);
1565 /* Build a static initializer. EXPR is the expression for the initial value.
1566 The other parameters describe the variable of the component being
1567 initialized. EXPR may be null. */
1570 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1571 bool array, bool pointer)
1575 if (!(expr || pointer))
1580 /* Arrays need special handling. */
1582 return gfc_build_null_descriptor (type);
1584 return gfc_conv_array_initializer (type, expr);
1587 return fold_convert (type, null_pointer_node);
1593 gfc_init_se (&se, NULL);
1594 gfc_conv_structure (&se, expr, 1);
1598 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1601 gfc_init_se (&se, NULL);
1602 gfc_conv_constant (&se, expr);
1609 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1621 gfc_start_block (&block);
1623 /* Initialize the scalarizer. */
1624 gfc_init_loopinfo (&loop);
1626 gfc_init_se (&lse, NULL);
1627 gfc_init_se (&rse, NULL);
1630 rss = gfc_walk_expr (expr);
1631 if (rss == gfc_ss_terminator)
1633 /* The rhs is scalar. Add a ss for the expression. */
1634 rss = gfc_get_ss ();
1635 rss->next = gfc_ss_terminator;
1636 rss->type = GFC_SS_SCALAR;
1640 /* Create a SS for the destination. */
1641 lss = gfc_get_ss ();
1642 lss->type = GFC_SS_COMPONENT;
1644 lss->shape = gfc_get_shape (cm->as->rank);
1645 lss->next = gfc_ss_terminator;
1646 lss->data.info.dimen = cm->as->rank;
1647 lss->data.info.descriptor = dest;
1648 lss->data.info.data = gfc_conv_array_data (dest);
1649 lss->data.info.offset = gfc_conv_array_offset (dest);
1650 for (n = 0; n < cm->as->rank; n++)
1652 lss->data.info.dim[n] = n;
1653 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1654 lss->data.info.stride[n] = gfc_index_one_node;
1656 mpz_init (lss->shape[n]);
1657 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1658 cm->as->lower[n]->value.integer);
1659 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1662 /* Associate the SS with the loop. */
1663 gfc_add_ss_to_loop (&loop, lss);
1664 gfc_add_ss_to_loop (&loop, rss);
1666 /* Calculate the bounds of the scalarization. */
1667 gfc_conv_ss_startstride (&loop);
1669 /* Setup the scalarizing loops. */
1670 gfc_conv_loop_setup (&loop);
1672 /* Setup the gfc_se structures. */
1673 gfc_copy_loopinfo_to_se (&lse, &loop);
1674 gfc_copy_loopinfo_to_se (&rse, &loop);
1677 gfc_mark_ss_chain_used (rss, 1);
1679 gfc_mark_ss_chain_used (lss, 1);
1681 /* Start the scalarized loop body. */
1682 gfc_start_scalarized_body (&loop, &body);
1684 gfc_conv_tmp_array_ref (&lse);
1685 if (cm->ts.type == BT_CHARACTER)
1686 lse.string_length = cm->ts.cl->backend_decl;
1688 gfc_conv_expr (&rse, expr);
1690 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1691 gfc_add_expr_to_block (&body, tmp);
1693 gcc_assert (rse.ss == gfc_ss_terminator);
1695 /* Generate the copying loops. */
1696 gfc_trans_scalarizing_loops (&loop, &body);
1698 /* Wrap the whole thing up. */
1699 gfc_add_block_to_block (&block, &loop.pre);
1700 gfc_add_block_to_block (&block, &loop.post);
1702 for (n = 0; n < cm->as->rank; n++)
1703 mpz_clear (lss->shape[n]);
1704 gfc_free (lss->shape);
1706 gfc_cleanup_loop (&loop);
1708 return gfc_finish_block (&block);
1711 /* Assign a single component of a derived type constructor. */
1714 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1721 gfc_start_block (&block);
1724 gfc_init_se (&se, NULL);
1725 /* Pointer component. */
1728 /* Array pointer. */
1729 if (expr->expr_type == EXPR_NULL)
1730 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
1733 rss = gfc_walk_expr (expr);
1734 se.direct_byref = 1;
1736 gfc_conv_expr_descriptor (&se, expr, rss);
1737 gfc_add_block_to_block (&block, &se.pre);
1738 gfc_add_block_to_block (&block, &se.post);
1743 /* Scalar pointers. */
1744 se.want_pointer = 1;
1745 gfc_conv_expr (&se, expr);
1746 gfc_add_block_to_block (&block, &se.pre);
1747 gfc_add_modify_expr (&block, dest,
1748 fold_convert (TREE_TYPE (dest), se.expr));
1749 gfc_add_block_to_block (&block, &se.post);
1752 else if (cm->dimension)
1754 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1755 gfc_add_expr_to_block (&block, tmp);
1757 else if (expr->ts.type == BT_DERIVED)
1759 /* Nested derived type. */
1760 tmp = gfc_trans_structure_assign (dest, expr);
1761 gfc_add_expr_to_block (&block, tmp);
1765 /* Scalar component. */
1768 gfc_init_se (&se, NULL);
1769 gfc_init_se (&lse, NULL);
1771 gfc_conv_expr (&se, expr);
1772 if (cm->ts.type == BT_CHARACTER)
1773 lse.string_length = cm->ts.cl->backend_decl;
1775 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1776 gfc_add_expr_to_block (&block, tmp);
1778 return gfc_finish_block (&block);
1781 /* Assign a derived type constructor to a variable. */
1784 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1792 gfc_start_block (&block);
1793 cm = expr->ts.derived->components;
1794 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1796 /* Skip absent members in default initializers. */
1800 field = cm->backend_decl;
1801 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1802 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1803 gfc_add_expr_to_block (&block, tmp);
1805 return gfc_finish_block (&block);
1808 /* Build an expression for a constructor. If init is nonzero then
1809 this is part of a static variable initializer. */
1812 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1819 VEC(constructor_elt,gc) *v = NULL;
1821 gcc_assert (se->ss == NULL);
1822 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1823 type = gfc_typenode_for_spec (&expr->ts);
1827 /* Create a temporary variable and fill it in. */
1828 se->expr = gfc_create_var (type, expr->ts.derived->name);
1829 tmp = gfc_trans_structure_assign (se->expr, expr);
1830 gfc_add_expr_to_block (&se->pre, tmp);
1834 cm = expr->ts.derived->components;
1835 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1837 /* Skip absent members in default initializers. */
1841 val = gfc_conv_initializer (c->expr, &cm->ts,
1842 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1844 /* Append it to the constructor list. */
1845 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
1847 se->expr = build_constructor (type, v);
1851 /* Translate a substring expression. */
1854 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1860 gcc_assert (ref->type == REF_SUBSTRING);
1862 se->expr = gfc_build_string_const(expr->value.character.length,
1863 expr->value.character.string);
1864 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1865 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1867 gfc_conv_substring(se,ref,expr->ts.kind);
1871 /* Entry point for expression translation. Evaluates a scalar quantity.
1872 EXPR is the expression to be translated, and SE is the state structure if
1873 called from within the scalarized. */
1876 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1878 if (se->ss && se->ss->expr == expr
1879 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1881 /* Substitute a scalar expression evaluated outside the scalarization
1883 se->expr = se->ss->data.scalar.expr;
1884 se->string_length = se->ss->string_length;
1885 gfc_advance_se_ss_chain (se);
1889 switch (expr->expr_type)
1892 gfc_conv_expr_op (se, expr);
1896 gfc_conv_function_expr (se, expr);
1900 gfc_conv_constant (se, expr);
1904 gfc_conv_variable (se, expr);
1908 se->expr = null_pointer_node;
1911 case EXPR_SUBSTRING:
1912 gfc_conv_substring_expr (se, expr);
1915 case EXPR_STRUCTURE:
1916 gfc_conv_structure (se, expr, 0);
1920 gfc_conv_array_constructor_expr (se, expr);
1929 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
1930 of an assignment. */
1932 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1934 gfc_conv_expr (se, expr);
1935 /* All numeric lvalues should have empty post chains. If not we need to
1936 figure out a way of rewriting an lvalue so that it has no post chain. */
1937 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
1940 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
1941 numeric expressions. Used for scalar values whee inserting cleanup code
1944 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1948 gcc_assert (expr->ts.type != BT_CHARACTER);
1949 gfc_conv_expr (se, expr);
1952 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1953 gfc_add_modify_expr (&se->pre, val, se->expr);
1955 gfc_add_block_to_block (&se->pre, &se->post);
1959 /* Helper to translate and expression and convert it to a particular type. */
1961 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1963 gfc_conv_expr_val (se, expr);
1964 se->expr = convert (type, se->expr);
1968 /* Converts an expression so that it can be passed by reference. Scalar
1972 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1976 if (se->ss && se->ss->expr == expr
1977 && se->ss->type == GFC_SS_REFERENCE)
1979 se->expr = se->ss->data.scalar.expr;
1980 se->string_length = se->ss->string_length;
1981 gfc_advance_se_ss_chain (se);
1985 if (expr->ts.type == BT_CHARACTER)
1987 gfc_conv_expr (se, expr);
1988 gfc_conv_string_parameter (se);
1992 if (expr->expr_type == EXPR_VARIABLE)
1994 se->want_pointer = 1;
1995 gfc_conv_expr (se, expr);
1998 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1999 gfc_add_modify_expr (&se->pre, var, se->expr);
2000 gfc_add_block_to_block (&se->pre, &se->post);
2006 gfc_conv_expr (se, expr);
2008 /* Create a temporary var to hold the value. */
2009 if (TREE_CONSTANT (se->expr))
2011 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2012 DECL_INITIAL (var) = se->expr;
2017 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2018 gfc_add_modify_expr (&se->pre, var, se->expr);
2020 gfc_add_block_to_block (&se->pre, &se->post);
2022 /* Take the address of that value. */
2023 se->expr = gfc_build_addr_expr (NULL, var);
2028 gfc_trans_pointer_assign (gfc_code * code)
2030 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2034 /* Generate code for a pointer assignment. */
2037 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2045 gfc_start_block (&block);
2047 gfc_init_se (&lse, NULL);
2049 lss = gfc_walk_expr (expr1);
2050 rss = gfc_walk_expr (expr2);
2051 if (lss == gfc_ss_terminator)
2053 /* Scalar pointers. */
2054 lse.want_pointer = 1;
2055 gfc_conv_expr (&lse, expr1);
2056 gcc_assert (rss == gfc_ss_terminator);
2057 gfc_init_se (&rse, NULL);
2058 rse.want_pointer = 1;
2059 gfc_conv_expr (&rse, expr2);
2060 gfc_add_block_to_block (&block, &lse.pre);
2061 gfc_add_block_to_block (&block, &rse.pre);
2062 gfc_add_modify_expr (&block, lse.expr,
2063 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2064 gfc_add_block_to_block (&block, &rse.post);
2065 gfc_add_block_to_block (&block, &lse.post);
2069 /* Array pointer. */
2070 gfc_conv_expr_descriptor (&lse, expr1, lss);
2071 /* Implement Nullify. */
2072 if (expr2->expr_type == EXPR_NULL)
2073 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2076 lse.direct_byref = 1;
2077 gfc_conv_expr_descriptor (&lse, expr2, rss);
2079 gfc_add_block_to_block (&block, &lse.pre);
2080 gfc_add_block_to_block (&block, &lse.post);
2082 return gfc_finish_block (&block);
2086 /* Makes sure se is suitable for passing as a function string parameter. */
2087 /* TODO: Need to check all callers fo this function. It may be abused. */
2090 gfc_conv_string_parameter (gfc_se * se)
2094 if (TREE_CODE (se->expr) == STRING_CST)
2096 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2100 type = TREE_TYPE (se->expr);
2101 if (TYPE_STRING_FLAG (type))
2103 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2104 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2107 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2108 gcc_assert (se->string_length
2109 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2113 /* Generate code for assignment of scalar variables. Includes character
2117 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2121 gfc_init_block (&block);
2123 if (type == BT_CHARACTER)
2125 gcc_assert (lse->string_length != NULL_TREE
2126 && rse->string_length != NULL_TREE);
2128 gfc_conv_string_parameter (lse);
2129 gfc_conv_string_parameter (rse);
2131 gfc_add_block_to_block (&block, &lse->pre);
2132 gfc_add_block_to_block (&block, &rse->pre);
2134 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2135 rse->string_length, rse->expr);
2139 gfc_add_block_to_block (&block, &lse->pre);
2140 gfc_add_block_to_block (&block, &rse->pre);
2142 gfc_add_modify_expr (&block, lse->expr,
2143 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2146 gfc_add_block_to_block (&block, &lse->post);
2147 gfc_add_block_to_block (&block, &rse->post);
2149 return gfc_finish_block (&block);
2153 /* Try to translate array(:) = func (...), where func is a transformational
2154 array function, without using a temporary. Returns NULL is this isn't the
2158 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2163 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2164 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2167 /* Elemental functions don't need a temporary anyway. */
2168 if (expr2->symtree->n.sym->attr.elemental)
2171 /* Check for a dependency. */
2172 if (gfc_check_fncall_dependency (expr1, expr2))
2175 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2177 gcc_assert (expr2->value.function.isym
2178 || (gfc_return_by_reference (expr2->value.function.esym)
2179 && expr2->value.function.esym->result->attr.dimension));
2181 ss = gfc_walk_expr (expr1);
2182 gcc_assert (ss != gfc_ss_terminator);
2183 gfc_init_se (&se, NULL);
2184 gfc_start_block (&se.pre);
2185 se.want_pointer = 1;
2187 gfc_conv_array_parameter (&se, expr1, ss, 0);
2189 se.direct_byref = 1;
2190 se.ss = gfc_walk_expr (expr2);
2191 gcc_assert (se.ss != gfc_ss_terminator);
2192 gfc_conv_function_expr (&se, expr2);
2193 gfc_add_block_to_block (&se.pre, &se.post);
2195 return gfc_finish_block (&se.pre);
2199 /* Translate an assignment. Most of the code is concerned with
2200 setting up the scalarizer. */
2203 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2208 gfc_ss *lss_section;
2215 /* Special case a single function returning an array. */
2216 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2218 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2223 /* Assignment of the form lhs = rhs. */
2224 gfc_start_block (&block);
2226 gfc_init_se (&lse, NULL);
2227 gfc_init_se (&rse, NULL);
2230 lss = gfc_walk_expr (expr1);
2232 if (lss != gfc_ss_terminator)
2234 /* The assignment needs scalarization. */
2237 /* Find a non-scalar SS from the lhs. */
2238 while (lss_section != gfc_ss_terminator
2239 && lss_section->type != GFC_SS_SECTION)
2240 lss_section = lss_section->next;
2242 gcc_assert (lss_section != gfc_ss_terminator);
2244 /* Initialize the scalarizer. */
2245 gfc_init_loopinfo (&loop);
2248 rss = gfc_walk_expr (expr2);
2249 if (rss == gfc_ss_terminator)
2251 /* The rhs is scalar. Add a ss for the expression. */
2252 rss = gfc_get_ss ();
2253 rss->next = gfc_ss_terminator;
2254 rss->type = GFC_SS_SCALAR;
2257 /* Associate the SS with the loop. */
2258 gfc_add_ss_to_loop (&loop, lss);
2259 gfc_add_ss_to_loop (&loop, rss);
2261 /* Calculate the bounds of the scalarization. */
2262 gfc_conv_ss_startstride (&loop);
2263 /* Resolve any data dependencies in the statement. */
2264 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2265 /* Setup the scalarizing loops. */
2266 gfc_conv_loop_setup (&loop);
2268 /* Setup the gfc_se structures. */
2269 gfc_copy_loopinfo_to_se (&lse, &loop);
2270 gfc_copy_loopinfo_to_se (&rse, &loop);
2273 gfc_mark_ss_chain_used (rss, 1);
2274 if (loop.temp_ss == NULL)
2277 gfc_mark_ss_chain_used (lss, 1);
2281 lse.ss = loop.temp_ss;
2282 gfc_mark_ss_chain_used (lss, 3);
2283 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2286 /* Start the scalarized loop body. */
2287 gfc_start_scalarized_body (&loop, &body);
2290 gfc_init_block (&body);
2292 /* Translate the expression. */
2293 gfc_conv_expr (&rse, expr2);
2295 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2297 gfc_conv_tmp_array_ref (&lse);
2298 gfc_advance_se_ss_chain (&lse);
2301 gfc_conv_expr (&lse, expr1);
2303 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2304 gfc_add_expr_to_block (&body, tmp);
2306 if (lss == gfc_ss_terminator)
2308 /* Use the scalar assignment as is. */
2309 gfc_add_block_to_block (&block, &body);
2313 gcc_assert (lse.ss == gfc_ss_terminator
2314 && rse.ss == gfc_ss_terminator);
2316 if (loop.temp_ss != NULL)
2318 gfc_trans_scalarized_loop_boundary (&loop, &body);
2320 /* We need to copy the temporary to the actual lhs. */
2321 gfc_init_se (&lse, NULL);
2322 gfc_init_se (&rse, NULL);
2323 gfc_copy_loopinfo_to_se (&lse, &loop);
2324 gfc_copy_loopinfo_to_se (&rse, &loop);
2326 rse.ss = loop.temp_ss;
2329 gfc_conv_tmp_array_ref (&rse);
2330 gfc_advance_se_ss_chain (&rse);
2331 gfc_conv_expr (&lse, expr1);
2333 gcc_assert (lse.ss == gfc_ss_terminator
2334 && rse.ss == gfc_ss_terminator);
2336 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2337 gfc_add_expr_to_block (&body, tmp);
2339 /* Generate the copying loops. */
2340 gfc_trans_scalarizing_loops (&loop, &body);
2342 /* Wrap the whole thing up. */
2343 gfc_add_block_to_block (&block, &loop.pre);
2344 gfc_add_block_to_block (&block, &loop.post);
2346 gfc_cleanup_loop (&loop);
2349 return gfc_finish_block (&block);
2353 gfc_trans_assign (gfc_code * code)
2355 return gfc_trans_assignment (code->expr, code->expr2);