/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
+ Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-expr.c-- generate GENERIC trees for gfc_expr. */
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
+#include "arith.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
- return build2 (NE_EXPR, boolean_type_node, decl,
- fold_convert (TREE_TYPE (decl), null_pointer_node));
+ return fold_build2 (NE_EXPR, boolean_type_node, decl,
+ fold_convert (TREE_TYPE (decl), null_pointer_node));
}
/* Converts a missing, dummy argument into a null or zero. */
void
-gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
{
tree present;
tree tmp;
present = gfc_conv_expr_present (arg->symtree->n.sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
- build_int_cst (TREE_TYPE (se->expr), 0));
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = tmp;
+
+ if (kind > 0)
+ {
+ /* Create a temporary and convert it to the correct type. */
+ tmp = gfc_get_int_type (kind);
+ tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
+
+ /* Test for a NULL value. */
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, integer_one_node);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->expr = build_fold_addr_expr (tmp);
+ }
+ else
+ {
+ tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
+ fold_convert (TREE_TYPE (se->expr), integer_zero_node));
+ 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 = build3 (COND_EXPR, gfc_charlen_type_node, present,
- se->string_length, tmp);
+ tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
+ present, se->string_length, tmp);
tmp = gfc_evaluate_now (tmp, &se->pre);
se->string_length = tmp;
}
length = NULL; /* To silence compiler warning. */
+ if (is_subref_array (e) && e->ts.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
+ e->ts.cl->backend_decl = tmpse.expr;
+ return tmpse.expr;
+ }
+
/* First candidate: if the variable is of type CHARACTER, the
expression's length could be the length of the character
variable. */
/* We should never got substring references here. These will be
broken down by the scalarizer. */
gcc_unreachable ();
+ break;
}
}
value. */
void
-gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
+gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
{
gfc_se se;
- tree tmp;
gfc_init_se (&se, NULL);
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));
gfc_add_block_to_block (pblock, &se.pre);
- tmp = cl->backend_decl;
- gfc_add_modify_expr (pblock, tmp, se.expr);
+ if (cl->backend_decl)
+ gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
+ else
+ cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
}
static void
-gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
+gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
+ const char *name, locus *where)
{
tree tmp;
tree type;
tree var;
+ tree fault;
gfc_se start;
gfc_se end;
+ char *msg;
type = gfc_get_character_type (kind, ref->u.ss.length);
type = build_pointer_type (type);
gfc_conv_string_parameter (se);
else
{
+ /* Avoid multiple evaluation of substring start. */
+ if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
+ start.expr = gfc_evaluate_now (start.expr, &se->pre);
+
/* Change the start of the string. */
if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
tmp = build_fold_indirect_ref (se->expr);
- tmp = gfc_build_array_ref (tmp, start.expr);
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
se->expr = gfc_build_addr_expr (type, tmp);
}
gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
+ if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
+ end.expr = gfc_evaluate_now (end.expr, &se->pre);
+
+ if (flag_bounds_check)
+ {
+ tree nonempty = fold_build2 (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);
+ if (name)
+ asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
+ "is less than one", name);
+ else
+ asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
+ "is less than one");
+ gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node,
+ start.expr));
+ 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);
+ if (name)
+ asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
+ "exceeds string length (%%ld)", name);
+ else
+ asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
+ "exceeds string length (%%ld)");
+ gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node, end.expr),
+ fold_convert (long_integer_type_node,
+ se->string_length));
+ gfc_free (msg);
+ }
+
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
build_int_cst (gfc_charlen_type_node, 1),
start.expr);
field = c->backend_decl;
gcc_assert (TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
se->expr = tmp;
separately. */
if (sym->ts.type == BT_CHARACTER)
{
- /* Dereference character pointer dummy arguments
+ /* Dereference character pointer dummy arguments
or results. */
if ((sym->attr.pointer || sym->attr.allocatable)
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result))
se->expr = build_fold_indirect_ref (se->expr);
+
}
- else
+ else if (!sym->attr.value)
{
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension)
/* Dereference scalar hidden result. */
if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
&& (sym->attr.function || sym->attr.result)
- && !sym->attr.dimension && !sym->attr.pointer)
+ && !sym->attr.dimension && !sym->attr.pointer
+ && !sym->attr.always_explicit)
se->expr = build_fold_indirect_ref (se->expr);
/* Dereference non-character pointer variables.
break;
case REF_SUBSTRING:
- gfc_conv_substring (se, ref, expr->ts.kind);
+ gfc_conv_substring (se, ref, expr->ts.kind,
+ expr->symtree->name, &expr->where);
break;
default:
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 = build2 (EQ_EXPR, type, operand.expr,
- build_int_cst (type, 0));
+ se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
+ build_int_cst (type, 0));
else
- se->expr = build1 (code, type, operand.expr);
+ se->expr = fold_build1 (code, type, operand.expr);
}
/* Recursive function to expand the power operator. The temporary
values are put in tmpvar. The function returns tmpvar[1] ** n. */
static tree
-gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
+gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
{
tree op0;
tree op1;
tree tmp;
tree type;
tree vartmp[POWI_TABLE_SIZE];
- int n;
+ HOST_WIDE_INT m;
+ unsigned HOST_WIDE_INT n;
int sgn;
+ /* If exponent is too large, we won't expand it anyway, so don't bother
+ with large integer values. */
+ if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
+ return 0;
+
+ m = double_int_to_shwi (TREE_INT_CST (rhs));
+ /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
+ of the asymmetric range of the integer type. */
+ n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
+
type = TREE_TYPE (lhs);
- n = abs (TREE_INT_CST_LOW (rhs));
sgn = tree_int_cst_sgn (rhs);
- if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
- && (n > 2 || n < -1))
+ if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
+ || optimize_size) && (m > 2 || m < -1))
return 0;
/* rhs == 0 */
se->expr = gfc_build_const (type, integer_one_node);
return 1;
}
+
/* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
{
- tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
- build_int_cst (TREE_TYPE (lhs), -1));
- cond = build2 (EQ_EXPR, boolean_type_node, lhs,
- build_int_cst (TREE_TYPE (lhs), 1));
+ 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));
/* If rhs is even,
result = (lhs == 1 || lhs == -1) ? 1 : 0. */
if ((n & 1) == 0)
{
- tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
- se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
- build_int_cst (type, 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));
return 1;
}
/* If rhs is odd,
result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
- tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
- build_int_cst (type, 0));
- se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
+ 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);
return 1;
}
if (sgn == -1)
{
tmp = gfc_build_const (type, integer_one_node);
- vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
+ vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
}
se->expr = gfc_conv_powi (se, n, vartmp);
gfc_se lse;
gfc_se rse;
tree fndecl;
- tree tmp;
gfc_init_se (&lse, se);
gfc_conv_expr_val (&lse, expr->value.op.op1);
gfc_add_block_to_block (&se->pre, &rse.pre);
if (expr->value.op.op2->ts.type == BT_INTEGER
- && expr->value.op.op2->expr_type == EXPR_CONSTANT)
+ && expr->value.op.op2->expr_type == EXPR_CONSTANT)
if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
- return;
+ return;
gfc_int4_type_node = gfc_get_int_type (4);
break;
case BT_REAL:
- fndecl = gfor_fndecl_math_powi[kind][ikind].real;
+ /* Use builtins for real ** int4. */
+ if (ikind == 0)
+ {
+ switch (kind)
+ {
+ case 0:
+ fndecl = built_in_decls[BUILT_IN_POWIF];
+ break;
+
+ case 1:
+ fndecl = built_in_decls[BUILT_IN_POWI];
+ break;
+
+ case 2:
+ case 3:
+ fndecl = built_in_decls[BUILT_IN_POWIL];
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ }
+ else
+ fndecl = gfor_fndecl_math_powi[kind][ikind].real;
break;
case BT_COMPLEX:
switch (kind)
{
case 4:
- fndecl = gfor_fndecl_math_cpowf;
+ fndecl = built_in_decls[BUILT_IN_CPOWF];
break;
case 8:
- fndecl = gfor_fndecl_math_cpow;
+ fndecl = built_in_decls[BUILT_IN_CPOW];
break;
case 10:
- fndecl = gfor_fndecl_math_cpowl10;
- break;
case 16:
- fndecl = gfor_fndecl_math_cpowl16;
+ fndecl = built_in_decls[BUILT_IN_CPOWL];
break;
default:
gcc_unreachable ();
break;
}
- tmp = gfc_chainon_list (NULL_TREE, lse.expr);
- tmp = gfc_chainon_list (tmp, rse.expr);
- se->expr = build_function_call_expr (fndecl, tmp);
+ se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
}
{
tree var;
tree tmp;
- tree args;
gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
{
/* Allocate a temporary to hold the result. */
var = gfc_create_var (type, "pstr");
- args = gfc_chainon_list (NULL_TREE, len);
- tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
- tmp = convert (type, tmp);
+ tmp = gfc_call_malloc (&se->pre, type, len);
gfc_add_modify_expr (&se->pre, var, tmp);
/* Free the temporary afterwards. */
- tmp = convert (pvoid_type_node, var);
- args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
+ tmp = gfc_call_free (convert (pvoid_type_node, var));
gfc_add_expr_to_block (&se->post, tmp);
}
tree len;
tree type;
tree var;
- tree args;
tree tmp;
gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
var = gfc_conv_string_tmp (se, type, len);
/* Do the actual concatenation. */
- args = NULL_TREE;
- args = gfc_chainon_list (args, len);
- args = gfc_chainon_list (args, var);
- args = gfc_chainon_list (args, lse.string_length);
- args = gfc_chainon_list (args, lse.expr);
- args = gfc_chainon_list (args, rse.string_length);
- args = gfc_chainon_list (args, rse.expr);
- tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
+ tmp = build_call_expr (gfor_fndecl_concat_string, 6,
+ len, var,
+ lse.string_length, lse.expr,
+ rse.string_length, rse.expr);
gfc_add_expr_to_block (&se->pre, tmp);
/* Add the cleanup for the operands. */
enum tree_code code;
gfc_se lse;
gfc_se rse;
- tree type;
- tree tmp;
+ tree tmp, type;
int lop;
int checkstring;
lop = 0;
switch (expr->value.op.operator)
{
- case INTRINSIC_UPLUS:
case INTRINSIC_PARENTHESES:
+ if (expr->ts.type == BT_REAL
+ || expr->ts.type == BT_COMPLEX)
+ {
+ gfc_conv_unary_op (PAREN_EXPR, se, expr);
+ gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
+ return;
+ }
+
+ /* Fallthrough. */
+ case INTRINSIC_UPLUS:
gfc_conv_expr (se, expr->value.op.op1);
return;
/* EQV and NEQV only work on logicals, but since we represent them
as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_EQV:
code = EQ_EXPR;
checkstring = 1;
break;
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
case INTRINSIC_NEQV:
code = NE_EXPR;
checkstring = 1;
break;
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
code = GT_EXPR;
checkstring = 1;
lop = 1;
break;
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
code = GE_EXPR;
checkstring = 1;
lop = 1;
break;
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
code = LT_EXPR;
checkstring = 1;
lop = 1;
break;
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
code = LE_EXPR;
checkstring = 1;
lop = 1;
lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
rse.string_length, rse.expr);
- rse.expr = integer_zero_node;
+ 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, type, lse.expr, rse.expr);
+ tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
se->expr = convert (type, tmp);
}
else
return NULL_TREE;
}
+
+void
+gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
+{
+
+ if (sym->backend_decl)
+ {
+ /* This becomes the nominal_type in
+ function.c:assign_parm_find_data_types. */
+ TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
+ /* This becomes the passed_type in
+ function.c:assign_parm_find_data_types. C promotes char to
+ integer for argument passing. */
+ DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
+
+ DECL_BY_REFERENCE (sym->backend_decl) = 0;
+ }
+
+ if (expr != NULL)
+ {
+ /* If we have a constant character expression, make it into an
+ integer. */
+ if ((*expr)->expr_type == EXPR_CONSTANT)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ *expr = gfc_int_expr ((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
+ conversion fails, then the 2 causes an ICE. */
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (*expr, &ts, 2);
+ }
+ }
+ else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
+ {
+ if ((*expr)->ref == NULL)
+ {
+ se->expr = gfc_to_single_character
+ (build_int_cst (integer_type_node, 1),
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_get_symbol_decl
+ ((*expr)->symtree->n.sym)));
+ }
+ else
+ {
+ gfc_conv_variable (se, *expr);
+ se->expr = gfc_to_single_character
+ (build_int_cst (integer_type_node, 1),
+ gfc_build_addr_expr (pchar_type_node, se->expr));
+ }
+ }
+ }
+}
+
+
/* Compare two strings. If they are all single characters, the result is the
subtraction of them. Otherwise, we build a library call. */
{
tree sc1;
tree sc2;
- tree type;
tree tmp;
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
- type = gfc_get_int_type (gfc_default_integer_kind);
-
sc1 = gfc_to_single_character (len1, str1);
sc2 = gfc_to_single_character (len2, str2);
/* Deal with single character specially. */
if (sc1 != NULL_TREE && sc2 != NULL_TREE)
{
- sc1 = fold_convert (type, sc1);
- sc2 = fold_convert (type, sc2);
- tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
+ sc1 = fold_convert (integer_type_node, sc1);
+ sc2 = fold_convert (integer_type_node, sc2);
+ tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
}
else
- {
- tmp = NULL_TREE;
- tmp = gfc_chainon_list (tmp, len1);
- tmp = gfc_chainon_list (tmp, str1);
- tmp = gfc_chainon_list (tmp, len2);
- tmp = gfc_chainon_list (tmp, str2);
-
- /* Build a call for the comparison. */
- tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
- }
-
+ /* Build a call for the comparison. */
+ tmp = build_call_expr (gfor_fndecl_compare_string, 4,
+ len1, str1, len2, str2);
return tmp;
}
}
+/* Translate the call for an elemental subroutine call used in an operator
+ assignment. This is a simplified version of gfc_conv_function_call. */
+
+tree
+gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
+{
+ tree args;
+ tree tmp;
+ gfc_se se;
+ stmtblock_t block;
+
+ /* Only elemental subroutines with two arguments. */
+ gcc_assert (sym->attr.elemental && sym->attr.subroutine);
+ gcc_assert (sym->formal->next->next == NULL);
+
+ gfc_init_block (&block);
+
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+
+ /* Build the argument list for the call, including hidden string lengths. */
+ args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
+ args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
+ if (lse->string_length != NULL_TREE)
+ args = gfc_chainon_list (args, lse->string_length);
+ if (rse->string_length != NULL_TREE)
+ args = gfc_chainon_list (args, rse->string_length);
+
+ /* Build the function call. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_function_val (&se, sym);
+ tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
+ tmp = build_call_list (tmp, se.expr, args);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_add_block_to_block (&block, &lse->post);
+ gfc_add_block_to_block (&block, &rse->post);
+
+ return gfc_finish_block (&block);
+}
+
+
/* Initialize MAPPING. */
void
{
nextsym = sym->next;
gfc_free_symbol (sym->new->n.sym);
+ gfc_free_expr (sym->expr);
gfc_free (sym->new);
gfc_free (sym);
}
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
- int packed, tree data)
+ gfc_packed packed, tree data)
{
tree type;
tree var;
void
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
- gfc_symbol * sym, gfc_se * se)
+ gfc_symbol * sym, gfc_se * se,
+ gfc_expr *expr)
{
gfc_interface_sym_mapping *sm;
tree desc;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
+ new_sym->attr.function = sym->attr.function;
/* Create a fake symtree for it. */
root = NULL;
sm->next = mapping->syms;
sm->old = sym;
sm->new = new_symtree;
+ sm->expr = gfc_copy_expr (expr);
mapping->syms = sm;
/* Stabilize the argument's value. */
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
+ if (!sym->attr.function && se)
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
if (sym->ts.type == BT_CHARACTER)
{
/* Create a copy of the dummy argument's length. */
new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
+ sm->expr->ts.cl = new_sym->ts.cl;
/* If the length is specified as "*", record the length that
the caller is passing. We should use the callee's length
in all other cases. */
- if (!new_sym->ts.cl->length)
+ if (!new_sym->ts.cl->length && se)
{
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
new_sym->ts.cl->backend_decl = se->string_length;
}
}
+ if (!se)
+ return;
+
/* Use the passed value as-is if the argument is a function. */
if (sym->attr.flavor == FL_PROCEDURE)
value = se->expr;
/* Create the replacement variable. */
tmp = gfc_conv_descriptor_data_get (desc);
- value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
+ value = gfc_get_interface_mapping_array (&se->pre, sym,
+ PACKED_NO, tmp);
/* Use DESC to work out the upper bounds, strides and offset. */
gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
}
else
/* Otherwise we have a packed array. */
- value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
+ value = gfc_get_interface_mapping_array (&se->pre, sym,
+ PACKED_FULL, se->expr);
new_sym->backend_decl = value;
}
}
+/* Convert intrinsic function calls into result expressions. */
+static bool
+gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping)
+{
+ gfc_symbol *sym;
+ gfc_expr *new_expr;
+ gfc_expr *arg1;
+ gfc_expr *arg2;
+ int d, dup;
+
+ arg1 = expr->value.function.actual->expr;
+ if (expr->value.function.actual->next)
+ arg2 = expr->value.function.actual->next->expr;
+ else
+ arg2 = NULL;
+
+ sym = arg1->symtree->n.sym;
+
+ if (sym->attr.dummy)
+ return false;
+
+ new_expr = NULL;
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_LEN:
+ /* TODO figure out why this condition is necessary. */
+ if (sym->attr.function
+ && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
+ && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
+ return false;
+
+ new_expr = gfc_copy_expr (arg1->ts.cl->length);
+ break;
+
+ case GFC_ISYM_SIZE:
+ if (!sym->as)
+ return false;
+
+ if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+ {
+ dup = mpz_get_si (arg2->value.integer);
+ d = dup - 1;
+ }
+ else
+ {
+ dup = sym->as->rank;
+ d = 0;
+ }
+
+ for (; d < dup; d++)
+ {
+ gfc_expr *tmp;
+ tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+ tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
+ if (new_expr)
+ new_expr = gfc_multiply (new_expr, tmp);
+ else
+ new_expr = tmp;
+ }
+ break;
+
+ case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UBOUND:
+ /* 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)
+ return false;
+
+ if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+ d = mpz_get_si (arg2->value.integer) - 1;
+ else
+ /* TODO: If the need arises, this could produce an array of
+ ubound/lbounds. */
+ gcc_unreachable ();
+
+ if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
+ new_expr = gfc_copy_expr (sym->as->lower[d]);
+ else
+ new_expr = gfc_copy_expr (sym->as->upper[d]);
+ break;
+
+ default:
+ break;
+ }
+
+ gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+ if (!new_expr)
+ return false;
+
+ gfc_replace_expr (expr, new_expr);
+ return true;
+}
+
+
+static void
+gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
+ gfc_interface_mapping * mapping)
+{
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *actual;
+
+ actual = expr->value.function.actual;
+ f = map_expr->symtree->n.sym->formal;
+
+ for (; f && actual; f = f->next, actual = actual->next)
+ {
+ if (!actual->expr)
+ continue;
+
+ gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
+ }
+
+ if (map_expr->symtree->n.sym->attr.dimension)
+ {
+ int d;
+ gfc_array_spec *as;
+
+ as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
+
+ for (d = 0; d < as->rank; d++)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
+ gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
+ }
+
+ expr->value.function.esym->as = as;
+ }
+
+ if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
+ {
+ expr->value.function.esym->ts.cl->length
+ = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+
+ gfc_apply_interface_mapping_to_expr (mapping,
+ expr->value.function.esym->ts.cl->length);
+ }
+}
+
+
/* EXPR is a copy of an expression that appeared in the interface
associated with MAPPING. Walk it recursively looking for references to
dummy arguments that MAPPING maps to actual arguments. Replace each such
gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
/* ...and to the expression's symbol, if it has one. */
- if (expr->symtree)
- for (sym = mapping->syms; sym; sym = sym->next)
- if (sym->old == expr->symtree->n.sym)
- expr->symtree = sym->new;
+ /* TODO Find out why the condition on expr->symtree had to be moved into
+ the loop rather than being ouside it, as originally. */
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (expr->symtree && sym->old == expr->symtree->n.sym)
+ {
+ if (sym->new->n.sym->backend_decl)
+ expr->symtree = sym->new;
+ else if (sym->expr)
+ gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+ }
- /* ...and to subexpressions in expr->value. */
+ /* ...and to subexpressions in expr->value. */
switch (expr->expr_type)
{
case EXPR_VARIABLE:
break;
case EXPR_FUNCTION:
- for (sym = mapping->syms; sym; sym = sym->next)
- if (sym->old == expr->value.function.esym)
- expr->value.function.esym = sym->new->n.sym;
-
for (actual = expr->value.function.actual; actual; actual = actual->next)
gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+
+ if (expr->value.function.esym == NULL
+ && expr->value.function.isym != NULL
+ && expr->value.function.actual->expr->symtree
+ && gfc_map_intrinsic_function (expr, mapping))
+ break;
+
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->old == expr->value.function.esym)
+ {
+ expr->value.function.esym = sym->new->n.sym;
+ gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
+ expr->value.function.esym->result = sym->new->n.sym;
+ }
break;
case EXPR_ARRAY:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
}
+
+ return;
}
gfc_free_expr (expr);
}
+
/* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
- after the function call.
- TODO Get rid of this kludge, when array descriptors are capable of
- handling aliased arrays. */
-
-static void
-gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
- int g77, sym_intent intent)
+ after the function call. */
+void
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
+ int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
gfc_conv_ss_startstride (&loop);
/* Build an ss for the temporary. */
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
|| GFC_DESCRIPTOR_TYPE_P (base_type))
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
- {
- gfc_ref *char_ref = expr->ref;
-
- for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
- if (char_ref->type == REF_SUBSTRING)
- {
- gfc_se tmp_se;
-
- expr->ts.cl = gfc_get_charlen ();
- expr->ts.cl->next = char_ref->u.ss.length->next;
- char_ref->u.ss.length->next = expr->ts.cl;
-
- gfc_init_se (&tmp_se, NULL);
- gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
- gfc_array_index_type);
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- tmp_se.expr, gfc_index_one_node);
- tmp = gfc_evaluate_now (tmp, &parmse->pre);
- gfc_init_se (&tmp_se, NULL);
- gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
- gfc_array_index_type);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- tmp, tmp_se.expr);
- expr->ts.cl->backend_decl = tmp;
-
- break;
- }
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
- }
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ else
+ loop.temp_ss->string_length = NULL;
+ parmse->string_length = loop.temp_ss->string_length;
loop.temp_ss->data.temp.dimen = loop.dimen;
loop.temp_ss->next = gfc_ss_terminator;
/* Now use the offset for the reference. */
tmp = build_fold_indirect_ref (info->data);
- rse.expr = gfc_build_array_ref (tmp, tmp_index);
+ rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
rse.string_length = expr->ts.cl->backend_decl;
return;
}
-/* Is true if an array reference is followed by a component or substring
- reference. */
-static bool
-is_aliased_array (gfc_expr * e)
-{
- gfc_ref * ref;
- bool seen_array;
+/* Generate the code for argument list functions. */
- seen_array = false;
- for (ref = e->ref; ref; ref = ref->next)
+static void
+conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
+{
+ /* Pass by value for g77 %VAL(arg), pass the address
+ indirectly for %LOC, else by reference. Thus %REF
+ is a "do-nothing" and %LOC is the same as an F95
+ pointer. */
+ if (strncmp (name, "%VAL", 4) == 0)
+ gfc_conv_expr (se, expr);
+ else if (strncmp (name, "%LOC", 4) == 0)
{
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
- seen_array = true;
-
- if (seen_array
- && ref->type != REF_ARRAY)
- return seen_array;
+ gfc_conv_expr_reference (se, expr);
+ se->expr = gfc_build_addr_expr (NULL, se->expr);
}
- return false;
+ else if (strncmp (name, "%REF", 4) == 0)
+ gfc_conv_expr_reference (se, expr);
+ else
+ gfc_error ("Unknown argument list function at %L", &expr->where);
}
+
/* 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. */
stringargs = NULL_TREE;
var = NULL_TREE;
len = NULL_TREE;
+ gfc_clear_ts (&ts);
+
+ if (sym->from_intmod == INTMOD_ISO_C_BINDING)
+ {
+ if (sym->intmod_sym_id == ISOCBINDING_LOC)
+ {
+ if (arg->expr->rank == 0)
+ gfc_conv_expr_reference (se, arg->expr);
+ else
+ {
+ int f;
+ /* This is really the actual arg because no formal arglist is
+ created for C_LOC. */
+ fsym = arg->expr->symtree->n.sym;
+
+ /* We should want it to do g77 calling convention. */
+ f = (fsym != NULL)
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as->type != AS_ASSUMED_SHAPE;
+ f = f || !sym->attr.always_explicit;
+
+ argss = gfc_walk_expr (arg->expr);
+ gfc_conv_array_parameter (se, arg->expr, argss, f);
+ }
+
+ /* TODO -- the following two lines shouldn't be necessary, but
+ they're removed a bug is exposed later in the codepath.
+ This is workaround was thus introduced, but will have to be
+ removed; please see PR 35150 for details about the issue. */
+ se->expr = convert (pvoid_type_node, se->expr);
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+ return 0;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ arg->expr->ts.type = sym->ts.derived->ts.type;
+ arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
+ arg->expr->ts.kind = sym->ts.derived->ts.kind;
+ gfc_conv_expr_reference (se, arg->expr);
+
+ return 0;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ gfc_se arg1se;
+ gfc_se arg2se;
+
+ /* Build the addr_expr for the first argument. The argument is
+ already an *address* so we don't need to set want_pointer in
+ the gfc_se. */
+ gfc_init_se (&arg1se, NULL);
+ gfc_conv_expr (&arg1se, arg->expr);
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
+
+ /* See if we were given two arguments. */
+ 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));
+ else
+ {
+ tree eq_expr;
+ tree not_null_expr;
+
+ /* Given two arguments so build the arg2se from second arg. */
+ gfc_init_se (&arg2se, NULL);
+ gfc_conv_expr (&arg2se, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &arg2se.pre);
+ 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);
+ /* 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);
+
+ /* 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);
+ }
+
+ return 0;
+ }
+ }
+
if (se->ss != NULL)
{
if (!sym->attr.elemental)
if (argss == gfc_ss_terminator)
{
- gfc_conv_expr_reference (&parmse, e);
- parm_kind = SCALAR;
- if (fsym && fsym->attr.pointer
- && e->expr_type != EXPR_NULL)
- {
- /* Scalar pointer dummy args require an extra level of
- indirection. The null pointer already contains
- this level of indirection. */
- parm_kind = SCALAR_POINTER;
- parmse.expr = build_fold_addr_expr (parmse.expr);
- }
- }
+ if (fsym && fsym->attr.value)
+ {
+ if (fsym->ts.type == BT_CHARACTER
+ && fsym->ts.is_c_interop
+ && fsym->ns->proc_name != NULL
+ && fsym->ns->proc_name->attr.is_bind_c)
+ {
+ parmse.expr = NULL;
+ gfc_conv_scalar_char_value (fsym, &parmse, &e);
+ if (parmse.expr == NULL)
+ gfc_conv_expr (&parmse, e);
+ }
+ else
+ gfc_conv_expr (&parmse, e);
+ }
+ else if (arg->name && arg->name[0] == '%')
+ /* Argument list functions %VAL, %LOC and %REF are signalled
+ through arg->name. */
+ conv_arglist_function (&parmse, arg->expr, arg->name);
+ else if ((e->expr_type == EXPR_FUNCTION)
+ && e->symtree->n.sym->attr.pointer
+ && fsym && fsym->attr.target)
+ {
+ gfc_conv_expr (&parmse, e);
+ parmse.expr = build_fold_addr_expr (parmse.expr);
+ }
+ else
+ {
+ gfc_conv_expr_reference (&parmse, e);
+ if (fsym && fsym->attr.pointer
+ && fsym->attr.flavor != FL_PROCEDURE
+ && e->expr_type != EXPR_NULL)
+ {
+ /* Scalar pointer dummy args require an extra level of
+ indirection. The null pointer already contains
+ this level of indirection. */
+ parm_kind = SCALAR_POINTER;
+ parmse.expr = build_fold_addr_expr (parmse.expr);
+ }
+ }
+ }
else
{
/* If the procedure requires an explicit interface, the actual
f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
- && is_aliased_array (e))
+ && is_subref_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call. */
- gfc_conv_aliased_arg (&parmse, e, f,
+ gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
{
- tmp = e->symtree->n.sym->backend_decl;
- if (e->symtree->n.sym->attr.dummy)
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref (parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
}
- if (fsym)
+ /* The case with fsym->attr.optional is that of a user subroutine
+ with an interface indicating an optional argument. When we call
+ an intrinsic subroutine, however, fsym is NULL, but we might still
+ have an optional argument, so we proceed to the substitution
+ just in case. */
+ if (e && (fsym == NULL || fsym->attr.optional))
{
- if (e)
- {
- /* If an optional argument is itself an optional dummy
- argument, check its presence and substitute a null
- if absent. */
- if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional
- && fsym->attr.optional)
- gfc_conv_missing_dummy (&parmse, e, fsym->ts);
-
- /* If an INTENT(OUT) dummy of derived type has a default
- initializer, it must be (re)initialized here. */
- if (fsym->attr.intent == INTENT_OUT
- && fsym->ts.type == BT_DERIVED
- && fsym->value)
- {
- gcc_assert (!fsym->attr.allocatable);
- tmp = gfc_trans_assignment (e, fsym->value, false);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
+ /* If an optional argument is itself an optional dummy argument,
+ check its presence and substitute a null if absent. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
+ e->representation.length);
+ }
- /* Obtain the character length of an assumed character
- length procedure from the typespec. */
- if (fsym->ts.type == BT_CHARACTER
- && parmse.string_length == NULL_TREE
- && e->ts.type == BT_PROCEDURE
- && e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl->length != NULL)
- {
- gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
- parmse.string_length
- = e->symtree->n.sym->ts.cl->backend_decl;
- }
+ if (fsym && e)
+ {
+ /* Obtain the character length of an assumed character length
+ length procedure from the typespec. */
+ if (fsym->ts.type == BT_CHARACTER
+ && parmse.string_length == NULL_TREE
+ && e->ts.type == BT_PROCEDURE
+ && e->symtree->n.sym->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->ts.cl->length != NULL)
+ {
+ gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+ parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
}
-
- if (need_interface_mapping)
- gfc_add_interface_mapping (&mapping, fsym, &parmse);
}
+ if (fsym && need_interface_mapping && e)
+ gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
+
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
}
/* Character strings are passed as two parameters, a length and a
- pointer. */
- if (parmse.string_length != NULL_TREE)
+ 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);
arglist = gfc_chainon_list (arglist, parmse.expr);
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
ts = sym->ts;
- if (ts.type == BT_CHARACTER)
+ if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
{
if (sym->ts.cl->length == NULL)
{
}
else
{
+ tree tmp;
+
/* Calculate the length of the returned string. */
gfc_init_se (&parmse, NULL);
if (need_interface_mapping)
gfc_conv_expr (&parmse, sym->ts.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
- cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
+
+ 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));
+ cl.backend_decl = tmp;
}
/* Set up a charlen structure for it. */
if (byref)
{
if (se->direct_byref)
- retargs = gfc_chainon_list (retargs, se->expr);
+ {
+ /* Sometimes, too much indirection can be applied; eg. for
+ function_result = array_valued_recursive_function. */
+ if (TREE_TYPE (TREE_TYPE (se->expr))
+ && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
+ && GFC_DESCRIPTOR_TYPE_P
+ (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
+ se->expr = build_fold_indirect_ref (se->expr);
+
+ retargs = gfc_chainon_list (retargs, se->expr);
+ }
else if (sym->result->attr.dimension)
{
gcc_assert (se->loop && info);
mustn't be deallocated. */
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- false, !sym->attr.pointer, callee_alloc,
- true);
+ false, !sym->attr.pointer, callee_alloc);
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
character pointers. */
if (sym->attr.pointer || sym->attr.allocatable)
{
- /* Build char[0:len-1] * pstr. */
- tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
- build_int_cst (gfc_charlen_type_node, 1));
- tmp = build_range_type (gfc_array_index_type,
- gfc_index_zero_node, tmp);
- tmp = build_array_type (gfc_character1_type_node, tmp);
- var = gfc_create_var (build_pointer_type (tmp), "pstr");
+ var = gfc_create_var (type, "pstr");
/* Provide an address expression for the function arguments. */
var = build_fold_addr_expr (var);
/* Generate the actual call. */
gfc_conv_function_val (se, sym);
+
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
- with other functions. */
+ with other functions. For dummy arguments, the typing is done to
+ to this result, even if it has to be repeated for each call. */
if (has_alternate_specifier
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
{
- gcc_assert (! sym->attr.dummy);
- TREE_TYPE (sym->backend_decl)
- = build_function_type (integer_type_node,
- TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
- se->expr = build_fold_addr_expr (sym->backend_decl);
+ if (!sym->attr.dummy)
+ {
+ TREE_TYPE (sym->backend_decl)
+ = build_function_type (integer_type_node,
+ TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
+ se->expr = build_fold_addr_expr (sym->backend_decl);
+ }
+ else
+ TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
}
fntype = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
- arglist, NULL_TREE);
+ se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
/* If we have a pointer function, but we don't want a pointer, e.g.
something like
tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, info->data);
- gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
+ gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
}
se->expr = info->descriptor;
/* Bundle in the string length. */
/* Generate code to copy a string. */
-static void
+void
gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
tree slength, tree src)
{
tree tmp4;
stmtblock_t tempblock;
- dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
- slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+ if (slength != NULL_TREE)
+ {
+ slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+ ssc = gfc_to_single_character (slen, src);
+ }
+ else
+ {
+ slen = build_int_cst (size_type_node, 1);
+ ssc = src;
+ }
+
+ if (dlength != NULL_TREE)
+ {
+ dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
+ dsc = gfc_to_single_character (slen, dest);
+ }
+ else
+ {
+ dlen = build_int_cst (size_type_node, 1);
+ dsc = dest;
+ }
+
+ if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
+ ssc = gfc_to_single_character (slen, src);
+ if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
+ dsc = gfc_to_single_character (dlen, dest);
+
- /* Deal with single character specially. */
- dsc = gfc_to_single_character (dlen, dest);
- ssc = gfc_to_single_character (slen, src);
if (dsc != NULL_TREE && ssc != NULL_TREE)
{
gfc_add_modify_expr (block, dsc, ssc);
/* Do nothing if the destination length is zero. */
cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
- build_int_cst (gfc_charlen_type_node, 0));
+ build_int_cst (size_type_node, 0));
/* The following code was previously in _gfortran_copy_string:
We're now doing it here for better optimization, but the logic
is the same. */
-
+
+ if (dlength)
+ dest = fold_convert (pvoid_type_node, dest);
+ else
+ dest = gfc_build_addr_expr (pvoid_type_node, dest);
+
+ if (slength)
+ src = fold_convert (pvoid_type_node, src);
+ else
+ src = gfc_build_addr_expr (pvoid_type_node, src);
+
/* Truncate string if source is too long. */
cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
- tmp2 = gfc_chainon_list (NULL_TREE, dest);
- tmp2 = gfc_chainon_list (tmp2, src);
- tmp2 = gfc_chainon_list (tmp2, dlen);
- tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2);
+ tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+ 3, dest, src, dlen);
/* Else copy and pad with spaces. */
- tmp3 = gfc_chainon_list (NULL_TREE, dest);
- tmp3 = gfc_chainon_list (tmp3, src);
- tmp3 = gfc_chainon_list (tmp3, slen);
- tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3);
-
- tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
- fold_convert (pchar_type_node, slen));
- tmp4 = gfc_chainon_list (NULL_TREE, tmp4);
- tmp4 = gfc_chainon_list (tmp4, build_int_cst
- (gfc_get_int_type (gfc_c_int_kind),
- lang_hooks.to_target_charset (' ')));
- tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
- dlen, slen));
- tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4);
+ tmp3 = build_call_expr (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 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
+ tmp4,
+ build_int_cst (gfc_get_int_type (gfc_c_int_kind),
+ lang_hooks.to_target_charset (' ')),
+ fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
+ dlen, slen));
gfc_init_block (&tempblock);
gfc_add_expr_to_block (&tempblock, tmp3);
if (!(expr || pointer))
return NULL_TREE;
+ /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
+ (these are the only two iso_c_binding derived types that can be
+ used as initialization expressions). If so, we need to modify
+ the 'expr' to be that for a (void *). */
+ if (expr != NULL && expr->ts.type == BT_DERIVED
+ && expr->ts.is_iso_c && expr->ts.derived)
+ {
+ gfc_symbol *derived = expr->ts.derived;
+
+ expr = gfc_int_expr (0);
+
+ /* The derived symbol has already been converted to a (void *). Use
+ its kind. */
+ expr->ts.f90_type = derived->ts.f90_type;
+ expr->ts.kind = derived->ts.kind;
+ }
+
if (array)
{
/* Arrays need special handling. */
if (cm->allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else if (cm->allocatable)
- {
- tree tmp2;
+ {
+ tree tmp2;
gfc_init_se (&se, NULL);
rss = gfc_walk_expr (expr);
- se.want_pointer = 0;
- gfc_conv_expr_descriptor (&se, expr, rss);
+ se.want_pointer = 0;
+ gfc_conv_expr_descriptor (&se, expr, rss);
gfc_add_block_to_block (&block, &se.pre);
tmp = fold_convert (TREE_TYPE (dest), se.expr);
gfc_add_modify_expr (&block, dest, tmp);
- if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
+ if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
cm->as->rank);
else
- tmp = gfc_duplicate_allocatable (dest, se.expr,
+ 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);
- gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
+ gfc_add_expr_to_block (&block, tmp);
- /* 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 (dest);
- gfc_add_modify_expr (&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)
- {
- tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
- gfc_add_modify_expr (&block, tmp,
- fold_build2 (PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node));
- tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
- gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
- }
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound (dest,
+ gfc_add_block_to_block (&block, &se.post);
+ 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 (dest);
+ gfc_add_modify_expr (&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 (dest, gfc_rank_cst[n]);
+ span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
+ gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
+ gfc_add_modify_expr (&block, tmp,
+ fold_build2 (PLUS_EXPR,
+ gfc_array_index_type,
+ span, gfc_index_one_node));
+ tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
+ gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
+ }
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound (dest,
gfc_rank_cst[n]),
- gfc_conv_descriptor_stride (dest,
+ gfc_conv_descriptor_stride (dest,
gfc_rank_cst[n]));
- gfc_add_modify_expr (&block, tmp2, tmp);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
- gfc_add_modify_expr (&block, offset, tmp);
- }
- }
+ gfc_add_modify_expr (&block, tmp2, tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+ gfc_add_modify_expr (&block, offset, tmp);
+ }
+ }
else
- {
+ {
tmp = gfc_trans_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
- }
+ }
}
else if (expr->ts.type == BT_DERIVED)
{
if (!c->expr)
continue;
+ /* Update the type/kind of the expression if it represents either
+ C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
+ be the first place reached for initializing output variables that
+ have components of type C_PTR/C_FUNPTR that are initialized. */
+ if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
+ && c->expr->ts.derived->attr.is_iso_c)
+ {
+ c->expr->expr_type = EXPR_NULL;
+ c->expr->ts.type = c->expr->ts.derived->ts.type;
+ c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
+ c->expr->ts.kind = c->expr->ts.derived->ts.kind;
+ }
+
field = cm->backend_decl;
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ dest, field, NULL_TREE);
tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
gfc_add_expr_to_block (&block, tmp);
}
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
se->expr = build_constructor (type, v);
+ if (init)
+ {
+ TREE_CONSTANT(se->expr) = 1;
+ TREE_INVARIANT(se->expr) = 1;
+ }
}
ref = expr->ref;
- gcc_assert (ref->type == REF_SUBSTRING);
+ gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
- se->expr = gfc_build_string_const(expr->value.character.length,
- expr->value.character.string);
+ se->expr = gfc_build_string_const (expr->value.character.length,
+ expr->value.character.string);
se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
- TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
+ TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
- gfc_conv_substring(se,ref,expr->ts.kind);
+ if (ref)
+ gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
}
return;
}
+ /* We need to convert the expressions for the iso_c_binding derived types.
+ C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
+ null_pointer_node. C_PTR and C_FUNPTR are converted to match the
+ typespec for the C_PTR and C_FUNPTR symbols, which has already been
+ updated to be an integer with a kind equal to the size of a (void *). */
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived
+ && expr->ts.derived->attr.is_iso_c)
+ {
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ {
+ /* Set expr_type to EXPR_NULL, which will result in
+ null_pointer_node being used below. */
+ expr->expr_type = EXPR_NULL;
+ }
+ else
+ {
+ /* Update the type/kind of the expression to be what the new
+ type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
+ expr->ts.type = expr->ts.derived->ts.type;
+ expr->ts.f90_type = expr->ts.derived->ts.f90_type;
+ expr->ts.kind = expr->ts.derived->ts.kind;
+ }
+ }
+
switch (expr->expr_type)
{
case EXPR_OP:
}
}
-/* Helper to translate and expression and convert it to a particular type. */
+/* Helper to translate an expression and convert it to a particular type. */
void
gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
{
return;
}
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->symtree->n.sym->attr.pointer
+ && !expr->symtree->n.sym->attr.dimension)
+ {
+ se->want_pointer = 1;
+ gfc_conv_expr (se, expr);
+ var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify_expr (&se->pre, var, se->expr);
+ se->expr = var;
+ return;
+ }
+
+
gfc_conv_expr (se, expr);
/* Create a temporary var to hold the value. */
if (TREE_CONSTANT (se->expr))
{
- var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
- DECL_INITIAL (var) = se->expr;
+ tree tmp = se->expr;
+ STRIP_TYPE_NOPS (tmp);
+ var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
+ DECL_INITIAL (var) = tmp;
TREE_STATIC (var) = 1;
pushdecl (var);
}
stmtblock_t block;
tree desc;
tree tmp;
+ tree decl;
+
gfc_start_block (&block);
/* Assign directly to the pointer's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+
+ /* If this is a subreference array pointer assignment, use the rhs
+ descriptor element size for the lhs span. */
+ if (expr1->symtree->n.sym->attr.subref_array_pointer)
+ {
+ decl = expr1->symtree->n.sym->backend_decl;
+ gfc_init_se (&rse, NULL);
+ rse.descriptor_only = 1;
+ gfc_conv_expr (&rse, expr2);
+ tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
+ tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+ if (!INTEGER_CST_P (tmp))
+ gfc_add_block_to_block (&lse.post, &rse.pre);
+ gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
+ }
+
break;
default:
type = TREE_TYPE (se->expr);
if (TYPE_STRING_FLAG (type))
{
- gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
- se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+ if (TREE_CODE (se->expr) != INDIRECT_REF)
+ se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+ else
+ {
+ type = gfc_get_character_type_len (gfc_default_character_kind,
+ se->string_length);
+ type = build_pointer_type (type);
+ se->expr = gfc_build_addr_expr (type, se->expr);
+ }
}
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
if (ts.type == BT_CHARACTER)
{
- gcc_assert (lse->string_length != NULL_TREE
- && rse->string_length != NULL_TREE);
+ tree rlen = NULL;
+ tree llen = NULL;
- gfc_conv_string_parameter (lse);
- gfc_conv_string_parameter (rse);
+ if (lse->string_length != NULL_TREE)
+ {
+ gfc_conv_string_parameter (lse);
+ gfc_add_block_to_block (&block, &lse->pre);
+ llen = lse->string_length;
+ }
- gfc_add_block_to_block (&block, &lse->pre);
- gfc_add_block_to_block (&block, &rse->pre);
+ if (rse->string_length != NULL_TREE)
+ {
+ gcc_assert (rse->string_length != NULL_TREE);
+ gfc_conv_string_parameter (rse);
+ gfc_add_block_to_block (&block, &rse->pre);
+ rlen = rse->string_length;
+ }
- gfc_trans_string_copy (&block, lse->string_length, lse->expr,
- rse->string_length, rse->expr);
+ gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr);
}
else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
{
}
/* Deallocate the lhs allocated components as long as it is not
- the same as the rhs. */
+ 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)
{
- tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
+ tmp = gfc_evaluate_now (lse->expr, &lse->pre);
+ tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
if (r_is_var)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
- gfc_add_expr_to_block (&lse->pre, tmp);
+ gfc_add_expr_to_block (&lse->post, tmp);
}
-
- gfc_add_block_to_block (&block, &lse->pre);
+
gfc_add_block_to_block (&block, &rse->pre);
+ gfc_add_block_to_block (&block, &lse->pre);
gfc_add_modify_expr (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
|| expr2->symtree->n.sym->attr.allocatable)
return NULL;
+ /* Character array functions need temporaries unless the
+ character lengths are the same. */
+ if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
+ {
+ if (expr1->ts.cl->length == NULL
+ || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (expr2->ts.cl->length == NULL
+ || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpz_cmp (expr1->ts.cl->length->value.integer,
+ expr2->ts.cl->length->value.integer) != 0)
+ return NULL;
+ }
+
/* Check that no LHS component references appear during an array
reference. This is needed because we do not have the means to
span any arbitrary stride with an array descriptor. This check
return gfc_finish_block (&se.pre);
}
+/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
-/* Translate an assignment. Most of the code is concerned with
- setting up the scalarizer. */
+static bool
+is_zero_initializer_p (gfc_expr * expr)
+{
+ if (expr->expr_type != EXPR_CONSTANT)
+ return false;
-tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+ /* 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 (expr->value.complex.r)
+ && MPFR_SIGN (expr->value.complex.r) >= 0
+ && mpfr_zero_p (expr->value.complex.i)
+ && MPFR_SIGN (expr->value.complex.i) >= 0;
+
+ default:
+ break;
+ }
+ return false;
+}
+
+/* Try to efficiently translate array(:) = 0. Return NULL if this
+ can't be done. */
+
+static tree
+gfc_trans_zero_assign (gfc_expr * expr)
+{
+ tree dest, len, type;
+ tree tmp;
+ gfc_symbol *sym;
+
+ sym = expr->symtree->n.sym;
+ dest = gfc_get_symbol_decl (sym);
+
+ type = TREE_TYPE (dest);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (!GFC_ARRAY_TYPE_P (type))
+ return NULL_TREE;
+
+ /* Determine the length of the array. */
+ len = GFC_TYPE_ARRAY_SIZE (type);
+ if (!len || TREE_CODE (len) != INTEGER_CST)
+ 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));
+
+ /* Convert arguments to the correct types. */
+ if (!POINTER_TYPE_P (TREE_TYPE (dest)))
+ dest = gfc_build_addr_expr (pvoid_type_node, dest);
+ else
+ dest = fold_convert (pvoid_type_node, dest);
+ len = fold_convert (size_type_node, len);
+
+ /* Construct call to __builtin_memset. */
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
+ 3, dest, integer_zero_node, len);
+ return fold_convert (void_type_node, tmp);
+}
+
+
+/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
+ that constructs the call to __builtin_memcpy. */
+
+static tree
+gfc_build_memcpy_call (tree dst, tree src, tree len)
+{
+ tree tmp;
+
+ /* Convert arguments to the correct types. */
+ if (!POINTER_TYPE_P (TREE_TYPE (dst)))
+ dst = gfc_build_addr_expr (pvoid_type_node, dst);
+ else
+ dst = fold_convert (pvoid_type_node, dst);
+
+ if (!POINTER_TYPE_P (TREE_TYPE (src)))
+ src = gfc_build_addr_expr (pvoid_type_node, src);
+ else
+ src = fold_convert (pvoid_type_node, src);
+
+ len = fold_convert (size_type_node, len);
+
+ /* Construct call to __builtin_memcpy. */
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+ return fold_convert (void_type_node, tmp);
+}
+
+
+/* Try to efficiently translate dst(:) = src(:). Return NULL if this
+ can't be done. EXPR1 is the destination/lhs and EXPR2 is the
+ source/rhs, both are gfc_full_array_ref_p which have been checked for
+ dependencies. */
+
+static tree
+gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
+{
+ tree dst, dlen, dtype;
+ tree src, slen, stype;
+ tree tmp;
+
+ dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
+ src = gfc_get_symbol_decl (expr2->symtree->n.sym);
+
+ dtype = TREE_TYPE (dst);
+ if (POINTER_TYPE_P (dtype))
+ dtype = TREE_TYPE (dtype);
+ stype = TREE_TYPE (src);
+ if (POINTER_TYPE_P (stype))
+ stype = TREE_TYPE (stype);
+
+ if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
+ return NULL_TREE;
+
+ /* Determine the lengths of the arrays. */
+ dlen = GFC_TYPE_ARRAY_SIZE (dtype);
+ 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));
+
+ 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));
+
+ /* Sanity check that they are the same. This should always be
+ the case, as we should already have checked for conformance. */
+ if (!tree_int_cst_equal (slen, dlen))
+ return NULL_TREE;
+
+ return gfc_build_memcpy_call (dst, src, dlen);
+}
+
+
+/* Try to efficiently translate array(:) = (/ ... /). Return NULL if
+ this can't be done. EXPR1 is the destination/lhs for which
+ gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
+
+static tree
+gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
+{
+ unsigned HOST_WIDE_INT nelem;
+ tree dst, dtype;
+ tree src, stype;
+ tree len;
+ tree tmp;
+
+ nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
+ if (nelem == 0)
+ return NULL_TREE;
+
+ dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
+ dtype = TREE_TYPE (dst);
+ if (POINTER_TYPE_P (dtype))
+ dtype = TREE_TYPE (dtype);
+ if (!GFC_ARRAY_TYPE_P (dtype))
+ return NULL_TREE;
+
+ /* Determine the lengths of the array. */
+ len = GFC_TYPE_ARRAY_SIZE (dtype);
+ if (!len || TREE_CODE (len) != INTEGER_CST)
+ return NULL_TREE;
+
+ /* Confirm that the constructor is the same size. */
+ if (compare_tree_int (len, nelem) != 0)
+ 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));
+
+ stype = gfc_typenode_for_spec (&expr2->ts);
+ src = gfc_build_constant_array_constructor (expr2, stype);
+
+ stype = TREE_TYPE (src);
+ if (POINTER_TYPE_P (stype))
+ stype = TREE_TYPE (stype);
+
+ return gfc_build_memcpy_call (dst, src, len);
+}
+
+
+/* Subroutine of gfc_trans_assignment that actually scalarizes the
+ assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
+
+static tree
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
{
gfc_se lse;
gfc_se rse;
stmtblock_t body;
bool l_is_temp;
- /* Special case a single function returning an array. */
- if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
- {
- tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
- if (tmp)
- return tmp;
- }
-
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
return gfc_finish_block (&block);
}
+
+/* Check whether EXPR is a copyable array. */
+
+static bool
+copyable_array_p (gfc_expr * expr)
+{
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
+ /* First check it's an array. */
+ if (expr->rank < 1 || !expr->ref || expr->ref->next)
+ return false;
+
+ if (!gfc_full_array_ref_p (expr->ref))
+ return false;
+
+ /* Next check that it's of a simple enough type. */
+ switch (expr->ts.type)
+ {
+ case BT_INTEGER:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_LOGICAL:
+ return true;
+
+ case BT_CHARACTER:
+ return false;
+
+ case BT_DERIVED:
+ return !expr->ts.derived->attr.alloc_comp;
+
+ default:
+ break;
+ }
+
+ return false;
+}
+
+/* Translate an assignment. */
+
+tree
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+{
+ tree tmp;
+
+ /* Special case a single function returning an array. */
+ if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
+ {
+ tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
+ if (tmp)
+ return tmp;
+ }
+
+ /* Special case assigning an array to zero. */
+ if (copyable_array_p (expr1)
+ && is_zero_initializer_p (expr2))
+ {
+ tmp = gfc_trans_zero_assign (expr1);
+ if (tmp)
+ return tmp;
+ }
+
+ /* Special case copying one array to another. */
+ if (copyable_array_p (expr1)
+ && copyable_array_p (expr2)
+ && gfc_compare_types (&expr1->ts, &expr2->ts)
+ && !gfc_check_dependency (expr1, expr2, 0))
+ {
+ tmp = gfc_trans_array_copy (expr1, expr2);
+ if (tmp)
+ return tmp;
+ }
+
+ /* Special case initializing an array from a constant array constructor. */
+ if (copyable_array_p (expr1)
+ && expr2->expr_type == EXPR_ARRAY
+ && gfc_compare_types (&expr1->ts, &expr2->ts))
+ {
+ tmp = gfc_trans_array_constructor_copy (expr1, expr2);
+ if (tmp)
+ return tmp;
+ }
+
+ /* Fallback to the scalarizer to generate explicit loops. */
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag);
+}
+
tree
gfc_trans_init_assign (gfc_code * code)
{
projects / gcc.git / blobdiff