This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, fortran] PR31205 - aliased operator assignment produces wrong result


PING**0.5 (since I am not doing my share of reviewing right now :-( )

This is partly to remind myself but if anybody does have a bit of time to cast an eye over the patch, I'd be grateful. This is a bit more intrusive than some of my recent one-liners.

Paul

PS I mention the character patch - I am just on that now.
:ADDPATCH fortran:

This one was 'fun'!  Neither aliased lhs and rhs in operator
assignments, nor INTENT(IN) actual arguments, aliased with an
INTENT(OUT) argument, would produce the correct result, if the
argument was a derived type with a default initializer.

The steps taken to fix this problem were:

(i) Generate a temporary for the rhs/INTENT(IN), using
gfc_get_parentheses.  This required a bit of improvement to this
function; resolving the argument and checking for references with
non-numeric expressions.  I believe that this latter will be
unnecessary when I complete the character patch (next week's task) and
will update accordingly.

(ii) Remove the initialization of derived types with a default
initializer from the caller to the callee.  The reasons for doing this
are discussed in the PR.  It has a gratifying effect on passing
derived types with allocatable components, in that the amount of
generated code goes down (see alloc_comp_basics_1.f90).

Note (i) involved what I believe is a misinterpretation of the
standard - see the comment and the relevant paragraph in the standard
(7.1.7.2).

The testcase is the reporter's.

Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?

Paul

2007-06-30 Paul Thomas <pault@gcc.gnu.org>

    PR fortran/31205
    * trans-expr.c (gfc_conv_function_call): Remove the default
    initialization of intent(out) derived types.
    * symbol.c (gfc_lval_expr_from_sym): New function.
    * matchexp.c (gfc_get_parentheses): Rsolve argument expression
    and return argument, if it is not numeric and posseses a ref.
    * gfortran.h : Add prototype for gfc_lval_expr_from_sym.
    * resolve.c (has_default_initializer): Move higher up in file.
    (resolve_code): On detecting an interface assignment, check
    if the rhs and the lhs are the same symbol.  If this is so,
    enclose the rhs in parenetheses to generate a temporary and
    prevent any possible aliasing.
    (apply_default_init): Remove code making the lval and call
    gfc_lval_expr_from_sym instead.
    * trans-decl.c (gfc_trans_deferred_vars): Apply the a default
    initializer, if any, to an intent(out) derived type, using
    gfc_lval_expr_from_sym and gfc_trans_assignment.  Check if
    the dummy is present.


2007-06-30 Paul Thomas <pault@gcc.gnu.org>


    PR fortran/31205
    * gfortran.dg/alloc_comp_basics_1.f90 : Restore number of
    "deallocates" to 24, since patch has code rid of much spurious
    code.
    * gfortran.dg/interface_assignment_1.f90 : New test.
------------------------------------------------------------------------

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 126090)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2186,17 +2186,6 @@ gfc_conv_function_call (gfc_se * se, gfc
&& fsym->attr.optional)
gfc_conv_missing_dummy (&parmse, e, fsym->ts);
- /* If an INTENT(OUT) dummy of derived type has a default
- initializer, it must be (re)initialized here. */
- if (fsym->attr.intent == INTENT_OUT
- && fsym->ts.type == BT_DERIVED
- && fsym->value)
- {
- gcc_assert (!fsym->attr.allocatable);
- tmp = gfc_trans_assignment (e, fsym->value, false);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
/* Obtain the character length of an assumed character
length procedure from the typespec. */
if (fsym->ts.type == BT_CHARACTER
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 126090)
+++ gcc/fortran/symbol.c (working copy)
@@ -1857,6 +1857,35 @@ done:
}
+/*******A helper function for creating new expressions*************/
+
+
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+ gfc_expr *lval;
+ lval = gfc_get_expr ();
+ lval->expr_type = EXPR_VARIABLE;
+ lval->where = sym->declared_at;
+ lval->ts = sym->ts;
+ lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+ /* It will always be a full array. */
+ lval->rank = sym->as ? sym->as->rank : 0;
+ if (lval->rank)
+ {
+ lval->ref = gfc_get_ref ();
+ lval->ref->type = REF_ARRAY;
+ lval->ref->u.ar.type = AR_FULL;
+ lval->ref->u.ar.dimen = lval->rank;
+ lval->ref->u.ar.where = sym->declared_at;
+ lval->ref->u.ar.as = sym->as;
+ }
+
+ return lval;
+}
+
+
/************** Symbol table management subroutines ****************/
/* Basic details: Fortran 95 requires a potentially unlimited number
Index: gcc/fortran/matchexp.c
===================================================================
--- gcc/fortran/matchexp.c (revision 126090)
+++ gcc/fortran/matchexp.c (working copy)
@@ -130,6 +130,11 @@ gfc_expr *
gfc_get_parentheses (gfc_expr *e)
{
gfc_expr *e2;
+ if (gfc_resolve_expr (e) == FAILURE)
+ return e;
+ + if (!gfc_numeric_ts (&e->ts) && e->ref)
+ return e;
e2 = gfc_get_expr();
e2->expr_type = EXPR_OP;
@@ -181,13 +186,9 @@ match_primary (gfc_expr **result)
gfc_error ("Expected a right parenthesis in expression at %C");
/* Now we have the expression inside the parentheses, build the
- expression pointing to it. By 7.1.7.2 the integrity of
- parentheses is only conserved in numerical calculations, so we
- don't bother to keep the parentheses otherwise. */
- if(!gfc_numeric_ts(&e->ts))
- *result = e;
- else
- *result = gfc_get_parentheses (e);
+ expression pointing to it. By 7.1.7.2, any expression in
+ parentheses shall be treated as a data entity. */
+ *result = gfc_get_parentheses (e);
if (m != MATCH_YES)
{
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 126090)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2007,6 +2007,8 @@ void gfc_free_st_label (gfc_st_label *);
void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
try gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
+gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
+
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 126090)
+++ gcc/fortran/resolve.c (working copy)
@@ -5112,6 +5112,21 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
}
+static gfc_component *
+has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+ for (c = der->components; c; c = c->next)
+ if ((c->ts.type != BT_DERIVED && c->initializer)
+ || (c->ts.type == BT_DERIVED
+ && !c->pointer
+ && has_default_initializer (c->ts.derived)))
+ break;
+
+ return c;
+}
+
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@@ -5231,6 +5246,9 @@ resolve_code (gfc_code *code, gfc_namesp
if (gfc_extend_assign (code, ns) == SUCCESS)
{
+ gfc_expr *lhs = code->ext.actual->expr;
+ gfc_expr *rhs = code->ext.actual->next->expr;
+
if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
{
gfc_error ("Subroutine '%s' called instead of assignment at "
@@ -5238,6 +5256,15 @@ resolve_code (gfc_code *code, gfc_namesp
&code->loc);
break;
}
+
+ /* Make a temporary rhs when there is a default initializer
+ and rhs is the same symbol as the lhs. */
+ if (rhs->expr_type == EXPR_VARIABLE
+ && rhs->symtree->n.sym->ts.type == BT_DERIVED
+ && has_default_initializer (rhs->symtree->n.sym->ts.derived)
+ && (lhs->symtree->n.sym == rhs->symtree->n.sym))
+ code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+
goto call;
}
@@ -5615,23 +5642,7 @@ apply_default_init (gfc_symbol *sym)
}
/* Build an l-value expression for the result. */
- lval = gfc_get_expr ();
- lval->expr_type = EXPR_VARIABLE;
- lval->where = sym->declared_at;
- lval->ts = sym->ts;
- lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
- /* It will always be a full array. */
- lval->rank = sym->as ? sym->as->rank : 0;
- if (lval->rank)
- {
- lval->ref = gfc_get_ref ();
- lval->ref->type = REF_ARRAY;
- lval->ref->u.ar.type = AR_FULL;
- lval->ref->u.ar.dimen = lval->rank;
- lval->ref->u.ar.where = sym->declared_at;
- lval->ref->u.ar.as = sym->as;
- }
+ lval = gfc_lval_expr_from_sym (sym);
/* Add the code at scope entry. */
init_st = gfc_get_code ();
@@ -5687,21 +5698,6 @@ resolve_fl_var_and_proc (gfc_symbol *sym
}
-static gfc_component *
-has_default_initializer (gfc_symbol *der)
-{
- gfc_component *c;
- for (c = der->components; c; c = c->next)
- if ((c->ts.type != BT_DERIVED && c->initializer)
- || (c->ts.type == BT_DERIVED
- && !c->pointer
- && has_default_initializer (c->ts.derived)))
- break;
-
- return c;
-}
-
-
/* Resolve symbols with flavor variable. */
static try
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 126090)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -2707,12 +2707,35 @@ gfc_trans_deferred_vars (gfc_symbol * pr
gfc_init_block (&body);
for (f = proc_sym->formal; f; f = f->next)
- if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
- {
- gcc_assert (f->sym->ts.cl->backend_decl != NULL);
- if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
- gfc_trans_vla_type_sizes (f->sym, &body);
- }
+ {
+ if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (f->sym->ts.cl->backend_decl != NULL);
+ if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+ gfc_trans_vla_type_sizes (f->sym, &body);
+ }
+
+ /* If an INTENT(OUT) dummy of derived type has a default
+ initializer, it must be initialized here. */
+ if (f->sym && f->sym->attr.referenced
+ && f->sym->attr.intent == INTENT_OUT
+ && f->sym->ts.type == BT_DERIVED
+ && !f->sym->ts.derived->attr.alloc_comp
+ && f->sym->value)
+ {
+ gfc_expr *tmpe;
+ tree tmp, present;
+ gcc_assert (!f->sym->attr.allocatable);
+ tmpe = gfc_lval_expr_from_sym (f->sym);
+ tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
+
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_free_expr (tmpe);
+ }
+ }
if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
&& current_fake_result_decl != NULL)
Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (revision 126090)
+++ gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (working copy)
@@ -139,6 +139,6 @@ contains
end subroutine check_alloc2
end program alloc
-! { dg-final { scan-tree-dump-times "deallocate" 33 "original" } }
+! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "alloc_m" } }
Index: gcc/testsuite/gfortran.dg/interface_assignment_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_assignment_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/interface_assignment_1.f90 (revision 0)
@@ -0,0 +1,39 @@
+! { dg-do run }
+! Checks the fix for PR31205, in which temporaries were not
+! written for the interface assignment and the parentheses below.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE TT
+ TYPE data_type
+ INTEGER :: I=2
+ END TYPE data_type
+ INTERFACE ASSIGNMENT (=)
+ MODULE PROCEDURE set
+ END INTERFACE
+CONTAINS
+ PURE SUBROUTINE set(x1,x2)
+ TYPE(data_type), INTENT(IN) :: x2
+ TYPE(data_type), INTENT(OUT) :: x1
+ CALL S1(x1,x2)
+ END SUBROUTINE
+ PURE SUBROUTINE S1(x1,x2)
+ TYPE(data_type), INTENT(IN) :: x2
+ TYPE(data_type), INTENT(OUT) :: x1
+ x1%i=x2%i
+ END SUBROUTINE
+END MODULE
+
+USE TT
+TYPE(data_type) :: D,E
+
+D%I=4
+D=D
+
+E%I=4
+CALL set(E,(E))
+
+IF (D%I.NE.4) call abort ()
+IF (4.NE.E%I) call abort ()
+END
+! { dg-final { cleanup-modules "TT" } }



Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]