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, 59 Temple Place - Suite 330, 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)
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);
359 /* Dereference scalar dummy variables. */
361 && sym->ts.type != BT_CHARACTER
362 && !sym->attr.dimension)
363 se->expr = gfc_build_indirect_ref (se->expr);
365 /* Dereference scalar hidden result. */
366 if (gfc_option.flag_f2c
367 && (sym->attr.function || sym->attr.result)
368 && sym->ts.type == BT_COMPLEX
369 && !sym->attr.dimension)
370 se->expr = gfc_build_indirect_ref (se->expr);
372 /* Dereference pointer variables. */
373 if ((sym->attr.pointer || sym->attr.allocatable)
376 || sym->attr.function
377 || !sym->attr.dimension)
378 && sym->ts.type != BT_CHARACTER)
379 se->expr = gfc_build_indirect_ref (se->expr);
384 /* For character variables, also get the length. */
385 if (sym->ts.type == BT_CHARACTER)
387 se->string_length = sym->ts.cl->backend_decl;
388 gcc_assert (se->string_length);
396 /* Return the descriptor if that's what we want and this is an array
397 section reference. */
398 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
400 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
401 /* Return the descriptor for array pointers and allocations. */
403 && ref->next == NULL && (se->descriptor_only))
406 gfc_conv_array_ref (se, &ref->u.ar);
407 /* Return a pointer to an element. */
411 gfc_conv_component_ref (se, ref);
415 gfc_conv_substring (se, ref, expr->ts.kind);
424 /* Pointer assignment, allocation or pass by reference. Arrays are handled
426 if (se->want_pointer)
428 if (expr->ts.type == BT_CHARACTER)
429 gfc_conv_string_parameter (se);
431 se->expr = gfc_build_addr_expr (NULL, se->expr);
434 gfc_advance_se_ss_chain (se);
438 /* Unary ops are easy... Or they would be if ! was a valid op. */
441 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
446 gcc_assert (expr->ts.type != BT_CHARACTER);
447 /* Initialize the operand. */
448 gfc_init_se (&operand, se);
449 gfc_conv_expr_val (&operand, expr->value.op.op1);
450 gfc_add_block_to_block (&se->pre, &operand.pre);
452 type = gfc_typenode_for_spec (&expr->ts);
454 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
455 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
456 All other unary operators have an equivalent GIMPLE unary operator. */
457 if (code == TRUTH_NOT_EXPR)
458 se->expr = build2 (EQ_EXPR, type, operand.expr,
459 convert (type, integer_zero_node));
461 se->expr = build1 (code, type, operand.expr);
465 /* Expand power operator to optimal multiplications when a value is raised
466 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
467 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
468 Programming", 3rd Edition, 1998. */
470 /* This code is mostly duplicated from expand_powi in the backend.
471 We establish the "optimal power tree" lookup table with the defined size.
472 The items in the table are the exponents used to calculate the index
473 exponents. Any integer n less than the value can get an "addition chain",
474 with the first node being one. */
475 #define POWI_TABLE_SIZE 256
477 /* The table is from builtins.c. */
478 static const unsigned char powi_table[POWI_TABLE_SIZE] =
480 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
481 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
482 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
483 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
484 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
485 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
486 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
487 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
488 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
489 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
490 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
491 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
492 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
493 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
494 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
495 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
496 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
497 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
498 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
499 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
500 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
501 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
502 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
503 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
504 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
505 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
506 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
507 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
508 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
509 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
510 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
511 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
514 /* If n is larger than lookup table's max index, we use the "window
516 #define POWI_WINDOW_SIZE 3
518 /* Recursive function to expand the power operator. The temporary
519 values are put in tmpvar. The function returns tmpvar[1] ** n. */
521 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
528 if (n < POWI_TABLE_SIZE)
533 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
534 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
538 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
539 op0 = gfc_conv_powi (se, n - digit, tmpvar);
540 op1 = gfc_conv_powi (se, digit, tmpvar);
544 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
548 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
549 tmp = gfc_evaluate_now (tmp, &se->pre);
551 if (n < POWI_TABLE_SIZE)
558 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
559 return 1. Else return 0 and a call to runtime library functions
560 will have to be built. */
562 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
567 tree vartmp[POWI_TABLE_SIZE];
571 type = TREE_TYPE (lhs);
572 n = abs (TREE_INT_CST_LOW (rhs));
573 sgn = tree_int_cst_sgn (rhs);
575 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
576 && (n > 2 || n < -1))
582 se->expr = gfc_build_const (type, integer_one_node);
585 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
586 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
588 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
589 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
590 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
591 convert (TREE_TYPE (lhs), integer_one_node));
594 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
597 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
598 se->expr = build3 (COND_EXPR, type, tmp,
599 convert (type, integer_one_node),
600 convert (type, integer_zero_node));
604 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
605 tmp = build3 (COND_EXPR, type, tmp,
606 convert (type, integer_minus_one_node),
607 convert (type, integer_zero_node));
608 se->expr = build3 (COND_EXPR, type, cond,
609 convert (type, integer_one_node),
614 memset (vartmp, 0, sizeof (vartmp));
618 tmp = gfc_build_const (type, integer_one_node);
619 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
622 se->expr = gfc_conv_powi (se, n, vartmp);
628 /* Power op (**). Constant integer exponent has special handling. */
631 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
633 tree gfc_int4_type_node;
641 gfc_init_se (&lse, se);
642 gfc_conv_expr_val (&lse, expr->value.op.op1);
643 gfc_add_block_to_block (&se->pre, &lse.pre);
645 gfc_init_se (&rse, se);
646 gfc_conv_expr_val (&rse, expr->value.op.op2);
647 gfc_add_block_to_block (&se->pre, &rse.pre);
649 if (expr->value.op.op2->ts.type == BT_INTEGER
650 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
651 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
654 gfc_int4_type_node = gfc_get_int_type (4);
656 kind = expr->value.op.op1->ts.kind;
657 switch (expr->value.op.op2->ts.type)
660 ikind = expr->value.op.op2->ts.kind;
665 rse.expr = convert (gfc_int4_type_node, rse.expr);
683 if (expr->value.op.op1->ts.type == BT_INTEGER)
684 lse.expr = convert (gfc_int4_type_node, lse.expr);
701 switch (expr->value.op.op1->ts.type)
704 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
708 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
712 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
724 fndecl = built_in_decls[BUILT_IN_POWF];
727 fndecl = built_in_decls[BUILT_IN_POW];
738 fndecl = gfor_fndecl_math_cpowf;
741 fndecl = gfor_fndecl_math_cpow;
753 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
754 tmp = gfc_chainon_list (tmp, rse.expr);
755 se->expr = fold (gfc_build_function_call (fndecl, tmp));
759 /* Generate code to allocate a string temporary. */
762 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
768 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
770 if (gfc_can_put_var_on_stack (len))
772 /* Create a temporary variable to hold the result. */
773 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
774 convert (gfc_charlen_type_node, integer_one_node));
775 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
776 tmp = build_array_type (gfc_character1_type_node, tmp);
777 var = gfc_create_var (tmp, "str");
778 var = gfc_build_addr_expr (type, var);
782 /* Allocate a temporary to hold the result. */
783 var = gfc_create_var (type, "pstr");
784 args = gfc_chainon_list (NULL_TREE, len);
785 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
786 tmp = convert (type, tmp);
787 gfc_add_modify_expr (&se->pre, var, tmp);
789 /* Free the temporary afterwards. */
790 tmp = convert (pvoid_type_node, var);
791 args = gfc_chainon_list (NULL_TREE, tmp);
792 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
793 gfc_add_expr_to_block (&se->post, tmp);
800 /* Handle a string concatenation operation. A temporary will be allocated to
804 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
814 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
815 && expr->value.op.op2->ts.type == BT_CHARACTER);
817 gfc_init_se (&lse, se);
818 gfc_conv_expr (&lse, expr->value.op.op1);
819 gfc_conv_string_parameter (&lse);
820 gfc_init_se (&rse, se);
821 gfc_conv_expr (&rse, expr->value.op.op2);
822 gfc_conv_string_parameter (&rse);
824 gfc_add_block_to_block (&se->pre, &lse.pre);
825 gfc_add_block_to_block (&se->pre, &rse.pre);
827 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
828 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
829 if (len == NULL_TREE)
831 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
832 lse.string_length, rse.string_length);
835 type = build_pointer_type (type);
837 var = gfc_conv_string_tmp (se, type, len);
839 /* Do the actual concatenation. */
841 args = gfc_chainon_list (args, len);
842 args = gfc_chainon_list (args, var);
843 args = gfc_chainon_list (args, lse.string_length);
844 args = gfc_chainon_list (args, lse.expr);
845 args = gfc_chainon_list (args, rse.string_length);
846 args = gfc_chainon_list (args, rse.expr);
847 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
848 gfc_add_expr_to_block (&se->pre, tmp);
850 /* Add the cleanup for the operands. */
851 gfc_add_block_to_block (&se->pre, &rse.post);
852 gfc_add_block_to_block (&se->pre, &lse.post);
855 se->string_length = len;
859 /* Translates an op expression. Common (binary) cases are handled by this
860 function, others are passed on. Recursion is used in either case.
861 We use the fact that (op1.ts == op2.ts) (except for the power
863 Operators need no special handling for scalarized expressions as long as
864 they call gfc_conv_simple_val to get their operands.
865 Character strings get special handling. */
868 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
880 switch (expr->value.op.operator)
882 case INTRINSIC_UPLUS:
883 gfc_conv_expr (se, expr->value.op.op1);
886 case INTRINSIC_UMINUS:
887 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
891 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
898 case INTRINSIC_MINUS:
902 case INTRINSIC_TIMES:
906 case INTRINSIC_DIVIDE:
907 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
908 an integer, we must round towards zero, so we use a
910 if (expr->ts.type == BT_INTEGER)
911 code = TRUNC_DIV_EXPR;
916 case INTRINSIC_POWER:
917 gfc_conv_power_op (se, expr);
920 case INTRINSIC_CONCAT:
921 gfc_conv_concat_op (se, expr);
925 code = TRUTH_ANDIF_EXPR;
930 code = TRUTH_ORIF_EXPR;
934 /* EQV and NEQV only work on logicals, but since we represent them
935 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
975 case INTRINSIC_ASSIGN:
976 /* These should be converted into function calls by the frontend. */
980 fatal_error ("Unknown intrinsic op");
984 /* The only exception to this is **, which is handled separately anyway. */
985 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
987 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
991 gfc_init_se (&lse, se);
992 gfc_conv_expr (&lse, expr->value.op.op1);
993 gfc_add_block_to_block (&se->pre, &lse.pre);
996 gfc_init_se (&rse, se);
997 gfc_conv_expr (&rse, expr->value.op.op2);
998 gfc_add_block_to_block (&se->pre, &rse.pre);
1000 /* For string comparisons we generate a library call, and compare the return
1004 gfc_conv_string_parameter (&lse);
1005 gfc_conv_string_parameter (&rse);
1007 tmp = gfc_chainon_list (tmp, lse.string_length);
1008 tmp = gfc_chainon_list (tmp, lse.expr);
1009 tmp = gfc_chainon_list (tmp, rse.string_length);
1010 tmp = gfc_chainon_list (tmp, rse.expr);
1012 /* Build a call for the comparison. */
1013 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1014 gfc_add_block_to_block (&lse.post, &rse.post);
1016 rse.expr = integer_zero_node;
1019 type = gfc_typenode_for_spec (&expr->ts);
1023 /* The result of logical ops is always boolean_type_node. */
1024 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1025 se->expr = convert (type, tmp);
1028 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1030 /* Add the post blocks. */
1031 gfc_add_block_to_block (&se->post, &rse.post);
1032 gfc_add_block_to_block (&se->post, &lse.post);
1037 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1041 if (sym->attr.dummy)
1043 tmp = gfc_get_symbol_decl (sym);
1044 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1045 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1051 if (!sym->backend_decl)
1052 sym->backend_decl = gfc_get_extern_function_decl (sym);
1054 tmp = sym->backend_decl;
1055 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1056 se->expr = gfc_build_addr_expr (NULL, tmp);
1061 /* Generate code for a procedure call. Note can return se->post != NULL.
1062 If se->direct_byref is set then se->expr contains the return parameter. */
1065 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1066 gfc_actual_arglist * arg)
1079 gfc_formal_arglist *formal;
1081 arglist = NULL_TREE;
1082 stringargs = NULL_TREE;
1088 if (!sym->attr.elemental)
1090 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1091 if (se->ss->useflags)
1093 gcc_assert (gfc_return_by_reference (sym)
1094 && sym->result->attr.dimension);
1095 gcc_assert (se->loop != NULL);
1097 /* Access the previously obtained result. */
1098 gfc_conv_tmp_array_ref (se);
1099 gfc_advance_se_ss_chain (se);
1103 info = &se->ss->data.info;
1108 byref = gfc_return_by_reference (sym);
1111 if (se->direct_byref)
1112 arglist = gfc_chainon_list (arglist, se->expr);
1113 else if (sym->result->attr.dimension)
1115 gcc_assert (se->loop && se->ss);
1116 /* Set the type of the array. */
1117 tmp = gfc_typenode_for_spec (&sym->ts);
1118 info->dimen = se->loop->dimen;
1119 /* Allocate a temporary to store the result. */
1120 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1122 /* Zero the first stride to indicate a temporary. */
1124 gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1125 gfc_add_modify_expr (&se->pre, tmp,
1126 convert (TREE_TYPE (tmp), integer_zero_node));
1127 /* Pass the temporary as the first argument. */
1128 tmp = info->descriptor;
1129 tmp = gfc_build_addr_expr (NULL, tmp);
1130 arglist = gfc_chainon_list (arglist, tmp);
1132 else if (sym->ts.type == BT_CHARACTER)
1134 gcc_assert (sym->ts.cl && sym->ts.cl->length
1135 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
1136 len = gfc_conv_mpz_to_tree
1137 (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
1138 sym->ts.cl->backend_decl = len;
1139 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1140 type = build_pointer_type (type);
1142 var = gfc_conv_string_tmp (se, type, len);
1143 arglist = gfc_chainon_list (arglist, var);
1144 arglist = gfc_chainon_list (arglist,
1145 convert (gfc_charlen_type_node, len));
1149 gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
1151 type = gfc_get_complex_type (sym->ts.kind);
1152 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1153 arglist = gfc_chainon_list (arglist, var);
1157 formal = sym->formal;
1158 /* Evaluate the arguments. */
1159 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1161 if (arg->expr == NULL)
1164 if (se->ignore_optional)
1166 /* Some intrinsics have already been resolved to the correct
1170 else if (arg->label)
1172 has_alternate_specifier = 1;
1177 /* Pass a NULL pointer for an absent arg. */
1178 gfc_init_se (&parmse, NULL);
1179 parmse.expr = null_pointer_node;
1180 if (arg->missing_arg_type == BT_CHARACTER)
1183 gfc_chainon_list (stringargs,
1184 convert (gfc_charlen_type_node,
1185 integer_zero_node));
1189 else if (se->ss && se->ss->useflags)
1191 /* An elemental function inside a scalarized loop. */
1192 gfc_init_se (&parmse, se);
1193 gfc_conv_expr_reference (&parmse, arg->expr);
1197 /* A scalar or transformational function. */
1198 gfc_init_se (&parmse, NULL);
1199 argss = gfc_walk_expr (arg->expr);
1201 if (argss == gfc_ss_terminator)
1203 gfc_conv_expr_reference (&parmse, arg->expr);
1204 if (formal && formal->sym->attr.pointer
1205 && arg->expr->expr_type != EXPR_NULL)
1207 /* Scalar pointer dummy args require an extra level of
1208 indirection. The null pointer already contains
1209 this level of indirection. */
1210 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1215 /* If the procedure requires an explicit interface, the
1216 actual argument is passed according to the
1217 corresponding formal argument. If the corresponding
1218 formal argument is a POINTER or assumed shape, we do
1219 not use g77's calling convention, and pass the
1220 address of the array descriptor instead. Otherwise we
1221 use g77's calling convention. */
1223 f = (formal != NULL)
1224 && !formal->sym->attr.pointer
1225 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1226 f = f || !sym->attr.always_explicit;
1227 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1231 gfc_add_block_to_block (&se->pre, &parmse.pre);
1232 gfc_add_block_to_block (&se->post, &parmse.post);
1234 /* Character strings are passed as two parameters, a length and a
1236 if (parmse.string_length != NULL_TREE)
1237 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1239 arglist = gfc_chainon_list (arglist, parmse.expr);
1242 /* Add the hidden string length parameters to the arguments. */
1243 arglist = chainon (arglist, stringargs);
1245 /* Generate the actual call. */
1246 gfc_conv_function_val (se, sym);
1247 /* If there are alternate return labels, function type should be
1249 if (has_alternate_specifier)
1250 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
1252 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1253 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1254 arglist, NULL_TREE);
1259 /* If we have a pointer function, but we don't want a pointer, e.g.
1262 where f is pointer valued, we have to dereference the result. */
1263 if (!se->want_pointer && !byref && sym->attr.pointer)
1264 se->expr = gfc_build_indirect_ref (se->expr);
1266 /* f2c calling conventions require a scalar default real function to
1267 return a double precision result. Convert this back to default
1268 real. We only care about the cases that can happen in Fortran 77.
1270 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1271 && sym->ts.kind == gfc_default_real_kind
1272 && !sym->attr.always_explicit)
1273 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1275 /* A pure function may still have side-effects - it may modify its
1277 TREE_SIDE_EFFECTS (se->expr) = 1;
1279 if (!sym->attr.pure)
1280 TREE_SIDE_EFFECTS (se->expr) = 1;
1285 /* Add the function call to the pre chain. There is no expression. */
1286 gfc_add_expr_to_block (&se->pre, se->expr);
1287 se->expr = NULL_TREE;
1289 if (!se->direct_byref)
1291 if (sym->result->attr.dimension)
1293 if (flag_bounds_check)
1295 /* Check the data pointer hasn't been modified. This would
1296 happen in a function returning a pointer. */
1297 tmp = gfc_conv_descriptor_data (info->descriptor);
1298 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1299 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1301 se->expr = info->descriptor;
1303 else if (sym->ts.type == BT_CHARACTER)
1306 se->string_length = len;
1310 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1311 se->expr = gfc_build_indirect_ref (var);
1318 /* Generate code to copy a string. */
1321 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1322 tree slen, tree src)
1327 tmp = gfc_chainon_list (tmp, dlen);
1328 tmp = gfc_chainon_list (tmp, dest);
1329 tmp = gfc_chainon_list (tmp, slen);
1330 tmp = gfc_chainon_list (tmp, src);
1331 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1332 gfc_add_expr_to_block (block, tmp);
1336 /* Translate a statement function.
1337 The value of a statement function reference is obtained by evaluating the
1338 expression using the values of the actual arguments for the values of the
1339 corresponding dummy arguments. */
1342 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1346 gfc_formal_arglist *fargs;
1347 gfc_actual_arglist *args;
1350 gfc_saved_var *saved_vars;
1356 sym = expr->symtree->n.sym;
1357 args = expr->value.function.actual;
1358 gfc_init_se (&lse, NULL);
1359 gfc_init_se (&rse, NULL);
1362 for (fargs = sym->formal; fargs; fargs = fargs->next)
1364 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1365 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1367 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1369 /* Each dummy shall be specified, explicitly or implicitly, to be
1371 gcc_assert (fargs->sym->attr.dimension == 0);
1374 /* Create a temporary to hold the value. */
1375 type = gfc_typenode_for_spec (&fsym->ts);
1376 temp_vars[n] = gfc_create_var (type, fsym->name);
1378 if (fsym->ts.type == BT_CHARACTER)
1380 /* Copy string arguments. */
1383 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1384 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1386 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1387 tmp = gfc_build_addr_expr (build_pointer_type (type),
1390 gfc_conv_expr (&rse, args->expr);
1391 gfc_conv_string_parameter (&rse);
1392 gfc_add_block_to_block (&se->pre, &lse.pre);
1393 gfc_add_block_to_block (&se->pre, &rse.pre);
1395 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1397 gfc_add_block_to_block (&se->pre, &lse.post);
1398 gfc_add_block_to_block (&se->pre, &rse.post);
1402 /* For everything else, just evaluate the expression. */
1403 gfc_conv_expr (&lse, args->expr);
1405 gfc_add_block_to_block (&se->pre, &lse.pre);
1406 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1407 gfc_add_block_to_block (&se->pre, &lse.post);
1413 /* Use the temporary variables in place of the real ones. */
1414 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1415 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1417 gfc_conv_expr (se, sym->value);
1419 if (sym->ts.type == BT_CHARACTER)
1421 gfc_conv_const_charlen (sym->ts.cl);
1423 /* Force the expression to the correct length. */
1424 if (!INTEGER_CST_P (se->string_length)
1425 || tree_int_cst_lt (se->string_length,
1426 sym->ts.cl->backend_decl))
1428 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1429 tmp = gfc_create_var (type, sym->name);
1430 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1431 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1432 se->string_length, se->expr);
1435 se->string_length = sym->ts.cl->backend_decl;
1438 /* Restore the original variables. */
1439 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1440 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1441 gfc_free (saved_vars);
1445 /* Translate a function expression. */
1448 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1452 if (expr->value.function.isym)
1454 gfc_conv_intrinsic_function (se, expr);
1458 /* We distinguish statement functions from general functions to improve
1459 runtime performance. */
1460 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1462 gfc_conv_statement_function (se, expr);
1466 /* expr.value.function.esym is the resolved (specific) function symbol for
1467 most functions. However this isn't set for dummy procedures. */
1468 sym = expr->value.function.esym;
1470 sym = expr->symtree->n.sym;
1471 gfc_conv_function_call (se, sym, expr->value.function.actual);
1476 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1478 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1479 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1481 gfc_conv_tmp_array_ref (se);
1482 gfc_advance_se_ss_chain (se);
1486 /* Build a static initializer. EXPR is the expression for the initial value.
1487 The other parameters describe the variable of the component being
1488 initialized. EXPR may be null. */
1491 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1492 bool array, bool pointer)
1496 if (!(expr || pointer))
1501 /* Arrays need special handling. */
1503 return gfc_build_null_descriptor (type);
1505 return gfc_conv_array_initializer (type, expr);
1508 return fold_convert (type, null_pointer_node);
1514 gfc_init_se (&se, NULL);
1515 gfc_conv_structure (&se, expr, 1);
1519 return gfc_conv_string_init (ts->cl->backend_decl,expr);
1522 gfc_init_se (&se, NULL);
1523 gfc_conv_constant (&se, expr);
1530 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1542 gfc_start_block (&block);
1544 /* Initialize the scalarizer. */
1545 gfc_init_loopinfo (&loop);
1547 gfc_init_se (&lse, NULL);
1548 gfc_init_se (&rse, NULL);
1551 rss = gfc_walk_expr (expr);
1552 if (rss == gfc_ss_terminator)
1554 /* The rhs is scalar. Add a ss for the expression. */
1555 rss = gfc_get_ss ();
1556 rss->next = gfc_ss_terminator;
1557 rss->type = GFC_SS_SCALAR;
1561 /* Create a SS for the destination. */
1562 lss = gfc_get_ss ();
1563 lss->type = GFC_SS_COMPONENT;
1565 lss->shape = gfc_get_shape (cm->as->rank);
1566 lss->next = gfc_ss_terminator;
1567 lss->data.info.dimen = cm->as->rank;
1568 lss->data.info.descriptor = dest;
1569 lss->data.info.data = gfc_conv_array_data (dest);
1570 lss->data.info.offset = gfc_conv_array_offset (dest);
1571 for (n = 0; n < cm->as->rank; n++)
1573 lss->data.info.dim[n] = n;
1574 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
1575 lss->data.info.stride[n] = gfc_index_one_node;
1577 mpz_init (lss->shape[n]);
1578 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
1579 cm->as->lower[n]->value.integer);
1580 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
1583 /* Associate the SS with the loop. */
1584 gfc_add_ss_to_loop (&loop, lss);
1585 gfc_add_ss_to_loop (&loop, rss);
1587 /* Calculate the bounds of the scalarization. */
1588 gfc_conv_ss_startstride (&loop);
1590 /* Setup the scalarizing loops. */
1591 gfc_conv_loop_setup (&loop);
1593 /* Setup the gfc_se structures. */
1594 gfc_copy_loopinfo_to_se (&lse, &loop);
1595 gfc_copy_loopinfo_to_se (&rse, &loop);
1598 gfc_mark_ss_chain_used (rss, 1);
1600 gfc_mark_ss_chain_used (lss, 1);
1602 /* Start the scalarized loop body. */
1603 gfc_start_scalarized_body (&loop, &body);
1605 gfc_conv_tmp_array_ref (&lse);
1606 gfc_conv_expr (&rse, expr);
1608 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
1609 gfc_add_expr_to_block (&body, tmp);
1611 gcc_assert (rse.ss == gfc_ss_terminator);
1613 /* Generate the copying loops. */
1614 gfc_trans_scalarizing_loops (&loop, &body);
1616 /* Wrap the whole thing up. */
1617 gfc_add_block_to_block (&block, &loop.pre);
1618 gfc_add_block_to_block (&block, &loop.post);
1620 for (n = 0; n < cm->as->rank; n++)
1621 mpz_clear (lss->shape[n]);
1622 gfc_free (lss->shape);
1624 gfc_cleanup_loop (&loop);
1626 return gfc_finish_block (&block);
1629 /* Assign a single component of a derived type constructor. */
1632 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
1639 gfc_start_block (&block);
1642 gfc_init_se (&se, NULL);
1643 /* Pointer component. */
1646 /* Array pointer. */
1647 if (expr->expr_type == EXPR_NULL)
1649 dest = gfc_conv_descriptor_data (dest);
1650 tmp = fold_convert (TREE_TYPE (se.expr),
1652 gfc_add_modify_expr (&block, dest, tmp);
1656 rss = gfc_walk_expr (expr);
1657 se.direct_byref = 1;
1659 gfc_conv_expr_descriptor (&se, expr, rss);
1660 gfc_add_block_to_block (&block, &se.pre);
1661 gfc_add_block_to_block (&block, &se.post);
1666 /* Scalar pointers. */
1667 se.want_pointer = 1;
1668 gfc_conv_expr (&se, expr);
1669 gfc_add_block_to_block (&block, &se.pre);
1670 gfc_add_modify_expr (&block, dest,
1671 fold_convert (TREE_TYPE (dest), se.expr));
1672 gfc_add_block_to_block (&block, &se.post);
1675 else if (cm->dimension)
1677 tmp = gfc_trans_subarray_assign (dest, cm, expr);
1678 gfc_add_expr_to_block (&block, tmp);
1680 else if (expr->ts.type == BT_DERIVED)
1682 /* Nested derived type. */
1683 tmp = gfc_trans_structure_assign (dest, expr);
1684 gfc_add_expr_to_block (&block, tmp);
1688 /* Scalar component. */
1691 gfc_init_se (&se, NULL);
1692 gfc_init_se (&lse, NULL);
1694 gfc_conv_expr (&se, expr);
1695 if (cm->ts.type == BT_CHARACTER)
1696 lse.string_length = cm->ts.cl->backend_decl;
1698 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
1699 gfc_add_expr_to_block (&block, tmp);
1701 return gfc_finish_block (&block);
1704 /* Assign a derived type constructor to a variable. */
1707 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
1715 gfc_start_block (&block);
1716 cm = expr->ts.derived->components;
1717 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1719 /* Skip absent members in default initializers. */
1723 field = cm->backend_decl;
1724 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
1725 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
1726 gfc_add_expr_to_block (&block, tmp);
1728 return gfc_finish_block (&block);
1731 /* Build an expression for a constructor. If init is nonzero then
1732 this is part of a static variable initializer. */
1735 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
1745 gcc_assert (se->ss == NULL);
1746 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
1747 type = gfc_typenode_for_spec (&expr->ts);
1751 /* Create a temporary variable and fill it in. */
1752 se->expr = gfc_create_var (type, expr->ts.derived->name);
1753 tmp = gfc_trans_structure_assign (se->expr, expr);
1754 gfc_add_expr_to_block (&se->pre, tmp);
1758 head = build1 (CONSTRUCTOR, type, NULL_TREE);
1761 cm = expr->ts.derived->components;
1762 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
1764 /* Skip absent members in default initializers. */
1768 val = gfc_conv_initializer (c->expr, &cm->ts,
1769 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
1771 /* Build a TREE_CHAIN to hold it. */
1772 val = tree_cons (cm->backend_decl, val, NULL_TREE);
1774 /* Add it to the list. */
1775 if (tail == NULL_TREE)
1776 TREE_OPERAND(head, 0) = tail = val;
1779 TREE_CHAIN (tail) = val;
1787 /* Translate a substring expression. */
1790 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
1796 gcc_assert (ref->type == REF_SUBSTRING);
1798 se->expr = gfc_build_string_const(expr->value.character.length,
1799 expr->value.character.string);
1800 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
1801 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
1803 gfc_conv_substring(se,ref,expr->ts.kind);
1807 /* Entry point for expression translation. */
1810 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
1812 if (se->ss && se->ss->expr == expr
1813 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
1815 /* Substitute a scalar expression evaluated outside the scalarization
1817 se->expr = se->ss->data.scalar.expr;
1818 se->string_length = se->ss->string_length;
1819 gfc_advance_se_ss_chain (se);
1823 switch (expr->expr_type)
1826 gfc_conv_expr_op (se, expr);
1830 gfc_conv_function_expr (se, expr);
1834 gfc_conv_constant (se, expr);
1838 gfc_conv_variable (se, expr);
1842 se->expr = null_pointer_node;
1845 case EXPR_SUBSTRING:
1846 gfc_conv_substring_expr (se, expr);
1849 case EXPR_STRUCTURE:
1850 gfc_conv_structure (se, expr, 0);
1854 gfc_conv_array_constructor_expr (se, expr);
1864 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
1866 gfc_conv_expr (se, expr);
1867 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1868 figure out a way of rewriting an lvalue so that it has no post chain. */
1869 gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
1873 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
1877 gcc_assert (expr->ts.type != BT_CHARACTER);
1878 gfc_conv_expr (se, expr);
1881 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
1882 gfc_add_modify_expr (&se->pre, val, se->expr);
1887 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
1889 gfc_conv_expr_val (se, expr);
1890 se->expr = convert (type, se->expr);
1894 /* Converts an expression so that it can be passed by reference. Scalar
1898 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
1902 if (se->ss && se->ss->expr == expr
1903 && se->ss->type == GFC_SS_REFERENCE)
1905 se->expr = se->ss->data.scalar.expr;
1906 se->string_length = se->ss->string_length;
1907 gfc_advance_se_ss_chain (se);
1911 if (expr->ts.type == BT_CHARACTER)
1913 gfc_conv_expr (se, expr);
1914 gfc_conv_string_parameter (se);
1918 if (expr->expr_type == EXPR_VARIABLE)
1920 se->want_pointer = 1;
1921 gfc_conv_expr (se, expr);
1924 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1925 gfc_add_modify_expr (&se->pre, var, se->expr);
1926 gfc_add_block_to_block (&se->pre, &se->post);
1932 gfc_conv_expr (se, expr);
1934 /* Create a temporary var to hold the value. */
1935 if (TREE_CONSTANT (se->expr))
1937 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
1938 DECL_INITIAL (var) = se->expr;
1943 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1944 gfc_add_modify_expr (&se->pre, var, se->expr);
1946 gfc_add_block_to_block (&se->pre, &se->post);
1948 /* Take the address of that value. */
1949 se->expr = gfc_build_addr_expr (NULL, var);
1954 gfc_trans_pointer_assign (gfc_code * code)
1956 return gfc_trans_pointer_assignment (code->expr, code->expr2);
1960 /* Generate code for a pointer assignment. */
1963 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
1971 gfc_start_block (&block);
1973 gfc_init_se (&lse, NULL);
1975 lss = gfc_walk_expr (expr1);
1976 rss = gfc_walk_expr (expr2);
1977 if (lss == gfc_ss_terminator)
1979 /* Scalar pointers. */
1980 lse.want_pointer = 1;
1981 gfc_conv_expr (&lse, expr1);
1982 gcc_assert (rss == gfc_ss_terminator);
1983 gfc_init_se (&rse, NULL);
1984 rse.want_pointer = 1;
1985 gfc_conv_expr (&rse, expr2);
1986 gfc_add_block_to_block (&block, &lse.pre);
1987 gfc_add_block_to_block (&block, &rse.pre);
1988 gfc_add_modify_expr (&block, lse.expr,
1989 fold_convert (TREE_TYPE (lse.expr), rse.expr));
1990 gfc_add_block_to_block (&block, &rse.post);
1991 gfc_add_block_to_block (&block, &lse.post);
1995 /* Array pointer. */
1996 gfc_conv_expr_descriptor (&lse, expr1, lss);
1997 /* Implement Nullify. */
1998 if (expr2->expr_type == EXPR_NULL)
2000 lse.expr = gfc_conv_descriptor_data (lse.expr);
2001 rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
2002 gfc_add_modify_expr (&block, lse.expr, rse.expr);
2006 lse.direct_byref = 1;
2007 gfc_conv_expr_descriptor (&lse, expr2, rss);
2009 gfc_add_block_to_block (&block, &lse.pre);
2010 gfc_add_block_to_block (&block, &lse.post);
2012 return gfc_finish_block (&block);
2016 /* Makes sure se is suitable for passing as a function string parameter. */
2017 /* TODO: Need to check all callers fo this function. It may be abused. */
2020 gfc_conv_string_parameter (gfc_se * se)
2024 if (TREE_CODE (se->expr) == STRING_CST)
2026 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2030 type = TREE_TYPE (se->expr);
2031 if (TYPE_STRING_FLAG (type))
2033 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2034 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2037 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2038 gcc_assert (se->string_length
2039 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2043 /* Generate code for assignment of scalar variables. Includes character
2047 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2051 gfc_init_block (&block);
2053 if (type == BT_CHARACTER)
2055 gcc_assert (lse->string_length != NULL_TREE
2056 && rse->string_length != NULL_TREE);
2058 gfc_conv_string_parameter (lse);
2059 gfc_conv_string_parameter (rse);
2061 gfc_add_block_to_block (&block, &lse->pre);
2062 gfc_add_block_to_block (&block, &rse->pre);
2064 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2065 rse->string_length, rse->expr);
2069 gfc_add_block_to_block (&block, &lse->pre);
2070 gfc_add_block_to_block (&block, &rse->pre);
2072 gfc_add_modify_expr (&block, lse->expr,
2073 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2076 gfc_add_block_to_block (&block, &lse->post);
2077 gfc_add_block_to_block (&block, &rse->post);
2079 return gfc_finish_block (&block);
2083 /* Try to translate array(:) = func (...), where func is a transformational
2084 array function, without using a temporary. Returns NULL is this isn't the
2088 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2093 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2094 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2097 /* Elemental functions don't need a temporary anyway. */
2098 if (expr2->symtree->n.sym->attr.elemental)
2101 /* Check for a dependency. */
2102 if (gfc_check_fncall_dependency (expr1, expr2))
2105 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2107 gcc_assert (expr2->value.function.isym
2108 || (gfc_return_by_reference (expr2->value.function.esym)
2109 && expr2->value.function.esym->result->attr.dimension));
2111 ss = gfc_walk_expr (expr1);
2112 gcc_assert (ss != gfc_ss_terminator);
2113 gfc_init_se (&se, NULL);
2114 gfc_start_block (&se.pre);
2115 se.want_pointer = 1;
2117 gfc_conv_array_parameter (&se, expr1, ss, 0);
2119 se.direct_byref = 1;
2120 se.ss = gfc_walk_expr (expr2);
2121 gcc_assert (se.ss != gfc_ss_terminator);
2122 gfc_conv_function_expr (&se, expr2);
2123 gfc_add_block_to_block (&se.pre, &se.post);
2125 return gfc_finish_block (&se.pre);
2129 /* Translate an assignment. Most of the code is concerned with
2130 setting up the scalarizer. */
2133 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2138 gfc_ss *lss_section;
2145 /* Special case a single function returning an array. */
2146 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2148 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2153 /* Assignment of the form lhs = rhs. */
2154 gfc_start_block (&block);
2156 gfc_init_se (&lse, NULL);
2157 gfc_init_se (&rse, NULL);
2160 lss = gfc_walk_expr (expr1);
2162 if (lss != gfc_ss_terminator)
2164 /* The assignment needs scalarization. */
2167 /* Find a non-scalar SS from the lhs. */
2168 while (lss_section != gfc_ss_terminator
2169 && lss_section->type != GFC_SS_SECTION)
2170 lss_section = lss_section->next;
2172 gcc_assert (lss_section != gfc_ss_terminator);
2174 /* Initialize the scalarizer. */
2175 gfc_init_loopinfo (&loop);
2178 rss = gfc_walk_expr (expr2);
2179 if (rss == gfc_ss_terminator)
2181 /* The rhs is scalar. Add a ss for the expression. */
2182 rss = gfc_get_ss ();
2183 rss->next = gfc_ss_terminator;
2184 rss->type = GFC_SS_SCALAR;
2187 /* Associate the SS with the loop. */
2188 gfc_add_ss_to_loop (&loop, lss);
2189 gfc_add_ss_to_loop (&loop, rss);
2191 /* Calculate the bounds of the scalarization. */
2192 gfc_conv_ss_startstride (&loop);
2193 /* Resolve any data dependencies in the statement. */
2194 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2195 /* Setup the scalarizing loops. */
2196 gfc_conv_loop_setup (&loop);
2198 /* Setup the gfc_se structures. */
2199 gfc_copy_loopinfo_to_se (&lse, &loop);
2200 gfc_copy_loopinfo_to_se (&rse, &loop);
2203 gfc_mark_ss_chain_used (rss, 1);
2204 if (loop.temp_ss == NULL)
2207 gfc_mark_ss_chain_used (lss, 1);
2211 lse.ss = loop.temp_ss;
2212 gfc_mark_ss_chain_used (lss, 3);
2213 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2216 /* Start the scalarized loop body. */
2217 gfc_start_scalarized_body (&loop, &body);
2220 gfc_init_block (&body);
2222 /* Translate the expression. */
2223 gfc_conv_expr (&rse, expr2);
2225 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2227 gfc_conv_tmp_array_ref (&lse);
2228 gfc_advance_se_ss_chain (&lse);
2231 gfc_conv_expr (&lse, expr1);
2233 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2234 gfc_add_expr_to_block (&body, tmp);
2236 if (lss == gfc_ss_terminator)
2238 /* Use the scalar assignment as is. */
2239 gfc_add_block_to_block (&block, &body);
2243 gcc_assert (lse.ss == gfc_ss_terminator
2244 && rse.ss == gfc_ss_terminator);
2246 if (loop.temp_ss != NULL)
2248 gfc_trans_scalarized_loop_boundary (&loop, &body);
2250 /* We need to copy the temporary to the actual lhs. */
2251 gfc_init_se (&lse, NULL);
2252 gfc_init_se (&rse, NULL);
2253 gfc_copy_loopinfo_to_se (&lse, &loop);
2254 gfc_copy_loopinfo_to_se (&rse, &loop);
2256 rse.ss = loop.temp_ss;
2259 gfc_conv_tmp_array_ref (&rse);
2260 gfc_advance_se_ss_chain (&rse);
2261 gfc_conv_expr (&lse, expr1);
2263 gcc_assert (lse.ss == gfc_ss_terminator
2264 && rse.ss == gfc_ss_terminator);
2266 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2267 gfc_add_expr_to_block (&body, tmp);
2269 /* Generate the copying loops. */
2270 gfc_trans_scalarizing_loops (&loop, &body);
2272 /* Wrap the whole thing up. */
2273 gfc_add_block_to_block (&block, &loop.pre);
2274 gfc_add_block_to_block (&block, &loop.post);
2276 gfc_cleanup_loop (&loop);
2279 return gfc_finish_block (&block);
2283 gfc_trans_assign (gfc_code * code)
2285 return gfc_trans_assignment (code->expr, code->expr2);