/* Expression translation
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
You should have received a copy of the GNU General Public License
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. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, 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"
#include "trans-array.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
#include "trans-stmt.h"
+#include "dependency.h"
+static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
+static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+ gfc_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. */
if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
- tmp = gfc_build_indirect_ref (se->expr);
+ tmp = build_fold_indirect_ref (se->expr);
tmp = gfc_build_array_ref (tmp, start.expr);
se->expr = gfc_build_addr_expr (type, tmp);
}
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);
- se->string_length = fold (tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
+ build_int_cst (gfc_charlen_type_node, 1),
+ start.expr);
+ tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
+ se->string_length = 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 (c->pointer && c->dimension == 0)
- se->expr = gfc_build_indirect_ref (se->expr);
+ if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
+ se->expr = build_fold_indirect_ref (se->expr);
}
{
gfc_ref *ref;
gfc_symbol *sym;
+ tree parent_decl;
+ int parent_flag;
+ bool return_value;
+ bool alternate_entry;
+ bool entry_master;
sym = expr->symtree->n.sym;
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;
- ref = se->ss->data.info.ref;
+ se->string_length = se->ss->string_length;
+ for (ref = se->ss->data.info.ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+ break;
}
else
{
+ tree se_expr = NULL_TREE;
+
se->expr = gfc_get_symbol_decl (sym);
+ /* Deal with references to a parent results or entries by storing
+ the current_function_decl and moving to the parent_decl. */
+ parent_flag = 0;
+
+ return_value = sym->attr.function && sym->result == sym;
+ alternate_entry = sym->attr.function && sym->attr.entry
+ && sym->result == sym;
+ entry_master = sym->attr.result
+ && sym->ns->proc_name->attr.entry_master
+ && !gfc_return_by_reference (sym->ns->proc_name);
+ parent_decl = DECL_CONTEXT (current_function_decl);
+
+ if ((se->expr == parent_decl && return_value)
+ || (sym->ns && sym->ns->proc_name
+ && sym->ns->proc_name->backend_decl == parent_decl
+ && (alternate_entry || entry_master)))
+ parent_flag = 1;
+ else
+ parent_flag = 0;
+
+ /* Special case for assigning the return value of a function.
+ Self recursive functions must have an explicit return value. */
+ if (sym->attr.function && sym->result == sym
+ && (se->expr == current_function_decl || parent_flag))
+ se_expr = gfc_get_fake_result_decl (sym, parent_flag);
+
+ /* Similarly for alternate entry points. */
+ else if (alternate_entry
+ && (sym->ns->proc_name->backend_decl == current_function_decl
+ || parent_flag))
+ {
+ 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, parent_flag);
+ break;
+ }
+ }
+
+ else if (entry_master
+ && (sym->ns->proc_name->backend_decl == current_function_decl
+ || parent_flag))
+ se_expr = gfc_get_fake_result_decl (sym, parent_flag);
+
+ 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);
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
+ se->expr = build_fold_addr_expr (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))
+
+ /* Dereference the expression, where needed. Since characters
+ are entirely different from other types, they are treated
+ separately. */
+ if (sym->ts.type == BT_CHARACTER)
{
- se->expr = gfc_get_fake_result_decl (sym);
+ /* Dereference character pointer dummy arguments
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result))
+ se->expr = build_fold_indirect_ref (se->expr);
+ }
+ else
+ {
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension)
+ se->expr = build_fold_indirect_ref (se->expr);
+
+ /* Dereference scalar hidden result. */
+ if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
+ && (sym->attr.function || sym->attr.result)
+ && !sym->attr.dimension && !sym->attr.pointer)
+ se->expr = build_fold_indirect_ref (se->expr);
+
+ /* Dereference non-character pointer variables.
+ These must be dummies, results, or scalars. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result
+ || !sym->attr.dimension))
+ se->expr = build_fold_indirect_ref (se->expr);
}
-
- /* 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 pointer variables. */
- if ((sym->attr.pointer || sym->attr.allocatable)
- && (sym->attr.dummy
- || sym->attr.result
- || sym->attr.function
- || !sym->attr.dimension)
- && sym->ts.type != BT_CHARACTER)
- se->expr = gfc_build_indirect_ref (se->expr);
ref = expr->ref;
}
/* For character variables, also get the length. */
if (sym->ts.type == BT_CHARACTER)
{
- se->string_length = sym->ts.cl->backend_decl;
- assert (se->string_length);
+ /* If the character length of an entry isn't set, get the length from
+ the master function instead. */
+ if (sym->attr.entry && !sym->ts.cl->backend_decl)
+ se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
+ else
+ se->string_length = sym->ts.cl->backend_decl;
+ 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_conv_string_parameter (se);
else
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ se->expr = build_fold_addr_expr (se->expr);
}
- if (se->ss != NULL)
- gfc_advance_se_ss_chain (se);
}
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);
}
/* Expand power operator to optimal multiplications when a value is raised
- to an constant integer n. See section 4.6.3, "Evaluation of Powers" of
+ 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. */
with the first node being one. */
#define POWI_TABLE_SIZE 256
-/* The table is from Builtins.c. */
+/* 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 */
124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
};
-/* If n is larger than lookup table's max index, we use "window method". */
+/* If n is larger than lookup table's max index, we use the "window
+ method". */
#define POWI_WINDOW_SIZE 3
-/* Recursive function to expand power operator. The temporary values are put
- in tmpvar. The function return tmpvar[1] ** n. */
+/* 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)
{
op1 = op0;
}
- tmp = fold (build (MULT_EXPR, TREE_TYPE (op0), op0, op1));
+ tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
tmp = gfc_evaluate_now (tmp, &se->pre);
if (n < POWI_TABLE_SIZE)
return tmp;
}
-/* Expand lhs ** rhs. rhs is an constant integer. If expand successfully,
- return 1. Else return 0 and will call runtime library functions. */
+
+/* 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)
{
n = abs (TREE_INT_CST_LOW (rhs));
sgn = tree_int_cst_sgn (rhs);
- if ((!flag_unsafe_math_optimizations || optimize_size) && (n > 2 || n < -1))
+ if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
+ && (n > 2 || n < -1))
return 0;
/* rhs == 0 */
/* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
{
- tmp = build (EQ_EXPR, boolean_type_node, lhs,
- integer_minus_one_node);
- cond = build (EQ_EXPR, boolean_type_node, lhs,
- integer_one_node);
+ 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 an even,
- result = (lhs == 1 || lhs == -1) ? 1 : 0. */
+ /* If rhs is even,
+ result = (lhs == 1 || lhs == -1) ? 1 : 0. */
if ((n & 1) == 0)
{
- tmp = build (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
- se->expr = build (COND_EXPR, type, tmp, integer_one_node,
- integer_zero_node);
+ 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 an odd,
+ /* If rhs is odd,
result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
- tmp = build (COND_EXPR, type, tmp, integer_minus_one_node,
- integer_zero_node);
- se->expr = build (COND_EXPR, type, cond, integer_one_node,
- tmp);
+ 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;
}
if (sgn == -1)
{
tmp = gfc_build_const (type, integer_one_node);
- vartmp[1] = build (RDIV_EXPR, type, tmp, vartmp[1]);
+ vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
}
se->expr = gfc_conv_powi (se, n, vartmp);
static void
gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
{
+ tree gfc_int4_type_node;
int kind;
int ikind;
gfc_se lse;
tree tmp;
gfc_init_se (&lse, se);
- gfc_conv_expr_val (&lse, expr->op1);
+ gfc_conv_expr_val (&lse, expr->value.op.op1);
+ lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
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);
- if (expr->op2->ts.type == BT_INTEGER
- && expr->op2->expr_type == EXPR_CONSTANT)
+ 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;
- kind = expr->op1->ts.kind;
- switch (expr->op2->ts.type)
+ gfc_int4_type_node = gfc_get_int_type (4);
+
+ kind = expr->value.op.op1->ts.kind;
+ switch (expr->value.op.op2->ts.type)
{
case BT_INTEGER:
- ikind = expr->op2->ts.kind;
+ ikind = expr->value.op.op2->ts.kind;
switch (ikind)
{
case 1:
ikind = 1;
break;
+ case 16:
+ ikind = 2;
+ break;
+
default:
- abort();
+ gcc_unreachable ();
}
switch (kind)
{
case 1:
case 2:
- if (expr->op1->ts.type == BT_INTEGER)
+ if (expr->value.op.op1->ts.type == BT_INTEGER)
lse.expr = convert (gfc_int4_type_node, lse.expr);
else
- abort ();
+ gcc_unreachable ();
/* Fall through. */
case 4:
kind = 1;
break;
+ case 10:
+ kind = 2;
+ break;
+
+ case 16:
+ kind = 3;
+ break;
+
default:
- abort();
+ gcc_unreachable ();
}
- switch (expr->op1->ts.type)
+ switch (expr->value.op.op1->ts.type)
{
case BT_INTEGER:
+ if (kind == 3) /* Case 16 was not handled properly above. */
+ kind = 2;
fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
break;
break;
default:
- abort ();
+ gcc_unreachable ();
}
break;
case 8:
fndecl = built_in_decls[BUILT_IN_POW];
break;
+ case 10:
+ case 16:
+ fndecl = built_in_decls[BUILT_IN_POWL];
+ break;
default:
- abort ();
+ gcc_unreachable ();
}
break;
case 8:
fndecl = gfor_fndecl_math_cpow;
break;
+ case 10:
+ fndecl = gfor_fndecl_math_cpowl10;
+ break;
+ case 16:
+ fndecl = gfor_fndecl_math_cpowl16;
+ 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 = fold (gfc_build_function_call (fndecl, tmp));
+ se->expr = build_function_call_expr (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);
/* Allocate a temporary to hold the result. */
var = gfc_create_var (type, "pstr");
args = gfc_chainon_list (NULL_TREE, len);
- tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
+ tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
tmp = convert (type, tmp);
gfc_add_modify_expr (&se->pre, var, tmp);
/* Free the temporary afterwards. */
tmp = convert (pvoid_type_node, var);
args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
gfc_add_expr_to_block (&se->post, tmp);
}
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);
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_concat_string, args);
+ tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Add the cleanup for the operands. */
se->string_length = len;
}
-
/* 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);
+ case INTRINSIC_PARENTHESES:
+ 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
- value with 0. */
if (checkstring)
{
gfc_conv_string_parameter (&lse);
gfc_conv_string_parameter (&rse);
- tmp = NULL_TREE;
- tmp = gfc_chainon_list (tmp, lse.string_length);
- tmp = gfc_chainon_list (tmp, lse.expr);
- tmp = gfc_chainon_list (tmp, rse.string_length);
- tmp = gfc_chainon_list (tmp, rse.expr);
-
- /* Build a call for the comparison. */
- lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
- gfc_add_block_to_block (&lse.post, &rse.post);
+ lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
+ rse.string_length, rse.expr);
rse.expr = integer_zero_node;
+ gfc_add_block_to_block (&lse.post, &rse.post);
}
type = gfc_typenode_for_spec (&expr->ts);
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);
}
+/* If a string's length is one, we convert it to a single character. */
+
+static tree
+gfc_to_single_character (tree len, tree str)
+{
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
+
+ if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
+ && TREE_INT_CST_HIGH (len) == 0)
+ {
+ str = fold_convert (pchar_type_node, str);
+ return build_fold_indirect_ref (str);
+ }
+
+ return NULL_TREE;
+}
+
+/* Compare two strings. If they are all single characters, the result is the
+ subtraction of them. Otherwise, we build a library call. */
+
+tree
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
+{
+ tree sc1;
+ tree sc2;
+ tree type;
+ tree tmp;
+
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
+
+ type = gfc_get_int_type (gfc_default_integer_kind);
+
+ sc1 = gfc_to_single_character (len1, str1);
+ sc2 = gfc_to_single_character (len2, str2);
+
+ /* Deal with single character specially. */
+ if (sc1 != NULL_TREE && sc2 != NULL_TREE)
+ {
+ sc1 = fold_convert (type, sc1);
+ sc2 = fold_convert (type, sc2);
+ tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
+ }
+ else
+ {
+ tmp = NULL_TREE;
+ tmp = gfc_chainon_list (tmp, len1);
+ tmp = gfc_chainon_list (tmp, str1);
+ tmp = gfc_chainon_list (tmp, len2);
+ tmp = gfc_chainon_list (tmp, str2);
+
+ /* Build a call for the comparison. */
+ tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
+ }
+
+ return tmp;
+}
+
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);
+ }
+ else
+ {
+ if (!sym->backend_decl)
+ sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+ tmp = sym->backend_decl;
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = build_fold_addr_expr (tmp);
+ }
+ }
+ se->expr = tmp;
+}
+
+
+/* Initialize MAPPING. */
+
+void
+gfc_init_interface_mapping (gfc_interface_mapping * mapping)
+{
+ mapping->syms = NULL;
+ mapping->charlens = NULL;
+}
+
+
+/* Free all memory held by MAPPING (but not MAPPING itself). */
+
+void
+gfc_free_interface_mapping (gfc_interface_mapping * mapping)
+{
+ gfc_interface_sym_mapping *sym;
+ gfc_interface_sym_mapping *nextsym;
+ gfc_charlen *cl;
+ gfc_charlen *nextcl;
+
+ for (sym = mapping->syms; sym; sym = nextsym)
+ {
+ nextsym = sym->next;
+ gfc_free_symbol (sym->new->n.sym);
+ gfc_free (sym->new);
+ gfc_free (sym);
+ }
+ for (cl = mapping->charlens; cl; cl = nextcl)
+ {
+ nextcl = cl->next;
+ gfc_free_expr (cl->length);
+ gfc_free (cl);
+ }
+}
+
+
+/* Return a copy of gfc_charlen CL. Add the returned structure to
+ MAPPING so that it will be freed by gfc_free_interface_mapping. */
+
+static gfc_charlen *
+gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
+ gfc_charlen * cl)
+{
+ gfc_charlen *new;
+
+ new = gfc_get_charlen ();
+ new->next = mapping->charlens;
+ new->length = gfc_copy_expr (cl->length);
+
+ mapping->charlens = new;
+ return new;
+}
+
+
+/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
+ array variable that can be used as the actual argument for dummy
+ argument SYM. Add any initialization code to BLOCK. PACKED is as
+ for gfc_get_nodesc_array_type and DATA points to the first element
+ in the passed array. */
+
+static tree
+gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
+ int packed, tree data)
+{
+ tree type;
+ tree var;
+
+ type = gfc_typenode_for_spec (&sym->ts);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed);
+
+ var = gfc_create_var (type, "ifm");
+ gfc_add_modify_expr (block, var, fold_convert (type, data));
+
+ return var;
+}
+
+
+/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
+ and offset of descriptorless array type TYPE given that it has the same
+ size as DESC. Add any set-up code to BLOCK. */
+
+static void
+gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
+{
+ int n;
+ tree dim;
+ tree offset;
+ tree tmp;
+
+ offset = gfc_index_zero_node;
+ for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
+ {
+ GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
+ if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
+ {
+ dim = gfc_rank_cst[n];
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (desc, dim),
+ gfc_conv_descriptor_lbound (desc, dim));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, n),
+ tmp);
+ tmp = gfc_evaluate_now (tmp, block);
+ GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+ }
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, n),
+ GFC_TYPE_ARRAY_STRIDE (type, n));
+ offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
+ }
+ offset = gfc_evaluate_now (offset, block);
+ GFC_TYPE_ARRAY_OFFSET (type) = offset;
+}
+
+
+/* Extend MAPPING so that it maps dummy argument SYM to the value stored
+ in SE. The caller may still use se->expr and se->string_length after
+ calling this function. */
+
+void
+gfc_add_interface_mapping (gfc_interface_mapping * mapping,
+ gfc_symbol * sym, gfc_se * se)
+{
+ gfc_interface_sym_mapping *sm;
+ tree desc;
+ tree tmp;
+ tree value;
+ gfc_symbol *new_sym;
+ gfc_symtree *root;
+ gfc_symtree *new_symtree;
+
+ /* Create a new symbol to represent the actual argument. */
+ new_sym = gfc_new_symbol (sym->name, NULL);
+ new_sym->ts = sym->ts;
+ new_sym->attr.referenced = 1;
+ new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.pointer = sym->attr.pointer;
+ new_sym->attr.allocatable = sym->attr.allocatable;
+ new_sym->attr.flavor = sym->attr.flavor;
+
+ /* Create a fake symtree for it. */
+ root = NULL;
+ new_symtree = gfc_new_symtree (&root, sym->name);
+ new_symtree->n.sym = new_sym;
+ gcc_assert (new_symtree == root);
+
+ /* Create a dummy->actual mapping. */
+ sm = gfc_getmem (sizeof (*sm));
+ sm->next = mapping->syms;
+ sm->old = sym;
+ sm->new = new_symtree;
+ mapping->syms = sm;
+
+ /* Stabilize the argument's value. */
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Create a copy of the dummy argument's length. */
+ new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
+
+ /* If the length is specified as "*", record the length that
+ the caller is passing. We should use the callee's length
+ in all other cases. */
+ if (!new_sym->ts.cl->length)
+ {
+ se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
+ new_sym->ts.cl->backend_decl = se->string_length;
+ }
+ }
+
+ /* Use the passed value as-is if the argument is a function. */
+ if (sym->attr.flavor == FL_PROCEDURE)
+ value = se->expr;
+
+ /* If the argument is either a string or a pointer to a string,
+ convert it to a boundless character type. */
+ else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
+ {
+ tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
+ tmp = build_pointer_type (tmp);
+ if (sym->attr.pointer)
+ tmp = build_pointer_type (tmp);
+
+ value = fold_convert (tmp, se->expr);
+ if (sym->attr.pointer)
+ value = build_fold_indirect_ref (value);
+ }
+
+ /* If the argument is a scalar, a pointer to an array or an allocatable,
+ dereference it. */
+ else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
+ value = build_fold_indirect_ref (se->expr);
+
+ /* For character(*), use the actual argument's descriptor. */
+ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
+ value = build_fold_indirect_ref (se->expr);
+
+ /* If the argument is an array descriptor, use it to determine
+ information about the actual argument's shape. */
+ else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+ {
+ /* Get the actual argument's descriptor. */
+ desc = build_fold_indirect_ref (se->expr);
+
+ /* Create the replacement variable. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
+
+ /* Use DESC to work out the upper bounds, strides and offset. */
+ gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
+ }
+ else
+ /* Otherwise we have a packed array. */
+ value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
+
+ new_sym->backend_decl = value;
+}
+
+
+/* Called once all dummy argument mappings have been added to MAPPING,
+ but before the mapping is used to evaluate expressions. Pre-evaluate
+ the length of each argument, adding any initialization code to PRE and
+ any finalization code to POST. */
+
+void
+gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
+ stmtblock_t * pre, stmtblock_t * post)
+{
+ gfc_interface_sym_mapping *sym;
+ gfc_expr *expr;
+ gfc_se se;
+
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->new->n.sym->ts.type == BT_CHARACTER
+ && !sym->new->n.sym->ts.cl->backend_decl)
+ {
+ expr = sym->new->n.sym->ts.cl->length;
+ gfc_apply_interface_mapping_to_expr (mapping, expr);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+
+ se.expr = gfc_evaluate_now (se.expr, &se.pre);
+ gfc_add_block_to_block (pre, &se.pre);
+ gfc_add_block_to_block (post, &se.post);
+
+ sym->new->n.sym->ts.cl->backend_decl = se.expr;
+ }
+}
+
+
+/* Like gfc_apply_interface_mapping_to_expr, but applied to
+ constructor C. */
+
+static void
+gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
+ gfc_constructor * c)
+{
+ for (; c; c = c->next)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, c->expr);
+ if (c->iterator)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
+ gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
+ gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
+ }
+ }
+}
+
+
+/* Like gfc_apply_interface_mapping_to_expr, but applied to
+ reference REF. */
+
+static void
+gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
+ gfc_ref * ref)
+{
+ int n;
+
+ for (; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
+ }
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
+ break;
+
+ case REF_COMPONENT:
+ break;
+
+ case REF_SUBSTRING:
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
+ break;
+ }
+}
+
+
+/* EXPR is a copy of an expression that appeared in the interface
+ associated with MAPPING. Walk it recursively looking for references to
+ dummy arguments that MAPPING maps to actual arguments. Replace each such
+ reference with a reference to the associated actual argument. */
+
+static void
+gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
+ gfc_expr * expr)
+{
+ gfc_interface_sym_mapping *sym;
+ gfc_actual_arglist *actual;
+
+ if (!expr)
+ return;
+
+ /* Copying an expression does not copy its length, so do that here. */
+ if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
+ {
+ expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
+ }
+
+ /* Apply the mapping to any references. */
+ gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
+
+ /* ...and to the expression's symbol, if it has one. */
+ if (expr->symtree)
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->old == expr->symtree->n.sym)
+ expr->symtree = sym->new;
+
+ /* ...and to subexpressions in expr->value. */
+ switch (expr->expr_type)
+ {
+ case EXPR_VARIABLE:
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_SUBSTRING:
+ break;
+
+ case EXPR_OP:
+ gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
+ break;
+
+ case EXPR_FUNCTION:
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->old == expr->value.function.esym)
+ expr->value.function.esym = sym->new->n.sym;
+
+ for (actual = expr->value.function.actual; actual; actual = actual->next)
+ gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+ break;
+
+ case EXPR_ARRAY:
+ case EXPR_STRUCTURE:
+ gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
+ break;
+ }
+}
+
+
+/* Evaluate interface expression EXPR using MAPPING. Store the result
+ in SE. */
+
+void
+gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
+ gfc_se * se, gfc_expr * expr)
+{
+ expr = gfc_copy_expr (expr);
+ gfc_apply_interface_mapping_to_expr (mapping, expr);
+ gfc_conv_expr (se, expr);
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+ gfc_free_expr (expr);
+}
+
+/* Returns a reference to a temporary array into which a component of
+ an actual argument derived type array is copied and then returned
+ after the function call.
+ TODO Get rid of this kludge, when array descriptors are capable of
+ handling aliased arrays. */
+
+static void
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
+{
+ gfc_se lse;
+ gfc_se rse;
+ gfc_ss *lss;
+ gfc_ss *rss;
+ gfc_loopinfo loop;
+ gfc_loopinfo loop2;
+ gfc_ss_info *info;
+ tree offset;
+ tree tmp_index;
+ tree tmp;
+ tree base_type;
+ stmtblock_t body;
+ int n;
+
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ rss = gfc_walk_expr (expr);
+
+ gcc_assert (rss != gfc_ss_terminator);
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, rss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop);
+
+ /* Build an ss for the temporary. */
+ base_type = gfc_typenode_for_spec (&expr->ts);
+ if (GFC_ARRAY_TYPE_P (base_type)
+ || GFC_DESCRIPTOR_TYPE_P (base_type))
+ base_type = gfc_get_element_type (base_type);
+
+ loop.temp_ss = gfc_get_ss ();;
+ loop.temp_ss->type = GFC_SS_TEMP;
+ loop.temp_ss->data.temp.type = base_type;
+
+ if (expr->ts.type == BT_CHARACTER)
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+
+ loop.temp_ss->data.temp.dimen = loop.dimen;
+ loop.temp_ss->next = gfc_ss_terminator;
+
+ /* Associate the SS with the loop. */
+ gfc_add_ss_to_loop (&loop, loop.temp_ss);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop);
+
+ /* Pass the temporary descriptor back to the caller. */
+ info = &loop.temp_ss->data.info;
+ parmse->expr = info->descriptor;
+
+ /* Setup the gfc_se structures. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
+ gfc_copy_loopinfo_to_se (&rse, &loop);
+
+ rse.ss = rss;
+ lse.ss = loop.temp_ss;
+ gfc_mark_ss_chain_used (rss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Start the scalarized loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ /* Translate the expression. */
+ gfc_conv_expr (&rse, expr);
+
+ gfc_conv_tmp_array_ref (&lse);
+ gfc_advance_se_ss_chain (&lse);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ gfc_add_expr_to_block (&body, tmp);
+
+ gcc_assert (rse.ss == gfc_ss_terminator);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ /* Add the post block after the second loop, so that any
+ freeing of allocated memory is done at the right time. */
+ gfc_add_block_to_block (&parmse->pre, &loop.pre);
+
+ /**********Copy the temporary back again.*********/
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ lss = gfc_walk_expr (expr);
+ rse.ss = loop.temp_ss;
+ lse.ss = lss;
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop2);
+ gfc_add_ss_to_loop (&loop2, lss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop2);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop2);
+
+ gfc_copy_loopinfo_to_se (&lse, &loop2);
+ gfc_copy_loopinfo_to_se (&rse, &loop2);
+
+ gfc_mark_ss_chain_used (lss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Declare the variable to hold the temporary offset and start the
+ scalarized loop body. */
+ offset = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_start_scalarized_body (&loop2, &body);
+
+ /* Build the offsets for the temporary from the loop variables. The
+ temporary array has lbounds of zero and strides of one in all
+ dimensions, so this is very simple. The offset is only computed
+ outside the innermost loop, so the overall transfer could be
+ optimised further. */
+ info = &rse.ss->data.info;
+
+ tmp_index = gfc_index_zero_node;
+ for (n = info->dimen - 1; n > 0; n--)
+ {
+ tree tmp_str;
+ tmp = rse.loop->loopvar[n];
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, rse.loop->from[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, tmp_index);
+
+ tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ rse.loop->to[n-1], rse.loop->from[n-1]);
+ tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp_str, gfc_index_one_node);
+
+ tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, tmp_str);
+ }
+
+ tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp_index, rse.loop->from[0]);
+ gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
+
+ tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ rse.loop->loopvar[0], offset);
+
+ /* Now use the offset for the reference. */
+ tmp = build_fold_indirect_ref (info->data);
+ rse.expr = gfc_build_array_ref (tmp, tmp_index);
+
+ if (expr->ts.type == BT_CHARACTER)
+ rse.string_length = expr->ts.cl->backend_decl;
+
+ gfc_conv_expr (&lse, expr);
+
+ gcc_assert (lse.ss == gfc_ss_terminator);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Generate the copying loops. */
+ gfc_trans_scalarizing_loops (&loop2, &body);
+
+ /* Wrap the whole thing up by adding the second loop to the post-block
+ and following it by the post-block of the fist loop. In this way,
+ if the temporary needs freeing, it is done after use! */
+ gfc_add_block_to_block (&parmse->post, &loop2.pre);
+ gfc_add_block_to_block (&parmse->post, &loop2.post);
+
+ gfc_add_block_to_block (&parmse->post, &loop.post);
+
+ gfc_cleanup_loop (&loop);
+ gfc_cleanup_loop (&loop2);
+
+ /* Pass the string length to the argument expression. */
+ if (expr->ts.type == BT_CHARACTER)
+ parmse->string_length = expr->ts.cl->backend_decl;
- se->expr = tmp;
- }
+ /* We want either the address for the data or the address of the descriptor,
+ depending on the mode of passing array arguments. */
+ if (g77)
+ parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
else
+ parmse->expr = build_fold_addr_expr (parmse->expr);
+
+ return;
+}
+
+/* Is true if the last array reference is followed by a component reference. */
+
+static bool
+is_aliased_array (gfc_expr * e)
+{
+ gfc_ref * ref;
+ bool seen_array;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
{
- if (!sym->backend_decl)
- sym->backend_decl = gfc_get_extern_function_decl (sym);
+ if (ref->type == REF_ARRAY)
+ seen_array = true;
- tmp = sym->backend_decl;
- assert (TREE_CODE (tmp) == FUNCTION_DECL);
- se->expr = gfc_build_addr_expr (NULL, tmp);
+ if (ref->next == NULL && ref->type == REF_COMPONENT)
+ return seen_array;
}
+ return false;
}
-
/* Generate code for a procedure call. Note can return se->post != NULL.
- If se->direct_byref is set then se->expr contains the return parameter. */
+ If se->direct_byref is set then se->expr contains the return parameter.
+ Return nonzero, if the call has alternate specifiers. */
-void
+int
gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg)
{
+ gfc_interface_mapping mapping;
tree arglist;
+ tree retargs;
tree tmp;
tree fntype;
gfc_se parmse;
tree len;
tree stringargs;
gfc_formal_arglist *formal;
+ int has_alternate_specifier = 0;
+ bool need_interface_mapping;
+ gfc_typespec ts;
+ gfc_charlen cl;
arglist = NULL_TREE;
+ retargs = NULL_TREE;
stringargs = NULL_TREE;
var = NULL_TREE;
len = NULL_TREE;
{
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);
gfc_advance_se_ss_chain (se);
- return;
+ return 0;
}
}
info = &se->ss->data.info;
else
info = NULL;
- byref = gfc_return_by_reference (sym);
- if (byref)
- {
- if (se->direct_byref)
- arglist = gfc_chainon_list (arglist, se->expr);
- else if (sym->result->attr.dimension)
- {
- 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);
-
- /* 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);
- /* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL, tmp);
- arglist = gfc_chainon_list (arglist, tmp);
- }
- else if (sym->ts.type == BT_CHARACTER)
- {
- 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);
- sym->ts.cl->backend_decl = len;
- type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
- type = build_pointer_type (type);
-
- 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));
- }
- else /* TODO: derived type function return values. */
- abort ();
- }
-
+ gfc_init_interface_mapping (&mapping);
+ need_interface_mapping = ((sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type
+ != EXPR_CONSTANT)
+ || sym->attr.dimension);
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
- {
- stringargs = gfc_chainon_list (stringargs,
- convert (gfc_strlen_type_node, integer_zero_node));
- }
+ parmse.string_length = convert (gfc_charlen_type_node,
+ integer_zero_node);
}
}
else if (se->ss && se->ss->useflags)
&& arg->expr->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
- indirection. The null pointer already contains
- this level of indirection. */
- parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
+ indirection. The null pointer already contains
+ this level of indirection. */
+ parmse.expr = build_fold_addr_expr (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,
+ ALLOCATABLE 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
+ && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
&& formal->sym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
- gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && is_aliased_array (arg->expr))
+ /* The actual argument is a component reference to an
+ array of derived types. In this case, the argument
+ is converted to a temporary, which is passed and then
+ written back after the procedure call. */
+ gfc_conv_aliased_arg (&parmse, arg->expr, f);
+ else
+ gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (formal && formal->sym->attr.allocatable
+ && formal->sym->attr.intent == INTENT_OUT)
+ {
+ tmp = gfc_trans_dealloc_allocated (arg->expr->symtree->n.sym);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
}
}
+ if (formal && need_interface_mapping)
+ gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
+
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);
arglist = gfc_chainon_list (arglist, parmse.expr);
}
+ gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
+
+ ts = sym->ts;
+ if (ts.type == BT_CHARACTER)
+ {
+ if (sym->ts.cl->length == NULL)
+ {
+ /* Assumed character length results are not allowed by 5.1.1.5 of the
+ standard and are trapped in resolve.c; except in the case of SPREAD
+ (and other intrinsics?). In this case, we take the character length
+ of the first argument for the result. */
+ cl.backend_decl = TREE_VALUE (stringargs);
+ }
+ else
+ {
+ /* Calculate the length of the returned string. */
+ gfc_init_se (&parmse, NULL);
+ if (need_interface_mapping)
+ gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
+ else
+ gfc_conv_expr (&parmse, sym->ts.cl->length);
+ gfc_add_block_to_block (&se->pre, &parmse.pre);
+ gfc_add_block_to_block (&se->post, &parmse.post);
+ cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
+ }
+
+ /* Set up a charlen structure for it. */
+ cl.next = NULL;
+ cl.length = NULL;
+ ts.cl = &cl;
+
+ len = cl.backend_decl;
+ }
+
+ byref = gfc_return_by_reference (sym);
+ if (byref)
+ {
+ if (se->direct_byref)
+ retargs = gfc_chainon_list (retargs, se->expr);
+ else if (sym->result->attr.dimension)
+ {
+ gcc_assert (se->loop && info);
+
+ /* Set the type of the array. */
+ tmp = gfc_typenode_for_spec (&ts);
+ info->dimen = se->loop->dimen;
+
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
+
+ /* Allocate a temporary to store the result. In case the function
+ returns a pointer, the temporary will be a shallow copy and
+ mustn't be deallocated. */
+ gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, info,
+ tmp, false, !sym->attr.pointer);
+
+ /* 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,
+ convert (TREE_TYPE (tmp), integer_zero_node));
+
+ /* Pass the temporary as the first argument. */
+ tmp = info->descriptor;
+ tmp = build_fold_addr_expr (tmp);
+ retargs = gfc_chainon_list (retargs, tmp);
+ }
+ else if (ts.type == BT_CHARACTER)
+ {
+ /* Pass the string length. */
+ type = gfc_get_character_type (ts.kind, ts.cl);
+ type = build_pointer_type (type);
+
+ /* Return an address to a char[0:len-1]* temporary for
+ character pointers. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ {
+ /* Build char[0:len-1] * pstr. */
+ tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
+ build_int_cst (gfc_charlen_type_node, 1));
+ 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 (build_pointer_type (tmp), "pstr");
+
+ /* Provide an address expression for the function arguments. */
+ var = build_fold_addr_expr (var);
+ }
+ else
+ var = gfc_conv_string_tmp (se, type, len);
+
+ retargs = gfc_chainon_list (retargs, var);
+ }
+ else
+ {
+ gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
+
+ type = gfc_get_complex_type (ts.kind);
+ var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
+ retargs = gfc_chainon_list (retargs, var);
+ }
+
+ /* Add the string length to the argument list. */
+ if (ts.type == BT_CHARACTER)
+ retargs = gfc_chainon_list (retargs, len);
+ }
+ gfc_free_interface_mapping (&mapping);
+
+ /* Add the return arguments. */
+ arglist = chainon (retargs, arglist);
/* Add the hidden string length parameters to the arguments. */
arglist = chainon (arglist, stringargs);
/* Generate the actual call. */
gfc_conv_function_val (se, sym);
/* If there are alternate return labels, function type should be
- integer. */
- if (has_alternate_specifier)
- TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
+ integer. Can't modify the type in place though, since it can be shared
+ with other functions. */
+ if (has_alternate_specifier
+ && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
+ {
+ gcc_assert (! sym->attr.dummy);
+ TREE_TYPE (sym->backend_decl)
+ = build_function_type (integer_type_node,
+ TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
+ se->expr = build_fold_addr_expr (sym->backend_decl);
+ }
fntype = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr,
- arglist, NULL_TREE);
-
-/* A pure function may still have side-effects - it may modify its
- parameters. */
+ se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
+ arglist, NULL_TREE);
+
+ /* 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 = build_fold_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->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_get (info->descriptor);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ tmp, info->data);
+ gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ }
+ se->expr = info->descriptor;
+ /* Bundle in the string length. */
+ se->string_length = len;
+ }
+ else if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Dereference for character pointer results. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ se->expr = build_fold_indirect_ref (var);
+ else
+ se->expr = var;
+
+ se->string_length = len;
+ }
+ else
+ {
+ gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+ se->expr = build_fold_indirect_ref (var);
}
- se->expr = info->descriptor;
- }
- else if (sym->ts.type == BT_CHARACTER)
- {
- se->expr = var;
- se->string_length = len;
}
- else
- abort ();
}
+
+ return has_alternate_specifier;
}
tree slen, tree src)
{
tree tmp;
+ tree dsc;
+ tree ssc;
+
+ /* Deal with single character specially. */
+ dsc = gfc_to_single_character (dlen, dest);
+ ssc = gfc_to_single_character (slen, src);
+ if (dsc != NULL_TREE && ssc != NULL_TREE)
+ {
+ gfc_add_modify_expr (block, dsc, ssc);
+ return;
+ }
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);
+ tmp = build_function_call_expr (gfor_fndecl_copy_string, tmp);
gfc_add_expr_to_block (block, tmp);
}
{
/* 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;
/* Create a temporary to hold the value. */
/* Copy string arguments. */
tree arglen;
- assert (fsym->ts.cl && fsym->ts.cl->length
+ gcc_assert (fsym->ts.cl && fsym->ts.cl->length
&& fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
se->string_length = sym->ts.cl->backend_decl;
}
- /* Resore the original variables. */
+ /* 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);
+ if (cm->ts.type == BT_CHARACTER)
+ lse.string_length = cm->ts.cl->backend_decl;
+
+ 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)
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ 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. */
{
gfc_constructor *c;
gfc_component *cm;
- tree head;
- tree tail;
tree val;
- gfc_se cse;
tree type;
- tree arraytype;
+ tree tmp;
+ VEC(constructor_elt,gc) *v = NULL;
- 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);
- head = build1 (CONSTRUCTOR, type, NULL_TREE);
- tail = NULL_TREE;
+
+ 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;
+ }
cm = expr->ts.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
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);
- }
-
- /* Build a TREE_CHAIN to hold it. */
- val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
- /* Add it to the list. */
- if (tail == NULL_TREE)
- TREE_OPERAND(head, 0) = tail = val;
- else
- {
- TREE_CHAIN (tail) = val;
- tail = val;
- }
+ /* Append it to the constructor list. */
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
- se->expr = head;
+ se->expr = build_constructor (type, v);
}
-/*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);
}
-/* Entry point for expression translation. */
+/* Entry point for expression translation. Evaluates a scalar quantity.
+ EXPR is the expression to be translated, and SE is the state structure if
+ called from within the scalarized. */
void
gfc_conv_expr (gfc_se * se, gfc_expr * expr)
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;
}
}
+/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
+ of an assignment. */
void
gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
{
gfc_conv_expr (se, expr);
- /* AFAICS all numeric lvalues have empty post chains. If not we need to
+ /* All numeric lvalues should 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);
}
+/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
+ numeric expressions. Used for scalar values where inserting cleanup code
+ is inconvenient. */
void
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
{
tree val;
- assert (expr->ts.type != BT_CHARACTER);
+ gcc_assert (expr->ts.type != BT_CHARACTER);
gfc_conv_expr (se, expr);
if (se->post.head)
{
val = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify_expr (&se->pre, val, se->expr);
+ se->expr = val;
+ gfc_add_block_to_block (&se->pre, &se->post);
}
}
+/* Helper to translate and expression and convert it to a particular type. */
void
gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
{
}
-/* 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. */
- se->expr = gfc_build_addr_expr (NULL, var);
+ se->expr = build_fold_addr_expr (var);
}
}
+/* 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 desc;
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);
- }
- else
- {
+ switch (expr2->expr_type)
+ {
+ case EXPR_NULL:
+ /* Just set the data pointer to null. */
+ gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
+ break;
+
+ case EXPR_VARIABLE:
+ /* Assign directly to the pointer's descriptor. */
lse.direct_byref = 1;
- gfc_conv_expr_descriptor (&lse, expr2, rss);
+ gfc_conv_expr_descriptor (&lse, expr2, rss);
+ break;
+
+ default:
+ /* Assign to a temporary descriptor and then copy that
+ temporary to the pointer. */
+ desc = lse.expr;
+ tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
+
+ lse.expr = tmp;
+ lse.direct_byref = 1;
+ gfc_conv_expr_descriptor (&lse, expr2, rss);
+ gfc_add_modify_expr (&lse.pre, desc, tmp);
+ break;
}
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &lse.post);
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);
}
if (type == BT_CHARACTER)
{
- 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);
- 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);
{
gfc_se se;
gfc_ss *ss;
+ gfc_ref * ref;
+ bool seen_array_ref;
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
return NULL;
/* Elemental functions don't need a temporary anyway. */
- if (expr2->symtree->n.sym->attr.elemental)
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.elemental)
return NULL;
+ /* Fail if EXPR1 can't be expressed as a descriptor. */
+ if (gfc_ref_needs_temporary_p (expr1->ref))
+ return NULL;
+
+ /* Functions returning pointers need temporaries. */
+ if (expr2->symtree->n.sym->attr.pointer)
+ return NULL;
+
+ /* Check that no LHS component references appear during an array
+ reference. This is needed because we do not have the means to
+ span any arbitrary stride with an array descriptor. This check
+ is not needed for the rhs because the function result has to be
+ a complete type. */
+ seen_array_ref = false;
+ for (ref = expr1->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ seen_array_ref= true;
+ else if (ref->type == REF_COMPONENT && seen_array_ref)
+ return NULL;
+ }
+
/* Check for a dependency. */
- if (gfc_check_fncall_dependency (expr1, expr2))
+ if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
+ expr2->value.function.esym,
+ expr2->value.function.actual))
return NULL;
/* 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);
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop);
/* Resolve any data dependencies in the statement. */
- gfc_conv_resolve_dependencies (&loop, lss_section, rss);
+ gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&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
