re PR fortran/20863 ([4.2 only] Pointer problems in PURE procedures)

2007-06-19  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.

	PR fortran/32236
	* data.c (gfc_assign_data_value): Change the ICE on an array
	reference initializer not being an array into an error and
	clear init to prevent a repetition of the error.

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

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

	PR fortran/32236
	* gfortran.dg/data_initialized_2.f90 : New test.

	* gfortran.dg/equiv_7.f90 : Test for endianess and call the
	appropriate version of 'dmach'.

From-SVN: r125831

7 files changed, 164 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7528c11..74b8103 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2007-06-19  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.
+
+	PR fortran/32236
+	* data.c (gfc_assign_data_value): Change the ICE on an array
+	reference initializer not being an array into an error and
+	clear init to prevent a repetition of the error.
+
 2007-06-17  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	* gfortran.texi: Add documentation for GFORTRAN_UNBUFFERED_n
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 75e4241..35213a8 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -288,6 +288,15 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
       switch (ref->type)
 	{
 	case REF_ARRAY:
+	  if (init && expr->expr_type != EXPR_ARRAY)
+	    {
+	      gfc_error ("'%s' at %L already is initialized at %L",
+			 lvalue->symtree->n.sym->name, &lvalue->where,
+			 &init->where);
+	      gfc_free_expr (init);
+	      init = NULL;
+	    }
+
 	  if (init == NULL)
 	    {
 	      /* The element typespec will be the same as the array
@@ -297,8 +306,6 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 	      expr->expr_type = EXPR_ARRAY;
 	      expr->rank = ref->u.ar.as->rank;
 	    }
-	  else
-	    gcc_assert (expr->expr_type == EXPR_ARRAY);
 
 	  if (ref->u.ar.type == AR_ELEMENT)
 	    get_array_index (&ref->u.ar, &offset);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 99797aa..cbf4f7c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5266,17 +5266,20 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 		  break;
 		}
 
-	      if (code->expr2->ts.type == BT_DERIVED
-		  && derived_pointer (code->expr2->ts.derived))
+	      if (code->expr->ts.type == BT_DERIVED
+		    && code->expr->expr_type == EXPR_VARIABLE
+		    && derived_pointer (code->expr->ts.derived)
+		    && gfc_impure_variable (code->expr2->symtree->n.sym))
 		{
-		  gfc_error ("Right side of assignment at %L is a derived "
-			     "type containing a POINTER in a PURE procedure",
+		  gfc_error ("The impure variable at %L is assigned to "
+			     "a derived type variable with a POINTER "
+			     "component in a PURE procedure (12.6)",
 			     &code->expr2->where);
 		  break;
 		}
 	    }
 
-	  gfc_check_assign (code->expr, code->expr2, 1);
+	    gfc_check_assign (code->expr, code->expr2, 1);
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
@@ -6800,21 +6803,36 @@ resolve_data (gfc_data * d)
 }
 
 
+/* 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;
 
-  /* TODO: Check storage association through EQUIVALENCE statements */
+  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;
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0d626bb..5838047 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2007-06-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20863
+	PR fortran/20082
+	* gfortran.dg/impure_assignment_2.f90 : New test.
+
+	PR fortran/32236
+	* gfortran.dg/data_initialized_2.f90 : New test.
+
+	* gfortran.dg/equiv_7.f90 : Test for endianess and call the
+	appropriate version of 'dmach'.
+
 2007-06-18  Uros Bizjak  <ubizjak@gmail.com>
 
 	PR target/32389
diff --git a/gcc/testsuite/gfortran.dg/data_initialized_2.f90 b/gcc/testsuite/gfortran.dg/data_initialized_2.f90
new file mode 100644
index 0000000..c6331cd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_initialized_2.f90
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! Tests the fix for PR32236, in which the error below manifested itself
+! as an ICE.
+! Contributed by Bob Arduini <r.f.arduini@larc.nasa.gov>
+  real :: x(2) = 1.0 ! { dg-error "already is initialized" }
+  data x /1.0, 2.0/  ! { dg-error "already is initialized" }
+  print *, x
+end
diff --git a/gcc/testsuite/gfortran.dg/equiv_7.f90 b/gcc/testsuite/gfortran.dg/equiv_7.f90
index 51beba7..925f40a 100644
--- a/gcc/testsuite/gfortran.dg/equiv_7.f90
+++ b/gcc/testsuite/gfortran.dg/equiv_7.f90
@@ -13,16 +13,26 @@ block data
   data cb /99/
 end block data
 
+  integer(4), parameter :: abcd = ichar ("a") + 256_4 * (ichar("b") + 256_4 * &
+                                 (ichar ("c") + 256_4 * ichar ("d")))
+  logical(4), parameter :: bigendian = transfer (abcd, "wxyz") .eq. "abcd"
+
   call int4_int4
   call real4_real4
   call complex_real
   call check_block_data
   call derived_types         ! Thanks to Tobias Burnus for this:)
 !
-! This came up in PR29786 comment #9
+! This came up in PR29786 comment #9 - Note the need to treat endianess
+! Thanks Dominique d'Humieres:)
 !
-  if (d1mach (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) call abort ()
-  if (d1mach (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) call abort ()
+  if (bigendian) then
+    if (d1mach_little (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) call abort ()
+    if (d1mach_little (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) call abort ()
+  else
+    if (d1mach_big (1) .ne. transfer ((/1048576_4, 0_4/), 1d0)) call abort ()
+    if (d1mach_big (2) .ne. transfer ((/2146435071_4,-1_4/), 1d0)) call abort ()
+  end if 
 !
 contains
   subroutine int4_int4
@@ -59,7 +69,7 @@ contains
       integer(4) ca
       if (any (ca .ne. (/42, 43, 99, 44/))) call abort ()
   end subroutine check_block_data
-  function d1mach(i)
+  function d1mach_little(i) result(d1mach)
     implicit none
     double precision d1mach,dmach(5)
     integer i,large(4),small(4)
@@ -68,7 +78,17 @@ contains
     data small(1),small(2) / 0,   1048576/
     data large(1),large(2) /-1,2146435071/
     d1mach = dmach(i) 
-  end function d1mach
+  end function d1mach_little
+  function d1mach_big(i) result(d1mach)
+    implicit none
+    double precision d1mach,dmach(5)
+    integer i,large(4),small(4)
+    equivalence ( dmach(1), small(1) )
+    equivalence ( dmach(2), large(1) )
+    data small(1),small(2) /1048576,    0/
+    data large(1),large(2) /2146435071,-1/
+    d1mach = dmach(i) 
+  end function d1mach_big
     subroutine derived_types
       TYPE T1
         sequence
diff --git a/gcc/testsuite/gfortran.dg/impure_assignment_2.f90 b/gcc/testsuite/gfortran.dg/impure_assignment_2.f90
new file mode 100644
index 0000000..3b212c1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/impure_assignment_2.f90
@@ -0,0 +1,70 @@
+! { 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
+  PURE FUNCTION give_next3(node)
+     TYPE(node_type), intent(in) :: node
+     TYPE(node_type) :: give_next
+     give_next = node ! { dg-error "impure variable" }
+  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" } }
+