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

gcc/fortran/ChangeLog

+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

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;
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/impure_assignment_3.f90

+! { 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