/* Expression translation
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA. */
/* trans-expr.c-- generate GENERIC trees for gfc_expr. */
#include "coretypes.h"
#include "tree.h"
#include "convert.h"
-#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "tree-gimple.h"
#include "flags.h"
-#include <gmp.h>
-#include <assert.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-const.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
#include "trans-stmt.h"
+static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
/* Copy the scalarization loop variables. */
}
-/* Initialise a simple expression holder.
+/* Initialize a simple expression holder.
Care must be taken when multiple se are created with the same parent.
The child se must be kept in sync. The easiest way is to delay creation
/* Advances to the next SS in the chain. Use this rather than setting
- se->ss = se->ss->next because all the parent needs to be kept in sync.
+ se->ss = se->ss->next because all the parents needs to be kept in sync.
See gfc_init_se. */
void
{
gfc_se *p;
- assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
+ gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
p = se;
/* Walk down the parent chain. */
while (p != NULL)
{
- /* Simple consistancy check. */
- assert (p->parent == NULL || p->parent->ss == p->ss);
+ /* Simple consistency check. */
+ gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
p->ss = p->ss->next;
{
tree var;
- if (TREE_CODE_CLASS (TREE_CODE (se->expr)) == 'c')
+ if (CONSTANT_CLASS_P (se->expr))
return;
- /* we need a temporary for this result */
+ /* We need a temporary for this result. */
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify_expr (&se->pre, var, se->expr);
se->expr = var;
}
-/* Return an expression which determines if a dummy parameter is present. */
+/* Return an expression which determines if a dummy parameter is present.
+ Also used for arguments to procedures with multiple entry points. */
tree
gfc_conv_expr_present (gfc_symbol * sym)
{
tree decl;
- assert (sym->attr.dummy && sym->attr.optional);
+ gcc_assert (sym->attr.dummy);
decl = gfc_get_symbol_decl (sym);
if (TREE_CODE (decl) != PARM_DECL)
{
/* Array parameters use a temporary descriptor, we want the real
parameter. */
- assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
- return build (NE_EXPR, boolean_type_node, decl, null_pointer_node);
+ return build2 (NE_EXPR, boolean_type_node, decl,
+ fold_convert (TREE_TYPE (decl), null_pointer_node));
}
+/* Get the character length of an expression, looking through gfc_refs
+ if necessary. */
+
+tree
+gfc_get_expr_charlen (gfc_expr *e)
+{
+ gfc_ref *r;
+ tree length;
+
+ gcc_assert (e->expr_type == EXPR_VARIABLE
+ && e->ts.type == BT_CHARACTER);
+
+ length = NULL; /* To silence compiler warning. */
+
+ /* First candidate: if the variable is of type CHARACTER, the
+ expression's length could be the length of the character
+ variable. */
+ if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+ length = e->symtree->n.sym->ts.cl->backend_decl;
+
+ /* Look through the reference chain for component references. */
+ for (r = e->ref; r; r = r->next)
+ {
+ switch (r->type)
+ {
+ case REF_COMPONENT:
+ if (r->u.c.component->ts.type == BT_CHARACTER)
+ length = r->u.c.component->ts.cl->backend_decl;
+ break;
+
+ case REF_ARRAY:
+ /* Do nothing. */
+ break;
+
+ default:
+ /* We should never got substring references here. These will be
+ broken down by the scalarizer. */
+ gcc_unreachable ();
+ }
+ }
+
+ gcc_assert (length != NULL);
+ return length;
+}
+
+
+
/* Generate code to initialize a string length variable. Returns the
value. */
tree tmp;
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node);
+ gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
gfc_add_block_to_block (pblock, &se.pre);
tmp = cl->backend_decl;
gfc_add_modify_expr (pblock, tmp, se.expr);
}
+
static void
gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
{
var = NULL_TREE;
gfc_init_se (&start, se);
- gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node);
+ gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &start.pre);
if (integer_onep (start.expr))
- {
- gfc_conv_string_parameter (se);
- }
+ gfc_conv_string_parameter (se);
else
{
/* Change the start of the string. */
end.expr = se->string_length;
else
{
- gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node);
+ gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
tmp =
- build (MINUS_EXPR, gfc_strlen_type_node, integer_one_node, start.expr);
- tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
+ build2 (MINUS_EXPR, gfc_charlen_type_node,
+ fold_convert (gfc_charlen_type_node, integer_one_node),
+ start.expr);
+ tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
se->string_length = fold (tmp);
}
c = ref->u.c.component;
- assert (c->backend_decl);
+ gcc_assert (c->backend_decl);
field = c->backend_decl;
- assert (TREE_CODE (field) == FIELD_DECL);
+ gcc_assert (TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
- tmp = build (COMPONENT_REF, TREE_TYPE (field), decl, field);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
se->expr = tmp;
if (c->ts.type == BT_CHARACTER)
{
tmp = c->ts.cl->backend_decl;
- assert (tmp);
- if (!INTEGER_CST_P (tmp))
- gfc_todo_error ("Unknown length character component");
+ /* Components must always be constant length. */
+ gcc_assert (tmp && INTEGER_CST_P (tmp));
se->string_length = tmp;
}
if (se->ss != NULL)
{
/* Check that something hasn't gone horribly wrong. */
- assert (se->ss != gfc_ss_terminator);
- assert (se->ss->expr == expr);
+ gcc_assert (se->ss != gfc_ss_terminator);
+ gcc_assert (se->ss->expr == expr);
/* A scalarized term. We already know the descriptor. */
se->expr = se->ss->data.info.descriptor;
+ se->string_length = se->ss->string_length;
ref = se->ss->data.info.ref;
}
else
{
+ tree se_expr = NULL_TREE;
+
se->expr = gfc_get_symbol_decl (sym);
+ /* Special case for assigning the return value of a function.
+ Self recursive functions must have an explicit return value. */
+ if (se->expr == current_function_decl && sym->attr.function
+ && (sym->result == sym))
+ se_expr = gfc_get_fake_result_decl (sym);
+
+ /* Similarly for alternate entry points. */
+ else if (sym->attr.function && sym->attr.entry
+ && (sym->result == sym)
+ && sym->ns->proc_name->backend_decl == current_function_decl)
+ {
+ gfc_entry_list *el = NULL;
+
+ for (el = sym->ns->entries; el; el = el->next)
+ if (sym == el->sym)
+ {
+ se_expr = gfc_get_fake_result_decl (sym);
+ break;
+ }
+ }
+
+ else if (sym->attr.result
+ && sym->ns->proc_name->backend_decl == current_function_decl
+ && sym->ns->proc_name->attr.entry_master
+ && !gfc_return_by_reference (sym->ns->proc_name))
+ se_expr = gfc_get_fake_result_decl (sym);
+
+ if (se_expr)
+ se->expr = se_expr;
+
/* Procedure actual arguments. */
- if (sym->attr.flavor == FL_PROCEDURE
- && se->expr != current_function_decl)
+ else if (sym->attr.flavor == FL_PROCEDURE
+ && se->expr != current_function_decl)
{
- assert (se->want_pointer);
+ gcc_assert (se->want_pointer);
if (!sym->attr.dummy)
{
- assert (TREE_CODE (se->expr) == FUNCTION_DECL);
+ gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
se->expr = gfc_build_addr_expr (NULL, se->expr);
}
return;
}
- /* Special case for assigning the return value of a function.
- Self recursive functions must have an explicit return value. */
- if (se->expr == current_function_decl && sym->attr.function
- && (sym->result == sym))
- {
- se->expr = gfc_get_fake_result_decl (sym);
- }
-
/* Dereference scalar dummy variables. */
if (sym->attr.dummy
&& sym->ts.type != BT_CHARACTER
&& !sym->attr.dimension)
se->expr = gfc_build_indirect_ref (se->expr);
+ /* Dereference scalar hidden result. */
+ if (gfc_option.flag_f2c
+ && (sym->attr.function || sym->attr.result)
+ && sym->ts.type == BT_COMPLEX
+ && !sym->attr.dimension)
+ se->expr = gfc_build_indirect_ref (se->expr);
+
/* Dereference pointer variables. */
if ((sym->attr.pointer || sym->attr.allocatable)
&& (sym->attr.dummy
if (sym->ts.type == BT_CHARACTER)
{
se->string_length = sym->ts.cl->backend_decl;
- assert (se->string_length);
+ gcc_assert (se->string_length);
}
while (ref)
break;
default:
- abort ();
+ gcc_unreachable ();
break;
}
ref = ref->next;
}
/* Pointer assignment, allocation or pass by reference. Arrays are handled
- seperately. */
+ separately. */
if (se->want_pointer)
{
if (expr->ts.type == BT_CHARACTER)
gfc_se operand;
tree type;
- assert (expr->ts.type != BT_CHARACTER);
+ gcc_assert (expr->ts.type != BT_CHARACTER);
/* Initialize the operand. */
gfc_init_se (&operand, se);
- gfc_conv_expr_val (&operand, expr->op1);
+ gfc_conv_expr_val (&operand, expr->value.op.op1);
gfc_add_block_to_block (&se->pre, &operand.pre);
type = gfc_typenode_for_spec (&expr->ts);
/* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
- All other unary operators have an equivalent GIMPLE unary operator */
+ All other unary operators have an equivalent GIMPLE unary operator. */
if (code == TRUTH_NOT_EXPR)
- se->expr = build (EQ_EXPR, type, operand.expr, integer_zero_node);
+ se->expr = build2 (EQ_EXPR, type, operand.expr,
+ convert (type, integer_zero_node));
else
se->expr = build1 (code, type, operand.expr);
}
-
-/* For power op (lhs ** rhs) We generate:
- m = lhs
- if (rhs > 0)
- count = rhs
- else if (rhs == 0)
- {
- count = 0
- m = 1
- }
- else // (rhs < 0)
- {
- count = -rhs
- m = 1 / m;
- }
- // for constant rhs we do the above at compile time
- val = m;
- for (n = 1; n < count; n++)
- val = val * m;
- */
-
-static void
-gfc_conv_integer_power (gfc_se * se, tree lhs, tree rhs)
+/* Expand power operator to optimal multiplications when a value is raised
+ to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
+ Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
+ Programming", 3rd Edition, 1998. */
+
+/* This code is mostly duplicated from expand_powi in the backend.
+ We establish the "optimal power tree" lookup table with the defined size.
+ The items in the table are the exponents used to calculate the index
+ exponents. Any integer n less than the value can get an "addition chain",
+ with the first node being one. */
+#define POWI_TABLE_SIZE 256
+
+/* The table is from builtins.c. */
+static const unsigned char powi_table[POWI_TABLE_SIZE] =
+ {
+ 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
+ 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
+ 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
+ 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
+ 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
+ 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
+ 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
+ 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
+ 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
+ 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
+ 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
+ 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
+ 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
+ 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
+ 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
+ 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
+ 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
+ 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
+ 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
+ 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
+ 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
+ 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
+ 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
+ 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
+ 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
+ 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
+ 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
+ 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
+ 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
+ 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
+ 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
+ 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
+ };
+
+/* If n is larger than lookup table's max index, we use the "window
+ method". */
+#define POWI_WINDOW_SIZE 3
+
+/* Recursive function to expand the power operator. The temporary
+ values are put in tmpvar. The function returns tmpvar[1] ** n. */
+static tree
+gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
{
- tree count;
- tree result;
- tree cond;
- tree neg_stmt;
- tree pos_stmt;
+ tree op0;
+ tree op1;
tree tmp;
- tree var;
- tree type;
- stmtblock_t block;
- tree exit_label;
-
- type = TREE_TYPE (lhs);
+ int digit;
- if (INTEGER_CST_P (rhs))
+ if (n < POWI_TABLE_SIZE)
{
- if (integer_zerop (rhs))
- {
- se->expr = gfc_build_const (type, integer_one_node);
- return;
- }
- /* Special cases for constant values. */
- if (TREE_INT_CST_HIGH (rhs) == -1)
- {
- /* x ** (-y) == 1 / (x ** y). */
- if (TREE_CODE (type) == INTEGER_TYPE)
- {
- se->expr = integer_zero_node;
- return;
- }
-
- tmp = gfc_build_const (type, integer_one_node);
- lhs = fold (build (RDIV_EXPR, type, tmp, lhs));
-
- rhs = fold (build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs));
- assert (INTEGER_CST_P (rhs));
- }
- else
- {
- /* TODO: really big integer powers. */
- assert (TREE_INT_CST_HIGH (rhs) == 0);
- }
+ if (tmpvar[n])
+ return tmpvar[n];
- if (integer_onep (rhs))
- {
- se->expr = lhs;
- return;
- }
- if (TREE_INT_CST_LOW (rhs) == 2)
- {
- se->expr = build (MULT_EXPR, type, lhs, lhs);
- return;
- }
- if (TREE_INT_CST_LOW (rhs) == 3)
- {
- tmp = build (MULT_EXPR, type, lhs, lhs);
- se->expr = fold (build (MULT_EXPR, type, tmp, lhs));
- return;
- }
-
- /* Create the loop count variable. */
- count = gfc_create_var (TREE_TYPE (rhs), "count");
- gfc_add_modify_expr (&se->pre, count, rhs);
+ op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
+ op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
+ }
+ else if (n & 1)
+ {
+ digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
+ op0 = gfc_conv_powi (se, n - digit, tmpvar);
+ op1 = gfc_conv_powi (se, digit, tmpvar);
}
else
{
- /* Put the lhs into a temporary variable. */
- var = gfc_create_var (type, "val");
- count = gfc_create_var (TREE_TYPE (rhs), "count");
- gfc_add_modify_expr (&se->pre, var, lhs);
- lhs = var;
-
- /* Generate code for negative rhs. */
- gfc_start_block (&block);
+ op0 = gfc_conv_powi (se, n >> 1, tmpvar);
+ op1 = op0;
+ }
- if (TREE_CODE (TREE_TYPE (lhs)) == INTEGER_TYPE)
- {
- gfc_add_modify_expr (&block, lhs, integer_zero_node);
- gfc_add_modify_expr (&block, count, integer_zero_node);
- }
- else
- {
- tmp = gfc_build_const (type, integer_one_node);
- tmp = build (RDIV_EXPR, type, tmp, lhs);
- gfc_add_modify_expr (&block, var, tmp);
+ tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
- tmp = build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs);
- gfc_add_modify_expr (&block, count, tmp);
- }
- neg_stmt = gfc_finish_block (&block);
+ if (n < POWI_TABLE_SIZE)
+ tmpvar[n] = tmp;
- pos_stmt = build_v (MODIFY_EXPR, count, rhs);
+ return tmp;
+}
- /* Code for rhs == 0. */
- gfc_start_block (&block);
- gfc_add_modify_expr (&block, count, integer_zero_node);
- tmp = gfc_build_const (type, integer_one_node);
- gfc_add_modify_expr (&block, lhs, tmp);
+/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
+ return 1. Else return 0 and a call to runtime library functions
+ will have to be built. */
+static int
+gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
+{
+ tree cond;
+ tree tmp;
+ tree type;
+ tree vartmp[POWI_TABLE_SIZE];
+ int n;
+ int sgn;
- tmp = gfc_finish_block (&block);
+ type = TREE_TYPE (lhs);
+ n = abs (TREE_INT_CST_LOW (rhs));
+ sgn = tree_int_cst_sgn (rhs);
- /* Select the appropriate action. */
- cond = build (EQ_EXPR, boolean_type_node, rhs, integer_zero_node);
- tmp = build_v (COND_EXPR, cond, tmp, neg_stmt);
+ if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
+ && (n > 2 || n < -1))
+ return 0;
- cond = build (GT_EXPR, boolean_type_node, rhs, integer_zero_node);
- tmp = build_v (COND_EXPR, cond, pos_stmt, tmp);
- gfc_add_expr_to_block (&se->pre, tmp);
+ /* rhs == 0 */
+ if (sgn == 0)
+ {
+ se->expr = gfc_build_const (type, integer_one_node);
+ return 1;
+ }
+ /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
+ if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
+ {
+ tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
+ fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
+ cond = build2 (EQ_EXPR, boolean_type_node, lhs,
+ convert (TREE_TYPE (lhs), integer_one_node));
+
+ /* If rhs is even,
+ result = (lhs == 1 || lhs == -1) ? 1 : 0. */
+ if ((n & 1) == 0)
+ {
+ tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
+ se->expr = build3 (COND_EXPR, type, tmp,
+ convert (type, integer_one_node),
+ convert (type, integer_zero_node));
+ return 1;
+ }
+ /* If rhs is odd,
+ result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
+ tmp = build3 (COND_EXPR, type, tmp,
+ convert (type, integer_minus_one_node),
+ convert (type, integer_zero_node));
+ se->expr = build3 (COND_EXPR, type, cond,
+ convert (type, integer_one_node),
+ tmp);
+ return 1;
}
- /* Create a variable for the result. */
- result = gfc_create_var (type, "pow");
- gfc_add_modify_expr (&se->pre, result, lhs);
-
- exit_label = gfc_build_label_decl (NULL_TREE);
- TREE_USED (exit_label) = 1;
-
- /* Create the loop body. */
- gfc_start_block (&block);
-
- /* First the exit condition (until count <= 1). */
- tmp = build1_v (GOTO_EXPR, exit_label);
- cond = build (LE_EXPR, TREE_TYPE (count), count, integer_one_node);
- tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
-
- /* Multiply by the lhs. */
- tmp = build (MULT_EXPR, type, result, lhs);
- gfc_add_modify_expr (&block, result, tmp);
-
- /* Adjust the loop count. */
- tmp = build (MINUS_EXPR, TREE_TYPE (count), count, integer_one_node);
- gfc_add_modify_expr (&block, count, tmp);
-
- tmp = gfc_finish_block (&block);
-
- /* Create the the loop. */
- tmp = build_v (LOOP_EXPR, tmp);
- gfc_add_expr_to_block (&se->pre, tmp);
+ memset (vartmp, 0, sizeof (vartmp));
+ vartmp[1] = lhs;
+ if (sgn == -1)
+ {
+ tmp = gfc_build_const (type, integer_one_node);
+ vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
+ }
- /* Add the exit label. */
- tmp = build1_v (LABEL_EXPR, exit_label);
- gfc_add_expr_to_block (&se->pre, tmp);
+ se->expr = gfc_conv_powi (se, n, vartmp);
- se->expr = result;
+ return 1;
}
-/* Power op (**). Integer rhs has special handling. */
+/* Power op (**). Constant integer exponent has special handling. */
static void
gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
{
+ tree gfc_int4_type_node;
int kind;
+ int ikind;
gfc_se lse;
gfc_se rse;
tree fndecl;
tree tmp;
- tree type;
gfc_init_se (&lse, se);
- gfc_conv_expr_val (&lse, expr->op1);
+ gfc_conv_expr_val (&lse, expr->value.op.op1);
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_init_se (&rse, se);
- gfc_conv_expr_val (&rse, expr->op2);
+ gfc_conv_expr_val (&rse, expr->value.op.op2);
gfc_add_block_to_block (&se->pre, &rse.pre);
- type = TREE_TYPE (lse.expr);
+ if (expr->value.op.op2->ts.type == BT_INTEGER
+ && expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
+ return;
+
+ gfc_int4_type_node = gfc_get_int_type (4);
- kind = expr->op1->ts.kind;
- switch (expr->op2->ts.type)
+ kind = expr->value.op.op1->ts.kind;
+ switch (expr->value.op.op2->ts.type)
{
case BT_INTEGER:
- /* Integer powers are expanded inline as multiplications. */
- gfc_conv_integer_power (se, lse.expr, rse.expr);
- return;
+ ikind = expr->value.op.op2->ts.kind;
+ switch (ikind)
+ {
+ case 1:
+ case 2:
+ rse.expr = convert (gfc_int4_type_node, rse.expr);
+ /* Fall through. */
+
+ case 4:
+ ikind = 0;
+ break;
+
+ case 8:
+ ikind = 1;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ switch (kind)
+ {
+ case 1:
+ case 2:
+ if (expr->value.op.op1->ts.type == BT_INTEGER)
+ lse.expr = convert (gfc_int4_type_node, lse.expr);
+ else
+ gcc_unreachable ();
+ /* Fall through. */
+
+ case 4:
+ kind = 0;
+ break;
+
+ case 8:
+ kind = 1;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ switch (expr->value.op.op1->ts.type)
+ {
+ case BT_INTEGER:
+ fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
+ break;
+
+ case BT_REAL:
+ fndecl = gfor_fndecl_math_powi[kind][ikind].real;
+ break;
+
+ case BT_COMPLEX:
+ fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ break;
case BT_REAL:
switch (kind)
{
case 4:
- fndecl = gfor_fndecl_math_powf;
+ fndecl = built_in_decls[BUILT_IN_POWF];
break;
case 8:
- fndecl = gfor_fndecl_math_pow;
+ fndecl = built_in_decls[BUILT_IN_POW];
break;
default:
- abort ();
+ gcc_unreachable ();
}
break;
fndecl = gfor_fndecl_math_cpow;
break;
default:
- abort ();
+ gcc_unreachable ();
}
break;
default:
- abort ();
+ gcc_unreachable ();
break;
}
tmp = gfc_chainon_list (NULL_TREE, lse.expr);
tmp = gfc_chainon_list (tmp, rse.expr);
- se->expr = gfc_build_function_call (fndecl, tmp);
+ se->expr = fold (gfc_build_function_call (fndecl, tmp));
}
tree tmp;
tree args;
+ gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
+
if (gfc_can_put_var_on_stack (len))
{
/* Create a temporary variable to hold the result. */
- tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node));
- tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
+ convert (gfc_charlen_type_node, integer_one_node));
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
tmp = build_array_type (gfc_character1_type_node, tmp);
var = gfc_create_var (tmp, "str");
var = gfc_build_addr_expr (type, var);
tree args;
tree tmp;
- assert (expr->op1->ts.type == BT_CHARACTER
- && expr->op2->ts.type == BT_CHARACTER);
+ gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
+ && expr->value.op.op2->ts.type == BT_CHARACTER);
gfc_init_se (&lse, se);
- gfc_conv_expr (&lse, expr->op1);
+ gfc_conv_expr (&lse, expr->value.op.op1);
gfc_conv_string_parameter (&lse);
gfc_init_se (&rse, se);
- gfc_conv_expr (&rse, expr->op2);
+ gfc_conv_expr (&rse, expr->value.op.op2);
gfc_conv_string_parameter (&rse);
gfc_add_block_to_block (&se->pre, &lse.pre);
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len == NULL_TREE)
{
- len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
- lse.string_length, rse.string_length));
+ len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
+ lse.string_length, rse.string_length);
}
type = build_pointer_type (type);
/* Translates an op expression. Common (binary) cases are handled by this
function, others are passed on. Recursion is used in either case.
We use the fact that (op1.ts == op2.ts) (except for the power
- operand **).
+ operator **).
Operators need no special handling for scalarized expressions as long as
- they call gfc_conv_siple_val to get their operands.
+ they call gfc_conv_simple_val to get their operands.
Character strings get special handling. */
static void
checkstring = 0;
lop = 0;
- switch (expr->operator)
+ switch (expr->value.op.operator)
{
case INTRINSIC_UPLUS:
- gfc_conv_expr (se, expr->op1);
+ gfc_conv_expr (se, expr->value.op.op1);
return;
case INTRINSIC_UMINUS:
case INTRINSIC_USER:
case INTRINSIC_ASSIGN:
/* These should be converted into function calls by the frontend. */
- abort ();
- return;
+ gcc_unreachable ();
default:
fatal_error ("Unknown intrinsic op");
return;
}
- /* The only exception to this is **, which is handled seperately anyway. */
- assert (expr->op1->ts.type == expr->op2->ts.type);
+ /* The only exception to this is **, which is handled separately anyway. */
+ gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
- if (checkstring && expr->op1->ts.type != BT_CHARACTER)
+ if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
checkstring = 0;
/* lhs */
gfc_init_se (&lse, se);
- gfc_conv_expr (&lse, expr->op1);
+ gfc_conv_expr (&lse, expr->value.op.op1);
gfc_add_block_to_block (&se->pre, &lse.pre);
/* rhs */
gfc_init_se (&rse, se);
- gfc_conv_expr (&rse, expr->op2);
+ gfc_conv_expr (&rse, expr->value.op.op2);
gfc_add_block_to_block (&se->pre, &rse.pre);
/* For string comparisons we generate a library call, and compare the return
if (lop)
{
/* The result of logical ops is always boolean_type_node. */
- tmp = fold (build (code, type, lse.expr, rse.expr));
+ tmp = fold_build2 (code, type, lse.expr, rse.expr);
se->expr = convert (type, tmp);
}
else
- se->expr = fold (build (code, type, lse.expr, rse.expr));
-
+ se->expr = fold_build2 (code, type, lse.expr, rse.expr);
/* Add the post blocks. */
gfc_add_block_to_block (&se->post, &rse.post);
gfc_add_block_to_block (&se->post, &lse.post);
}
+
static void
gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
{
if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
- assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
se->expr = tmp;
sym->backend_decl = gfc_get_extern_function_decl (sym);
tmp = sym->backend_decl;
- assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
se->expr = gfc_build_addr_expr (NULL, tmp);
}
}
{
if (!sym->attr.elemental)
{
- assert (se->ss->type == GFC_SS_FUNCTION);
+ gcc_assert (se->ss->type == GFC_SS_FUNCTION);
if (se->ss->useflags)
{
- assert (gfc_return_by_reference (sym)
+ gcc_assert (gfc_return_by_reference (sym)
&& sym->result->attr.dimension);
- assert (se->loop != NULL);
+ gcc_assert (se->loop != NULL);
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
arglist = gfc_chainon_list (arglist, se->expr);
else if (sym->result->attr.dimension)
{
- assert (se->loop && se->ss);
+ gcc_assert (se->loop && se->ss);
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&sym->ts);
info->dimen = se->loop->dimen;
/* Allocate a temporary to store the result. */
- gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE);
+ gfc_trans_allocate_temp_array (se->loop, info, tmp);
/* Zero the first stride to indicate a temporary. */
tmp =
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
- gfc_add_modify_expr (&se->pre, tmp, integer_zero_node);
+ gfc_add_modify_expr (&se->pre, tmp,
+ convert (TREE_TYPE (tmp), integer_zero_node));
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
tmp = gfc_build_addr_expr (NULL, tmp);
}
else if (sym->ts.type == BT_CHARACTER)
{
- assert (sym->ts.cl && sym->ts.cl->length
+ gcc_assert (sym->ts.cl && sym->ts.cl->length
&& sym->ts.cl->length->expr_type == EXPR_CONSTANT);
len = gfc_conv_mpz_to_tree
(sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
var = gfc_conv_string_tmp (se, type, len);
arglist = gfc_chainon_list (arglist, var);
- arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node,
- len));
+ arglist = gfc_chainon_list (arglist,
+ convert (gfc_charlen_type_node, len));
+ }
+ else
+ {
+ gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
+
+ type = gfc_get_complex_type (sym->ts.kind);
+ var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
+ arglist = gfc_chainon_list (arglist, var);
}
- else /* TODO: derived type function return values. */
- abort ();
}
formal = sym->formal;
/* Pass a NULL pointer for an absent arg. */
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
- if (formal && formal->sym->ts.type == BT_CHARACTER)
+ if (arg->missing_arg_type == BT_CHARACTER)
{
- stringargs = gfc_chainon_list (stringargs,
- convert (gfc_strlen_type_node, integer_zero_node));
+ stringargs =
+ gfc_chainon_list (stringargs,
+ convert (gfc_charlen_type_node,
+ integer_zero_node));
}
}
}
if (argss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&parmse, arg->expr);
- if (formal && formal->sym->attr.pointer)
+ if (formal && formal->sym->attr.pointer
+ && arg->expr->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
- indirection. */
+ indirection. The null pointer already contains
+ this level of indirection. */
parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
}
}
else
{
- /* If the procedure requires explicit interface, actual argument
- is passed according to corresponing formal argument. We
- do not use g77 method and the address of array descriptor
- is passed if corresponing formal is pointer or
- assumed-shape, Otherwise use g77 method. */
+ /* If the procedure requires an explicit interface, the
+ actual argument is passed according to the
+ corresponding formal argument. If the corresponding
+ formal argument is a POINTER or assumed shape, we do
+ not use g77's calling convention, and pass the
+ address of the array descriptor instead. Otherwise we
+ use g77's calling convention. */
int f;
f = (formal != NULL)
&& !formal->sym->attr.pointer
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
- /* Character strings are passed as two paramarers, a length and a
+ /* Character strings are passed as two parameters, a length and a
pointer. */
if (parmse.string_length != NULL_TREE)
stringargs = gfc_chainon_list (stringargs, parmse.string_length);
TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
fntype = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
- arglist, NULL_TREE);
+ se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
+ arglist, NULL_TREE);
+
+ if (sym->result)
+ sym = sym->result;
-/* A pure function may still have side-effects - it may modify its
- parameters. */
+ /* If we have a pointer function, but we don't want a pointer, e.g.
+ something like
+ x = f()
+ where f is pointer valued, we have to dereference the result. */
+ if (!se->want_pointer && !byref && sym->attr.pointer)
+ se->expr = gfc_build_indirect_ref (se->expr);
+
+ /* f2c calling conventions require a scalar default real function to
+ return a double precision result. Convert this back to default
+ real. We only care about the cases that can happen in Fortran 77.
+ */
+ if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
+ && sym->ts.kind == gfc_default_real_kind
+ && !sym->attr.always_explicit)
+ se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
+
+ /* A pure function may still have side-effects - it may modify its
+ parameters. */
TREE_SIDE_EFFECTS (se->expr) = 1;
#if 0
if (!sym->attr.pure)
TREE_SIDE_EFFECTS (se->expr) = 1;
#endif
- if (byref && !se->direct_byref)
+ if (byref)
{
+ /* Add the function call to the pre chain. There is no expression. */
gfc_add_expr_to_block (&se->pre, se->expr);
+ se->expr = NULL_TREE;
- if (sym->result->attr.dimension)
+ if (!se->direct_byref)
{
- if (flag_bounds_check)
+ if (sym->result->attr.dimension)
{
- /* Check the data pointer hasn't been modified. This would happen
- in a function returning a pointer. */
- tmp = gfc_conv_descriptor_data (info->descriptor);
- tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
- gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ if (flag_bounds_check)
+ {
+ /* Check the data pointer hasn't been modified. This would
+ happen in a function returning a pointer. */
+ tmp = gfc_conv_descriptor_data (info->descriptor);
+ tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
+ gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ }
+ se->expr = info->descriptor;
+ }
+ else if (sym->ts.type == BT_CHARACTER)
+ {
+ se->expr = var;
+ se->string_length = len;
+ }
+ else
+ {
+ gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+ se->expr = gfc_build_indirect_ref (var);
}
- se->expr = info->descriptor;
- }
- else if (sym->ts.type == BT_CHARACTER)
- {
- se->expr = var;
- se->string_length = len;
}
- else
- abort ();
}
}
+/* Generate code to copy a string. */
+
+static void
+gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
+ tree slen, tree src)
+{
+ tree tmp;
+
+ tmp = NULL_TREE;
+ tmp = gfc_chainon_list (tmp, dlen);
+ tmp = gfc_chainon_list (tmp, dest);
+ tmp = gfc_chainon_list (tmp, slen);
+ tmp = gfc_chainon_list (tmp, src);
+ tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
+ gfc_add_expr_to_block (block, tmp);
+}
+
+
/* Translate a statement function.
The value of a statement function reference is obtained by evaluating the
expression using the values of the actual arguments for the values of the
gfc_actual_arglist *args;
gfc_se lse;
gfc_se rse;
+ gfc_saved_var *saved_vars;
+ tree *temp_vars;
+ tree type;
+ tree tmp;
+ int n;
sym = expr->symtree->n.sym;
args = expr->value.function.actual;
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
+ n = 0;
for (fargs = sym->formal; fargs; fargs = fargs->next)
+ n++;
+ saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
+ temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
+
+ for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
{
/* Each dummy shall be specified, explicitly or implicitly, to be
scalar. */
- assert (fargs->sym->attr.dimension == 0);
+ gcc_assert (fargs->sym->attr.dimension == 0);
fsym = fargs->sym;
- assert (fsym->backend_decl);
- /* Convert non-pointer string dummy. */
- if (fsym->ts.type == BT_CHARACTER && !fsym->attr.pointer)
+ /* Create a temporary to hold the value. */
+ type = gfc_typenode_for_spec (&fsym->ts);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
+
+ if (fsym->ts.type == BT_CHARACTER)
{
- tree len1;
- tree len2;
- tree arg;
- tree tmp;
- tree type;
- tree var;
-
- assert (fsym->ts.cl && fsym->ts.cl->length
+ /* Copy string arguments. */
+ tree arglen;
+
+ gcc_assert (fsym->ts.cl && fsym->ts.cl->length
&& fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
- type = gfc_get_character_type (fsym->ts.kind, fsym->ts.cl);
- len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- var = gfc_build_addr_expr (build_pointer_type (type),
- fsym->backend_decl);
+ arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+ tmp = gfc_build_addr_expr (build_pointer_type (type),
+ temp_vars[n]);
gfc_conv_expr (&rse, args->expr);
gfc_conv_string_parameter (&rse);
- len2 = rse.string_length;
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- arg = NULL_TREE;
- arg = gfc_chainon_list (arg, len1);
- arg = gfc_chainon_list (arg, var);
- arg = gfc_chainon_list (arg, len2);
- arg = gfc_chainon_list (arg, rse.expr);
- tmp = gfc_build_function_call (gfor_fndecl_copy_string, arg);
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
+ rse.expr);
gfc_add_block_to_block (&se->pre, &lse.post);
gfc_add_block_to_block (&se->pre, &rse.post);
}
else
{
/* For everything else, just evaluate the expression. */
- if (fsym->attr.pointer == 1)
- lse.want_pointer = 1;
-
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_modify_expr (&se->pre, fsym->backend_decl, lse.expr);
+ gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
gfc_add_block_to_block (&se->pre, &lse.post);
}
+
args = args->next;
}
+
+ /* Use the temporary variables in place of the real ones. */
+ for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+ gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
+
gfc_conv_expr (se, sym->value);
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_conv_const_charlen (sym->ts.cl);
+
+ /* Force the expression to the correct length. */
+ if (!INTEGER_CST_P (se->string_length)
+ || tree_int_cst_lt (se->string_length,
+ sym->ts.cl->backend_decl))
+ {
+ type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
+ tmp = gfc_create_var (type, sym->name);
+ tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
+ gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
+ se->string_length, se->expr);
+ se->expr = tmp;
+ }
+ se->string_length = sym->ts.cl->backend_decl;
+ }
+
+ /* Restore the original variables. */
+ for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+ gfc_restore_sym (fargs->sym, &saved_vars[n]);
+ gfc_free (saved_vars);
}
return;
}
- /* We distinguish the statement function from general function to improve
+ /* We distinguish statement functions from general functions to improve
runtime performance. */
if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
{
gfc_conv_function_call (se, sym, expr->value.function.actual);
}
+
static void
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
{
- assert (se->ss != NULL && se->ss != gfc_ss_terminator);
- assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
+ gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
+ gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
gfc_conv_tmp_array_ref (se);
gfc_advance_se_ss_chain (se);
}
+/* Build a static initializer. EXPR is the expression for the initial value.
+ The other parameters describe the variable of the component being
+ initialized. EXPR may be null. */
+
+tree
+gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
+ bool array, bool pointer)
+{
+ gfc_se se;
+
+ if (!(expr || pointer))
+ return NULL_TREE;
+
+ if (array)
+ {
+ /* Arrays need special handling. */
+ if (pointer)
+ return gfc_build_null_descriptor (type);
+ else
+ return gfc_conv_array_initializer (type, expr);
+ }
+ else if (pointer)
+ return fold_convert (type, null_pointer_node);
+ else
+ {
+ switch (ts->type)
+ {
+ case BT_DERIVED:
+ gfc_init_se (&se, NULL);
+ gfc_conv_structure (&se, expr, 1);
+ return se.expr;
+
+ case BT_CHARACTER:
+ return gfc_conv_string_init (ts->cl->backend_decl,expr);
+
+ default:
+ gfc_init_se (&se, NULL);
+ gfc_conv_constant (&se, expr);
+ return se.expr;
+ }
+ }
+}
+
+static tree
+gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+{
+ gfc_se rse;
+ gfc_se lse;
+ gfc_ss *rss;
+ gfc_ss *lss;
+ stmtblock_t body;
+ stmtblock_t block;
+ gfc_loopinfo loop;
+ int n;
+ tree tmp;
+
+ gfc_start_block (&block);
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the rhs. */
+ rss = gfc_walk_expr (expr);
+ if (rss == gfc_ss_terminator)
+ {
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_ss ();
+ rss->next = gfc_ss_terminator;
+ rss->type = GFC_SS_SCALAR;
+ rss->expr = expr;
+ }
+
+ /* Create a SS for the destination. */
+ lss = gfc_get_ss ();
+ lss->type = GFC_SS_COMPONENT;
+ lss->expr = NULL;
+ lss->shape = gfc_get_shape (cm->as->rank);
+ lss->next = gfc_ss_terminator;
+ lss->data.info.dimen = cm->as->rank;
+ lss->data.info.descriptor = dest;
+ lss->data.info.data = gfc_conv_array_data (dest);
+ lss->data.info.offset = gfc_conv_array_offset (dest);
+ for (n = 0; n < cm->as->rank; n++)
+ {
+ lss->data.info.dim[n] = n;
+ lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
+ lss->data.info.stride[n] = gfc_index_one_node;
+
+ mpz_init (lss->shape[n]);
+ mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
+ cm->as->lower[n]->value.integer);
+ mpz_add_ui (lss->shape[n], lss->shape[n], 1);
+ }
+
+ /* Associate the SS with the loop. */
+ gfc_add_ss_to_loop (&loop, lss);
+ gfc_add_ss_to_loop (&loop, rss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop);
+
+ /* Setup the gfc_se structures. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
+ gfc_copy_loopinfo_to_se (&rse, &loop);
+
+ rse.ss = rss;
+ gfc_mark_ss_chain_used (rss, 1);
+ lse.ss = lss;
+ gfc_mark_ss_chain_used (lss, 1);
+
+ /* Start the scalarized loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ gfc_conv_tmp_array_ref (&lse);
+ gfc_conv_expr (&rse, expr);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
+ gfc_add_expr_to_block (&body, tmp);
+
+ gcc_assert (rse.ss == gfc_ss_terminator);
+
+ /* Generate the copying loops. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ /* Wrap the whole thing up. */
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+
+ for (n = 0; n < cm->as->rank; n++)
+ mpz_clear (lss->shape[n]);
+ gfc_free (lss->shape);
+
+ gfc_cleanup_loop (&loop);
+
+ return gfc_finish_block (&block);
+}
+
+/* Assign a single component of a derived type constructor. */
+
+static tree
+gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+{
+ gfc_se se;
+ gfc_ss *rss;
+ stmtblock_t block;
+ tree tmp;
+
+ gfc_start_block (&block);
+ if (cm->pointer)
+ {
+ gfc_init_se (&se, NULL);
+ /* Pointer component. */
+ if (cm->dimension)
+ {
+ /* Array pointer. */
+ if (expr->expr_type == EXPR_NULL)
+ {
+ dest = gfc_conv_descriptor_data (dest);
+ tmp = fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node);
+ gfc_add_modify_expr (&block, dest, tmp);
+ }
+ else
+ {
+ rss = gfc_walk_expr (expr);
+ se.direct_byref = 1;
+ se.expr = dest;
+ gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&block, &se.post);
+ }
+ }
+ else
+ {
+ /* Scalar pointers. */
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify_expr (&block, dest,
+ fold_convert (TREE_TYPE (dest), se.expr));
+ gfc_add_block_to_block (&block, &se.post);
+ }
+ }
+ else if (cm->dimension)
+ {
+ tmp = gfc_trans_subarray_assign (dest, cm, expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else if (expr->ts.type == BT_DERIVED)
+ {
+ /* Nested derived type. */
+ tmp = gfc_trans_structure_assign (dest, expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ /* Scalar component. */
+ gfc_se lse;
+
+ gfc_init_se (&se, NULL);
+ gfc_init_se (&lse, NULL);
+
+ gfc_conv_expr (&se, expr);
+ if (cm->ts.type == BT_CHARACTER)
+ lse.string_length = cm->ts.cl->backend_decl;
+ lse.expr = dest;
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ return gfc_finish_block (&block);
+}
+
+/* Assign a derived type constructor to a variable. */
+
+static tree
+gfc_trans_structure_assign (tree dest, gfc_expr * expr)
+{
+ gfc_constructor *c;
+ gfc_component *cm;
+ stmtblock_t block;
+ tree field;
+ tree tmp;
+
+ gfc_start_block (&block);
+ cm = expr->ts.derived->components;
+ for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ {
+ /* Skip absent members in default initializers. */
+ if (!c->expr)
+ continue;
+
+ field = cm->backend_decl;
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
+ tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ return gfc_finish_block (&block);
+}
/* Build an expression for a constructor. If init is nonzero then
this is part of a static variable initializer. */
tree head;
tree tail;
tree val;
- gfc_se cse;
tree type;
- tree arraytype;
+ tree tmp;
- assert (expr->expr_type == EXPR_STRUCTURE);
+ gcc_assert (se->ss == NULL);
+ gcc_assert (expr->expr_type == EXPR_STRUCTURE);
type = gfc_typenode_for_spec (&expr->ts);
+
+ if (!init)
+ {
+ /* Create a temporary variable and fill it in. */
+ se->expr = gfc_create_var (type, expr->ts.derived->name);
+ tmp = gfc_trans_structure_assign (se->expr, expr);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ return;
+ }
+
head = build1 (CONSTRUCTOR, type, NULL_TREE);
tail = NULL_TREE;
if (!c->expr)
continue;
- gfc_init_se (&cse, se);
- /* Evaluate the expression for this component. */
- if (init)
- {
- if (cm->dimension)
- {
- arraytype = TREE_TYPE (cm->backend_decl);
- cse.expr = gfc_conv_array_initializer (arraytype, c->expr);
- }
- else if (cm->ts.type == BT_DERIVED)
- gfc_conv_structure (&cse, c->expr, 1);
- else
- gfc_conv_expr (&cse, c->expr);
- }
- else
- {
- gfc_conv_expr (&cse, c->expr);
- gfc_add_block_to_block (&se->pre, &cse.pre);
- gfc_add_block_to_block (&se->post, &cse.post);
- }
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
/* Build a TREE_CHAIN to hold it. */
- val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
+ val = tree_cons (cm->backend_decl, val, NULL_TREE);
/* Add it to the list. */
if (tail == NULL_TREE)
}
-/*translate a substring expression */
+/* Translate a substring expression. */
static void
gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
ref = expr->ref;
- assert(ref->type == REF_SUBSTRING);
+ gcc_assert (ref->type == REF_SUBSTRING);
se->expr = gfc_build_string_const(expr->value.character.length,
expr->value.character.string);
if (se->ss && se->ss->expr == expr
&& (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
{
- /* Substiture a scalar expression evaluated outside the scalarization
+ /* Substitute a scalar expression evaluated outside the scalarization
loop. */
se->expr = se->ss->data.scalar.expr;
- se->string_length = se->ss->data.scalar.string_length;
+ se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
}
break;
default:
- abort ();
+ gcc_unreachable ();
break;
}
}
gfc_conv_expr (se, expr);
/* AFAICS all numeric lvalues have empty post chains. If not we need to
figure out a way of rewriting an lvalue so that it has no post chain. */
- assert (expr->ts.type != BT_CHARACTER || !se->post.head);
+ gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head);
}
void
{
tree val;
- assert (expr->ts.type != BT_CHARACTER);
+ gcc_assert (expr->ts.type != BT_CHARACTER);
gfc_conv_expr (se, expr);
if (se->post.head)
{
}
-/* Converts an expression so that it can be passed by refernece. Scalar
+/* Converts an expression so that it can be passed by reference. Scalar
values only. */
void
&& se->ss->type == GFC_SS_REFERENCE)
{
se->expr = se->ss->data.scalar.expr;
- se->string_length = se->ss->data.scalar.string_length;
+ se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
}
gfc_conv_expr (se, expr);
/* Create a temporary var to hold the value. */
- var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ if (TREE_CONSTANT (se->expr))
+ {
+ var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
+ DECL_INITIAL (var) = se->expr;
+ pushdecl (var);
+ }
+ else
+ {
+ var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify_expr (&se->pre, var, se->expr);
+ }
gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
}
+/* Generate code for a pointer assignment. */
+
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_ss *lss;
gfc_ss *rss;
stmtblock_t block;
- tree tmp;
gfc_start_block (&block);
rss = gfc_walk_expr (expr2);
if (lss == gfc_ss_terminator)
{
+ /* Scalar pointers. */
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
- assert (rss == gfc_ss_terminator);
+ gcc_assert (rss == gfc_ss_terminator);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
- gfc_add_modify_expr (&block, lse.expr, rse.expr);
+ gfc_add_modify_expr (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), rse.expr));
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
else
{
+ /* Array pointer. */
gfc_conv_expr_descriptor (&lse, expr1, lss);
/* Implement Nullify. */
if (expr2->expr_type == EXPR_NULL)
{
lse.expr = gfc_conv_descriptor_data (lse.expr);
- rse.expr = null_pointer_node;
- tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr);
- gfc_add_expr_to_block (&block, tmp);
+ rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
+ gfc_add_modify_expr (&block, lse.expr, rse.expr);
}
else
{
type = TREE_TYPE (se->expr);
if (TYPE_STRING_FLAG (type))
{
- assert (TREE_CODE (se->expr) != INDIRECT_REF);
+ gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
}
- assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
- assert (se->string_length
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
+ gcc_assert (se->string_length
&& TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
}
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
{
- tree tmp;
- tree args;
stmtblock_t block;
gfc_init_block (&block);
-
if (type == BT_CHARACTER)
{
- args = NULL_TREE;
-
- assert (lse->string_length != NULL_TREE
+ gcc_assert (lse->string_length != NULL_TREE
&& rse->string_length != NULL_TREE);
gfc_conv_string_parameter (lse);
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- args = gfc_chainon_list (args, lse->string_length);
- args = gfc_chainon_list (args, lse->expr);
- args = gfc_chainon_list (args, rse->string_length);
- args = gfc_chainon_list (args, rse->expr);
-
- tmp = gfc_build_function_call (gfor_fndecl_copy_string, args);
- gfc_add_expr_to_block (&block, tmp);
+ gfc_trans_string_copy (&block, lse->string_length, lse->expr,
+ rse->string_length, rse->expr);
}
else
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- gfc_add_modify_expr (&block, lse->expr, rse->expr);
+ gfc_add_modify_expr (&block, lse->expr,
+ fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
gfc_add_block_to_block (&block, &lse->post);
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
- assert (expr2->value.function.isym
- || (gfc_return_by_reference (expr2->symtree->n.sym)
- && expr2->symtree->n.sym->result->attr.dimension));
+ gcc_assert (expr2->value.function.isym
+ || (gfc_return_by_reference (expr2->value.function.esym)
+ && expr2->value.function.esym->result->attr.dimension));
ss = gfc_walk_expr (expr1);
- assert (ss != gfc_ss_terminator);
+ gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
se.want_pointer = 1;
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
- assert (se.ss != gfc_ss_terminator);
+ gcc_assert (se.ss != gfc_ss_terminator);
gfc_conv_function_expr (&se, expr2);
- gfc_add_expr_to_block (&se.pre, se.expr);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
&& lss_section->type != GFC_SS_SECTION)
lss_section = lss_section->next;
- assert (lss_section != gfc_ss_terminator);
+ gcc_assert (lss_section != gfc_ss_terminator);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
}
else
{
- if (lse.ss != gfc_ss_terminator)
- abort ();
- if (rse.ss != gfc_ss_terminator)
- abort ();
+ gcc_assert (lse.ss == gfc_ss_terminator
+ && rse.ss == gfc_ss_terminator);
if (loop.temp_ss != NULL)
{
gfc_advance_se_ss_chain (&rse);
gfc_conv_expr (&lse, expr1);
- if (lse.ss != gfc_ss_terminator)
- abort ();
-
- if (rse.ss != gfc_ss_terminator)
- abort ();
+ gcc_assert (lse.ss == gfc_ss_terminator
+ && rse.ss == gfc_ss_terminator);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
gfc_add_expr_to_block (&body, tmp);
OSDN Git Service
