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

3 files changed, 49 insertions, 9 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;
 }