[Patch, fortran] PR20863 and PR20082 - things PURE and impure

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

These might be said to be legacy PRs:)  Seriously, though, getting the 
constraints right for PURE procedures is important and it is a shame 
that these have lain around for so long.

The patch remedies two omissions in applying the constraints associated 
with variables in PURE procedures.  The testcase lifts the reporters' 
originals and exercises the fix a bit more.  The patch and the Changelog 
pretty much speak for themselves.

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

Paul

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

   PR fortran/20863
   PR fortran/20082
   * resolve.c (resolve_code): Use gfc_impure_variable as a
   condition for rejecting derived types with pointers, in pure
   procedures.
   (gfc_impure_variable): Add test for dummy arguments of pure
   procedures; any for functions and INTENT_IN for subroutines.

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

   PR fortran/20863
   PR fortran/20082
   * gfortran.dg/impure_assignment_2.f90 : New test.

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 125756)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_code (gfc_code *code, gfc_namesp
*** 5267,5282 ****
  		}
  
  	      if (code->expr2->ts.type == BT_DERIVED
! 		  && derived_pointer (code->expr2->ts.derived))
  		{
! 		  gfc_error ("Right side of assignment at %L is a derived "
! 			     "type containing a POINTER in a PURE procedure",
  			     &code->expr2->where);
  		  break;
  		}
  	    }
  
! 	  gfc_check_assign (code->expr, code->expr2, 1);
  	  break;
  
  	case EXEC_LABEL_ASSIGN:
--- 5267,5285 ----
  		}
  
  	      if (code->expr2->ts.type == BT_DERIVED
! 		    && code->expr2->expr_type == EXPR_VARIABLE
! 		    && gfc_impure_variable (code->expr2->symtree->n.sym)
! 		    && derived_pointer (code->expr2->ts.derived))
  		{
! 		  gfc_error ("Right side of assignment at %L is an impure "
! 			     "derived type variable with a POINTER "
! 			     "component a PURE procedure (12.6)",
  			     &code->expr2->where);
  		  break;
  		}
  	    }
  
! 	    gfc_check_assign (code->expr, code->expr2, 1);
  	  break;
  
  	case EXEC_LABEL_ASSIGN:
*************** resolve_data (gfc_data * d)
*** 6800,6820 ****
  }
  
  
  /* Determines if a variable is not 'pure', ie not assignable within a pure
     procedure.  Returns zero if assignment is OK, nonzero if there is a
     problem.  */
- 
  int
  gfc_impure_variable (gfc_symbol *sym)
  {
    if (sym->attr.use_assoc || sym->attr.in_common)
      return 1;
  
    if (sym->ns != gfc_current_ns)
      return !sym->attr.function;
  
!   /* TODO: Check storage association through EQUIVALENCE statements */
  
    return 0;
  }
  
--- 6803,6838 ----
  }
  
  
+ /* 12.6 Constraint: In a pure subprogram any variable which is in common or
+    accessed by host or use association, is a dummy argument to a pure function,
+    is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
+    is storage associated with any such variable, shall not be used in the
+    following contexts: (clients of this function).  */
+ 
  /* Determines if a variable is not 'pure', ie not assignable within a pure
     procedure.  Returns zero if assignment is OK, nonzero if there is a
     problem.  */
  int
  gfc_impure_variable (gfc_symbol *sym)
  {
+   gfc_symbol *proc;
+ 
    if (sym->attr.use_assoc || sym->attr.in_common)
      return 1;
  
    if (sym->ns != gfc_current_ns)
      return !sym->attr.function;
  
!   proc = sym->ns->proc_name;
!   if (sym->attr.dummy && gfc_pure (proc)
! 	&& ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
! 		||
! 	     proc->attr.function))
!     return 1;
  
+   /* TODO: Sort out what can be storage associated, if anything, and include
+      it here.  In principle equivalences should be scanned but it does not
+      seem to be possible to storage associate an impure variable this way.  */
    return 0;
  }
  
Index: gcc/testsuite/gfortran.dg/impure_assignment_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/impure_assignment_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/impure_assignment_2.f90	(revision 0)
***************
*** 0 ****
--- 1,67 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR20863 and PR20882, which were concerned with incorrect
+ ! application of constraints associated with "impure" variables in PURE
+ ! procedures.
+ !
+ ! resolve.c (gfc_impure_variable) detects the following: 
+ ! 12.6 Constraint: In a pure subprogram any variable which is in common or
+ ! accessed by host or use association, is a dummy argument to a pure function,
+ ! is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
+ ! is storage associated with any such variable, shall not be used in the
+ ! following contexts: (clients of this function).  */
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ !
+ MODULE pr20863
+  TYPE node_type
+   TYPE(node_type), POINTER :: next=>null()
+  END TYPE
+ CONTAINS
+ ! Original bug - pointer assignments to "impure" derived type with
+ ! pointer component.
+   PURE FUNCTION give_next1(node)
+      TYPE(node_type), POINTER :: node
+      TYPE(node_type), POINTER :: give_next
+      give_next => node%next ! { dg-error "Bad target" }
+      node%next => give_next ! { dg-error "Bad pointer object" }
+   END FUNCTION
+ ! Comment #2
+   PURE integer FUNCTION give_next2(i)
+      TYPE node_type
+        sequence
+        TYPE(node_type), POINTER :: next
+      END TYPE
+      TYPE(node_type), POINTER :: node
+      TYPE(node_type), target  :: t
+      integer, intent(in)      :: i
+      node%next = t          ! This is OK
+      give_next2 = i
+   END FUNCTION
+ END MODULE pr20863
+ 
+ MODULE pr20882
+   TYPE T1
+     INTEGER :: I
+   END TYPE T1
+   TYPE(T1), POINTER :: B
+ CONTAINS
+   PURE FUNCTION TST(A) RESULT(RES)
+     TYPE(T1), INTENT(IN), TARGET :: A
+     TYPE(T1), POINTER :: RES
+     RES => A  ! { dg-error "Bad target" }
+     RES => B  ! { dg-error "Bad target" }
+     B => RES  ! { dg-error "Bad pointer object" }
+   END FUNCTION
+   PURE FUNCTION TST2(A) RESULT(RES)
+     TYPE(T1), INTENT(IN), TARGET :: A
+     TYPE(T1), POINTER :: RES
+     allocate (RES)
+     RES = A
+     B = RES  ! { dg-error "Cannot assign" }
+     RES = B
+   END FUNCTION
+ END MODULE pr20882
+ ! { dg-final { cleanup-modules "pr20863 pr20882" } }
+ 
+ 
+ 

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

	PR fortran/20863
	PR fortran/20082
	* resolve.c (resolve_code): Use gfc_impure_variable as a
	condition for rejecting derived types with pointers, in pure
	procedures.
	(gfc_impure_variable): Add test for dummy arguments of pure
	procedures; any for functions and INTENT_IN for subroutines.

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

	PR fortran/20863
	PR fortran/20082
	* gfortran.dg/impure_assignment_2.f90 : New test.