/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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;
}
/* 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_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);
gfc_free (msg);
}
- 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));
+ /* 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));
+ }
+
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);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
se->expr = tmp;
parent.u.c.sym = dt;
parent.u.c.component = dt->components;
+ if (dt->backend_decl == NULL)
+ gfc_get_derived_type (dt);
+
if (dt->attr.extension && dt->components)
{
if (dt->attr.is_class)
{
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
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
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. */
break;
case 2:
- case 3:
fndecl = built_in_decls[BUILT_IN_POWIL];
break;
+ case 3:
+ /* Use the __builtin_powil() only if real(kind=16) is
+ actually the C long double type. */
+ if (!gfc_real16_is_float128)
+ fndecl = built_in_decls[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)
+ 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);
}
- 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);
+ 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;
}
- return tmp;
+ /* 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
+ gcc_unreachable ();
+
+ 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 vindex;
- stmtblock_t body;
- gfc_class_esym_list *next_elist, *tmp_elist;
- gfc_se tmpse;
-
- /* Convert the vindex expression. */
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, elist->vindex);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- vindex = 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;
-
- /* 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 (vindex),
- elist->derived->vindex);
- /* Build a label for the vindex 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->vindex)
- gfc_free_expr (elist->vindex);
- 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 vindex in dynamic dispatch");
- gfc_add_expr_to_block (&body, tmp);
-
- /* Write the switch expression. */
- tmp = gfc_finish_block (&body);
- tmp = build3_v (SWITCH_EXPR, vindex, 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)
}
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)
an actual argument derived type array is copied and then returned
after the function call. */
void
-gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
- int g77, sym_intent intent)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
+ sym_intent intent, bool formal_ptr)
{
gfc_se lse;
gfc_se rse;
tree tmp_index;
tree tmp;
tree base_type;
+ tree size;
stmtblock_t body;
int n;
+ int dimen;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
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);
outside the innermost loop, so the overall transfer could be
optimized further. */
info = &rse.ss->data.info;
+ dimen = info->dimen;
tmp_index = gfc_index_zero_node;
- for (n = info->dimen - 1; n > 0; n--)
+ for (n = dimen - 1; n > 0; n--)
{
tree tmp_str;
tmp = rse.loop->loopvar[n];
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- tmp, rse.loop->from[n]);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, tmp_index);
-
- tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- rse.loop->to[n-1], rse.loop->from[n-1]);
- tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- tmp_str, gfc_index_one_node);
-
- tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
- tmp, tmp_str);
+ tmp = 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_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_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. */
if (expr->ts.type == BT_CHARACTER)
parmse->string_length = expr->ts.u.cl->backend_decl;
+ /* Determine the offset for pointer formal arguments and set the
+ lbounds to one. */
+ if (formal_ptr)
+ {
+ size = gfc_index_one_node;
+ offset = gfc_index_zero_node;
+ for (n = 0; n < dimen; n++)
+ {
+ tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+ gfc_rank_cst[n]);
+ 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],
+ tmp);
+ gfc_conv_descriptor_lbound_set (&parmse->pre,
+ parmse->expr,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ size = gfc_evaluate_now (size, &parmse->pre);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, &parmse->pre);
+ 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,
+ offset);
+ }
+
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
if (g77)
}
+/* Takes a derived type expression and returns the address of a temporary
+ class object of the 'declared' type. */
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts)
+{
+ gfc_component *cmp;
+ gfc_symbol *vtab;
+ gfc_symbol *declared = class_ts.u.derived;
+ gfc_ss *ss;
+ tree ctree;
+ tree var;
+ tree tmp;
+
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ tmp = gfc_typenode_for_spec (&class_ts);
+ var = gfc_create_var (tmp, "class");
+
+ /* Set the vptr. */
+ 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. */
+ vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&parmse->pre, ctree,
+ fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Now set the data field. */
+ 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);
+ }
+
+ /* Pass the address of the class object. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
/* The following routine generates code for the intrinsic
procedures from the ISO_C_BINDING module:
* C_LOC (function)
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;
return 0;
}
-
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
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)
{
- tree data;
- tree vindex;
- tree size;
-
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- type = gfc_typenode_for_spec (&fsym->ts);
- var = gfc_create_var (type, "class");
-
- /* Get the components. */
- tmp = fsym->ts.u.derived->components->backend_decl;
- data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
- tmp = fsym->ts.u.derived->components->next->backend_decl;
- vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
- tmp = fsym->ts.u.derived->components->next->next->backend_decl;
- size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
-
- /* Set the vindex. */
- tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
- gfc_add_modify (&parmse.pre, vindex, tmp);
-
- /* Set the size. */
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
- gfc_add_modify (&parmse.pre, size,
- fold_convert (TREE_TYPE (size), tmp));
-
- /* Now set the data field. */
- argss = gfc_walk_expr (e);
- if (argss == gfc_ss_terminator)
- {
- gfc_conv_expr_reference (&parmse, e);
- tmp = fold_convert (TREE_TYPE (data),
- parmse.expr);
- gfc_add_modify (&parmse.pre, data, tmp);
- }
- else
- {
- gfc_conv_expr (&parmse, e);
- gfc_add_modify (&parmse.pre, data, parmse.expr);
- }
-
- /* Pass the address of the class object. */
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
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));
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)
+ {
+ 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;
+ }
+
if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e))
/* The actual argument is a component reference to an
is converted to a temporary, which is passed and then
written back after the procedure call. */
gfc_conv_subref_array_arg (&parmse, e, f,
- fsym ? fsym->attr.intent : INTENT_INOUT);
+ fsym ? fsym->attr.intent : INTENT_INOUT,
+ fsym && fsym->attr.pointer);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);
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)
+ 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);
goto end_pointer_check;
- 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, parmse.expr,
+ fold_convert (TREE_TYPE (parmse.expr),
+ null_pointer_node));
}
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
/* 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);
- arglist = gfc_chainon_list (arglist, parmse.expr);
+ VEC_safe_push (tree, gc, arglist, parmse.expr);
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
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);
+ 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);
- 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 instrinsics, 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)
{
/* 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, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- retargs = gfc_chainon_list (retargs, tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
else if (!comp && sym->result->attr.dimension)
{
/* 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, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- retargs = gfc_chainon_list (retargs, tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
{
{
var = gfc_create_var (type, "pstr");
+ if ((!comp && sym->attr.allocatable)
+ || (comp && comp->attr.allocatable))
+ gfc_add_modify (&se->pre, var,
+ fold_convert (TREE_TYPE (var),
+ null_pointer_node));
+
/* Provide an address expression for the function arguments. */
var = gfc_build_addr_expr (NULL_TREE, var);
}
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);
}
/* 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);
}
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
+ 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);
/* 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);
}
/* Follow the function call with the argument post block. */
if (byref)
- gfc_add_block_to_block (&se->pre, &post);
+ {
+ gfc_add_block_to_block (&se->pre, &post);
+
+ /* Transformational functions of derived types with allocatable
+ components must have the result allocatable components copied. */
+ arg = expr->value.function.actual;
+ if (result && arg && expr->rank
+ && expr->value.function.isym
+ && expr->value.function.isym->transformational
+ && arg->expr->ts.type == BT_DERIVED
+ && arg->expr->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp2;
+ /* Copy the allocatable components. We have to use a
+ temporary here to prevent source allocatable components
+ from being corrupted. */
+ tmp2 = gfc_evaluate_now (result, &se->pre);
+ tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
+ result, tmp2, expr->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
+ expr->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Finally free the temporary's data field. */
+ tmp = gfc_conv_descriptor_data_get (tmp2);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
else
gfc_add_block_to_block (&se->post, &post);
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_build2_loc (input_location, POINTER_PLUS_EXPR,
+ TREE_TYPE (el), 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)));
+ 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)
dest = fold_convert (pvoid_type_node, dest);
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);
built_in_decls[BUILT_IN_MEMMOVE],
3, dest, src, slen);
- tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
- fold_convert (sizetype, slen));
+ tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
+ dest, fold_convert (sizetype, 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);
}
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);
+/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
-}
+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;
-/* Build a static initializer. EXPR is the expression for the initial value.
- The other parameters describe the variable of the component being
- initialized. EXPR may be null. */
+ switch (expr->ts.type)
+ {
+ case BT_INTEGER:
+ return mpz_cmp_si (expr->value.integer, 0) == 0;
-tree
-gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
- bool array, bool pointer)
-{
- gfc_se se;
+ case BT_REAL:
+ return mpfr_zero_p (expr->value.real)
+ && MPFR_SIGN (expr->value.real) >= 0;
- if (!(expr || pointer))
+ 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.
+ The other parameters describe the variable of the component being
+ initialized. EXPR may be null. */
+
+tree
+gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
+ bool array, bool pointer, bool procptr)
+{
+ gfc_se se;
+
+ 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;
}
}
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);
}
+static tree
+gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
+ gfc_expr * expr)
+{
+ gfc_se se;
+ gfc_ss *rss;
+ stmtblock_t block;
+ tree offset;
+ int n;
+ tree tmp;
+ tree tmp2;
+ gfc_array_spec *as;
+ gfc_expr *arg = NULL;
+
+ gfc_start_block (&block);
+ gfc_init_se (&se, NULL);
+
+ /* Get the descriptor for the expressions. */
+ rss = gfc_walk_expr (expr);
+ se.want_pointer = 0;
+ gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify (&block, dest, se.expr);
+
+ /* Deal with arrays of derived types with allocatable components. */
+ if (cm->ts.type == BT_DERIVED
+ && cm->ts.u.derived->attr.alloc_comp)
+ tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
+ se.expr, dest,
+ cm->as->rank);
+ else
+ tmp = gfc_duplicate_allocatable (dest, se.expr,
+ TREE_TYPE(cm->backend_decl),
+ cm->as->rank);
+
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &se.post);
+
+ if (expr->expr_type != EXPR_VARIABLE)
+ gfc_conv_descriptor_data_set (&block, se.expr,
+ null_pointer_node);
+
+ /* We need to know if the argument of a conversion function is a
+ variable, so that the correct lower bound can be used. */
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->value.function.isym
+ && expr->value.function.isym->conversion
+ && expr->value.function.actual->expr
+ && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
+ arg = expr->value.function.actual->expr;
+
+ /* Obtain the array spec of full array references. */
+ if (arg)
+ as = gfc_get_full_arrayspec_from_expr (arg);
+ else
+ as = gfc_get_full_arrayspec_from_expr (expr);
+
+ /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset. */
+ offset = gfc_conv_descriptor_offset_get (dest);
+ gfc_add_modify (&block, offset, gfc_index_zero_node);
+ tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+
+ for (n = 0; n < expr->rank; n++)
+ {
+ tree span;
+ tree lbound;
+
+ /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+ TODO It looks as if gfc_conv_expr_descriptor should return
+ the correct bounds and that the following should not be
+ necessary. This would simplify gfc_conv_intrinsic_bound
+ as well. */
+ if (as && as->lower[n])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (&block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, &block);
+ }
+ else if (as && arg)
+ {
+ tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+ gfc_rank_cst[n]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (dest,
+ gfc_rank_cst[n]);
+ else
+ lbound = gfc_index_one_node;
+
+ lbound = fold_convert (gfc_array_index_type, lbound);
+
+ /* Shift the bounds and set the offset accordingly. */
+ tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
+ 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_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_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, tmp2);
+ gfc_conv_descriptor_offset_set (&block, dest, tmp);
+ }
+
+ if (arg)
+ {
+ /* If a conversion expression has a null data pointer
+ argument, nullify the allocatable component. */
+ tree non_null_expr;
+ tree null_expr;
+
+ if (arg->symtree->n.sym->attr.allocatable
+ || arg->symtree->n.sym->attr.pointer)
+ {
+ non_null_expr = gfc_finish_block (&block);
+ gfc_start_block (&block);
+ gfc_conv_descriptor_data_set (&block, dest,
+ null_pointer_node);
+ null_expr = gfc_finish_block (&block);
+ tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
+ 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);
+ }
+ }
+
+ return gfc_finish_block (&block);
+}
+
+
/* Assign a single component of a derived type constructor. */
static tree
gfc_ss *rss;
stmtblock_t block;
tree tmp;
- tree offset;
- int n;
gfc_start_block (&block);
{
/* 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)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else if (cm->attr.allocatable)
{
- tree tmp2;
-
- gfc_init_se (&se, NULL);
-
- rss = gfc_walk_expr (expr);
- se.want_pointer = 0;
- gfc_conv_expr_descriptor (&se, expr, rss);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify (&block, dest, se.expr);
-
- if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
- tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest,
- cm->as->rank);
- else
- tmp = gfc_duplicate_allocatable (dest, se.expr,
- TREE_TYPE(cm->backend_decl),
- cm->as->rank);
-
+ tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
- gfc_add_block_to_block (&block, &se.post);
-
- if (expr->expr_type != EXPR_VARIABLE)
- gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
-
- /* Shift the lbound and ubound of temporaries to being unity, rather
- than zero, based. Calculate the offset for all cases. */
- offset = gfc_conv_descriptor_offset_get (dest);
- gfc_add_modify (&block, offset, gfc_index_zero_node);
- tmp2 =gfc_create_var (gfc_array_index_type, NULL);
- for (n = 0; n < expr->rank; n++)
- {
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_CONSTANT)
- {
- tree span;
- 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, gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
- tmp);
- gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
- gfc_index_one_node);
- }
- tmp = fold_build2 (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);
- gfc_conv_descriptor_offset_set (&block, dest, tmp);
- }
-
- if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.isym
- && expr->value.function.isym->conversion
- && expr->value.function.actual->expr
- && expr->value.function.actual->expr->expr_type
- == EXPR_VARIABLE)
- {
- /* If a conversion expression has a null data pointer
- argument, nullify the allocatable component. */
- gfc_symbol *s;
- tree non_null_expr;
- tree null_expr;
- s = expr->value.function.actual->expr->symtree->n.sym;
- if (s->attr.allocatable || s->attr.pointer)
- {
- non_null_expr = gfc_finish_block (&block);
- gfc_start_block (&block);
- gfc_conv_descriptor_data_set (&block, dest,
- null_pointer_node);
- null_expr = gfc_finish_block (&block);
- tmp = gfc_conv_descriptor_data_get (s->backend_decl);
- tmp = build2 (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);
- }
- }
}
else
{
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)
+ 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_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field),
+ dest, field, NULL_TREE);
+ tmp = fold_build2_loc (input_location, 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
if (!c->expr || cm->attr.allocatable)
continue;
- if (cm->ts.type == BT_CLASS)
+ if (strcmp (cm->name, "_size") == 0)
{
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->ts.u.derived->components->backend_decl),
- cm->ts.u.derived->components->attr.dimension,
- cm->ts.u.derived->components->attr.pointer);
-
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
- val);
+ 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)
+ {
+ tree vtab;
+ gfc_symbol *vtabs;
+ vtabs = cm->initializer->symtree->n.sym;
+ 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 (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;
}
}
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);
}
/* 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;
+ 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. */
+ if (expr2->value.function.isym)
+ return false;
+
+ /* 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;
+
+ /* A PURE function can unconditionally be called without a temporary. */
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.pure)
+ return false;
+
+ /* TODO a function that could correctly be declared PURE but is not
+ could do with returning false as well. */
+
+ if (!sym->attr.use_assoc
+ && !sym->attr.in_common
+ && !sym->attr.pointer
+ && !sym->attr.target
+ && 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;
+}
+
+
+static void
+realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+{
+ tree desc;
+ tree tmp;
+ tree offset;
+ int n;
+
+ /* Use the allocation done by the library. */
+ desc = build_fold_indirect_ref_loc (input_location, se->expr);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+ /* 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)));
+
+ 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;
+
+ 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)
+ {
+ tree tmp;
+ tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
+ expr1->rank);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
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);
+ ss->is_alloc_lhs = 1;
+ }
+ else
+ realloc_lhs_bounds_for_intrinsic_call (&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);
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;
+}
+
+
/* 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;
bool l_is_temp;
bool scalar_to_array;
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)
{
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop);
+ /* Enable loop reversal. */
+ for (n = 0; n < loop.dimen; n++)
+ loop.reverse[n] = GFC_REVERSE_NOT_SET;
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
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);
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,
+ dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
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);
}
+ /* 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))
+ {
+ 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;
+
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ gfc_error ("Assignment to deferred-length character variable at %L "
+ "not implemented", &expr1->where);
+ return NULL_TREE;
+ }
/* Special case a single function returning an array. */
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
}
/* 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);
+ 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 *lhs;
+ gfc_expr *rhs;
gfc_start_block (&block);
- if (code->expr2->ts.type != BT_CLASS)
- {
- /* Insert an additional assignment which sets the '$vindex' field. */
- gfc_expr *lhs,*rhs;
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$vindex");
- if (code->expr2->ts.type == BT_DERIVED)
- /* vindex is constant, determined at compile time. */
- rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
- else if (code->expr2->expr_type == EXPR_NULL)
- rhs = gfc_int_expr (0);
- else
- gcc_unreachable ();
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
-
- /* Insert another assignment which sets the '$size' field. */
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$size");
- if (code->expr2->ts.type == BT_DERIVED)
- {
- /* Size is fixed at compile time. */
- gfc_se lse;
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&lse, lhs);
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
- }
- else if (code->expr2->expr_type == EXPR_NULL)
+ if (expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '_vptr' field. */
+ lhs = gfc_copy_expr (expr1);
+ gfc_add_vptr_component (lhs);
+ if (expr2->ts.type == BT_DERIVED)
{
- rhs = gfc_int_expr (0);
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+ vtab = gfc_find_derived_vtab (expr2->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;
}
+ else if (expr2->expr_type == EXPR_NULL)
+ rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
else
gcc_unreachable ();
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* 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
