re PR fortran/43169 ([OOP] gfortran rejects pure procedure with select type construct)

2010-03-03  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43169
	* resolve.c (resolve_code): Correctly set gfc_current_ns for
	EXEC_SELECT_TYPE.
	(gfc_impure_variable): Make it work with sub-namespaces (BLOCK etc).
	(gfc_pure): Ditto.

2010-03-03  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43169
	* gfortran.dg/impure_assignment_3.f90: New.

From-SVN: r157196

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 12c7192..01f2f3c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2010-03-03  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/43169
+       * resolve.c (resolve_code): Correctly set gfc_current_ns for
+       EXEC_SELECT_TYPE.
+       (gfc_impure_variable): Make it work with sub-namespaces (BLOCK etc).
+       (gfc_pure): Ditto.
+
 2010-03-02  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/43180

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8de0de6..10d8807 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8012,6 +8012,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
            case EXEC_OMP_DO:
              gfc_resolve_omp_do_blocks (code, ns);
              break;
+           case EXEC_SELECT_TYPE:
+             gfc_current_ns = code->ext.ns;
+             gfc_resolve_blocks (code->block, gfc_current_ns);
+             gfc_current_ns = ns;
+             break;
            case EXEC_OMP_WORKSHARE:
              omp_workshare_save = omp_workshare_flag;
              omp_workshare_flag = 1;
@@ -11670,12 +11675,19 @@ int
 gfc_impure_variable (gfc_symbol *sym)
 {
   gfc_symbol *proc;
+  gfc_namespace *ns;
 
   if (sym->attr.use_assoc || sym->attr.in_common)
     return 1;
 
-  if (sym->ns != gfc_current_ns)
-    return !sym->attr.function;
+  /* Check if the symbol's ns is inside the pure procedure.  */
+  for (ns = gfc_current_ns; ns; ns = ns->parent)
+    {
+      if (ns == sym->ns)
+       break;
+      if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+       return 1;
+    }
 
   proc = sym->ns->proc_name;
   if (sym->attr.dummy && gfc_pure (proc)
@@ -11691,18 +11703,30 @@ gfc_impure_variable (gfc_symbol *sym)
 }
 
 
-/* Test whether a symbol is pure or not.  For a NULL pointer, checks the
-   symbol of the current procedure.  */
+/* Test whether a symbol is pure or not.  For a NULL pointer, checks if the
+   current namespace is inside a pure procedure.  */
 
 int
 gfc_pure (gfc_symbol *sym)
 {
   symbol_attribute attr;
+  gfc_namespace *ns;
 
   if (sym == NULL)
-    sym = gfc_current_ns->proc_name;
-  if (sym == NULL)
-    return 0;
+    {
+      /* Check if the current namespace or one of its parents
+       belongs to a pure procedure.  */
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+       {
+         sym = ns->proc_name;
+         if (sym == NULL)
+           return 0;
+         attr = sym->attr;
+         if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
+           return 1;
+       }
+      return 0;
+    }
 
   attr = sym->attr;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9e81c0d..b8e0ee7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-03-03  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/43169
+       * gfortran.dg/impure_assignment_3.f90: New.
+
 2010-03-03  Jakub Jelinek  <jakub@redhat.com>
 
        PR debug/43229

diff --git a/gcc/testsuite/gfortran.dg/impure_assignment_3.f90 b/gcc/testsuite/gfortran.dg/impure_assignment_3.f90
new file mode 100644 (file)
index 0000000..462ceb6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/impure_assignment_3.f90
@@ -0,0 +1,44 @@
+! { dg-do compile }
+!
+! PR 43169: [OOP] gfortran rejects PURE procedure with SELECT TYPE construct
+!
+! Original test case by Todd Hay <haymaker@mail.utexas.edu>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+  implicit none
+  real :: g
+
+contains
+
+  pure subroutine sub1(x)
+    type :: myType
+      real :: a
+    end type myType
+    class(myType), intent(inout) :: x
+    real :: r3
+    select type(x)
+    class is (myType)
+      x%a = 42.
+      r3 =  43.
+      g = 44.             ! { dg-error "Cannot assign to variable" }
+    end select
+  end subroutine
+
+  pure subroutine sub2
+    real :: r1
+    block
+      real :: r2
+      r1 = 45.
+      r2 = 46.
+      g = 47.             ! { dg-error "Cannot assign to variable" }
+    end block
+  end subroutine
+
+  pure subroutine sub3
+    block
+      integer, save :: i  ! { dg-error "cannot be specified in a PURE procedure" }
+      integer :: j = 5    ! { dg-error "is not allowed in a PURE procedure" }
+    end block
+  end subroutine
+
+end