/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "convert.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
-#include "gimple.h"
+#include "diagnostic-core.h" /* For fatal_error. */
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
tree
gfc_conv_expr_present (gfc_symbol * sym)
{
- tree decl;
+ tree decl, cond;
gcc_assert (sym->attr.dummy);
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
- return fold_build2 (NE_EXPR, boolean_type_node, decl,
- fold_convert (TREE_TYPE (decl), null_pointer_node));
+
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
+ fold_convert (TREE_TYPE (decl), null_pointer_node));
+
+ /* Fortran 2008 allows to pass null pointers and non-associated pointers
+ as actual argument to denote absent dummies. For array descriptors,
+ we thus also need to check the array descriptor. */
+ if (!sym->attr.pointer && !sym->attr.allocatable
+ && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ {
+ tree tmp;
+ tmp = build_fold_indirect_ref_loc (input_location, decl);
+ tmp = gfc_conv_array_data (tmp);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, cond, tmp);
+ }
+
+ return cond;
}
se->expr));
/* Test for a NULL value. */
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
- fold_convert (TREE_TYPE (tmp), integer_one_node));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
- tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
- fold_convert (TREE_TYPE (se->expr), integer_zero_node));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+ present, se->expr,
+ build_zero_cst (TREE_TYPE (se->expr)));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = tmp;
}
if (ts.type == BT_CHARACTER)
{
tmp = build_int_cst (gfc_charlen_type_node, 0);
- tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
- present, se->string_length, tmp);
+ tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
+ present, se->string_length, tmp);
tmp = gfc_evaluate_now (tmp, &se->pre);
se->string_length = tmp;
}
}
+/* Return for an expression the backend decl of the coarray. */
+
+static tree
+get_tree_for_caf_expr (gfc_expr *expr)
+{
+ tree caf_decl = NULL_TREE;
+ gfc_ref *ref;
+
+ gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
+ if (expr->symtree->n.sym->attr.codimension)
+ caf_decl = expr->symtree->n.sym->backend_decl;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->attr.pointer || comp->attr.allocatable)
+ caf_decl = NULL_TREE;
+ if (comp->attr.codimension)
+ caf_decl = comp->backend_decl;
+ }
+
+ gcc_assert (caf_decl != NULL_TREE);
+ return caf_decl;
+}
+
+
/* For each character array constructor subexpression without a ts.u.cl->length,
replace it by its first element (if there aren't any elements, the length
should already be set to zero). */
/* We've found what we're looking for. */
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
+ gfc_constructor *c;
gfc_expr* new_expr;
+
gcc_assert (e->value.constructor);
- new_expr = e->value.constructor->expr;
- e->value.constructor->expr = NULL;
+ c = gfc_constructor_first (e->value.constructor);
+ new_expr = c->expr;
+ c->expr = NULL;
flatten_array_ctors_without_strlen (new_expr);
gfc_replace_expr (e, new_expr);
/* Otherwise, fall through to handle constructor elements. */
case EXPR_STRUCTURE:
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
flatten_array_ctors_without_strlen (c->expr);
break;
gfc_init_se (&se, NULL);
+ if (!cl->length
+ && cl->backend_decl
+ && TREE_CODE (cl->backend_decl) == VAR_DECL)
+ return;
+
/* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
"flatten" array constructors by taking their first element; all elements
should be the same length or a cl->length should be present. */
{
gfc_expr* expr_flat;
gcc_assert (expr);
-
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
gcc_assert (cl->length);
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
- se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
- build_int_cst (gfc_charlen_type_node, 0));
+ se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
+ se.expr, build_int_cst (gfc_charlen_type_node, 0));
gfc_add_block_to_block (pblock, &se.pre);
if (cl->backend_decl)
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
- tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
- start.expr, end.expr);
+ tree nonempty = fold_build2_loc (input_location, LE_EXPR,
+ boolean_type_node, start.expr,
+ end.expr);
/* Check lower bound. */
- fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
- build_int_cst (gfc_charlen_type_node, 1));
- fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
- nonempty, fault);
+ fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ start.expr,
+ build_int_cst (gfc_charlen_type_node, 1));
+ fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, nonempty, fault);
if (name)
asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
"is less than one", name);
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
start.expr));
- gfc_free (msg);
+ free (msg);
/* Check upper bound. */
- fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
- se->string_length);
- fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
- nonempty, fault);
+ fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ end.expr, se->string_length);
+ fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, nonempty, fault);
if (name)
asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
"exceeds string length (%%ld)", name);
fold_convert (long_integer_type_node, end.expr),
fold_convert (long_integer_type_node,
se->string_length));
- gfc_free (msg);
+ free (msg);
+ }
+
+ /* If the start and end expressions are equal, the length is one. */
+ if (ref->u.ss.end
+ && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
+ tmp = build_int_cst (gfc_charlen_type_node, 1);
+ else
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
+ end.expr, start.expr);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
+ build_int_cst (gfc_charlen_type_node, 1), tmp);
+ tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
+ tmp, build_int_cst (gfc_charlen_type_node, 0));
}
- tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
- end.expr, start.expr);
- tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
- build_int_cst (gfc_charlen_type_node, 1), tmp);
- tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
- build_int_cst (gfc_charlen_type_node, 0));
se->string_length = tmp;
}
field = c->backend_decl;
gcc_assert (TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
+
+ /* Components can correspond to fields of different containing
+ types, as components are created without context, whereas
+ a concrete use of a component has the type of decl as context.
+ So, if the type doesn't match, we search the corresponding
+ FIELD_DECL in the parent type. To not waste too much time
+ we cache this result in norestrict_decl. */
+
+ if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+ {
+ tree f2 = c->norestrict_decl;
+ if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
+ for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
+ if (TREE_CODE (f2) == FIELD_DECL
+ && DECL_NAME (f2) == DECL_NAME (field))
+ break;
+ gcc_assert (f2);
+ c->norestrict_decl = f2;
+ field = f2;
+ }
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
se->expr = tmp;
se->string_length = tmp;
}
- if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+ if (((c->attr.pointer || c->attr.allocatable)
+ && (!c->attr.dimension && !c->attr.codimension)
&& c->ts.type != BT_CHARACTER)
|| c->attr.proc_pointer)
se->expr = build_fold_indirect_ref_loc (input_location,
dt = ref->u.c.sym;
c = ref->u.c.component;
+ /* Return if the component is not in the parent type. */
+ for (cmp = dt->components; cmp; cmp = cmp->next)
+ if (strcmp (c->name, cmp->name) == 0)
+ return;
+
/* Build a gfc_ref to recursively call gfc_conv_component_ref. */
parent.type = REF_COMPONENT;
parent.next = NULL;
parent.u.c.sym = dt;
parent.u.c.component = dt->components;
- if (dt->attr.extension && dt->components)
- {
- if (dt->attr.is_class)
- cmp = dt->components;
- else
- cmp = dt->components->next;
- /* Return if the component is not in the parent type. */
- for (; cmp; cmp = cmp->next)
- if (strcmp (c->name, cmp->name) == 0)
- return;
-
- /* Otherwise build the reference and call self. */
- gfc_conv_component_ref (se, &parent);
- parent.u.c.sym = dt->components->ts.u.derived;
- parent.u.c.component = c;
- conv_parent_component_references (se, &parent);
- }
+ if (dt->backend_decl == NULL)
+ gfc_get_derived_type (dt);
+
+ /* Build the reference and call self. */
+ gfc_conv_component_ref (se, &parent);
+ parent.u.c.sym = dt->components->ts.u.derived;
+ parent.u.c.component = c;
+ conv_parent_component_references (se, &parent);
}
/* Return the contents of a variable. Also handles reference/pointer
{
gfc_ref *ref;
gfc_symbol *sym;
- tree parent_decl;
+ tree parent_decl = NULL_TREE;
int parent_flag;
bool return_value;
bool alternate_entry;
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 (current_function_decl)
+ parent_decl = DECL_CONTEXT (current_function_decl);
if ((se->expr == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
}
else if (!sym->attr.value)
{
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension)
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension
+ && !(sym->attr.codimension && sym->attr.allocatable))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- /* Dereference non-character pointer variables.
+ /* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
- if ((sym->attr.pointer || sym->attr.allocatable)
+ if ((sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
- || !sym->attr.dimension))
+ || (!sym->attr.dimension
+ && (!sym->attr.codimension || !sym->attr.allocatable))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}
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. */
if (code == TRUTH_NOT_EXPR)
- se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
- build_int_cst (type, 0));
+ se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
+ build_int_cst (type, 0));
else
- se->expr = fold_build1 (code, type, operand.expr);
+ se->expr = fold_build1_loc (input_location, code, type, operand.expr);
}
op1 = op0;
}
- tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
tmp = gfc_evaluate_now (tmp, &se->pre);
if (n < POWI_TABLE_SIZE)
/* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
{
- tmp = fold_build2 (EQ_EXPR, boolean_type_node,
- lhs, build_int_cst (TREE_TYPE (lhs), -1));
- cond = fold_build2 (EQ_EXPR, boolean_type_node,
- lhs, build_int_cst (TREE_TYPE (lhs), 1));
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ lhs, build_int_cst (TREE_TYPE (lhs), -1));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ lhs, build_int_cst (TREE_TYPE (lhs), 1));
/* If rhs is even,
result = (lhs == 1 || lhs == -1) ? 1 : 0. */
if ((n & 1) == 0)
{
- tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
- se->expr = fold_build3 (COND_EXPR, type,
- tmp, build_int_cst (type, 1),
- build_int_cst (type, 0));
+ tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, tmp, cond);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type,
+ tmp, build_int_cst (type, 1),
+ build_int_cst (type, 0));
return 1;
}
/* If rhs is odd,
result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
- tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
- build_int_cst (type, 0));
- se->expr = fold_build3 (COND_EXPR, type,
- cond, build_int_cst (type, 1), tmp);
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
+ build_int_cst (type, -1),
+ build_int_cst (type, 0));
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type,
+ cond, build_int_cst (type, 1), tmp);
return 1;
}
if (sgn == -1)
{
tmp = gfc_build_const (type, integer_one_node);
- vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
+ vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
+ vartmp[1]);
}
se->expr = gfc_conv_powi (se, n, vartmp);
tree gfc_int4_type_node;
int kind;
int ikind;
+ int res_ikind_1, res_ikind_2;
gfc_se lse;
gfc_se rse;
- tree fndecl;
+ tree fndecl = NULL;
gfc_init_se (&lse, se);
gfc_conv_expr_val (&lse, expr->value.op.op1);
gfc_int4_type_node = gfc_get_int_type (4);
+ /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
+ library routine. But in the end, we have to convert the result back
+ if this case applies -- with res_ikind_K, we keep track whether operand K
+ falls into this case. */
+ res_ikind_1 = -1;
+ res_ikind_2 = -1;
+
kind = expr->value.op.op1->ts.kind;
switch (expr->value.op.op2->ts.type)
{
case 1:
case 2:
rse.expr = convert (gfc_int4_type_node, rse.expr);
+ res_ikind_2 = ikind;
/* Fall through. */
case 4:
case 1:
case 2:
if (expr->value.op.op1->ts.type == BT_INTEGER)
- lse.expr = convert (gfc_int4_type_node, lse.expr);
+ {
+ lse.expr = convert (gfc_int4_type_node, lse.expr);
+ res_ikind_1 = kind;
+ }
else
gcc_unreachable ();
/* Fall through. */
switch (kind)
{
case 0:
- fndecl = built_in_decls[BUILT_IN_POWIF];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break;
case 1:
- fndecl = built_in_decls[BUILT_IN_POWI];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break;
case 2:
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
+ break;
+
case 3:
- fndecl = built_in_decls[BUILT_IN_POWIL];
+ /* Use the __builtin_powil() only if real(kind=16) is
+ actually the C long double type. */
+ if (!gfc_real16_is_float128)
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
break;
default:
gcc_unreachable ();
}
}
- else
+
+ /* If we don't have a good builtin for this, go for the
+ library function. */
+ if (!fndecl)
fndecl = gfor_fndecl_math_powi[kind][ikind].real;
break;
break;
case BT_REAL:
- switch (kind)
- {
- case 4:
- fndecl = built_in_decls[BUILT_IN_POWF];
- break;
- case 8:
- fndecl = built_in_decls[BUILT_IN_POW];
- break;
- case 10:
- case 16:
- fndecl = built_in_decls[BUILT_IN_POWL];
- break;
- default:
- gcc_unreachable ();
- }
+ fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
break;
case BT_COMPLEX:
- switch (kind)
- {
- case 4:
- fndecl = built_in_decls[BUILT_IN_CPOWF];
- break;
- case 8:
- fndecl = built_in_decls[BUILT_IN_CPOW];
- break;
- case 10:
- case 16:
- fndecl = built_in_decls[BUILT_IN_CPOWL];
- break;
- default:
- gcc_unreachable ();
- }
+ fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
break;
default:
se->expr = build_call_expr_loc (input_location,
fndecl, 2, lse.expr, rse.expr);
+
+ /* Convert the result back if it is of wrong integer kind. */
+ if (res_ikind_1 != -1 && res_ikind_2 != -1)
+ {
+ /* We want the maximum of both operand kinds as result. */
+ if (res_ikind_1 < res_ikind_2)
+ res_ikind_1 = res_ikind_2;
+ se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
+ }
}
tree var;
tree tmp;
- gcc_assert (types_compatible_p (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_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
- build_int_cst (gfc_charlen_type_node, 1));
+ tmp = fold_build2_loc (input_location, 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);
if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
/* Allocate a temporary to hold the result. */
var = gfc_create_var (type, "pstr");
tmp = gfc_call_malloc (&se->pre, type,
- fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
- fold_convert (TREE_TYPE (len),
- TYPE_SIZE (type))));
+ fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (len), len,
+ fold_convert (TREE_TYPE (len),
+ TYPE_SIZE (type))));
gfc_add_modify (&se->pre, var, tmp);
/* Free the temporary afterwards. */
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len == NULL_TREE)
{
- len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
- lse.string_length, rse.string_length);
+ len = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (lse.string_length),
+ lse.string_length, rse.string_length);
}
type = build_pointer_type (type);
switch (expr->value.op.op)
{
case INTRINSIC_PARENTHESES:
- if (expr->ts.type == BT_REAL
- || expr->ts.type == BT_COMPLEX)
+ if ((expr->ts.type == BT_REAL
+ || expr->ts.type == BT_COMPLEX)
+ && gfc_option.flag_protect_parens)
{
gfc_conv_unary_op (PAREN_EXPR, se, expr);
gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
rse.string_length, rse.expr,
- expr->value.op.op1->ts.kind);
+ expr->value.op.op1->ts.kind,
+ code);
rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
gfc_add_block_to_block (&lse.post, &rse.post);
}
if (lop)
{
/* The result of logical ops is always boolean_type_node. */
- tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
+ tmp = fold_build2_loc (input_location, code, boolean_type_node,
+ lse.expr, rse.expr);
se->expr = convert (type, tmp);
}
else
- se->expr = fold_build2 (code, type, lse.expr, rse.expr);
+ se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
/* Add the post blocks. */
gfc_add_block_to_block (&se->post, &rse.post);
/* If a string's length is one, we convert it to a single character. */
-static tree
-string_to_single_character (tree len, tree str, int kind)
+tree
+gfc_string_to_single_character (tree len, tree str, int kind)
{
- 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)
+ if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+ || !POINTER_TYPE_P (TREE_TYPE (str)))
+ return NULL_TREE;
+
+ if (TREE_INT_CST_LOW (len) == 1)
{
str = fold_convert (gfc_get_pchar_type (kind), str);
- return build_fold_indirect_ref_loc (input_location,
- str);
+ return build_fold_indirect_ref_loc (input_location, str);
+ }
+
+ if (kind == 1
+ && TREE_CODE (str) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
+ && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
+ && array_ref_low_bound (TREE_OPERAND (str, 0))
+ == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
+ && TREE_INT_CST_LOW (len) > 1
+ && TREE_INT_CST_LOW (len)
+ == (unsigned HOST_WIDE_INT)
+ TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
+ {
+ tree ret = fold_convert (gfc_get_pchar_type (kind), str);
+ ret = build_fold_indirect_ref_loc (input_location, ret);
+ if (TREE_CODE (ret) == INTEGER_CST)
+ {
+ tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
+ int i, length = TREE_STRING_LENGTH (string_cst);
+ const char *ptr = TREE_STRING_POINTER (string_cst);
+
+ for (i = 1; i < length; i++)
+ if (ptr[i] != ' ')
+ return NULL_TREE;
+
+ return ret;
+ }
}
return NULL_TREE;
gfc_typespec ts;
gfc_clear_ts (&ts);
- *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
+ *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ (int)(*expr)->value.character.string[0]);
if ((*expr)->ts.kind != gfc_c_int_kind)
{
/* The expr needs to be compatible with a C int. If the
{
if ((*expr)->ref == NULL)
{
- se->expr = string_to_single_character
+ se->expr = gfc_string_to_single_character
(build_int_cst (integer_type_node, 1),
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
gfc_get_symbol_decl
else
{
gfc_conv_variable (se, *expr);
- se->expr = string_to_single_character
+ se->expr = gfc_string_to_single_character
(build_int_cst (integer_type_node, 1),
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
se->expr),
}
}
+/* Helper function for gfc_build_compare_string. Return LEN_TRIM value
+ if STR is a string literal, otherwise return -1. */
+
+static int
+gfc_optimize_len_trim (tree len, tree str, int kind)
+{
+ if (kind == 1
+ && TREE_CODE (str) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
+ && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
+ && array_ref_low_bound (TREE_OPERAND (str, 0))
+ == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
+ && TREE_INT_CST_LOW (len) >= 1
+ && TREE_INT_CST_LOW (len)
+ == (unsigned HOST_WIDE_INT)
+ TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
+ {
+ tree folded = fold_convert (gfc_get_pchar_type (kind), str);
+ folded = build_fold_indirect_ref_loc (input_location, folded);
+ if (TREE_CODE (folded) == INTEGER_CST)
+ {
+ tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
+ int length = TREE_STRING_LENGTH (string_cst);
+ const char *ptr = TREE_STRING_POINTER (string_cst);
+
+ for (; length > 0; length--)
+ if (ptr[length - 1] != ' ')
+ break;
+
+ return length;
+ }
+ }
+ return -1;
+}
/* 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, int kind)
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
+ enum tree_code code)
{
tree sc1;
tree sc2;
- tree tmp;
+ tree fndecl;
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
- sc1 = string_to_single_character (len1, str1, kind);
- sc2 = string_to_single_character (len2, str2, kind);
+ sc1 = gfc_string_to_single_character (len1, str1, kind);
+ sc2 = gfc_string_to_single_character (len2, str2, kind);
if (sc1 != NULL_TREE && sc2 != NULL_TREE)
{
/* Deal with single character specially. */
sc1 = fold_convert (integer_type_node, sc1);
sc2 = fold_convert (integer_type_node, sc2);
- tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
- }
+ return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
+ sc1, sc2);
+ }
+
+ if ((code == EQ_EXPR || code == NE_EXPR)
+ && optimize
+ && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
+ {
+ /* If one string is a string literal with LEN_TRIM longer
+ than the length of the second string, the strings
+ compare unequal. */
+ int len = gfc_optimize_len_trim (len1, str1, kind);
+ if (len > 0 && compare_tree_int (len2, len) < 0)
+ return integer_one_node;
+ len = gfc_optimize_len_trim (len2, str2, kind);
+ if (len > 0 && compare_tree_int (len1, len) < 0)
+ return integer_one_node;
+ }
+
+ /* Build a call for the comparison. */
+ if (kind == 1)
+ fndecl = gfor_fndecl_compare_string;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_compare_string_char4;
else
- {
- /* Build a call for the comparison. */
- tree fndecl;
-
- if (kind == 1)
- fndecl = gfor_fndecl_compare_string;
- else if (kind == 4)
- fndecl = gfor_fndecl_compare_string_char4;
- else
- gcc_unreachable ();
-
- tmp = build_call_expr_loc (input_location,
- fndecl, 4, len1, str1, len2, str2);
- }
+ gcc_unreachable ();
- return tmp;
+ return build_call_expr_loc (input_location, fndecl, 4,
+ len1, str1, len2, str2);
}
{
gfc_se comp_se;
gfc_expr *e2;
+ expr_t old_type;
+
gfc_init_se (&comp_se, NULL);
e2 = gfc_copy_expr (e);
+ /* We have to restore the expr type later so that gfc_free_expr frees
+ the exact same thing that was allocated.
+ TODO: This is ugly. */
+ old_type = e2->expr_type;
e2->expr_type = EXPR_VARIABLE;
gfc_conv_expr (&comp_se, e2);
+ e2->expr_type = old_type;
gfc_free_expr (e2);
return build_fold_addr_expr_loc (input_location, comp_se.expr);
}
-/* Select a class typebound procedure at runtime. */
-static void
-select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
- tree declared, gfc_expr *expr)
-{
- tree end_label;
- tree label;
- tree tmp;
- tree hash;
- stmtblock_t body;
- gfc_class_esym_list *next_elist, *tmp_elist;
- gfc_se tmpse;
-
- /* Convert the hash expression. */
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, elist->hash_value);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- hash = gfc_evaluate_now (tmpse.expr, &se->pre);
- gfc_add_block_to_block (&se->post, &tmpse.post);
-
- /* Fix the function type to be that of the declared type method. */
- declared = gfc_create_var (TREE_TYPE (declared), "method");
-
- end_label = gfc_build_label_decl (NULL_TREE);
-
- gfc_init_block (&body);
-
- /* Go through the list of extensions. */
- for (; elist; elist = next_elist)
- {
- /* This case has already been added. */
- if (elist->derived == NULL)
- goto free_elist;
-
- /* Skip abstract base types. */
- if (elist->derived->attr.abstract)
- goto free_elist;
-
- /* Run through the chain picking up all the cases that call the
- same procedure. */
- tmp_elist = elist;
- for (; elist; elist = elist->next)
- {
- tree cval;
-
- if (elist->esym != tmp_elist->esym)
- continue;
-
- cval = build_int_cst (TREE_TYPE (hash),
- elist->derived->hash_value);
- /* Build a label for the hash value. */
- label = gfc_build_label_decl (NULL_TREE);
- tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
- cval, NULL_TREE, label);
- gfc_add_expr_to_block (&body, tmp);
-
- /* Null the reference the derived type so that this case is
- not used again. */
- elist->derived = NULL;
- }
-
- elist = tmp_elist;
-
- /* Get a pointer to the procedure, */
- tmp = gfc_get_symbol_decl (elist->esym);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- {
- gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
- /* Assign the pointer to the appropriate procedure. */
- gfc_add_modify (&body, declared,
- fold_convert (TREE_TYPE (declared), tmp));
-
- /* Break to the end of the construct. */
- tmp = build1_v (GOTO_EXPR, end_label);
- gfc_add_expr_to_block (&body, tmp);
-
- /* Free the elists as we go; freeing them in gfc_free_expr causes
- segfaults because it occurs too early and too often. */
- free_elist:
- next_elist = elist->next;
- if (elist->hash_value)
- gfc_free_expr (elist->hash_value);
- gfc_free (elist);
- elist = NULL;
- }
-
- /* Default is an error. */
- label = gfc_build_label_decl (NULL_TREE);
- tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
- NULL_TREE, NULL_TREE, label);
- gfc_add_expr_to_block (&body, tmp);
- tmp = gfc_trans_runtime_error (true, &expr->where,
- "internal error: bad hash value in dynamic dispatch");
- gfc_add_expr_to_block (&body, tmp);
-
- /* Write the switch expression. */
- tmp = gfc_finish_block (&body);
- tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- tmp = build1_v (LABEL_EXPR, end_label);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- se->expr = declared;
- return;
-}
-
-
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
- if (expr && expr->symtree
- && expr->value.function.class_esym)
- {
- 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 = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
- select_class_proc (se, expr->value.function.class_esym,
- tmp, expr);
- return;
- }
-
if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
sym->new_sym->n.sym->formal = NULL;
gfc_free_symbol (sym->new_sym->n.sym);
gfc_free_expr (sym->expr);
- gfc_free (sym->new_sym);
- gfc_free (sym);
+ free (sym->new_sym);
+ free (sym);
}
for (cl = mapping->charlens; cl; cl = nextcl)
{
nextcl = cl->next;
gfc_free_expr (cl->length);
- gfc_free (cl);
+ free (cl);
}
}
}
else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
{
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (desc, dim),
- gfc_conv_descriptor_lbound_get (desc, dim));
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- GFC_TYPE_ARRAY_LBOUND (type, n),
- tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, dim),
+ gfc_conv_descriptor_lbound_get (desc, dim));
+ tmp = fold_build2_loc (input_location, 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);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, n),
+ GFC_TYPE_ARRAY_STRIDE (type, n));
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
}
offset = gfc_evaluate_now (offset, block);
GFC_TYPE_ARRAY_OFFSET (type) = offset;
new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.contiguous = sym->attr.contiguous;
+ new_sym->attr.codimension = sym->attr.codimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
- gfc_constructor * c)
+ gfc_constructor_base base)
{
- for (; c; c = c->next)
+ gfc_constructor *c;
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
gfc_apply_interface_mapping_to_expr (mapping, c->expr);
if (c->iterator)
break;
case GFC_ISYM_SIZE:
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
return false;
}
- tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+ tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1));
tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
if (new_expr)
new_expr = gfc_multiply (new_expr, tmp);
/* TODO These implementations of lbound and ubound do not limit if
the size < 0, according to F95's 13.14.53 and 13.14.113. */
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
expr->symtree = sym->new_sym;
else if (sym->expr)
gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+ /* Replace base type for polymorphic arguments. */
+ if (expr->ref && expr->ref->type == REF_COMPONENT
+ && sym->expr && sym->expr->ts.type == BT_CLASS)
+ expr->ref->u.c.sym = sym->expr->ts.u.derived;
}
/* ...and to subexpressions in expr->value. */
|| 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.u.cl->backend_decl;
- else
- loop.temp_ss->string_length = NULL;
+ loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
+ ? expr->ts.u.cl->backend_decl
+ : NULL),
+ loop.dimen);
parmse->string_length = loop.temp_ss->string_length;
- 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);
gfc_conv_expr (&rse, expr);
gfc_conv_tmp_array_ref (&lse);
- gfc_advance_se_ss_chain (&lse);
if (intent != INTENT_OUT)
{
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
{
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 = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ tmp, rse.loop->from[n]);
+ tmp = fold_build2_loc (input_location, 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_str = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ rse.loop->to[n-1], rse.loop->from[n-1]);
+ tmp_str = fold_build2_loc (input_location, 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_loc (input_location, 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]);
+ tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ tmp_index, rse.loop->from[0]);
gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
- tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- rse.loop->loopvar[0], offset);
+ tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ rse.loop->loopvar[0], offset);
/* Now use the offset for the reference. */
tmp = build_fold_indirect_ref_loc (input_location,
gcc_assert (lse.ss == gfc_ss_terminator);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
{
tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
gfc_rank_cst[n]);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&parmse->pre,
parmse->expr,
gfc_rank_cst[n],
gfc_rank_cst[n],
gfc_index_one_node);
size = gfc_evaluate_now (size, &parmse->pre);
- offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- offset, size);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, size);
offset = gfc_evaluate_now (offset, &parmse->pre);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- rse.loop->to[n], rse.loop->from[n]);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type,
- size, tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ rse.loop->to[n], rse.loop->from[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
}
gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
- cmp = gfc_find_component (declared, "$vptr", true, true);
- ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
- var, cmp->backend_decl, NULL_TREE);
+ cmp = gfc_find_component (declared, "_vptr", true, true);
+ ctree = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
/* Remember the vtab corresponds to the derived type
- not to the class declared type. */
+ not to the class declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
- cmp = gfc_find_component (declared, "$data", true, true);
- ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
- var, cmp->backend_decl, NULL_TREE);
+ cmp = gfc_find_component (declared, "_data", true, true);
+ ctree = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
ss = gfc_walk_expr (e);
if (ss == gfc_ss_terminator)
{
+ parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
+ parmse->ss = ss;
gfc_conv_expr (parmse, e);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
- se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
- fptrse.expr,
- fold_convert (TREE_TYPE (fptrse.expr),
- cptrse.expr));
+ se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (fptrse.expr),
+ fptrse.expr,
+ fold_convert (TREE_TYPE (fptrse.expr),
+ cptrse.expr));
return 1;
}
if (arg->next == NULL)
/* Only given one arg so generate a null and do a
not-equal comparison against the first arg. */
- se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
- fold_convert (TREE_TYPE (arg1se.expr),
- null_pointer_node));
+ se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ arg1se.expr,
+ fold_convert (TREE_TYPE (arg1se.expr),
+ null_pointer_node));
else
{
tree eq_expr;
gfc_add_block_to_block (&se->post, &arg2se.post);
/* Generate test to compare that the two args are equal. */
- eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
- arg1se.expr, arg2se.expr);
+ eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ arg1se.expr, arg2se.expr);
/* Generate test to ensure that the first arg is not null. */
- not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
- arg1se.expr, null_pointer_node);
+ not_null_expr = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ arg1se.expr, null_pointer_node);
/* Finally, the generated test must check that both arg1 is not
NULL and that it is equal to the second arg. */
- se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- not_null_expr, eq_expr);
+ se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node,
+ not_null_expr, eq_expr);
}
return 1;
int
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * arg, gfc_expr * expr,
- tree append_args)
+ gfc_actual_arglist * args, gfc_expr * expr,
+ VEC(tree,gc) *append_args)
{
gfc_interface_mapping mapping;
- tree arglist;
- tree retargs;
+ VEC(tree,gc) *arglist;
+ VEC(tree,gc) *retargs;
tree tmp;
tree fntype;
gfc_se parmse;
tree type;
tree var;
tree len;
- tree stringargs;
+ VEC(tree,gc) *stringargs;
tree result = NULL;
gfc_formal_arglist *formal;
+ gfc_actual_arglist *arg;
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
stmtblock_t post;
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
+ int arglen;
- arglist = NULL_TREE;
- retargs = NULL_TREE;
- stringargs = NULL_TREE;
+ arglist = NULL;
+ retargs = NULL;
+ stringargs = NULL;
var = NULL_TREE;
len = NULL_TREE;
gfc_clear_ts (&ts);
if (sym->from_intmod == INTMOD_ISO_C_BINDING
- && conv_isocbinding_procedure (se, sym, arg))
+ && conv_isocbinding_procedure (se, sym, args))
return 0;
gfc_is_proc_ptr_comp (expr, &comp);
if (!sym->attr.elemental)
{
gcc_assert (se->ss->type == GFC_SS_FUNCTION);
- if (se->ss->useflags)
- {
+ if (se->ss->useflags)
+ {
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
|| (comp && comp->attr.dimension));
- gcc_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 0;
- }
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ return 0;
+ }
}
info = &se->ss->data.info;
}
}
/* Evaluate the arguments. */
- for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
+
if (e == NULL)
{
-
if (se->ignore_optional)
{
/* Some intrinsics have already been resolved to the correct
}
else if (arg->label)
{
- has_alternate_specifier = 1;
- continue;
+ has_alternate_specifier = 1;
+ continue;
}
else
{
/* Pass a NULL pointer for an absent arg. */
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
- if (arg->missing_arg_type == BT_CHARACTER)
+ if (arg->missing_arg_type == BT_CHARACTER)
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
+ else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+ {
+ /* Pass a NULL pointer to denote an absent arg. */
+ gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+ gfc_init_se (&parmse, NULL);
+ parmse.expr = null_pointer_node;
+ if (arg->missing_arg_type == BT_CHARACTER)
+ parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+ }
else if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_DERIVED)
{
else if (se->ss && se->ss->useflags)
{
/* An elemental function inside a scalarized loop. */
- gfc_init_se (&parmse, se);
- gfc_conv_expr_reference (&parmse, e);
+ gfc_init_se (&parmse, se);
+ gfc_conv_expr_reference (&parmse, e);
parm_kind = ELEMENTAL;
}
else
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
- {
+ {
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.cray_pointee
&& fsym && fsym->attr.flavor == FL_PROCEDURE)
tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
true, NULL);
gfc_add_expr_to_block (&block, tmp);
- tmp = fold_build2 (MODIFY_EXPR, void_type_node,
- parmse.expr, null_pointer_node);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, parmse.expr,
+ null_pointer_node);
gfc_add_expr_to_block (&block, tmp);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
{
- tmp = fold_build3 (COND_EXPR, void_type_node,
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node,
gfc_conv_expr_present (e->symtree->n.sym),
gfc_finish_block (&block),
build_empty_stmt (input_location));
&& fsym->attr.flavor != FL_PROCEDURE)
|| (fsym->attr.proc_pointer
&& !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy))
- || (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy))
+ || (fsym->attr.proc_pointer
+ && e->expr_type == EXPR_VARIABLE
&& gfc_is_proc_ptr_comp (e, NULL))
|| fsym->attr.allocatable))
{
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;
+ bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as->type != AS_ASSUMED_SHAPE;
+ && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
if (comp)
f = f || !comp->attr.always_explicit;
else
f = f || !sym->attr.always_explicit;
+ /* If the argument is a function call that may not create
+ a temporary for the result, we have to check that we
+ can do it, i.e. that there is no alias between this
+ argument and another one. */
+ if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
+ {
+ gfc_expr *iarg;
+ sym_intent intent;
+
+ if (fsym != NULL)
+ intent = fsym->attr.intent;
+ else
+ intent = INTENT_UNKNOWN;
+
+ if (gfc_check_fncall_dependency (e, intent, sym, args,
+ NOT_ELEMENTAL))
+ parmse.force_tmp = 1;
+
+ iarg = e->value.function.actual->expr;
+
+ /* Temporary needed if aliasing due to host association. */
+ if (sym->attr.contained
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && !sym->attr.use_assoc
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->ns == iarg->symtree->n.sym->ns)
+ parmse.force_tmp = 1;
+
+ /* Ditto within module. */
+ if (sym->attr.use_assoc
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->module == iarg->symtree->n.sym->module)
+ parmse.force_tmp = 1;
+ }
+
if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e))
/* The actual argument is a component reference to an
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
- tmp = fold_build3 (COND_EXPR, void_type_node,
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node,
gfc_conv_expr_present (e->symtree->n.sym),
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
&& ((e->rank > 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank > 0
- && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
- || fsym->as->type == AS_DEFERRED))))
+ && (fsym == NULL
+ || (fsym-> as
+ && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_DEFERRED))))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
}
if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
{
- symbol_attribute *attr;
+ symbol_attribute attr;
char *msg;
tree cond;
- if (e->expr_type == EXPR_VARIABLE)
- attr = &e->symtree->n.sym->attr;
- else if (e->expr_type == EXPR_FUNCTION)
- {
- /* For intrinsic functions, the gfc_attr are not available. */
- if (e->symtree->n.sym->attr.generic && e->value.function.isym)
- goto end_pointer_check;
-
- if (e->symtree->n.sym->attr.generic)
- attr = &e->value.function.esym->attr;
- else
- attr = &e->symtree->n.sym->result->attr;
- }
+ if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
+ attr = gfc_expr_attr (e);
else
goto end_pointer_check;
- if (attr->optional)
+ /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
+ allocatable to an optional dummy, cf. 12.5.2.12. */
+ if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ goto end_pointer_check;
+
+ if (attr.optional)
{
/* If the actual argument is an optional pointer/allocatable and
the formal argument takes an nonpointer optional value,
it is invalid to pass a non-present argument on, even
though there is no technical reason for this in gfortran.
See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
- tree present, nullptr, type;
+ tree present, null_ptr, type;
- if (attr->allocatable
+ if (attr.allocatable
&& (fsym == NULL || !fsym->attr.allocatable))
asprintf (&msg, "Allocatable actual argument '%s' is not "
"allocated or not present", e->symtree->n.sym->name);
- else if (attr->pointer
+ else if (attr.pointer
&& (fsym == NULL || !fsym->attr.pointer))
asprintf (&msg, "Pointer actual argument '%s' is not "
"associated or not present",
e->symtree->n.sym->name);
- else if (attr->proc_pointer
+ else if (attr.proc_pointer
&& (fsym == NULL || !fsym->attr.proc_pointer))
asprintf (&msg, "Proc-pointer actual argument '%s' is not "
"associated or not present",
present = gfc_conv_expr_present (e->symtree->n.sym);
type = TREE_TYPE (present);
- present = fold_build2 (EQ_EXPR, boolean_type_node, present,
- fold_convert (type, null_pointer_node));
+ present = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, present,
+ fold_convert (type,
+ null_pointer_node));
type = TREE_TYPE (parmse.expr);
- nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
- fold_convert (type, null_pointer_node));
- cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
- present, nullptr);
+ null_ptr = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, parmse.expr,
+ fold_convert (type,
+ null_pointer_node));
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, present, null_ptr);
}
else
{
- if (attr->allocatable
+ if (attr.allocatable
&& (fsym == NULL || !fsym->attr.allocatable))
asprintf (&msg, "Allocatable actual argument '%s' is not "
"allocated", e->symtree->n.sym->name);
- else if (attr->pointer
+ else if (attr.pointer
&& (fsym == NULL || !fsym->attr.pointer))
asprintf (&msg, "Pointer actual argument '%s' is not "
"associated", e->symtree->n.sym->name);
- else if (attr->proc_pointer
+ else if (attr.proc_pointer
&& (fsym == NULL || !fsym->attr.proc_pointer))
asprintf (&msg, "Proc-pointer actual argument '%s' is not "
"associated", e->symtree->n.sym->name);
else
goto end_pointer_check;
+ tmp = parmse.expr;
+
+ /* If the argument is passed by value, we need to strip the
+ INDIRECT_REF. */
+ if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
- null_pointer_node));
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
}
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg);
- gfc_free (msg);
+ free (msg);
}
end_pointer_check:
+ /* Deferred length dummies pass the character length by reference
+ so that the value can be returned. */
+ if (parmse.string_length && fsym && fsym->ts.deferred)
+ {
+ tmp = parmse.string_length;
+ if (TREE_CODE (tmp) != VAR_DECL)
+ tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
+ parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
/* Character strings are passed as two parameters, a length and a
pointer - except for Bind(c) which only passes the pointer. */
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
- stringargs = gfc_chainon_list (stringargs, parmse.string_length);
+ VEC_safe_push (tree, gc, stringargs, parmse.string_length);
+
+ /* For descriptorless coarrays and assumed-shape coarray dummies, we
+ pass the token and the offset as additional arguments. */
+ if (fsym && fsym->attr.codimension
+ && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && !fsym->attr.allocatable
+ && e == NULL)
+ {
+ /* Token and offset. */
+ VEC_safe_push (tree, gc, stringargs, null_pointer_node);
+ VEC_safe_push (tree, gc, stringargs,
+ build_int_cst (gfc_array_index_type, 0));
+ gcc_assert (fsym->attr.optional);
+ }
+ else if (fsym && fsym->attr.codimension
+ && !fsym->attr.allocatable
+ && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree caf_decl, caf_type;
+ tree offset, tmp2;
+
+ caf_decl = get_tree_for_caf_expr (e);
+ caf_type = TREE_TYPE (caf_decl);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ tmp = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
+
+ VEC_safe_push (tree, gc, stringargs, tmp);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ offset = build_int_cst (gfc_array_index_type, 0);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+ offset = GFC_DECL_CAF_OFFSET (caf_decl);
+ else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+ offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
+ else
+ offset = build_int_cst (gfc_array_index_type, 0);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ tmp = gfc_conv_descriptor_data_get (caf_decl);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (caf_type));
+ tmp = caf_decl;
+ }
+
+ if (fsym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+ (TREE_TYPE (parmse.expr))));
+ tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ tmp2 = gfc_conv_descriptor_data_get (tmp2);
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ tmp2 = parmse.expr;
+ }
- arglist = gfc_chainon_list (arglist, parmse.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type, tmp2),
+ fold_convert (gfc_array_index_type, tmp));
+ offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+
+ VEC_safe_push (tree, gc, stringargs, offset);
+ }
+
+ VEC_safe_push (tree, gc, arglist, parmse.expr);
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
we take the character length of the first argument for the result.
For dummies, we have to look through the formal argument list for
this function and use the character length found there.*/
- if (!sym->attr.dummy)
- cl.backend_decl = TREE_VALUE (stringargs);
+ if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
+ cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
+ else if (!sym->attr.dummy)
+ cl.backend_decl = VEC_index (tree, stringargs, 0);
else
{
formal = sym->ns->proc_name->formal;
gfc_add_block_to_block (&se->post, &parmse.post);
tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
- tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
- build_int_cst (gfc_charlen_type_node, 0));
+ tmp = fold_build2_loc (input_location, MAX_EXPR,
+ gfc_charlen_type_node, tmp,
+ build_int_cst (gfc_charlen_type_node, 0));
cl.backend_decl = tmp;
}
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- result = build_fold_indirect_ref_loc (input_location,
- se->expr);
- retargs = gfc_chainon_list (retargs, se->expr);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must do the automatic reallocation.
+ TODO - deal with intrinsics, without using a temporary. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->loop_chain
+ && se->ss->loop_chain->is_alloc_lhs
+ && !expr->value.function.isym
+ && sym->result->as != NULL)
+ {
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se,
+ sym->result->as);
+
+ /* Perform the automatic reallocation. */
+ tmp = gfc_alloc_allocatable_for_assignment (se->loop,
+ expr, NULL);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Pass the temporary as the first argument. */
+ result = info->descriptor;
+ }
+ else
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ VEC_safe_push (tree, gc, retargs, se->expr);
}
else if (comp && comp->attr.dimension)
{
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&comp->ts);
- info->dimen = se->loop->dimen;
+ gcc_assert (info->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must not generate the function call
+ here but should just send back the results of the mapping.
+ This is signalled by the function ss being flagged. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->is_alloc_lhs)
+ {
+ gfc_free_interface_mapping (&mapping);
+ return has_alternate_specifier;
+ }
+
/* Create 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. */
callee_alloc = comp->attr.allocatable || comp->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- NULL_TREE, false, !comp->attr.pointer,
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
+ tmp, NULL_TREE, false,
+ !comp->attr.pointer,
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
result = info->descriptor;
tmp = gfc_build_addr_expr (NULL_TREE, result);
- retargs = gfc_chainon_list (retargs, tmp);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
else if (!comp && sym->result->attr.dimension)
{
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&ts);
- info->dimen = se->loop->dimen;
+ gcc_assert (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);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must not generate the function call
+ here but should just send back the results of the mapping.
+ This is signalled by the function ss being flagged. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->is_alloc_lhs)
+ {
+ gfc_free_interface_mapping (&mapping);
+ return has_alternate_specifier;
+ }
+
/* Create 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. */
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- NULL_TREE, false, !sym->attr.pointer,
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
+ tmp, NULL_TREE, false,
+ !sym->attr.pointer,
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
result = info->descriptor;
tmp = gfc_build_addr_expr (NULL_TREE, result);
- retargs = gfc_chainon_list (retargs, tmp);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
{
else
var = gfc_conv_string_tmp (se, type, len);
- retargs = gfc_chainon_list (retargs, var);
+ VEC_safe_push (tree, gc, retargs, var);
}
else
{
type = gfc_get_complex_type (ts.kind);
var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
- retargs = gfc_chainon_list (retargs, var);
+ VEC_safe_push (tree, gc, retargs, var);
+ }
+
+ if (ts.type == BT_CHARACTER && ts.deferred
+ && (sym->attr.allocatable || sym->attr.pointer))
+ {
+ tmp = len;
+ if (TREE_CODE (tmp) != VAR_DECL)
+ tmp = gfc_evaluate_now (len, &se->pre);
+ len = gfc_build_addr_expr (NULL_TREE, tmp);
}
/* Add the string length to the argument list. */
if (ts.type == BT_CHARACTER)
- retargs = gfc_chainon_list (retargs, len);
+ VEC_safe_push (tree, gc, retargs, len);
}
gfc_free_interface_mapping (&mapping);
+ /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
+ arglen = (VEC_length (tree, arglist)
+ + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
+ VEC_reserve_exact (tree, gc, retargs, arglen);
+
/* Add the return arguments. */
- arglist = chainon (retargs, arglist);
+ VEC_splice (tree, retargs, arglist);
/* Add the hidden string length parameters to the arguments. */
- arglist = chainon (arglist, stringargs);
+ VEC_splice (tree, retargs, stringargs);
/* We may want to append extra arguments here. This is used e.g. for
calls to libgfortran_matmul_??, which need extra information. */
- if (append_args != NULL_TREE)
- arglist = chainon (arglist, append_args);
+ if (!VEC_empty (tree, append_args))
+ VEC_splice (tree, retargs, append_args);
+ arglist = retargs;
/* Generate the actual call. */
conv_function_val (se, sym, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
with other functions. For dummy arguments, the typing is done to
- to this result, even if it has to be repeated for each call. */
+ this result, even if it has to be repeated for each call. */
if (has_alternate_specifier
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
{
}
fntype = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
+ se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
/* 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 || sym->attr.allocatable)
- && !gfc_is_proc_ptr_comp (expr, NULL))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+ || (comp && (comp->attr.pointer || comp->attr.allocatable))))
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
/* f2c calling conventions require a scalar default real function to
return a double precision result. Convert this back to default
if (!se->direct_byref)
{
- if (sym->attr.dimension || (comp && comp->attr.dimension))
+ if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
{
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* 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);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ tmp, info->data);
gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
gfc_msg_fault);
}
else
se->expr = var;
- se->string_length = len;
+ if (!ts.deferred)
+ se->string_length = len;
+ else if (sym->attr.allocatable || sym->attr.pointer)
+ se->string_length = cl.backend_decl;
}
else
{
/* For a simple char type, we can call memset(). */
if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
return build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMSET], 3, start,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, start,
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
lang_hooks.to_target_charset (' ')),
size);
gfc_init_block (&loop);
/* Exit condition. */
- cond = fold_build2 (LE_EXPR, boolean_type_node, i,
- fold_convert (sizetype, integer_zero_node));
+ cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
+ build_zero_cst (sizetype));
tmp = build1_v (GOTO_EXPR, exit_label);
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
- build_empty_stmt (input_location));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&loop, tmp);
/* Assignment. */
- gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
- build_int_cst (type,
- lang_hooks.to_target_charset (' ')));
+ gfc_add_modify (&loop,
+ fold_build1_loc (input_location, INDIRECT_REF, type, el),
+ build_int_cst (type, lang_hooks.to_target_charset (' ')));
/* Increment loop variables. */
- gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
- TYPE_SIZE_UNIT (type)));
- gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
- TREE_TYPE (el), el,
- TYPE_SIZE_UNIT (type)));
+ gfc_add_modify (&loop, i,
+ fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
+ TYPE_SIZE_UNIT (type)));
+ gfc_add_modify (&loop, el,
+ fold_build_pointer_plus_loc (input_location,
+ el, TYPE_SIZE_UNIT (type)));
/* Making the loop... actually loop! */
tmp = gfc_finish_block (&loop);
if (slength != NULL_TREE)
{
slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
- ssc = string_to_single_character (slen, src, skind);
+ ssc = gfc_string_to_single_character (slen, src, skind);
}
else
{
if (dlength != NULL_TREE)
{
dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
- dsc = string_to_single_character (slen, dest, dkind);
+ dsc = gfc_string_to_single_character (dlen, dest, dkind);
}
else
{
dsc = dest;
}
- if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
- ssc = string_to_single_character (slen, src, skind);
- if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
- dsc = string_to_single_character (dlen, dest, dkind);
-
-
/* Assign directly if the types are compatible. */
if (dsc != NULL_TREE && ssc != NULL_TREE
&& TREE_TYPE (dsc) == TREE_TYPE (ssc))
}
/* Do nothing if the destination length is zero. */
- cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
- build_int_cst (size_type_node, 0));
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
+ build_int_cst (size_type_node, 0));
/* The following code was previously in _gfortran_copy_string:
/* For non-default character kinds, we have to multiply the string
length by the base type size. */
chartype = gfc_get_char_type (dkind);
- slen = fold_build2 (MULT_EXPR, size_type_node,
- fold_convert (size_type_node, slen),
- fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
- dlen = fold_build2 (MULT_EXPR, size_type_node,
- fold_convert (size_type_node, dlen),
- fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
-
- if (dlength)
+ slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, slen),
+ fold_convert (size_type_node,
+ TYPE_SIZE_UNIT (chartype)));
+ dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, dlen),
+ fold_convert (size_type_node,
+ TYPE_SIZE_UNIT (chartype)));
+
+ if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
dest = fold_convert (pvoid_type_node, dest);
else
dest = gfc_build_addr_expr (pvoid_type_node, dest);
- if (slength)
+ if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
src = fold_convert (pvoid_type_node, src);
else
src = gfc_build_addr_expr (pvoid_type_node, src);
/* Truncate string if source is too long. */
- cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
+ cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
+ dlen);
tmp2 = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE],
- 3, dest, src, dlen);
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src, dlen);
/* Else copy and pad with spaces. */
tmp3 = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE],
- 3, dest, src, slen);
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src, slen);
- tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
- fold_convert (sizetype, slen));
+ tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
tmp4 = fill_with_spaces (tmp4, chartype,
- fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
- dlen, slen));
+ fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE(dlen), dlen, slen));
gfc_init_block (&tempblock);
gfc_add_expr_to_block (&tempblock, tmp3);
tmp3 = gfc_finish_block (&tempblock);
/* The whole copy_string function is there. */
- tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
- build_empty_stmt (input_location));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
+ tmp2, tmp3);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
}
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));
+ saved_vars = XCNEWVEC (gfc_saved_var, n);
+ temp_vars = XCNEWVEC (tree, n);
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
{
gcc_assert (fargs->sym->attr.dimension == 0);
fsym = fargs->sym;
- /* 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)
{
/* Copy string arguments. */
- tree arglen;
+ tree arglen;
- gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+ gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
&& fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
- arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- tmp = gfc_build_addr_expr (build_pointer_type (type),
- temp_vars[n]);
+ /* Create a temporary to hold the value. */
+ if (fsym->ts.u.cl->backend_decl == NULL_TREE)
+ fsym->ts.u.cl->backend_decl
+ = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
- gfc_conv_expr (&rse, args->expr);
- gfc_conv_string_parameter (&rse);
- gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_block_to_block (&se->pre, &rse.pre);
+ type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
+
+ arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+
+ gfc_conv_expr (&rse, args->expr);
+ gfc_conv_string_parameter (&rse);
+ gfc_add_block_to_block (&se->pre, &lse.pre);
+ gfc_add_block_to_block (&se->pre, &rse.pre);
- gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+ gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
rse.string_length, rse.expr, fsym->ts.kind);
- gfc_add_block_to_block (&se->pre, &lse.post);
- gfc_add_block_to_block (&se->pre, &rse.post);
+ 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. */
+
+ /* Create a temporary to hold the value. */
+ type = gfc_typenode_for_spec (&fsym->ts);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
+
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
/* 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);
+ free (saved_vars);
}
if (!sym)
sym = expr->symtree->n.sym;
- gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
- NULL_TREE);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
}
-static void
-gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
-{
- 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);
-}
+/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
+
+static bool
+is_zero_initializer_p (gfc_expr * expr)
+{
+ if (expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ /* We ignore constants with prescribed memory representations for now. */
+ if (expr->representation.string)
+ return false;
+
+ switch (expr->ts.type)
+ {
+ case BT_INTEGER:
+ return mpz_cmp_si (expr->value.integer, 0) == 0;
+
+ case BT_REAL:
+ return mpfr_zero_p (expr->value.real)
+ && MPFR_SIGN (expr->value.real) >= 0;
+
+ case BT_LOGICAL:
+ return expr->value.logical == 0;
+
+ case BT_COMPLEX:
+ return mpfr_zero_p (mpc_realref (expr->value.complex))
+ && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
+ && mpfr_zero_p (mpc_imagref (expr->value.complex))
+ && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
+
+ default:
+ break;
+ }
+ return false;
+}
+
+
+static void
+gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
+{
+ 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);
+}
/* Build a static initializer. EXPR is the expression for the initial value.
tree
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
- bool array, bool pointer)
+ bool array, bool pointer, bool procptr)
{
gfc_se se;
- if (!(expr || pointer))
+ if (!(expr || pointer || procptr))
return NULL_TREE;
/* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
{
gfc_symbol *derived = expr->ts.u.derived;
- expr = gfc_int_expr (0);
-
/* The derived symbol has already been converted to a (void *). Use
its kind. */
+ expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
expr->ts.f90_type = derived->ts.f90_type;
- expr->ts.kind = derived->ts.kind;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_constant (&se, expr);
+ gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
+ return se.expr;
}
- if (array)
+ if (array && !procptr)
{
+ tree ctor;
/* Arrays need special handling. */
if (pointer)
- return gfc_build_null_descriptor (type);
+ ctor = gfc_build_null_descriptor (type);
+ /* Special case assigning an array to zero. */
+ else if (is_zero_initializer_p (expr))
+ ctor = build_constructor (type, NULL);
else
- return gfc_conv_array_initializer (type, expr);
+ ctor = gfc_conv_array_initializer (type, expr);
+ TREE_STATIC (ctor) = 1;
+ return ctor;
+ }
+ else if (pointer || procptr)
+ {
+ if (!expr || expr->expr_type == EXPR_NULL)
+ return fold_convert (type, null_pointer_node);
+ else
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
+ return se.expr;
+ }
}
- else if (pointer)
- return fold_convert (type, null_pointer_node);
else
{
switch (ts->type)
case BT_DERIVED:
case BT_CLASS:
gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, expr, 1);
+ if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
+ gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
+ else
+ gfc_conv_structure (&se, expr, 1);
+ gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+ TREE_STATIC (se.expr) = 1;
return se.expr;
case BT_CHARACTER:
- return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
+ {
+ tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
+ TREE_STATIC (ctor) = 1;
+ return ctor;
+ }
default:
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, expr);
+ gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
return se.expr;
}
}
/* 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;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
/* Create a SS for the destination. */
- lss = gfc_get_ss ();
- lss->type = GFC_SS_COMPONENT;
- lss->expr = NULL;
+ lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
+ GFC_SS_COMPONENT);
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;
gfc_conv_expr (&rse, expr);
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
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);
-
+ gcc_assert (lss->shape != NULL);
+ gfc_free_shape (&lss->shape, cm->as->rank);
gfc_cleanup_loop (&loop);
return gfc_finish_block (&block);
/* Shift the bounds and set the offset accordingly. */
tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
- span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
- gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
+ span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ span, lbound);
gfc_conv_descriptor_ubound_set (&block, dest,
gfc_rank_cst[n], tmp);
gfc_conv_descriptor_lbound_set (&block, dest,
gfc_rank_cst[n], lbound);
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
gfc_conv_descriptor_lbound_get (dest,
gfc_rank_cst[n]),
gfc_conv_descriptor_stride_get (dest,
gfc_rank_cst[n]));
gfc_add_modify (&block, tmp2, tmp);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, tmp2);
gfc_conv_descriptor_offset_set (&block, dest, tmp);
}
null_pointer_node);
null_expr = gfc_finish_block (&block);
tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
- tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
+ tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
return build3_v (COND_EXPR, tmp,
null_expr, non_null_expr);
}
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
- gfc_default_initializer (&cm->ts));
+ gfc_class_null_initializer (&cm->ts));
gfc_add_expr_to_block (&block, tmp);
}
- else if (cm->attr.dimension)
+ else if (cm->attr.dimension && !cm->attr.proc_pointer)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+
+ if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+ && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+ || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+ {
+ gfc_se se, lse;
+
+ gcc_assert (cm->backend_decl == NULL);
+ gfc_init_se (&se, NULL);
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
+ lse.expr = dest;
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), se.expr));
+
+ return gfc_finish_block (&block);
+ }
+
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers. */
if (!c->expr)
continue;
- /* Handle c_null_(fun)ptr. */
- if (c && c->expr && c->expr->ts.is_iso_c)
- {
- field = cm->backend_decl;
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- dest, field, NULL_TREE);
- tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- gfc_add_expr_to_block (&block, tmp);
- continue;
- }
-
field = cm->backend_decl;
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- dest, field, NULL_TREE);
+ tmp = fold_build3_loc (input_location, 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);
}
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
of EXPR_NULL,... by default, the static nullify is not needed
since this is done every time we come into scope. */
- if (!c->expr || cm->attr.allocatable)
+ if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
continue;
- if (cm->ts.type == BT_CLASS)
- {
- gfc_component *data;
- data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (data->backend_decl),
- data->attr.dimension,
- data->attr.pointer);
-
- CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
- }
- else if (strcmp (cm->name, "$size") == 0)
+ if (strcmp (cm->name, "_size") == 0)
{
val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
- && strcmp (cm->name, "$extends") == 0)
+ && strcmp (cm->name, "_extends") == 0)
{
+ tree vtab;
gfc_symbol *vtabs;
vtabs = cm->initializer->symtree->n.sym;
- val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
}
else
{
val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl), cm->attr.dimension,
- cm->attr.pointer || cm->attr.proc_pointer);
+ TREE_TYPE (cm->backend_decl),
+ cm->attr.dimension, cm->attr.pointer,
+ cm->attr.proc_pointer);
/* Append it to the constructor list. */
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
se->expr = se->ss->data.scalar.expr;
+ if (se->ss->type == GFC_SS_REFERENCE)
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->attr.is_iso_c)
{
- if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
- || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ if (expr->expr_type == EXPR_VARIABLE
+ && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id
+ == ISOCBINDING_NULL_FUNPTR))
{
/* Set expr_type to EXPR_NULL, which will result in
null_pointer_node being used below. */
if (se->ss && se->ss->expr == expr
&& se->ss->type == GFC_SS_REFERENCE)
{
- se->expr = se->ss->data.scalar.expr;
- se->string_length = se->ss->string_length;
- gfc_advance_se_ss_chain (se);
+ /* Returns a reference to the scalar evaluated outside the loop
+ for this case. */
+ gfc_conv_expr (se, expr);
return;
}
gfc_add_block_to_block (&block, &rse.pre);
/* Check character lengths if character expression. The test is only
- really added if -fbounds-check is enabled. */
+ really added if -fbounds-check is enabled. Exclude deferred
+ character length lefthand sides. */
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+ && !(expr1->ts.deferred
+ && (TREE_CODE (lse.string_length) == VAR_DECL))
&& !expr1->symtree->n.sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (expr1, NULL))
{
&block);
}
+ /* The assignment to an deferred character length sets the string
+ length to that of the rhs. */
+ if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
+ {
+ if (expr2->expr_type != EXPR_NULL)
+ gfc_add_modify (&block, lse.string_length, rse.string_length);
+ else
+ gfc_add_modify (&block, lse.string_length,
+ build_int_cst (gfc_charlen_type_node, 0));
+ }
+
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
}
else
{
+ gfc_ref* remap;
+ bool rank_remap;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
- /* Array pointer. */
+ /* Array pointer. Find the last reference on the LHS and if it is an
+ array section ref, we're dealing with bounds remapping. In this case,
+ set it to AR_FULL so that gfc_conv_expr_descriptor does
+ not see it and process the bounds remapping afterwards explicitely. */
+ for (remap = expr1->ref; remap; remap = remap->next)
+ if (!remap->next && remap->type == REF_ARRAY
+ && remap->u.ar.type == AR_SECTION)
+ {
+ remap->u.ar.type = AR_FULL;
+ break;
+ }
+ rank_remap = (remap && remap->u.ar.end[0]);
+
gfc_conv_expr_descriptor (&lse, expr1, lss);
strlen_lhs = lse.string_length;
- switch (expr2->expr_type)
+ desc = lse.expr;
+
+ if (expr2->expr_type == EXPR_NULL)
{
- case EXPR_NULL:
/* Just set the data pointer to null. */
gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
- break;
-
- case EXPR_VARIABLE:
- /* Assign directly to the pointer's descriptor. */
+ }
+ else if (rank_remap)
+ {
+ /* If we are rank-remapping, just get the RHS's descriptor and
+ process this later on. */
+ gfc_init_se (&rse, NULL);
+ rse.direct_byref = 1;
+ rse.byref_noassign = 1;
+ gfc_conv_expr_descriptor (&rse, expr2, rss);
+ strlen_rhs = rse.string_length;
+ }
+ else if (expr2->expr_type == EXPR_VARIABLE)
+ {
+ /* Assign directly to the LHS's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
strlen_rhs = lse.string_length;
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
-
- break;
-
- default:
+ }
+ else
+ {
/* 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;
gfc_conv_expr_descriptor (&lse, expr2, rss);
strlen_rhs = lse.string_length;
gfc_add_modify (&lse.pre, desc, tmp);
- break;
}
gfc_add_block_to_block (&block, &lse.pre);
+ if (rank_remap)
+ gfc_add_block_to_block (&block, &rse.pre);
+
+ /* If we do bounds remapping, update LHS descriptor accordingly. */
+ if (remap)
+ {
+ int dim;
+ gcc_assert (remap->u.ar.dimen == expr1->rank);
+
+ if (rank_remap)
+ {
+ /* Do rank remapping. We already have the RHS's descriptor
+ converted in rse and now have to build the correct LHS
+ descriptor for it. */
+
+ tree dtype, data;
+ tree offs, stride;
+ tree lbound, ubound;
+
+ /* Set dtype. */
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = gfc_get_dtype (TREE_TYPE (desc));
+ gfc_add_modify (&block, dtype, tmp);
+
+ /* Copy data pointer. */
+ data = gfc_conv_descriptor_data_get (rse.expr);
+ gfc_conv_descriptor_data_set (&block, desc, data);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ offs = gfc_conv_descriptor_offset_get (rse.expr);
+ for (dim = 0; dim < expr2->rank; ++dim)
+ {
+ stride = gfc_conv_descriptor_stride_get (rse.expr,
+ gfc_rank_cst[dim]);
+ lbound = gfc_conv_descriptor_lbound_get (rse.expr,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ stride = gfc_conv_descriptor_stride_get (rse.expr,
+ gfc_rank_cst[0]);
+ for (dim = 0; dim < expr1->rank; ++dim)
+ {
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
+ gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
+
+ gfc_add_block_to_block (&block, &lower_se.pre);
+ gfc_add_block_to_block (&block, &upper_se.pre);
+
+ lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+ ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+ lbound = gfc_evaluate_now (lbound, &block);
+ ubound = gfc_evaluate_now (ubound, &block);
+
+ gfc_add_block_to_block (&block, &lower_se.post);
+ gfc_add_block_to_block (&block, &upper_se.post);
+
+ /* Set bounds in descriptor. */
+ gfc_conv_descriptor_lbound_set (&block, desc,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (&block, desc,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = gfc_evaluate_now (stride, &block);
+ gfc_conv_descriptor_stride_set (&block, desc,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ offs = gfc_conv_descriptor_offset_get (desc);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+ offs = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ offs = gfc_evaluate_now (offs, &block);
+ gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+ }
+ }
+ else
+ {
+ /* Bounds remapping. Just shift the lower bounds. */
+
+ gcc_assert (expr1->rank == expr2->rank);
+
+ for (dim = 0; dim < remap->u.ar.dimen; ++dim)
+ {
+ gfc_se lbound_se;
+
+ gcc_assert (remap->u.ar.start[dim]);
+ gcc_assert (!remap->u.ar.end[dim]);
+ gfc_init_se (&lbound_se, NULL);
+ gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
+
+ gfc_add_block_to_block (&block, &lbound_se.pre);
+ gfc_conv_shift_descriptor_lbound (&block, desc,
+ dim, lbound_se.expr);
+ gfc_add_block_to_block (&block, &lbound_se.post);
+ }
+ }
+ }
/* Check string lengths if applicable. The check is only really added
to the output code if -fbounds-check is enabled. */
strlen_lhs, strlen_rhs, &block);
}
+ /* If rank remapping was done, check with -fcheck=bounds that
+ the target is at least as large as the pointer. */
+ if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+ {
+ tree lsize, rsize;
+ tree fault;
+ const char* msg;
+
+ lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
+ rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
+
+ lsize = gfc_evaluate_now (lsize, &block);
+ rsize = gfc_evaluate_now (rsize, &block);
+ fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ rsize, lsize);
+
+ msg = _("Target of rank remapping is too small (%ld < %ld)");
+ gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
+ msg, rsize, lsize);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
+ if (rank_remap)
+ gfc_add_block_to_block (&block, &rse.post);
}
+
return gfc_finish_block (&block);
}
}
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
- gcc_assert (se->string_length
- && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
}
/* Generate code for assignment of scalar variables. Includes character
- strings and derived types with allocatable components. */
+ strings and derived types with allocatable components.
+ If you know that the LHS has no allocations, set dealloc to false. */
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool l_is_temp, bool r_is_var)
+ bool l_is_temp, bool r_is_var, bool dealloc)
{
stmtblock_t block;
tree tmp;
/* Are the rhs and the lhs the same? */
if (r_is_var)
{
- cond = fold_build2 (EQ_EXPR, boolean_type_node,
- gfc_build_addr_expr (NULL_TREE, lse->expr),
- gfc_build_addr_expr (NULL_TREE, rse->expr));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ gfc_build_addr_expr (NULL_TREE, lse->expr),
+ gfc_build_addr_expr (NULL_TREE, rse->expr));
cond = gfc_evaluate_now (cond, &lse->pre);
}
the same as the rhs. This must be done following the assignment
to prevent deallocating data that could be used in the rhs
expression. */
- if (!l_is_temp)
+ if (!l_is_temp && dealloc)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
}
else
}
-/* Try to translate array(:) = func (...), where func is a transformational
- array function, without using a temporary. Returns NULL is this isn't the
- case. */
+/* There are quite a lot of restrictions on the optimisation in using an
+ array function assign without a temporary. */
-static tree
-gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+static bool
+arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
{
- gfc_se se;
- gfc_ss *ss;
gfc_ref * ref;
bool seen_array_ref;
bool c = false;
- gfc_component *comp = NULL;
+ gfc_symbol *sym = expr1->symtree->n.sym;
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
- return NULL;
+ return true;
- /* Elemental functions don't need a temporary anyway. */
+ /* Elemental functions are scalarized so that they don't need a
+ temporary in gfc_trans_assignment_1, so return a true. Otherwise,
+ they would need special treatment in gfc_trans_arrayfunc_assign. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.elemental)
- return NULL;
+ return true;
- /* Fail if rhs is not FULL or a contiguous section. */
+ /* Need a temporary if rhs is not FULL or a contiguous section. */
if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
- return NULL;
+ return true;
- /* Fail if EXPR1 can't be expressed as a descriptor. */
+ /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
if (gfc_ref_needs_temporary_p (expr1->ref))
- return NULL;
+ return true;
- /* Functions returning pointers need temporaries. */
- if (expr2->symtree->n.sym->attr.pointer
- || expr2->symtree->n.sym->attr.allocatable)
- return NULL;
+ /* Functions returning pointers or allocatables need temporaries. */
+ c = expr2->value.function.esym
+ ? (expr2->value.function.esym->attr.pointer
+ || expr2->value.function.esym->attr.allocatable)
+ : (expr2->symtree->n.sym->attr.pointer
+ || expr2->symtree->n.sym->attr.allocatable);
+ if (c)
+ return true;
/* Character array functions need temporaries unless the
character lengths are the same. */
{
if (expr1->ts.u.cl->length == NULL
|| expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return NULL;
+ return true;
if (expr2->ts.u.cl->length == NULL
|| expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return NULL;
+ return true;
if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
expr2->ts.u.cl->length->value.integer) != 0)
- return NULL;
+ return true;
}
/* Check that no LHS component references appear during an array
if (ref->type == REF_ARRAY)
seen_array_ref= true;
else if (ref->type == REF_COMPONENT && seen_array_ref)
- return NULL;
+ return true;
}
/* Check for a dependency. */
expr2->value.function.esym,
expr2->value.function.actual,
NOT_ELEMENTAL))
+ return true;
+
+ /* If we have reached here with an intrinsic function, we do not
+ need a temporary except in the particular case that reallocation
+ on assignment is active and the lhs is allocatable and a target. */
+ if (expr2->value.function.isym)
+ return (gfc_option.flag_realloc_lhs
+ && sym->attr.allocatable
+ && sym->attr.target);
+
+ /* If the LHS is a dummy, we need a temporary if it is not
+ INTENT(OUT). */
+ if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
+ return true;
+
+ /* If the lhs has been host_associated, is in common, a pointer or is
+ a target and the function is not using a RESULT variable, aliasing
+ can occur and a temporary is needed. */
+ if ((sym->attr.host_assoc
+ || sym->attr.in_common
+ || sym->attr.pointer
+ || sym->attr.cray_pointee
+ || sym->attr.target)
+ && expr2->symtree != NULL
+ && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+ return true;
+
+ /* A PURE function can unconditionally be called without a temporary. */
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.pure)
+ return false;
+
+ /* Implicit_pure functions are those which could legally be declared
+ to be PURE. */
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.implicit_pure)
+ return false;
+
+ if (!sym->attr.use_assoc
+ && !sym->attr.in_common
+ && !sym->attr.pointer
+ && !sym->attr.target
+ && !sym->attr.cray_pointee
+ && expr2->value.function.esym)
+ {
+ /* A temporary is not needed if the function is not contained and
+ the variable is local or host associated and not a pointer or
+ a target. */
+ if (!expr2->value.function.esym->attr.contained)
+ return false;
+
+ /* A temporary is not needed if the lhs has never been host
+ associated and the procedure is contained. */
+ else if (!sym->attr.host_assoc)
+ return false;
+
+ /* A temporary is not needed if the variable is local and not
+ a pointer, a target or a result. */
+ if (sym->ns->parent
+ && expr2->value.function.esym->ns == sym->ns->parent)
+ return false;
+ }
+
+ /* Default to temporary use. */
+ return true;
+}
+
+
+/* Provide the loop info so that the lhs descriptor can be built for
+ reallocatable assignments from extrinsic function calls. */
+
+static void
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
+ gfc_loopinfo *loop)
+{
+ /* Signal that the function call should not be made by
+ gfc_conv_loop_setup. */
+ se->ss->is_alloc_lhs = 1;
+ gfc_init_loopinfo (loop);
+ gfc_add_ss_to_loop (loop, *ss);
+ gfc_add_ss_to_loop (loop, se->ss);
+ gfc_conv_ss_startstride (loop);
+ gfc_conv_loop_setup (loop, where);
+ gfc_copy_loopinfo_to_se (se, loop);
+ gfc_add_block_to_block (&se->pre, &loop->pre);
+ gfc_add_block_to_block (&se->pre, &loop->post);
+ se->ss->is_alloc_lhs = 0;
+}
+
+
+/* For Assignment to a reallocatable lhs from intrinsic functions,
+ replace the se.expr (ie. the result) with a temporary descriptor.
+ Null the data field so that the library allocates space for the
+ result. Free the data of the original descriptor after the function,
+ in case it appears in an argument expression and transfer the
+ result to the original descriptor. */
+
+static void
+fcncall_realloc_result (gfc_se *se, int rank)
+{
+ tree desc;
+ tree res_desc;
+ tree tmp;
+ tree offset;
+ int n;
+
+ /* Use the allocation done by the library. Substitute the lhs
+ descriptor with a copy, whose data field is nulled.*/
+ desc = build_fold_indirect_ref_loc (input_location, se->expr);
+ /* Unallocated, the descriptor does not have a dtype. */
+ tmp = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ res_desc = gfc_evaluate_now (desc, &se->pre);
+ gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+ se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+
+ /* Free the lhs after the function call and copy the result to
+ the lhs descriptor. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->post, tmp);
+ gfc_add_modify (&se->post, desc, res_desc);
+
+ offset = gfc_index_zero_node;
+ tmp = gfc_index_one_node;
+ /* Now reset the bounds from zero based to unity based. */
+ for (n = 0 ; n < rank; n++)
+ {
+ /* Accumulate the offset. */
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp);
+ /* Now do the bounds. */
+ gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
+ tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_conv_descriptor_lbound_set (&se->post, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&se->post, desc,
+ gfc_rank_cst[n], tmp);
+
+ /* The extent for the next contribution to offset. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ }
+ gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+}
+
+
+
+/* Try to translate array(:) = func (...), where func is a transformational
+ array function, without using a temporary. Returns NULL if this isn't the
+ case. */
+
+static tree
+gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+{
+ gfc_se se;
+ gfc_ss *ss;
+ gfc_component *comp = NULL;
+ gfc_loopinfo loop;
+
+ if (arrayfunc_assign_needs_temporary (expr1, expr2))
return NULL;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
+ gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
if (expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived->attr.alloc_comp)
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
gcc_assert (se.ss != gfc_ss_terminator);
+
+ /* Reallocate on assignment needs the loopinfo for extrinsic functions.
+ This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
+ Clearly, this cannot be done for an allocatable function result, since
+ the shape of the result is unknown and, in any case, the function must
+ correctly take care of the reallocation internally. For intrinsic
+ calls, the array data is freed and the library takes care of allocation.
+ TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
+ to the library. */
+ if (gfc_option.flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && !gfc_expr_attr (expr1).codimension
+ && !gfc_is_coindexed (expr1)
+ && !(expr2->value.function.esym
+ && expr2->value.function.esym->result->attr.allocatable))
+ {
+ if (!expr2->value.function.isym)
+ {
+ realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
+ ss->is_alloc_lhs = 1;
+ }
+ else
+ fcncall_realloc_result (&se, expr1->rank);
+ }
+
gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
-/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
-
-static bool
-is_zero_initializer_p (gfc_expr * expr)
-{
- if (expr->expr_type != EXPR_CONSTANT)
- return false;
-
- /* We ignore constants with prescribed memory representations for now. */
- if (expr->representation.string)
- return false;
-
- switch (expr->ts.type)
- {
- case BT_INTEGER:
- return mpz_cmp_si (expr->value.integer, 0) == 0;
-
- case BT_REAL:
- return mpfr_zero_p (expr->value.real)
- && MPFR_SIGN (expr->value.real) >= 0;
-
- case BT_LOGICAL:
- return expr->value.logical == 0;
-
- case BT_COMPLEX:
- return mpfr_zero_p (mpc_realref (expr->value.complex))
- && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
- && mpfr_zero_p (mpc_imagref (expr->value.complex))
- && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
-
- default:
- break;
- }
- return false;
-}
/* Try to efficiently translate array(:) = 0. Return NULL if this
can't be done. */
return NULL_TREE;
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
- fold_convert (gfc_array_index_type, tmp));
+ len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
+ fold_convert (gfc_array_index_type, tmp));
/* If we are zeroing a local array avoid taking its address by emitting
a = {} instead. */
if (!POINTER_TYPE_P (TREE_TYPE (dest)))
- return build2 (MODIFY_EXPR, void_type_node,
- dest, build_constructor (TREE_TYPE (dest), NULL));
+ return build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ dest, build_constructor (TREE_TYPE (dest), NULL));
/* Convert arguments to the correct types. */
dest = fold_convert (pvoid_type_node, dest);
/* Construct call to __builtin_memset. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMSET],
- 3, dest, integer_zero_node, len);
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, dest, integer_zero_node, len);
return fold_convert (void_type_node, tmp);
}
/* Construct call to __builtin_memcpy. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3, dst, src, len);
return fold_convert (void_type_node, tmp);
}
if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
return NULL_TREE;
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
- dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
- fold_convert (gfc_array_index_type, tmp));
+ dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ dlen, fold_convert (gfc_array_index_type, tmp));
slen = GFC_TYPE_ARRAY_SIZE (stype);
if (!slen || TREE_CODE (slen) != INTEGER_CST)
return NULL_TREE;
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
- slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
- fold_convert (gfc_array_index_type, tmp));
+ slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ slen, fold_convert (gfc_array_index_type, tmp));
/* Sanity check that they are the same. This should always be
the case, as we should already have checked for conformance. */
return NULL_TREE;
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
- len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
- fold_convert (gfc_array_index_type, tmp));
+ len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
+ fold_convert (gfc_array_index_type, tmp));
stype = gfc_typenode_for_spec (&expr2->ts);
src = gfc_build_constant_array_constructor (expr2, stype);
}
+/* Tells whether the expression is to be treated as a variable reference. */
+
+static bool
+expr_is_variable (gfc_expr *expr)
+{
+ gfc_expr *arg;
+
+ if (expr->expr_type == EXPR_VARIABLE)
+ return true;
+
+ arg = gfc_get_noncopying_intrinsic_argument (expr);
+ if (arg)
+ {
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+ return expr_is_variable (arg);
+ }
+
+ return false;
+}
+
+
+/* Is the lhs OK for automatic reallocation? */
+
+static bool
+is_scalar_reallocatable_lhs (gfc_expr *expr)
+{
+ gfc_ref * ref;
+
+ /* An allocatable variable with no reference. */
+ if (expr->symtree->n.sym->attr.allocatable
+ && !expr->ref)
+ return true;
+
+ /* All that can be left are allocatable components. */
+ if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+ && expr->symtree->n.sym->ts.type != BT_CLASS)
+ || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+ return false;
+
+ /* Find an allocatable component ref last. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && !ref->next
+ && ref->u.c.component->attr.allocatable)
+ return true;
+
+ return false;
+}
+
+
+/* Allocate or reallocate scalar lhs, as necessary. */
+
+static void
+alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
+ tree string_length,
+ gfc_expr *expr1,
+ gfc_expr *expr2)
+
+{
+ tree cond;
+ tree tmp;
+ tree size;
+ tree size_in_bytes;
+ tree jump_label1;
+ tree jump_label2;
+ gfc_se lse;
+
+ if (!expr1 || expr1->rank)
+ return;
+
+ if (!expr2 || expr2->rank)
+ return;
+
+ /* Since this is a scalar lhs, we can afford to do this. That is,
+ there is no risk of side effects being repeated. */
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, expr1);
+
+ jump_label1 = gfc_build_label_decl (NULL_TREE);
+ jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+ /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
+ tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ lse.expr, tmp);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ /* Use the rhs string length and the lhs element size. */
+ size = string_length;
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+ tmp = TYPE_SIZE_UNIT (tmp);
+ size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (tmp), size));
+ }
+ else
+ {
+ /* Otherwise use the length in bytes of the rhs. */
+ size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+ size_in_bytes = size;
+ }
+
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size_in_bytes);
+ tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+ gfc_add_modify (block, lse.expr, tmp);
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ /* Deferred characters need checking for lhs and rhs string
+ length. Other deferred parameter variables will have to
+ come here too. */
+ tmp = build1_v (GOTO_EXPR, jump_label2);
+ gfc_add_expr_to_block (block, tmp);
+ }
+ tmp = build1_v (LABEL_EXPR, jump_label1);
+ gfc_add_expr_to_block (block, tmp);
+
+ /* For a deferred length character, reallocate if lengths of lhs and
+ rhs are different. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ expr1->ts.u.cl->backend_decl, size);
+ /* Jump past the realloc if the lengths are the same. */
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, fold_convert (pvoid_type_node, lse.expr),
+ size_in_bytes);
+ tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+ gfc_add_modify (block, lse.expr, tmp);
+ tmp = build1_v (LABEL_EXPR, jump_label2);
+ gfc_add_expr_to_block (block, tmp);
+
+ /* Update the lhs character length. */
+ size = string_length;
+ gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+ }
+}
+
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
- assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
+ assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
+ init_flag indicates initialization expressions and dealloc that no
+ deallocate prior assignment is needed (if in doubt, set true). */
static tree
-gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+ bool dealloc)
{
gfc_se lse;
gfc_se rse;
stmtblock_t body;
bool l_is_temp;
bool scalar_to_array;
+ bool def_clen_func;
tree string_length;
+ int n;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
/* Walk the lhs. */
lss = gfc_walk_expr (expr1);
+ if (gfc_is_reallocatable_lhs (expr1)
+ && !(expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym != NULL))
+ lss->is_alloc_lhs = 1;
rss = NULL;
if (lss != gfc_ss_terminator)
{
- /* Allow the scalarizer to workshare array assignments. */
- if (ompws_flags & OMPWS_WORKSHARE_FLAG)
- ompws_flags |= OMPWS_SCALARIZER_WS;
-
/* The assignment needs scalarization. */
lss_section = lss;
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
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 = expr2;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+
/* 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);
+ /* Enable loop reversal. */
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_mark_ss_chain_used (loop.temp_ss, 3);
}
+ /* Allow the scalarizer to workshare array assignments. */
+ if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
+ ompws_flags |= OMPWS_SCALARIZER_WS;
+
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop, &body);
}
if (l_is_temp)
{
gfc_conv_tmp_array_ref (&lse);
- gfc_advance_se_ss_chain (&lse);
if (expr2->ts.type == BT_CHARACTER)
lse.string_length = string_length;
}
must have its components deallocated afterwards. */
scalar_to_array = (expr2->ts.type == BT_DERIVED
&& expr2->ts.u.derived->attr.alloc_comp
- && expr2->expr_type != EXPR_VARIABLE
+ && !expr_is_variable (expr2)
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
- if (scalar_to_array)
+ if (scalar_to_array && dealloc)
{
tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
}
+ /* For a deferred character length function, the function call must
+ happen before the (re)allocation of the lhs, otherwise the character
+ length of the result is not known. */
+ def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
+ || (expr2->expr_type == EXPR_COMPCALL)
+ || (expr2->expr_type == EXPR_PPC))
+ && expr2->ts.deferred);
+ if (gfc_option.flag_realloc_lhs
+ && expr2->ts.type == BT_CHARACTER
+ && (def_clen_func || expr2->expr_type == EXPR_OP)
+ && expr1->ts.deferred)
+ gfc_add_block_to_block (&block, &rse.pre);
+
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
- (expr2->expr_type == EXPR_VARIABLE)
- || scalar_to_array);
+ expr_is_variable (expr2) || scalar_to_array
+ || expr2->expr_type == EXPR_ARRAY, dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
{
+ /* F2003: Add the code for reallocation on assignment. */
+ if (gfc_option.flag_realloc_lhs
+ && is_scalar_reallocatable_lhs (expr1))
+ alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+ expr1, expr2);
+
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &body);
}
lse.ss = lss;
gfc_conv_tmp_array_ref (&rse);
- gfc_advance_se_ss_chain (&rse);
gfc_conv_expr (&lse, expr1);
gcc_assert (lse.ss == gfc_ss_terminator
rse.string_length = string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- false, false);
+ false, false, dealloc);
gfc_add_expr_to_block (&body, tmp);
}
+ /* F2003: Allocate or reallocate lhs of allocatable array. */
+ if (gfc_option.flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && !gfc_expr_attr (expr1).codimension
+ && !gfc_is_coindexed (expr1))
+ {
+ ompws_flags &= ~OMPWS_SCALARIZER_WS;
+ tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
+ }
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
/* Translate an assignment. */
tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+ bool dealloc)
{
tree tmp;
}
/* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag);
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
}
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, true);
+ return gfc_trans_assignment (code->expr1, code->expr2, true, false);
}
tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, false, true);
+}
+
+
+/* Special case for initializing a polymorphic dummy with INTENT(OUT).
+ A MEMCPY is needed to copy the full data from the default initializer
+ of the dynamic type. */
+
+tree
+gfc_trans_class_init_assign (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp;
+ gfc_se dst,src,memsz;
+ gfc_expr *lhs,*rhs,*sz;
+
+ gfc_start_block (&block);
+
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_data_component (lhs);
+
+ rhs = gfc_copy_expr (code->expr1);
+ gfc_add_vptr_component (rhs);
+
+ /* Make sure that the component backend_decls have been built, which
+ will not have happened if the derived types concerned have not
+ been referenced. */
+ gfc_get_derived_type (rhs->ts.u.derived);
+ gfc_add_def_init_component (rhs);
+
+ sz = gfc_copy_expr (code->expr1);
+ gfc_add_vptr_component (sz);
+ gfc_add_size_component (sz);
+
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_init_se (&memsz, NULL);
+ gfc_conv_expr (&dst, lhs);
+ gfc_conv_expr (&src, rhs);
+ gfc_conv_expr (&memsz, sz);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
}
(pointer or ordinary assignment). */
tree
-gfc_trans_class_assign (gfc_code *code)
+gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
stmtblock_t block;
tree tmp;
gfc_expr *rhs;
gfc_start_block (&block);
-
- if (code->op == EXEC_INIT_ASSIGN)
- {
- /* Special case for initializing a CLASS variable on allocation.
- A MEMCPY is needed to copy the full data of the dynamic type,
- which may be different from the declared type. */
- gfc_se dst,src;
- tree memsz;
- gfc_init_se (&dst, NULL);
- gfc_init_se (&src, NULL);
- gfc_add_component_ref (code->expr1, "$data");
- gfc_conv_expr (&dst, code->expr1);
- gfc_conv_expr (&src, code->expr2);
- gfc_add_block_to_block (&block, &src.pre);
- memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
- gfc_add_expr_to_block (&block, tmp);
- return gfc_finish_block (&block);
- }
- if (code->expr2->ts.type != BT_CLASS)
+ if (expr2->ts.type != BT_CLASS)
{
- /* Insert an additional assignment which sets the '$vptr' field. */
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$vptr");
- if (code->expr2->ts.type == BT_DERIVED)
- {
- gfc_symbol *vtab;
- gfc_symtree *st;
- vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
- gcc_assert (vtab);
-
- rhs = gfc_get_expr ();
- rhs->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (vtab->name, NULL, 1, &st);
- rhs->symtree = st;
- rhs->ts = vtab->ts;
- }
- else if (code->expr2->expr_type == EXPR_NULL)
- rhs = gfc_int_expr (0);
- else
- gcc_unreachable ();
+ /* Insert an additional assignment which sets the '_vptr' field. */
+ gfc_symbol *vtab = NULL;
+ gfc_symtree *st;
+
+ lhs = gfc_copy_expr (expr1);
+ gfc_add_vptr_component (lhs);
+
+ if (expr2->ts.type == BT_DERIVED)
+ vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
+ else if (expr2->expr_type == EXPR_NULL)
+ vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
}
/* Do the actual CLASS assignment. */
- if (code->expr2->ts.type == BT_CLASS)
- code->op = EXEC_ASSIGN;
+ if (expr2->ts.type == BT_CLASS)
+ op = EXEC_ASSIGN;
else
- gfc_add_component_ref (code->expr1, "$data");
+ gfc_add_data_component (expr1);
- if (code->op == EXEC_ASSIGN)
- tmp = gfc_trans_assign (code);
- else if (code->op == EXEC_POINTER_ASSIGN)
- tmp = gfc_trans_pointer_assign (code);
+ if (op == EXEC_ASSIGN)
+ tmp = gfc_trans_assignment (expr1, expr2, false, true);
+ else if (op == EXEC_POINTER_ASSIGN)
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
else
gcc_unreachable();
OSDN Git Service
