[Fortran, patch] Fix missing parts of host-/use-associated VOLATILE (PR30522)

[Tobias Burnus <burnus at net-b dot de>]

:ADDPATCH fortran:

The following patch fixes the following issue with host-/use-associated
VOLATILE:

Now a proper error is given for:

module A
   real :: v
module A

module B
  use :: A
  volatile :: v
  volatile :: v ! ERROR, but was accepted
end module B

While the following is now accepted:

module test
  real, volatile :: A
contains
  subroutine sub
    volatile :: A ! VALID, but was rejected
  end subroutine sub
end module test


I decided to fill a new PR30733 about the missed optimization:
Currently, a variable is marked VOLATILE everywhere. It should only
be VOLATILE in the scope where it has be marked as such.
But I don't expect many program to profit from this optimization.

Bootstapped and regression tested on x86_64-unknown-linux-gnu.

Ok for the trunk? (It is not in any branch, except in fortran-experiments.)

Tobias

testsuite/
2007-02-08  Tobias Burnus  <burnus@net-b.de>

	PR fortran/30522
	* symbol.c (gfc_add_volatile): Allow to set VOLATILE
	  attribute for host-associated variables.
	* gfortran.h (symbol_attribute): Save namespace
	  where VOLATILE has been set.
	* trans-decl.c (gfc_finish_var_decl): Move variable
	  declaration to the top.

testsuite/
2007-02-08  Tobias Burnus  <burnus@net-b.de>

	PR fortran/30522
	* gfortran.dg/volatile10.f90: New test.

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 121710)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -876,24 +876,18 @@
 try
 gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
 {
-
   /* No check_used needed as 11.2.1 of the F2003 standard allows
      that the local identifier made accessible by a use statement can be
      given a VOLATILE attribute.  */
 
-  /* TODO: The following allows multiple VOLATILE statements for
-     use-associated variables and it prevents setting VOLATILE for a host-
-     associated variable which is already marked as VOLATILE in the host.  */
-  if (attr->volatile_ && !attr->use_assoc)
-    {
-	if (gfc_notify_std (GFC_STD_LEGACY, 
-			    "Duplicate VOLATILE attribute specified at %L",
-			    where) 
-	    == FAILURE)
-	  return FAILURE;
-    }
+  if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
+    if (gfc_notify_std (GFC_STD_LEGACY, 
+        		"Duplicate VOLATILE attribute specified at %L", where)
+        == FAILURE)
+      return FAILURE;
 
   attr->volatile_ = 1;
+  attr->volatile_ns = gfc_current_ns;
   return check_conflict (attr, name, where);
 }
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 121710)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -542,6 +542,9 @@
   /* The symbol is a derived type with allocatable components, possibly nested.
    */
   unsigned alloc_comp:1;
+
+  /* The namespace where the VOLATILE attribute has been set.  */
+  struct gfc_namespace *volatile_ns;
 }
 symbol_attribute;
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(Revision 121710)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -468,6 +468,7 @@
 static void
 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 {
+  tree new;
   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
      This is the equivalent of the TARGET variables.
      We also need to set this if the variable is passed by reference in a
@@ -518,7 +519,6 @@
 
   if (sym->attr.volatile_)
     {
-      tree new;
       TREE_THIS_VOLATILE (decl) = 1;
       new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
       TREE_TYPE (decl) = new;
Index: gcc/testsuite/gfortran.dg/volatile10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/volatile10.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/volatile10.f90	(Revision 0)
@@ -0,0 +1,147 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-optimized -O3" }
+
+module impl
+  implicit REAL (A-Z)
+  volatile :: x
+end module impl
+
+module one
+  implicit none
+  logical :: l, lv
+  volatile :: lv
+contains
+  subroutine test1(cmp)
+    logical  :: cmp
+    volatile :: l, lv
+    if (l  .neqv. cmp) call abort()
+    if (lv .neqv. cmp) call abort()
+    l = .false.
+    lv = .false.
+    if(l .or. lv) print *, 'one_test1' ! not optimized away
+  end subroutine test1
+  subroutine test2(cmp)
+    logical  :: cmp
+    if (l  .neqv. cmp) call abort()
+    if (lv .neqv. cmp) call abort()
+    l = .false.
+    if(l)  print *, 'one_test2_1' ! optimized away
+    lv = .false.
+    if(lv) print *, 'one_test2_2' ! not optimized away
+  end subroutine test2
+end module one
+
+module two
+  use :: one
+  implicit none
+  volatile :: lv,l
+contains
+  subroutine test1t(cmp)
+    logical  :: cmp
+    volatile :: l, lv
+    if (l  .neqv. cmp) call abort()
+    if (lv .neqv. cmp) call abort()
+    l = .false.
+    if(l)  print *, 'two_test1_1' ! not optimized away
+    lv = .false.
+    if(lv) print *, 'two_test1_2' ! not optimized away
+  end subroutine test1t
+  subroutine test2t(cmp)
+    logical  :: cmp
+    if (l  .neqv. cmp) call abort()
+    if (lv .neqv. cmp) call abort()
+    l = .false.
+    if(l)  print *, 'two_test2_1' ! not optimized away
+    lv = .false.
+    if(lv) print *, 'two_test2_2' ! not optimized away
+  end subroutine test2t
+end module two
+
+program main
+  use :: two, only: test1t, test2t
+  implicit none
+  logical :: lm, lmv
+  volatile :: lmv
+  lm = .true.
+  lmv = .true.
+  call test1m(.true.)
+  lm = .true.
+  lmv = .true.
+  call test2m(.true.)
+  lm = .false.
+  lmv = .false.
+  call test1m(.false.)
+  lm = .false.
+  lmv = .false.
+  call test2m(.false.)
+contains
+  subroutine test1m(cmp)
+    use :: one
+    logical  :: cmp
+    volatile :: lm,lmv
+    if(lm  .neqv. cmp) call abort()
+    if(lmv .neqv. cmp) call abort()
+    l  = .false.
+    lv = .false.
+    call test1(.false.)
+    l  = .true.
+    lv = .true.
+    call test1(.true.)
+    lm  = .false.
+    lmv = .false.
+    if(lm .or. lmv) print *, 'main_test1_1' ! not optimized away
+    l   = .false.
+    if(l)  print *, 'main_test1_2'          ! optimized away
+    lv  = .false.
+    if(lv) print *, 'main_test1_3'          ! not optimized away
+    l  = .false.
+    lv = .false.
+    call test2(.false.)
+    l  = .true.
+    lv = .true.
+    call test2(.true.)
+  end subroutine test1m
+  subroutine test2m(cmp)
+    use :: one
+    logical  :: cmp
+    volatile :: lv
+    if(lm .neqv. cmp) call abort
+    if(lmv .neqv. cmp) call abort()
+    l  = .false.
+    lv = .false.
+    call test1(.false.)
+    l  = .true.
+    lv = .true.
+    call test1(.true.)
+    lm  = .false.
+    if(lm) print *, 'main_test2_1' ! not optimized away
+    lmv = .false.
+    if(lmv)print *, 'main_test2_2' ! not optimized away
+    l   = .false.
+    if(l)  print *, 'main_test2_3' ! optimized away
+    lv  = .false.
+    if(lv) print *, 'main_test2_4' ! not optimized away
+    l  = .false.
+    lv = .false.
+    call test2(.false.)
+    l  = .true.
+    lv = .true.
+    call test2(.true.)
+  end subroutine test2m
+end program main
+
+! { dg-final { scan-tree-dump      "one_test1"   "optimized" } }
+! TODO: dg-final { scan-tree-dump-not  "one_test2_1" "optimized" } 
+! { dg-final { scan-tree-dump      "one_test2_2" "optimized" } }
+! { dg-final { scan-tree-dump      "one_test2_2" "optimized" } }
+! { dg-final { scan-tree-dump      "two_test2_1" "optimized" } }
+! { dg-final { scan-tree-dump      "two_test2_2" "optimized" } }
+! { dg-final { scan-tree-dump      "main_test1_1" "optimized" } }
+! TODO: dg-final { scan-tree-dump-not  "main_test1_2" "optimized" } 
+! { dg-final { scan-tree-dump      "main_test1_3" "optimized" } }
+! { dg-final { scan-tree-dump      "main_test2_1" "optimized" } }
+! { dg-final { scan-tree-dump      "main_test2_2" "optimized" } }
+! TODO: dg-final { scan-tree-dump-not  "main_test2_3" "optimized" } 
+! { dg-final { scan-tree-dump      "main_test2_4" "optimized" } }
+! { dg-final { cleanup-tree-dump  "optimized" } }
+! { dg-final { cleanup-modules "one two" } }