/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
+#include "arith.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "dependency.h"
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
-static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
/* Copy the scalarization loop variables. */
/* We need a temporary for this result. */
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
se->expr = var;
}
|| 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,
- fold_convert (TREE_TYPE (se->expr), integer_zero_node));
- 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,
+ 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 = 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;
}
}
return length;
}
-
+
+/* For each character array constructor subexpression without a ts.cl->length,
+ replace it by its first element (if there aren't any elements, the length
+ should already be set to zero). */
+
+static void
+flatten_array_ctors_without_strlen (gfc_expr* e)
+{
+ gfc_actual_arglist* arg;
+ gfc_constructor* c;
+
+ if (!e)
+ return;
+
+ switch (e->expr_type)
+ {
+
+ case EXPR_OP:
+ flatten_array_ctors_without_strlen (e->value.op.op1);
+ flatten_array_ctors_without_strlen (e->value.op.op2);
+ break;
+
+ case EXPR_COMPCALL:
+ /* TODO: Implement as with EXPR_FUNCTION when needed. */
+ gcc_unreachable ();
+
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ flatten_array_ctors_without_strlen (arg->expr);
+ break;
+
+ case EXPR_ARRAY:
+
+ /* We've found what we're looking for. */
+ if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+ {
+ gfc_expr* new_expr;
+ gcc_assert (e->value.constructor);
+
+ new_expr = e->value.constructor->expr;
+ e->value.constructor->expr = NULL;
+
+ flatten_array_ctors_without_strlen (new_expr);
+ gfc_replace_expr (e, new_expr);
+ break;
+ }
+
+ /* Otherwise, fall through to handle constructor elements. */
+ case EXPR_STRUCTURE:
+ for (c = e->value.constructor; c; c = c->next)
+ flatten_array_ctors_without_strlen (c->expr);
+ break;
+
+ default:
+ break;
+
+ }
+}
+
/* Generate code to initialize a string length variable. Returns the
- value. */
+ value. For array constructors, cl->length might be NULL and in this case,
+ the first element of the constructor is needed. expr is the original
+ expression so we can access it but can be NULL if this is not needed. */
void
-gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
+gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
{
gfc_se se;
- tree tmp;
gfc_init_se (&se, NULL);
+
+ /* 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. */
+ if (!cl->length)
+ {
+ 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);
+
+ gfc_conv_expr (&se, expr_flat);
+ gfc_add_block_to_block (pblock, &se.pre);
+ cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
+
+ gfc_free_expr (expr_flat);
+ return;
+ }
+
+ /* Convert cl->length. */
+
+ 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));
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 (pblock, cl->backend_decl, se.expr);
+ else
+ cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
}
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);
}
if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
end.expr = gfc_evaluate_now (end.expr, &se->pre);
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
start.expr, end.expr);
fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
nonempty, fault);
if (name)
- asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
+ 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 "
+ asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
"is less than one");
- gfc_trans_runtime_check (fault, msg, &se->pre, where);
+ gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node,
+ start.expr));
gfc_free (msg);
/* Check upper bound. */
fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
nonempty, fault);
if (name)
- asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
- "exceeds string length", 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 "
- "exceeds string length");
- gfc_trans_runtime_check (fault, msg, &se->pre, where);
+ asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
+ "exceeds string length (%%ld)");
+ gfc_trans_runtime_check (true, false, 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);
}
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;
se->string_length = tmp;
}
- if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
+ if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+ || c->attr.proc_pointer)
se->expr = build_fold_indirect_ref (se->expr);
}
+/* This function deals with component references to components of the
+ parent type for derived type extensons. */
+static void
+conv_parent_component_references (gfc_se * se, gfc_ref * ref)
+{
+ gfc_component *c;
+ gfc_component *cmp;
+ gfc_symbol *dt;
+ gfc_ref parent;
+
+ dt = ref->u.c.sym;
+ c = ref->u.c.component;
+
+ /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
+ parent.type = REF_COMPONENT;
+ parent.next = NULL;
+ parent.u.c.sym = dt;
+ parent.u.c.component = dt->components;
+
+ if (dt->attr.extension && dt->components)
+ {
+ /* Return if the component is not in the parent type. */
+ for (cmp = dt->components->next; cmp; cmp = cmp->next)
+ if (strcmp (c->name, cmp->name) == 0)
+ return;
+
+ /* Otherwise build the reference and call self. */
+ gfc_conv_component_ref (se, &parent);
+ parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.component = c;
+ conv_parent_component_references (se, &parent);
+ }
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
else if (sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
- gcc_assert (se->want_pointer);
- if (!sym->attr.dummy)
+ if (!sym->attr.dummy && !sym->attr.proc_pointer)
{
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
return;
}
/* 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_COMPONENT:
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (se, ref);
+
gfc_conv_component_ref (se, ref);
break;
if (expr->ts.type == BT_CHARACTER)
gfc_conv_string_parameter (se);
else
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
}
We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
All other unary operators have an equivalent GIMPLE unary operator. */
if (code == TRUTH_NOT_EXPR)
- se->expr = 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);
}
/* 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);
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 ();
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);
+
+ if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
+ tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
+ else
+ tmp = build_array_type (TREE_TYPE (type), tmp);
+
var = gfc_create_var (tmp, "str");
var = gfc_build_addr_expr (type, var);
}
{
/* Allocate a temporary to hold the result. */
var = gfc_create_var (type, "pstr");
- tmp = gfc_call_malloc (&se->pre, type, len);
- gfc_add_modify_expr (&se->pre, var, tmp);
+ tmp = gfc_call_malloc (&se->pre, type,
+ fold_build2 (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. */
tmp = gfc_call_free (convert (pvoid_type_node, var));
static void
gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
{
- gfc_se lse;
- gfc_se rse;
- tree len;
- tree type;
- tree var;
- tree tmp;
+ gfc_se lse, rse;
+ tree len, type, var, tmp, fndecl;
gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
- && expr->value.op.op2->ts.type == BT_CHARACTER);
+ && expr->value.op.op2->ts.type == BT_CHARACTER);
+ gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
gfc_init_se (&lse, se);
gfc_conv_expr (&lse, expr->value.op.op1);
var = gfc_conv_string_tmp (se, type, len);
/* Do the actual concatenation. */
- tmp = build_call_expr (gfor_fndecl_concat_string, 6,
- len, var,
- lse.string_length, lse.expr,
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_concat_string;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_concat_string_char4;
+ else
+ gcc_unreachable ();
+
+ tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
rse.string_length, rse.expr);
gfc_add_expr_to_block (&se->pre, tmp);
enum tree_code code;
gfc_se lse;
gfc_se rse;
- tree type;
- tree tmp;
+ tree tmp, type;
int lop;
int checkstring;
checkstring = 0;
lop = 0;
- switch (expr->value.op.operator)
+ switch (expr->value.op.op)
{
- 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;
gfc_conv_string_parameter (&rse);
lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
- rse.string_length, rse.expr);
+ rse.string_length, rse.expr,
+ expr->value.op.op1->ts.kind);
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
/* If a string's length is one, we convert it to a single character. */
static tree
-gfc_to_single_character (tree len, tree str)
+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)
+ && TREE_INT_CST_HIGH (len) == 0)
{
- str = fold_convert (pchar_type_node, str);
+ str = fold_convert (gfc_get_pchar_type (kind), str);
return build_fold_indirect_ref (str);
}
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)
{
if ((*expr)->ref == NULL)
{
- se->expr = gfc_to_single_character
+ se->expr = string_to_single_character
(build_int_cst (integer_type_node, 1),
- gfc_build_addr_expr (pchar_type_node,
+ gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
gfc_get_symbol_decl
- ((*expr)->symtree->n.sym)));
+ ((*expr)->symtree->n.sym)),
+ (*expr)->ts.kind);
}
else
{
gfc_conv_variable (se, *expr);
- se->expr = gfc_to_single_character
+ se->expr = string_to_single_character
(build_int_cst (integer_type_node, 1),
- gfc_build_addr_expr (pchar_type_node, se->expr));
+ gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+ se->expr),
+ (*expr)->ts.kind);
}
}
}
subtraction of them. Otherwise, we build a library call. */
tree
-gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
{
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);
+ sc1 = string_to_single_character (len1, str1, kind);
+ sc2 = string_to_single_character (len2, str2, kind);
- /* 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);
+ /* 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);
+ }
+ 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 (fndecl, 4, len1, str1, len2, str2);
}
- else
- /* Build a call for the comparison. */
- tmp = build_call_expr (gfor_fndecl_compare_string, 4,
- len1, str1, len2, str2);
+
return tmp;
}
static void
-gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
- if (sym->attr.dummy)
+ if (is_proc_ptr_comp (expr, NULL))
+ tmp = gfc_get_proc_ptr_comp (se, expr);
+ else if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
+ if (sym->attr.proc_pointer)
+ tmp = build_fold_indirect_ref (tmp);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
}
sym->backend_decl = gfc_get_extern_function_decl (sym);
tmp = sym->backend_decl;
+
if (sym->attr.cray_pointee)
- tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
- gfc_get_symbol_decl (sym->cp_pointer));
+ {
+ /* TODO - make the cray pointee a pointer to a procedure,
+ assign the pointer to it and use it for the call. This
+ will do for now! */
+ tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
+ gfc_get_symbol_decl (sym->cp_pointer));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ }
+
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
{
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
}
}
se->expr = 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
for (sym = mapping->syms; sym; sym = nextsym)
{
nextsym = sym->next;
- gfc_free_symbol (sym->new->n.sym);
- gfc_free (sym->new);
+ sym->new_sym->n.sym->formal = NULL;
+ gfc_free_symbol (sym->new_sym->n.sym);
+ gfc_free_expr (sym->expr);
+ gfc_free (sym->new_sym);
gfc_free (sym);
}
for (cl = mapping->charlens; cl; cl = nextcl)
gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
gfc_charlen * cl)
{
- gfc_charlen *new;
+ gfc_charlen *new_charlen;
- new = gfc_get_charlen ();
- new->next = mapping->charlens;
- new->length = gfc_copy_expr (cl->length);
+ new_charlen = gfc_get_charlen ();
+ new_charlen->next = mapping->charlens;
+ new_charlen->length = gfc_copy_expr (cl->length);
- mapping->charlens = new;
- return new;
+ mapping->charlens = new_charlen;
+ return new_charlen;
}
type = gfc_get_nodesc_array_type (type, sym->as, packed);
var = gfc_create_var (type, "ifm");
- gfc_add_modify_expr (block, var, fold_convert (type, data));
+ gfc_add_modify (block, var, fold_convert (type, data));
return 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;
/* Create a new symbol to represent the actual argument. */
new_sym = gfc_new_symbol (sym->name, NULL);
new_sym->ts = sym->ts;
+ new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
+ new_sym->attr.function = sym->attr.function;
+
+ /* Ensure that the interface is available and that
+ descriptors are passed for array actual arguments. */
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ new_sym->formal = expr->symtree->n.sym->formal;
+ new_sym->attr.always_explicit
+ = expr->symtree->n.sym->attr.always_explicit;
+ }
/* Create a fake symtree for it. */
root = NULL;
gcc_assert (new_symtree == root);
/* Create a dummy->actual mapping. */
- sm = gfc_getmem (sizeof (*sm));
+ sm = XCNEW (gfc_interface_sym_mapping);
sm->next = mapping->syms;
sm->old = sym;
- sm->new = new_symtree;
+ sm->new_sym = 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;
gfc_se se;
for (sym = mapping->syms; sym; sym = sym->next)
- if (sym->new->n.sym->ts.type == BT_CHARACTER
- && !sym->new->n.sym->ts.cl->backend_decl)
+ if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
+ && !sym->new_sym->n.sym->ts.cl->backend_decl)
{
- expr = sym->new->n.sym->ts.cl->length;
+ expr = sym->new_sym->n.sym->ts.cl->length;
gfc_apply_interface_mapping_to_expr (mapping, expr);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
-
+ se.expr = fold_convert (gfc_charlen_type_node, se.expr);
se.expr = gfc_evaluate_now (se.expr, &se.pre);
gfc_add_block_to_block (pre, &se.pre);
gfc_add_block_to_block (post, &se.post);
- sym->new->n.sym->ts.cl->backend_decl = se.expr;
+ sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
}
}
}
+/* 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 == NULL
+ || (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;
+
+ if (!sym->as->upper[d] || !sym->as->lower[d])
+ {
+ gfc_free_expr (new_expr);
+ return false;
+ }
+
+ 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)
+ {
+ if (sym->as->lower[d])
+ new_expr = gfc_copy_expr (sym->as->lower[d]);
+ }
+ else
+ {
+ if (sym->as->upper[d])
+ 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
reference with a reference to the associated actual argument. */
-static int
+static void
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
gfc_expr * expr)
{
gfc_interface_sym_mapping *sym;
gfc_actual_arglist *actual;
- int seen_result = 0;
if (!expr)
- return 0;
+ return;
/* Copying an expression does not copy its length, so do that here. */
if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
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 outside it, as originally. */
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (expr->symtree && sym->old == expr->symtree->n.sym)
+ {
+ if (sym->new_sym->n.sym->backend_decl)
+ expr->symtree = sym->new_sym;
+ 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:
- if (expr->symtree->n.sym->attr.result)
- seen_result = 1;
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
break;
case EXPR_FUNCTION:
+ 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.isym->id == GFC_ISYM_LEN
- && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
- && gfc_apply_interface_mapping_to_expr (mapping,
- expr->value.function.actual->expr))
- {
- gfc_expr *new_expr;
- new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
- *expr = *new_expr;
- gfc_free (new_expr);
- gfc_apply_interface_mapping_to_expr (mapping, expr);
- break;
- }
+ && 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;
-
- for (actual = expr->value.function.actual; actual; actual = actual->next)
- gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+ {
+ expr->value.function.esym = sym->new_sym->n.sym;
+ gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
+ expr->value.function.esym->result = sym->new_sym->n.sym;
+ }
break;
case EXPR_ARRAY:
case EXPR_STRUCTURE:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gcc_unreachable ();
+ break;
}
- return seen_result;
+
+ 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 arrays with a bigger stride in bytes than size. */
-
+ after the function call. */
void
-gfc_conv_aliased_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)
{
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, expr, &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 (; 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;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
/* Pass the temporary descriptor back to the caller. */
info = &loop.temp_ss->data.info;
gfc_conv_ss_startstride (&loop2);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop2);
+ gfc_conv_loop_setup (&loop2, &expr->where);
gfc_copy_loopinfo_to_se (&lse, &loop2);
gfc_copy_loopinfo_to_se (&rse, &loop2);
tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
tmp_index, rse.loop->from[0]);
- gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
+ 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);
/* 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;
if (g77)
parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
else
- parmse->expr = build_fold_addr_expr (parmse->expr);
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
return;
}
-/* Is true if an array reference is followed by a component or substring
- reference. */
-
-bool
-is_aliased_array (gfc_expr * e)
-{
- gfc_ref * ref;
- bool seen_array;
-
- seen_array = false;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
- seen_array = true;
-
- if (seen_array
- && ref->type != REF_ARRAY)
- return seen_array;
- }
- return false;
-}
/* Generate the code for argument list functions. */
/* 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. */
+ Return nonzero, if the call has alternate specifiers.
+ 'expr' is only needed for procedure pointer components. */
int
-gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * arg, tree append_args)
+gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
+ gfc_actual_arglist * arg, gfc_expr * expr,
+ tree append_args)
{
gfc_interface_mapping mapping;
tree arglist;
gfc_symbol *fsym;
stmtblock_t post;
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+ gfc_component *comp = NULL;
arglist = NULL_TREE;
retargs = NULL_TREE;
stringargs = NULL_TREE;
var = NULL_TREE;
len = NULL_TREE;
+ gfc_clear_ts (&ts);
if (sym->from_intmod == INTMOD_ISO_C_BINDING)
{
f = f || !sym->attr.always_explicit;
argss = gfc_walk_expr (arg->expr);
- gfc_conv_array_parameter (se, arg->expr, argss, f);
+ gfc_conv_array_parameter (se, arg->expr, argss, f,
+ NULL, NULL, NULL);
}
+ /* 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)
return 0;
}
+ else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ && arg->next->expr->rank == 0)
+ || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+ {
+ /* Convert c_f_pointer if fptr is a scalar
+ and convert c_f_procpointer. */
+ gfc_se cptrse;
+ gfc_se fptrse;
+
+ gfc_init_se (&cptrse, NULL);
+ gfc_conv_expr (&cptrse, arg->expr);
+ gfc_add_block_to_block (&se->pre, &cptrse.pre);
+ gfc_add_block_to_block (&se->post, &cptrse.post);
+
+ gfc_init_se (&fptrse, NULL);
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ || is_proc_ptr_comp (arg->next->expr, NULL))
+ fptrse.want_pointer = 1;
+
+ gfc_conv_expr (&fptrse, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &fptrse.pre);
+ gfc_add_block_to_block (&se->post, &fptrse.post);
+
+ if (is_proc_ptr_comp (arg->next->expr, NULL))
+ tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
+ else
+ tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
+ se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
+ fold_convert (tmp, cptrse.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)
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
+ is_proc_ptr_comp (expr, &comp);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length
&& sym->ts.cl->length->expr_type
!= EXPR_CONSTANT)
- || sym->attr.dimension);
+ || (comp && comp->attr.dimension)
+ || (!comp && sym->attr.dimension));
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
if (argss == gfc_ss_terminator)
{
- if (fsym && fsym->attr.value)
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.cray_pointee
+ && fsym && fsym->attr.flavor == FL_PROCEDURE)
+ {
+ /* The Cray pointer needs to be converted to a pointer to
+ a type given by the expression. */
+ gfc_conv_expr (&parmse, e);
+ type = build_pointer_type (TREE_TYPE (parmse.expr));
+ tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
+ parmse.expr = convert (type, tmp);
+ }
+ else if (fsym && fsym->attr.value)
{
if (fsym->ts.type == BT_CHARACTER
&& fsym->ts.is_c_interop
&& fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
- parmse.expr = build_fold_addr_expr (parmse.expr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
else
{
gfc_conv_expr_reference (&parmse, e);
- if (fsym && fsym->attr.pointer
- && fsym->attr.flavor != FL_PROCEDURE
- && e->expr_type != EXPR_NULL)
+ if (fsym && e->expr_type != EXPR_NULL
+ && ((fsym->attr.pointer
+ && fsym->attr.flavor != FL_PROCEDURE)
+ || fsym->attr.proc_pointer))
{
/* 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);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
}
}
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);
+ gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
+ sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
}
}
- 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)
+ gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
+ e->representation.length);
+ }
+
+ 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
+ && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
{
- /* 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);
-
- /* 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;
- }
+ 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);
/* Allocated allocatable components of derived types must be
- deallocated for INTENT(OUT) dummy arguments and non-variable
- scalars. Non-variable arrays are dealt with in trans-array.c
- (gfc_conv_array_parameter). */
+ deallocated for non-variable scalars. Non-variable arrays are
+ dealt with in trans-array.c(gfc_conv_array_parameter). */
if (e && e->ts.type == BT_DERIVED
&& e->ts.derived->attr.alloc_comp
- && ((formal && formal->sym->attr.intent == INTENT_OUT)
- ||
- (e->expr_type != EXPR_VARIABLE && !e->rank)))
+ && (e->expr_type != EXPR_VARIABLE && !e->rank))
{
int parm_rank;
tmp = build_fold_indirect_ref (parmse.expr);
case (SCALAR_POINTER):
tmp = build_fold_indirect_ref (tmp);
break;
- case (ARRAY):
- tmp = parmse.expr;
- break;
}
- tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
- if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
- tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
- tmp, build_empty_stmt ());
-
- if (e->expr_type != EXPR_VARIABLE)
- /* Don't deallocate non-variables until they have been used. */
- gfc_add_expr_to_block (&se->post, tmp);
- else
+ if (e->expr_type == EXPR_OP
+ && e->value.op.op == INTRINSIC_PARENTHESES
+ && e->value.op.op1->expr_type == EXPR_VARIABLE)
{
- gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
- gfc_add_expr_to_block (&se->pre, tmp);
+ tree local_tmp;
+ local_tmp = gfc_evaluate_now (tmp, &se->pre);
+ local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
+ gfc_add_expr_to_block (&se->post, local_tmp);
}
+
+ tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+
+ gfc_add_expr_to_block (&se->post, tmp);
}
/* 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)
+ se->string_length = build_int_cst (gfc_charlen_type_node, 1);
+ else if (ts.type == BT_CHARACTER)
{
if (sym->ts.cl->length == NULL)
{
len = cl.backend_decl;
}
- byref = gfc_return_by_reference (sym);
+ byref = (comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
{
- /* Sometimes, too much indirection can be applied; eg. for
+ /* Sometimes, too much indirection can be applied; e.g. for
function_result = array_valued_recursive_function. */
if (TREE_TYPE (TREE_TYPE (se->expr))
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
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);
+ NULL_TREE, false, !sym->attr.pointer,
+ callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
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);
+ var = gfc_build_addr_expr (NULL_TREE, var);
}
else
var = gfc_conv_string_tmp (se, type, len);
gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
type = gfc_get_complex_type (ts.kind);
- var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
+ var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
retargs = gfc_chainon_list (retargs, var);
}
arglist = chainon (arglist, append_args);
/* Generate the actual call. */
- gfc_conv_function_val (se, sym);
+ conv_function_val (se, sym, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
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);
+ se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
}
else
TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
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
+ && !is_proc_ptr_comp (expr, NULL))
se->expr = build_fold_indirect_ref (se->expr);
/* f2c calling conventions require a scalar default real function to
{
if (sym->attr.dimension)
{
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Check the data pointer hasn't been modified. This would
happen in a function returning a pointer. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, info->data);
- gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
+ gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
+ gfc_msg_fault);
}
se->expr = info->descriptor;
/* Bundle in the string length. */
}
+/* Fill a character string with spaces. */
+
+static tree
+fill_with_spaces (tree start, tree type, tree size)
+{
+ stmtblock_t block, loop;
+ tree i, el, exit_label, cond, tmp;
+
+ /* For a simple char type, we can call memset(). */
+ if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
+ return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
+ build_int_cst (gfc_get_int_type (gfc_c_int_kind),
+ lang_hooks.to_target_charset (' ')),
+ size);
+
+ /* Otherwise, we use a loop:
+ for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
+ *el = (type) ' ';
+ */
+
+ /* Initialize variables. */
+ gfc_init_block (&block);
+ i = gfc_create_var (sizetype, "i");
+ gfc_add_modify (&block, i, fold_convert (sizetype, size));
+ el = gfc_create_var (build_pointer_type (type), "el");
+ gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+
+ /* Loop body. */
+ gfc_init_block (&loop);
+
+ /* Exit condition. */
+ cond = fold_build2 (LE_EXPR, boolean_type_node, i,
+ fold_convert (sizetype, integer_zero_node));
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+ 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 (' ')));
+
+ /* 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)));
+
+ /* Making the loop... actually loop! */
+ tmp = gfc_finish_block (&loop);
+ tmp = build1_v (LOOP_EXPR, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* The exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&block, tmp);
+
+
+ return gfc_finish_block (&block);
+}
+
+
/* Generate code to copy a string. */
-static void
+void
gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
- tree slength, tree src)
+ int dkind, tree slength, tree src, int skind)
{
tree tmp, dlen, slen;
tree dsc;
tree tmp2;
tree tmp3;
tree tmp4;
+ tree chartype;
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));
+ gcc_assert (dkind == skind);
+
+ if (slength != NULL_TREE)
+ {
+ slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+ ssc = string_to_single_character (slen, src, skind);
+ }
+ 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 = string_to_single_character (slen, dest, dkind);
+ }
+ else
+ {
+ dlen = build_int_cst (size_type_node, 1);
+ 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);
- /* 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)
+
+ /* Assign directly if the types are compatible. */
+ if (dsc != NULL_TREE && ssc != NULL_TREE
+ && TREE_TYPE (dsc) == TREE_TYPE (ssc))
{
- gfc_add_modify_expr (block, dsc, ssc);
+ gfc_add_modify (block, dsc, ssc);
return;
}
We're now doing it here for better optimization, but the logic
is the same. */
-
+
+ /* For non-default character kinds, we have to multiply the string
+ length by the base type size. */
+ chartype = gfc_get_char_type (dkind);
+ slen = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, slen),
+ fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
+ dlen = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, dlen),
+ fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
+
+ if (dlength)
+ 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 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3, dest, src, slen);
- tmp4 = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
+ 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));
+ tmp4 = fill_with_spaces (tmp4, chartype,
+ fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
+ dlen, slen));
gfc_init_block (&tempblock);
gfc_add_expr_to_block (&tempblock, tmp3);
tree arglen;
gcc_assert (fsym->ts.cl && fsym->ts.cl->length
- && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
tmp = gfc_build_addr_expr (build_pointer_type (type),
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
- rse.expr);
+ gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+ rse.string_length, rse.expr, fsym->ts.kind);
gfc_add_block_to_block (&se->pre, &lse.post);
gfc_add_block_to_block (&se->pre, &rse.post);
}
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
+ gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
gfc_add_block_to_block (&se->pre, &lse.post);
}
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
- se->string_length, se->expr);
+ sym->ts.kind, se->string_length, se->expr,
+ sym->ts.kind);
se->expr = tmp;
}
se->string_length = sym->ts.cl->backend_decl;
}
+/* Return the backend_decl for a procedure pointer component. */
+
+tree
+gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
+{
+ gfc_se comp_se;
+ gfc_init_se (&comp_se, NULL);
+ e->expr_type = EXPR_VARIABLE;
+ gfc_conv_expr (&comp_se, e);
+ comp_se.expr = build_fold_addr_expr (comp_se.expr);
+ return gfc_evaluate_now (comp_se.expr, &se->pre);
+}
+
+
/* Translate a function expression. */
static void
sym = expr->value.function.esym;
if (!sym)
sym = expr->symtree->n.sym;
- gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
+
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ NULL_TREE);
}
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
- && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
- || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
+ && 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)
{
gfc_conv_ss_startstride (&loop);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
gfc_start_block (&block);
- if (cm->pointer)
+ if (cm->attr.pointer)
{
gfc_init_se (&se, NULL);
/* Pointer component. */
- if (cm->dimension)
+ if (cm->attr.dimension)
{
/* Array pointer. */
if (expr->expr_type == EXPR_NULL)
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify_expr (&block, dest,
+ gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), se.expr));
gfc_add_block_to_block (&block, &se.post);
}
}
- else if (cm->dimension)
+ else if (cm->attr.dimension)
{
- if (cm->allocatable && expr->expr_type == EXPR_NULL)
+ if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else if (cm->allocatable)
+ else if (cm->attr.allocatable)
{
tree tmp2;
gfc_add_block_to_block (&block, &se.pre);
tmp = fold_convert (TREE_TYPE (dest), se.expr);
- gfc_add_modify_expr (&block, dest, tmp);
+ gfc_add_modify (&block, dest, tmp);
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);
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);
+
+ 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 (dest);
- gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
+ 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++)
{
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,
+ gfc_add_modify (&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);
+ gfc_add_modify (&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_rank_cst[n]));
- gfc_add_modify_expr (&block, tmp2, tmp);
+ gfc_add_modify (&block, tmp2, tmp);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
- gfc_add_modify_expr (&block, offset, tmp);
+ gfc_add_modify (&block, offset, 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
{
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
- gfc_add_modify_expr (&block, dest,
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), se.expr));
+ gfc_add_block_to_block (&block, &se.post);
}
else
{
{
/* Skip absent members in default initializers. */
if (!c->expr)
- continue;
+ continue;
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);
}
components. Although the latter have a default initializer
of EXPR_NULL,... by default, the static nullify is not needed
since this is done every time we come into scope. */
- if (!c->expr || cm->allocatable)
+ if (!c->expr || cm->attr.allocatable)
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl), cm->dimension, cm->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);
}
se->expr = build_constructor (type, v);
+ if (init)
+ TREE_CONSTANT (se->expr) = 1;
}
ref = expr->ref;
- gcc_assert (ref->type == REF_SUBSTRING);
+ gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
+
+ se->expr = gfc_build_wide_string_const (expr->ts.kind,
+ 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,NULL,&expr->where);
+ if (ref)
+ gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
}
if (se->post.head)
{
val = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, val, se->expr);
+ gfc_add_modify (&se->pre, val, se->expr);
se->expr = val;
gfc_add_block_to_block (&se->pre, &se->post);
}
}
-/* Helper to translate and expression and convert it to a particular type. */
+/* 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)
{
if (se->post.head)
{
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
gfc_add_block_to_block (&se->pre, &se->post);
se->expr = var;
}
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);
+ gfc_add_modify (&se->pre, var, se->expr);
se->expr = var;
return;
}
else
{
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
- gfc_add_modify_expr (&se->pre, var, se->expr);
+ gfc_add_modify (&se->pre, var, se->expr);
}
gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
- se->expr = build_fold_addr_expr (var);
+ se->expr = gfc_build_addr_expr (NULL_TREE, var);
}
tree
gfc_trans_pointer_assign (gfc_code * code)
{
- return gfc_trans_pointer_assignment (code->expr, code->expr2);
+ return gfc_trans_pointer_assignment (code->expr1, code->expr2);
}
stmtblock_t block;
tree desc;
tree tmp;
+ tree decl;
gfc_start_block (&block);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
+
+ if (expr1->symtree->n.sym->attr.proc_pointer
+ && expr1->symtree->n.sym->attr.dummy)
+ lse.expr = build_fold_indirect_ref (lse.expr);
+
+ if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+ && expr2->symtree->n.sym->attr.dummy)
+ rse.expr = build_fold_indirect_ref (rse.expr);
+
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
- gfc_add_modify_expr (&block, lse.expr,
+
+ /* Check character lengths if character expression. The test is only
+ really added if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (lse.string_length && rse.string_length);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ lse.string_length, rse.string_length,
+ &block);
+ }
+
+ gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
+
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
else
{
+ tree strlen_lhs;
+ tree strlen_rhs = NULL_TREE;
+
/* Array pointer. */
gfc_conv_expr_descriptor (&lse, expr1, lss);
+ strlen_lhs = lse.string_length;
switch (expr2->expr_type)
{
case EXPR_NULL:
case EXPR_VARIABLE:
/* Assign directly to the pointer's descriptor. */
- lse.direct_byref = 1;
+ lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ strlen_rhs = lse.string_length;
+
+ /* 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 (&lse.post, GFC_DECL_SPAN(decl), tmp);
+ }
+
break;
default:
lse.expr = tmp;
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
- gfc_add_modify_expr (&lse.pre, desc, tmp);
+ strlen_rhs = lse.string_length;
+ gfc_add_modify (&lse.pre, desc, tmp);
break;
- }
+ }
+
gfc_add_block_to_block (&block, &lse.pre);
+
+ /* Check string lengths if applicable. The check is only really added
+ to the output code if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (strlen_lhs && strlen_rhs);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ strlen_lhs, strlen_rhs, &block);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
}
return gfc_finish_block (&block);
/* Makes sure se is suitable for passing as a function string parameter. */
-/* TODO: Need to check all callers fo this function. It may be abused. */
+/* TODO: Need to check all callers of this function. It may be abused. */
void
gfc_conv_string_parameter (gfc_se * se)
if (TREE_CODE (se->expr) == STRING_CST)
{
- se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
+ type = TREE_TYPE (TREE_TYPE (se->expr));
+ se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
return;
}
- type = TREE_TYPE (se->expr);
- if (TYPE_STRING_FLAG (type))
+ if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
{
- 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)
+ {
+ type = TREE_TYPE (se->expr);
+ se->expr = gfc_build_addr_expr (build_pointer_type (type), 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, ts.kind, rlen,
+ rse->expr, ts.kind);
}
else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
{
if (r_is_var)
{
cond = fold_build2 (EQ_EXPR, boolean_type_node,
- build_fold_addr_expr (lse->expr),
- build_fold_addr_expr (rse->expr));
+ gfc_build_addr_expr (NULL_TREE, lse->expr),
+ gfc_build_addr_expr (NULL_TREE, rse->expr));
cond = gfc_evaluate_now (cond, &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,
+ gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
/* Do a deep copy if the rhs is a variable, if it is not the
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- gfc_add_modify_expr (&block, lse->expr,
+ gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
gfc_ss *ss;
gfc_ref * ref;
bool seen_array_ref;
+ gfc_component *comp = NULL;
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
/* Check for a dependency. */
if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
expr2->value.function.esym,
- expr2->value.function.actual))
+ expr2->value.function.actual,
+ NOT_ELEMENTAL))
return NULL;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
+ is_proc_ptr_comp(expr2, &comp);
gcc_assert (expr2->value.function.isym
- || (gfc_return_by_reference (expr2->value.function.esym)
+ || (comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension));
ss = gfc_walk_expr (expr1);
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, 0);
+ gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
fold_convert (gfc_array_index_type, tmp));
- /* Convert arguments to the correct types. */
+ /* If we are zeroing a local array avoid taking its address by emitting
+ a = {} instead. */
if (!POINTER_TYPE_P (TREE_TYPE (dest)))
- dest = gfc_build_addr_expr (pvoid_type_node, dest);
- else
- dest = fold_convert (pvoid_type_node, dest);
+ return build2 (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);
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memset. */
/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
that constructs the call to __builtin_memcpy. */
-static tree
+tree
gfc_build_memcpy_call (tree dst, tree src, tree len)
{
tree tmp;
stmtblock_t block;
stmtblock_t body;
bool l_is_temp;
+ bool scalar_to_array;
+ tree string_length;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
rss = NULL;
if (lss != gfc_ss_terminator)
{
+ /* Allow the scalarizer to workshare array assignments. */
+ if (ompws_flags & OMPWS_WORKSHARE_FLAG)
+ ompws_flags |= OMPWS_SCALARIZER_WS;
+
/* The assignment needs scalarization. */
lss_section = lss;
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr2->where);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
/* Translate the expression. */
gfc_conv_expr (&rse, expr2);
+ /* Stabilize a string length for temporaries. */
+ if (expr2->ts.type == BT_CHARACTER)
+ string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+ else
+ string_length = NULL_TREE;
+
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;
}
else
gfc_conv_expr (&lse, expr1);
+ /* Assignments of scalar derived types with allocatable components
+ to arrays must be done with a deep copy and the rhs temporary
+ must have its components deallocated afterwards. */
+ scalar_to_array = (expr2->ts.type == BT_DERIVED
+ && expr2->ts.derived->attr.alloc_comp
+ && expr2->expr_type != EXPR_VARIABLE
+ && !gfc_is_constant_expr (expr2)
+ && expr1->rank && !expr2->rank);
+ if (scalar_to_array)
+ {
+ tmp = gfc_deallocate_alloc_comp (expr2->ts.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);
+ (expr2->expr_type == EXPR_VARIABLE)
+ || scalar_to_array);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
+ if (expr2->ts.type == BT_CHARACTER)
+ rse.string_length = string_length;
+
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
false, false);
gfc_add_expr_to_block (&body, tmp);
}
-/* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
+/* 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)
+ 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. */
}
/* Special case assigning an array to zero. */
- if (expr1->expr_type == EXPR_VARIABLE
- && expr1->rank > 0
- && expr1->ref
- && expr1->ref->next == NULL
- && gfc_full_array_ref_p (expr1->ref)
+ if (copyable_array_p (expr1)
&& is_zero_initializer_p (expr2))
{
tmp = gfc_trans_zero_assign (expr1);
}
/* Special case copying one array to another. */
- if (expr1->expr_type == EXPR_VARIABLE
- && copyable_array_p (expr1)
- && gfc_full_array_ref_p (expr1->ref)
- && expr2->expr_type == EXPR_VARIABLE
+ if (copyable_array_p (expr1)
&& copyable_array_p (expr2)
- && gfc_full_array_ref_p (expr2->ref)
&& gfc_compare_types (&expr1->ts, &expr2->ts)
&& !gfc_check_dependency (expr1, expr2, 0))
{
}
/* Special case initializing an array from a constant array constructor. */
- if (expr1->expr_type == EXPR_VARIABLE
- && copyable_array_p (expr1)
- && gfc_full_array_ref_p (expr1->ref)
+ if (copyable_array_p (expr1)
&& expr2->expr_type == EXPR_ARRAY
&& gfc_compare_types (&expr1->ts, &expr2->ts))
{
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2, true);
+ return gfc_trans_assignment (code->expr1, code->expr2, true);
}
tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, false);
}
OSDN Git Service
