OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/55618 (Failures with ISO_Varying_String test suite) 

2013-01-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55618
	* trans-expr.c (gfc_conv_procedure_call): Dereference scalar
	character function arguments to elemental procedures in
	scalarization loops.

2013-01-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55618
	* gfortran.dg/elemental_scalar_args_2.f90: New test.

From-SVN: r195129
This commit is contained in:
Paul Thomas 2013-01-13 07:51:26 +00:00
parent 7737f4725a
commit 97935f9854
5 changed files with 223 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2013-01-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/55618
* trans-expr.c (gfc_conv_procedure_call): Dereference scalar
character function arguments to elemental procedures in
scalarization loops.
2013-01-08 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42769
@ -609,7 +616,7 @@
PR fortran/50981
* trans-array.c (gfc_walk_elemental_function_args): Fix
passing of deallocated allocatables/pointers as absent argument.
passing of deallocated allocatables/pointers as absent argument.
2012-01-16 Tobias Burnus <burnus@net-b.de>
@ -645,7 +652,7 @@
2012-01-16 Paul Thomas <pault@gcc.gnu.org>
* trans-array.c (gfc_trans_create_temp_array): In the case of a
class array temporary, detect a null 'eltype' on entry and use
class array temporary, detect a null 'eltype' on entry and use
'initial' to provde the class reference and so, through the
vtable, the element size for the dynamic type.
* trans-stmt.c (gfc_conv_elemental_dependencies): For class

216
gcc/fortran/resolve.c
View File

@ -94,7 +94,7 @@ static bool
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
{
for (ns = ns->parent; ns; ns = ns->parent)
{
{
if (sym->ns == ns)
return true;
}
@ -165,7 +165,7 @@ resolve_procedure_interface (gfc_symbol *sym)
sym->ts = ifc->result->ts;
sym->result = sym;
}
else
else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
@ -513,7 +513,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
}
}
/* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
/* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
type, lists the only ways a character length value of * can be used:
dummy arguments of procedures, named constants, and function results
in external functions. Internal function results and results of module
@ -1255,7 +1255,7 @@ generic_sym (gfc_symbol *sym)
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
if (s != NULL)
{
if (s == sym)
@ -1376,7 +1376,7 @@ count_specific_procs (gfc_expr *e)
int n;
gfc_interface *p;
gfc_symbol *sym;
n = 0;
sym = e->symtree->n.sym;
@ -1579,7 +1579,7 @@ resolve_procedure_expression (gfc_expr* expr)
gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
" itself recursively. Declare it RECURSIVE or use"
" -frecursive", sym->name, &expr->where);
return SUCCESS;
}
@ -1687,7 +1687,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
return FAILURE;
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
@ -1876,7 +1876,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
else if (c && c->ext.actual != NULL)
{
arg0 = c->ext.actual;
if (c->resolved_sym)
esym = c->resolved_sym;
else
@ -2275,7 +2275,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
if (sym->attr.if_source != IFSRC_IFBODY)
if (sym->attr.if_source != IFSRC_IFBODY)
gfc_procedure_use (def_sym, actual, where);
gfc_errors_to_warnings (0);
@ -2679,7 +2679,7 @@ is_scalar_expr_ptr (gfc_expr *expr)
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
scalar.
scalar.
FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
@ -2746,7 +2746,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
the actual expression could be a part-ref of the expr symbol. */
arg_ts = &(args->expr->ts);
arg_attr = gfc_expr_attr (args->expr);
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* If the user gave two args then they are providing something for
@ -2835,7 +2835,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
if (seen_section && retval == SUCCESS)
gfc_warning ("Array section in '%s' call at %L", name,
&(args->expr->where));
/* See if we have interoperable type and type param. */
if (gfc_verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
@ -2849,7 +2849,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
is not an array of zero size. */
if (args_sym->attr.allocatable == 1)
{
if (args_sym->attr.dimension != 0
if (args_sym->attr.dimension != 0
&& (args_sym->as && args_sym->as->rank == 0))
{
gfc_error_now ("Allocatable variable '%s' used as a "
@ -2888,7 +2888,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
retval = FAILURE;
}
}
/* Make sure it's not a character string. Arrays of
any type should be ok if the variable is of a C
interoperable type. */
@ -2928,7 +2928,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
with no length type parameters. It still must have either
the pointer or target attribute, and it can be
allocatable (but must be allocated when c_loc is called). */
if (args->expr->rank != 0
if (args->expr->rank != 0
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
@ -2936,7 +2936,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
&(args->expr->where));
retval = FAILURE;
}
else if (arg_ts->type == BT_CHARACTER
else if (arg_ts->type == BT_CHARACTER
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("CHARACTER argument '%s' to '%s' at "
@ -2975,7 +2975,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
retval = FAILURE;
}
}
/* for c_loc/c_funloc, the new symbol is the same as the old one */
*new_sym = sym;
}
@ -3010,7 +3010,7 @@ resolve_function (gfc_expr *expr)
/* If this is a procedure pointer component, it has already been resolved. */
if (gfc_is_proc_ptr_comp (expr, NULL))
return SUCCESS;
if (sym && sym->attr.intrinsic
&& resolve_intrinsic (sym, &expr->where) == FAILURE)
return FAILURE;
@ -3049,7 +3049,7 @@ resolve_function (gfc_expr *expr)
}
inquiry_argument = false;
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
@ -3057,12 +3057,12 @@ resolve_function (gfc_expr *expr)
if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
== FAILURE)
return FAILURE;
/* Get the symtree for the new symbol (resolved func).
the old one will be freed later, when it's no longer used. */
gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
}
/* Resume assumed_size checking. */
need_full_assumed_size--;
@ -3391,7 +3391,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym,
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
*binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
*binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
kind);
}
else
@ -3402,7 +3402,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym,
sprintf (name, "%s", sym->name);
*binding_label = sym->binding_label;
}
return;
}
@ -3426,7 +3426,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
/* default to success; will override if find error */
match m = MATCH_YES;
/* Make sure the actual arguments are in the necessary order (based on the
/* Make sure the actual arguments are in the necessary order (based on the
formal args) before resolving. */
gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
@ -3434,7 +3434,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
set_name_and_label (c, sym, name, &binding_label);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
{
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
@ -3445,7 +3445,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
gfc_procedure_use() (called above to sort actual args). */
if (c->ext.actual->next->expr->rank != 0)
{
if(c->ext.actual->next->next == NULL
if(c->ext.actual->next->next == NULL
|| c->ext.actual->next->next->expr == NULL)
{
m = MATCH_ERROR;
@ -3464,12 +3464,12 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
}
}
}
if (m != MATCH_ERROR)
{
/* the 1 means to add the optional arg to formal list */
new_sym = get_iso_c_sym (sym, name, binding_label, 1);
/* for error reporting, say it's declared where the original was */
new_sym->declared_at = sym->declared_at;
}
@ -3485,7 +3485,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
c->resolved_sym = new_sym;
else
c->resolved_sym = sym;
return m;
}
@ -3502,7 +3502,7 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
m = gfc_iso_c_sub_interface (c,sym);
return m;
}
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@ -3921,7 +3921,7 @@ resolve_operator (gfc_expr *e)
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
_("Logicals at %%L must be compared with %s instead of %s"),
(e->value.op.op == INTRINSIC_EQ
(e->value.op.op == INTRINSIC_EQ
|| e->value.op.op == INTRINSIC_EQ_OS)
? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
else
@ -4161,7 +4161,7 @@ compare_bound_mpz_t (gfc_expr *a, mpz_t b)
}
/* Compute the last value of a sequence given by a triplet.
/* Compute the last value of a sequence given by a triplet.
Return 0 if it wasn't able to compute the last value, or if the
sequence if empty, and 1 otherwise. */
@ -6003,7 +6003,7 @@ resolve_typebound_function (gfc_expr* e)
e->value.function.esym = NULL;
e->symtree = st;
if (new_ref)
if (new_ref)
e->ref = new_ref;
/* '_vptr' points to the vtab, which contains the procedure pointers. */
@ -6321,7 +6321,7 @@ gfc_resolve_expr (gfc_expr *e)
if (t == SUCCESS && e->ts.type == BT_CHARACTER)
{
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
here rather then add a duplicate test for it above. */
here rather then add a duplicate test for it above. */
gfc_expand_constructor (e, false);
t = gfc_resolve_character_array_constructor (e);
}
@ -6478,7 +6478,7 @@ forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
{
if (expr->expr_type != EXPR_VARIABLE)
return false;
/* A scalar assignment */
if (!expr->ref || *f == 1)
{
@ -6761,7 +6761,7 @@ remove_last_array_ref (gfc_expr* e)
/* Used in resolve_allocate_expr to check that a allocation-object and
a source-expr are conformable. This does not catch all possible
a source-expr are conformable. This does not catch all possible
cases; in particular a runtime checking is needed. */
static gfc_try
@ -6769,7 +6769,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
{
gfc_ref *tail;
for (tail = e2->ref; tail && tail->next; tail = tail->next);
/* First compare rank. */
if (tail && e1->rank != tail->u.ar.as->rank)
{
@ -7032,7 +7032,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
using _copy and trans_call. It is convenient to exploit that
when the allocated type is different from the declared type but
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
else if (!code->expr3)
{
@ -7293,7 +7293,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
/* This is a potential collision. */
gfc_ref *pr = pe->ref;
gfc_ref *qr = qe->ref;
/* Follow the references until
a) They start to differ, in which case there is no error;
you can deallocate a%b and a%c in a single statement
@ -7348,7 +7348,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (pr->u.c.component->name != qr->u.c.component->name)
break;
}
pr = pr->next;
qr = qr->next;
}
@ -7375,7 +7375,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
/* Callback function for our mergesort variant. Determines interval
overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
op1 > op2. Assumes we're not dealing with the default case.
op1 > op2. Assumes we're not dealing with the default case.
We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
There are nine situations to check. */
@ -8066,7 +8066,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
default_case = body;
}
}
if (error > 0)
return;
@ -8085,7 +8085,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
assoc->target = gfc_copy_expr (code->expr2);
assoc->target->where = code->expr2->where;
/* assoc->variable will be set by resolve_assoc_var. */
code->ext.block.assoc = assoc;
code->expr1->symtree->n.sym->assoc = assoc;
@ -8156,7 +8156,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
resolve_assoc_var (st->n.sym, false);
}
/* Take out CLASS IS cases for separate treatment. */
body = code;
while (body && body->block)
@ -8165,7 +8165,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
/* Add to class_is list. */
if (class_is == NULL)
{
{
class_is = body->block;
tail = class_is;
}
@ -8186,7 +8186,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
if (class_is)
{
gfc_symbol *vtab;
if (!default_case)
{
/* Add a default case to hold the CLASS IS cases. */
@ -8234,7 +8234,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
}
while (swapped);
}
/* Generate IF chain. */
if_st = gfc_get_code ();
if_st->op = EXEC_IF;
@ -8270,7 +8270,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
new_st->op = EXEC_IF;
new_st->next = default_case->next;
}
/* Replace CLASS DEFAULT code by the IF chain. */
default_case->next = if_st;
}
@ -8287,7 +8287,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
-- a derived type being transferred doesn't have private components, unless
-- a derived type being transferred doesn't have private components, unless
it's being transferred from the module where the type was defined
-- we're not trying to transfer a whole assumed size array. */
@ -8391,7 +8391,7 @@ resolve_transfer (gfc_code *code)
/* Find the set of labels that are reachable from this block. We also
record the last statement in each block. */
static void
find_reachable_labels (gfc_code *block)
{
@ -8697,7 +8697,7 @@ resolve_where (gfc_code *code, gfc_expr *mask)
"inconsistent shape", &cnext->expr1->where);
break;
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
if (!cnext->resolved_sym->attr.elemental)
@ -8783,7 +8783,7 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
break;
/* WHERE operator assignment statement */
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
@ -8851,10 +8851,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
/* Counts the number of iterators needed inside a forall construct, including
nested forall constructs. This is used to allocate the needed memory
nested forall constructs. This is used to allocate the needed memory
in gfc_resolve_forall. */
static int
static int
gfc_count_forall_iterators (gfc_code *code)
{
int max_iters, sub_iters, current_iters;
@ -8866,11 +8866,11 @@ gfc_count_forall_iterators (gfc_code *code)
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
current_iters ++;
code = code->block->next;
while (code)
{
{
if (code->op == EXEC_FORALL)
{
sub_iters = gfc_count_forall_iterators (code);
@ -9653,7 +9653,7 @@ resolve_values (gfc_symbol *sym)
if (sym->value->expr_type == EXPR_STRUCTURE)
t= resolve_structure_cons (sym->value, 1);
else
else
t = gfc_resolve_expr (sym->value);
if (t == FAILURE)
@ -9675,7 +9675,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
{
gfc_gsymbol *binding_label_gsym;
gfc_gsymbol *comm_name_gsym;
const char * bind_label = comm_block_tree->n.common->binding_label
const char * bind_label = comm_block_tree->n.common->binding_label
? comm_block_tree->n.common->binding_label : "";
/* See if a global symbol exists by the common block's name. It may
@ -9718,7 +9718,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
check and nothing to add as a global symbol for the label. */
if (!comm_block_tree->n.common->binding_label)
return;
binding_label_gsym =
gfc_find_gsymbol (gfc_gsym_root,
comm_block_tree->n.common->binding_label);
@ -9755,7 +9755,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
comm_name_gsym->name, &(comm_name_gsym->where));
}
}
return;
}
@ -9769,34 +9769,34 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym)
if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
&& derived_sym->attr.is_bind_c == 1)
verify_bind_c_derived_type (derived_sym);
return;
}
/* Verify that any binding labels used in a given namespace do not collide
/* Verify that any binding labels used in a given namespace do not collide
with the names or binding labels of any global symbols. */
static void
gfc_verify_binding_labels (gfc_symbol *sym)
{
int has_error = 0;
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
&& sym->attr.flavor != FL_DERIVED && sym->binding_label)
{
gfc_gsymbol *bind_c_sym;
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
if (bind_c_sym != NULL
if (bind_c_sym != NULL
&& strcmp (bind_c_sym->name, sym->binding_label) == 0)
{
if (sym->attr.if_source == IFSRC_DECL
&& (bind_c_sym->type != GSYM_SUBROUTINE
&& bind_c_sym->type != GSYM_FUNCTION)
&& ((sym->attr.contained == 1
&& strcmp (bind_c_sym->sym_name, sym->name) != 0)
|| (sym->attr.use_assoc == 1
if (sym->attr.if_source == IFSRC_DECL
&& (bind_c_sym->type != GSYM_SUBROUTINE
&& bind_c_sym->type != GSYM_FUNCTION)
&& ((sym->attr.contained == 1
&& strcmp (bind_c_sym->sym_name, sym->name) != 0)
|| (sym->attr.use_assoc == 1
&& (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
{
/* Make sure global procedures don't collide with anything. */
@ -9806,10 +9806,10 @@ gfc_verify_binding_labels (gfc_symbol *sym)
&(bind_c_sym->where));
has_error = 1;
}
else if (sym->attr.contained == 0
&& (sym->attr.if_source == IFSRC_IFBODY
&& sym->attr.flavor == FL_PROCEDURE)
&& (bind_c_sym->sym_name != NULL
else if (sym->attr.contained == 0
&& (sym->attr.if_source == IFSRC_IFBODY
&& sym->attr.flavor == FL_PROCEDURE)
&& (bind_c_sym->sym_name != NULL
&& strcmp (bind_c_sym->sym_name, sym->name) != 0))
{
/* Make sure procedures in interface bodies don't collide. */
@ -9820,10 +9820,10 @@ gfc_verify_binding_labels (gfc_symbol *sym)
&(bind_c_sym->where));
has_error = 1;
}
else if (sym->attr.contained == 0
else if (sym->attr.contained == 0
&& sym->attr.if_source == IFSRC_UNKNOWN)
if ((sym->attr.use_assoc && bind_c_sym->mod_name
&& strcmp (bind_c_sym->mod_name, sym->module) != 0)
&& strcmp (bind_c_sym->mod_name, sym->module) != 0)
|| sym->attr.use_assoc == 0)
{
gfc_error ("Binding label '%s' at %L collides with global "
@ -10019,7 +10019,7 @@ apply_default_init (gfc_symbol *sym)
/* Build an initializer for a local integer, real, complex, logical, or
character variable, based on the command line flags finit-local-zero,
finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
null if the symbol should not have a default initialization. */
static gfc_expr *
build_default_init_expr (gfc_symbol *sym)
@ -10050,10 +10050,10 @@ build_default_init_expr (gfc_symbol *sym)
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
switch (sym->ts.type)
{
{
case BT_INTEGER:
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
mpz_set_si (init_expr->value.integer,
mpz_set_si (init_expr->value.integer,
gfc_option.flag_init_integer_value);
else
{
@ -10090,7 +10090,7 @@ build_default_init_expr (gfc_symbol *sym)
break;
}
break;
case BT_COMPLEX:
switch (gfc_option.flag_init_real)
{
@ -10122,7 +10122,7 @@ build_default_init_expr (gfc_symbol *sym)
break;
}
break;
case BT_LOGICAL:
if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
init_expr->value.logical = 0;
@ -10134,9 +10134,9 @@ build_default_init_expr (gfc_symbol *sym)
init_expr = NULL;
}
break;
case BT_CHARACTER:
/* For characters, the length must be constant in order to
/* For characters, the length must be constant in order to
create a default initializer. */
if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
&& sym->ts.u.cl->length
@ -10175,7 +10175,7 @@ build_default_init_expr (gfc_symbol *sym)
init_expr->value.function.actual = arg;
}
break;
default:
gfc_free_expr (init_expr);
init_expr = NULL;
@ -10203,7 +10203,7 @@ apply_default_init_local (gfc_symbol *sym)
/* For saved variables, we don't want to add an initializer at function
entry, so we just add a static initializer. Note that automatic variables
are stack allocated even with -fno-automatic. */
if (sym->attr.save || sym->ns->save_all
if (sym->attr.save || sym->ns->save_all
|| (gfc_option.flag_max_stack_var_size == 0
&& (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
{
@ -10308,7 +10308,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
}
return SUCCESS;
}
@ -10730,7 +10730,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
sym->attr.is_c_interop = 1;
sym->ts.is_c_interop = 1;
}
curr_arg = sym->formal;
while (curr_arg != NULL)
{
@ -10742,7 +10742,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
BIND(C) to try and prevent multiple errors being
reported. */
has_non_interop_arg = 1;
curr_arg = curr_arg->next;
}
@ -10755,7 +10755,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
sym->attr.is_bind_c = 0;
}
}
if (!sym->attr.proc_pointer)
{
if (sym->attr.save == SAVE_EXPLICIT)
@ -10906,7 +10906,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
{
gfc_error ("FINAL procedure '%s' declared at %L has the same"
" rank (%d) as '%s'",
list->proc_sym->name, &list->where, my_rank,
list->proc_sym->name, &list->where, my_rank,
i->proc_sym->name);
goto error;
}
@ -11156,7 +11156,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
{
gfc_symbol* super_type;
gfc_tbp_generic* target;
/* If there's already an error here, do nothing (but don't fail again). */
if (p->error)
return SUCCESS;
@ -11381,7 +11381,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
me_arg->name, &where, resolve_bindings_derived->name);
goto error;
}
gcc_assert (me_arg->ts.type == BT_CLASS);
if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
{
@ -11458,7 +11458,7 @@ resolve_typebound_procedures (gfc_symbol* derived)
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
super_type = gfc_get_derived_super_type (derived);
if (super_type)
resolve_typebound_procedures (super_type);
@ -11551,7 +11551,7 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
clearer than something sophisticated. */
gcc_assert (ancestor && !sub->attr.abstract);
if (!ancestor->attr.abstract)
return SUCCESS;
@ -11685,7 +11685,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
c->as = gfc_copy_array_spec (ifc->result->as);
}
else
{
{
c->ts = ifc->ts;
c->attr.allocatable = ifc->attr.allocatable;
c->attr.pointer = ifc->attr.pointer;
@ -11854,7 +11854,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
|| (!sym->attr.is_class && c == sym->components))
&& strcmp (super_type->name, c->name) == 0)
c->attr.access = super_type->attr.access;
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
if (super_type && !sym->attr.is_class
@ -12028,10 +12028,10 @@ resolve_fl_derived (gfc_symbol *sym)
vptr->ts.u.derived = vtab->ts.u.derived;
}
}
if (resolve_fl_derived0 (sym) == FAILURE)
return FAILURE;
/* Resolve the type-bound procedures. */
if (resolve_typebound_procedures (sym) == FAILURE)
return FAILURE;
@ -12039,7 +12039,7 @@ resolve_fl_derived (gfc_symbol *sym)
/* Resolve the finalizer procedures. */
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
return SUCCESS;
}
@ -12186,7 +12186,7 @@ static gfc_try
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
if (sym->as != NULL
if (sym->as != NULL
&& (sym->as->type == AS_DEFERRED
|| is_non_constant_shape_array (sym)))
{
@ -12301,8 +12301,8 @@ resolve_symbol (gfc_symbol *sym)
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
/* Make sure that the intrinsic is consistent with its internal
representation. This needs to be done before assigning a default
/* Make sure that the intrinsic is consistent with its internal
representation. This needs to be done before assigning a default
type to avoid spurious warnings. */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
@ -12461,7 +12461,7 @@ resolve_symbol (gfc_symbol *sym)
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
{
gfc_try t = SUCCESS;
/* First, make sure the variable is declared at the
module-level scope (J3/04-007, Section 15.3). */
if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
@ -12491,7 +12491,7 @@ resolve_symbol (gfc_symbol *sym)
verify_bind_c_derived_type (sym->ts.u.derived);
t = FAILURE;
}
/* Verify the variable itself as C interoperable if it
is BIND(C). It is not possible for this to succeed if
the verify_bind_c_derived_type failed, so don't have to handle
@ -13263,12 +13263,12 @@ gfc_implicit_pure (gfc_symbol *sym)
sym = ns->proc_name;
if (sym == NULL)
return 0;
if (sym->attr.flavor == FL_PROCEDURE)
break;
}
}
return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
&& !sym->attr.pure;
}
@ -13439,7 +13439,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
}
/* Resolve equivalence object.
/* Resolve equivalence object.
An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
an allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component

122
gcc/fortran/trans-expr.c
View File

@ -1,6 +1,6 @@
/* Expression translation
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011, 2012
2011, 2012, 2013
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -148,7 +148,7 @@ gfc_vtable_copy_get (tree decl)
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. */
class object of the 'declared' type. */
static void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts)
@ -211,10 +211,10 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
/* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared'
type.
type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
the original class expression can be passed directly. */
the original class expression can be passed directly. */
void
gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, bool elemental)
@ -267,7 +267,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
tmp = NULL_TREE;
if (class_ref == NULL
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
tmp = e->symtree->n.sym->backend_decl;
else
{
@ -481,7 +481,7 @@ gfc_trans_class_init_assign (gfc_code *code)
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
@ -727,7 +727,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
tmp = gfc_get_int_type (kind);
tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
se->expr));
/* Test for a NULL value. */
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
@ -764,9 +764,9 @@ gfc_get_expr_charlen (gfc_expr *e)
gfc_ref *r;
tree length;
gcc_assert (e->expr_type == EXPR_VARIABLE
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER);
length = NULL; /* To silence compiler warning. */
if (is_subref_array (e) && e->ts.u.cl->length)
@ -855,8 +855,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
{
case EXPR_OP:
flatten_array_ctors_without_strlen (e->value.op.op1);
flatten_array_ctors_without_strlen (e->value.op.op2);
flatten_array_ctors_without_strlen (e->value.op.op1);
flatten_array_ctors_without_strlen (e->value.op.op2);
break;
case EXPR_COMPCALL:
@ -1221,7 +1221,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */
else if (alternate_entry
else if (alternate_entry
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
{
@ -1257,7 +1257,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* Dereference the expression, where needed. Since characters
are entirely different from other types, they are treated
are entirely different from other types, they are treated
separately. */
if (sym->ts.type == BT_CHARACTER)
{
@ -1287,7 +1287,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Dereference non-character pointer variables.
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable
|| gfc_is_associate_pointer (sym))
@ -1359,7 +1359,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
gfc_conv_string_parameter (se);
else
else
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
}
@ -1441,11 +1441,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] =
124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
};
/* If n is larger than lookup table's max index, we use the "window
/* If n is larger than lookup table's max index, we use the "window
method". */
#define POWI_WINDOW_SIZE 3
/* Recursive function to expand the power operator. The temporary
/* 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, unsigned HOST_WIDE_INT n, tree * tmpvar)
@ -1508,7 +1508,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree 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);
sgn = tree_int_cst_sgn (rhs);
@ -1619,7 +1619,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 4:
ikind = 0;
break;
case 8:
ikind = 1;
break;
@ -1647,7 +1647,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 4:
kind = 0;
break;
case 8:
kind = 1;
break;
@ -1663,7 +1663,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
default:
gcc_unreachable ();
}
switch (expr->value.op.op1->ts.type)
{
case BT_INTEGER:
@ -1681,7 +1681,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
case 0:
fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break;
case 1:
fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break;
@ -1691,7 +1691,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
break;
case 3:
/* Use the __builtin_powil() only if real(kind=16) is
/* Use the __builtin_powil() only if real(kind=16) is
actually the C long double type. */
if (!gfc_real16_is_float128)
fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
@ -1702,7 +1702,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
}
}
/* If we don't have a good builtin for this, go for the
/* If we don't have a good builtin for this, go for the
library function. */
if (!fndecl)
fndecl = gfor_fndecl_math_powi[kind][ikind].real;
@ -2109,7 +2109,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **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
/* 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;
@ -2547,8 +2547,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
value = build_fold_indirect_ref_loc (input_location,
se->expr);
/* For character(*), use the actual argument's descriptor. */
/* For character(*), use the actual argument's descriptor. */
else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
value = build_fold_indirect_ref_loc (input_location,
se->expr);
@ -2958,7 +2958,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
rss = gfc_walk_expr (expr);
gcc_assert (rss != gfc_ss_terminator);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, rss);
@ -3118,7 +3118,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop2, &body);
@ -3145,7 +3145,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
if (formal_ptr)
{
size = gfc_index_one_node;
offset = gfc_index_zero_node;
offset = gfc_index_zero_node;
for (n = 0; n < dimen; n++)
{
tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
@ -3230,7 +3230,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
{
gfc_symbol *fsym;
gfc_ss *argss;
if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
if (arg->expr->rank == 0)
@ -3247,7 +3247,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
&& !(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,
NULL, NULL, NULL);
@ -3268,7 +3268,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr);
return 1;
}
else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
@ -3293,12 +3293,12 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
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 (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
@ -3332,7 +3332,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
{
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);
@ -3356,7 +3356,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
return 1;
}
/* Nothing was done. */
return 0;
}
@ -3536,7 +3536,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
else
gfc_conv_expr_reference (&parmse, e);
{
gfc_conv_expr_reference (&parmse, e);
if (e->ts.type == BT_CHARACTER && !e->rank
&& e->expr_type == EXPR_FUNCTION)
parmse.expr = build_fold_indirect_ref_loc (input_location,
parmse.expr);
}
/* The scalarizer does not repackage the reference to a class
array - instead it returns a pointer to the data element. */
@ -3625,7 +3631,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& !CLASS_DATA (e)->attr.codimension)
parmse.expr = gfc_class_data_get (parmse.expr);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
@ -3709,7 +3715,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* If the argument is a function call that may not create
a temporary for the result, we have to check that we
can do it, i.e. that there is no alias between this
can do it, i.e. that there is no alias between this
argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{
@ -3770,7 +3776,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
@ -3787,7 +3793,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
}
}
}
}
/* The case with fsym->attr.optional is that of a user subroutine
@ -3813,7 +3819,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& ((e->rank > 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank > 0
&& (fsym == NULL
&& (fsym == NULL
|| (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE
|| fsym->as->type == AS_DEFERRED))))))
@ -3982,7 +3988,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg);
free (msg);
@ -4039,7 +4045,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
}
VEC_safe_push (tree, gc, stringargs, tmp);
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
@ -4132,7 +4138,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_expr (&parmse, ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
tmp = fold_build2_loc (input_location, MAX_EXPR,
gfc_charlen_type_node, tmp,
@ -4868,7 +4874,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
/* Build a static initializer. EXPR is the expression for the initial value.
The other parameters describe the variable of the component being
The other parameters describe the variable of the component being
initialized. EXPR may be null. */
tree
@ -4899,7 +4905,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
return se.expr;
}
if (array && !procptr)
{
tree ctor;
@ -4957,7 +4963,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
}
}
}
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
@ -5004,7 +5010,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
cm->as->lower[n]->value.integer);
mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
}
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
@ -5070,7 +5076,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_start_block (&block);
gfc_init_se (&se, NULL);
/* Get the descriptor for the expressions. */
/* Get the descriptor for the expressions. */
rss = gfc_walk_expr (expr);
se.want_pointer = 0;
gfc_conv_expr_descriptor (&se, expr, rss);
@ -5325,7 +5331,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
fold_convert (TREE_TYPE (lse.expr), se.expr));
return gfc_finish_block (&block);
}
}
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
@ -5407,7 +5413,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
}
}
se->expr = build_constructor (type, v);
if (init)
if (init)
TREE_CONSTANT (se->expr) = 1;
}
@ -5752,7 +5758,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
for (remap = expr1->ref; remap; remap = remap->next)
if (!remap->next && remap->type == REF_ARRAY
&& remap->u.ar.type == AR_SECTION)
{
{
remap->u.ar.type = AR_FULL;
break;
}
@ -6050,7 +6056,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
cond = NULL_TREE;
/* Are the rhs and the lhs the same? */
if (r_is_var)
{
@ -6146,7 +6152,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
/* Functions returning pointers or allocatables need temporaries. */
c = expr2->value.function.esym
? (expr2->value.function.esym->attr.pointer
? (expr2->value.function.esym->attr.pointer
|| expr2->value.function.esym->attr.allocatable)
: (expr2->symtree->n.sym->attr.pointer
|| expr2->symtree->n.sym->attr.allocatable);
@ -6439,7 +6445,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
correctly take care of the reallocation internally. For intrinsic
calls, the array data is freed and the library takes care of allocation.
TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
to the library. */
to the library. */
if (gfc_option.flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension
@ -6713,7 +6719,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = gfc_build_label_decl (NULL_TREE);

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2013-01-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/55618
* gfortran.dg/elemental_scalar_args_2.f90: New test.
2013-01-08 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42769
@ -2599,7 +2604,7 @@
2012-02-06 Andrey Belevantsev <abel@ispras.ru>
* gcc.dg/pr48374.c: Actually add the test I forgot
* gcc.dg/pr48374.c: Actually add the test I forgot
in the 2012-01-25 commit.
2012-02-05 Thomas König <tkoenig@gcc.gnu.org>

36
gcc/testsuite/gfortran.dg/elemental_scalar_args_2.f90 Normal file
View File

@ -0,0 +1,36 @@
! { dg-do run }
! Test the fix for PR55618, in which character scalar function arguments to
! elemental functions would gain an extra indirect reference thus causing
! failures in Vst17.f95, Vst 30.f95 and Vst31.f95 in the iso_varying_string
! testsuite, where elemental tests are done.
!
! Reported by Tobias Burnus <burnus@gcc.gnu.org>
!
integer, dimension (2) :: i = [1,2]
integer :: j = 64
character (len = 2) :: chr1 = "lm"
character (len = 1), dimension (2) :: chr2 = ["r", "s"]
if (any (foo (i, bar()) .ne. ["a", "b"])) call abort ! This would fail
if (any (foo (i, "xy") .ne. ["x", "y"])) call abort ! OK - not a function
if (any (foo (i, chr1) .ne. ["l", "m"])) call abort ! ditto
if (any (foo (i, char (j)) .ne. ["A", "B"])) call abort ! This would fail
if (any (foo (i, chr2) .ne. ["s", "u"])) call abort ! OK - not a scalar
if (any (foo (i, bar2()) .ne. ["e", "g"])) call abort ! OK - not a scalar function
contains
elemental character(len = 1) function foo (arg1, arg2)
integer, intent (in) :: arg1
character(len = *), intent (in) :: arg2
if (len (arg2) > 1) then
foo = arg2(arg1:arg1)
else
foo = char (ichar (arg2) + arg1)
end if
end function
character(len = 2) function bar ()
bar = "ab"
end function
function bar2 () result(res)
character (len = 1), dimension(2) :: res
res = ["d", "e"]
end function
end