This patch fixes a 4.6/4.7 wrong-code regression where an call to a
subroutine which is neither pure nor implicit_pure didn't mark the
calling procedure as impure.
Additionally, I changed for functions:
if (!pure_function (expr, &name) && name)
...
if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
to
if (!pure_function (expr, &name) && name)
...
if (gfc_implicit_pure (NULL))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
}
The "if (gfc_implicit_pure (NULL))" effectively only acts as "if
(gfc_current_ns->proc_name)".
(I was wondering whether one should use a check whether the called
procedure is implicit pure; however, given that all procedures start as
implicit pure and are only later set to impure, this could cause a
wrong-code problem, depending how the functions are resolved. What one
could do is a check whether a use-associated function is implicit pure
as that procedure has already been resolved.)
Build and regtested on x86-64-linux.
OK for the trunk and 4.6?
Tobias
2011-11-24 Tobias Burnus <bur...@net-b.de>
PR fortran/51218
* resolve.c (pure_subroutine): If called subroutine is
impure, unset implicit_pure.
(resolve_function): Move impure check to simplify code.
2011-11-24 Tobias Burnus <bur...@net-b.de>
PR fortran/51218
* gfortran.dg/implicit_pure_1.f90: New.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 181688)
+++ gcc/fortran/resolve.c (working copy)
@@ -3191,11 +3191,11 @@ resolve_function (gfc_expr *expr)
"procedure within a PURE procedure", name, &expr->where);
t = FAILURE;
}
+
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
}
- if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
@@ -3257,6 +3257,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc);
+
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
}
Index: gcc/testsuite/gfortran.dg/implicit_pure_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/implicit_pure_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/implicit_pure_1.f90 (working copy)
@@ -0,0 +1,53 @@
+! { dg-do run }
+!
+! PR fortran/51218
+!
+! Contributed by Harald Anlauf
+!
+
+module a
+ implicit none
+ integer :: neval = 0
+contains
+ subroutine inc_eval
+ neval = neval + 1
+ end subroutine inc_eval
+end module a
+
+module b
+ use a
+ implicit none
+contains
+ function f(x) ! Should be implicit pure
+ real :: f
+ real, intent(in) :: x
+ f = x
+ end function f
+
+ function g(x) ! Should NOT be implicit pure
+ real :: g
+ real, intent(in) :: x
+ call inc_eval
+ g = x
+ end function g
+end module b
+
+program gfcbug114a
+ use a
+ use b
+ implicit none
+ real :: x = 1, y = 1, t, u, v, w
+ if (neval /= 0) call abort ()
+ t = f(x)*f(y)
+ if (neval /= 0) call abort ()
+ u = f(x)*f(y) + f(x)*f(y)
+ if (neval /= 0) call abort ()
+ v = g(x)*g(y)
+ if (neval /= 2) call abort ()
+ w = g(x)*g(y) + g(x)*g(y)
+ if (neval /= 6) call abort ()
+ if (t /= 1.0 .or. u /= 2.0 .or. v /= 1.0 .or. w /= 2) call abort ()
+end program gfcbug114a
+
+! { dg-final { scan-module "b" "IMPLICIT_PURE" } }
+! { dg-final { cleanup-modules "b" } }
