re PR fortran/20779 (ALLOCATEing the STAT variable not detected)

2006-10-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20779
	PR fortran/20891
	* resolve.c (find_sym_in_expr): New function that returns true
	if a symbol is found in an expression.
	(resolve_allocate_expr): Check whether the STAT variable is
	itself allocated in the same statement.  Use the call above to
	check whether any of the allocated arrays are used in array
	specifications in the same statement.

2006-10-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20779
	PR fortran/20891
	* gfortran.dg/alloc_alloc_expr_1.f90: New test.

From-SVN: r117415

4 files changed, 171 insertions, 18 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f045511..ea011dc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20779
+	PR fortran/20891
+	* resolve.c (find_sym_in_expr): New function that returns true
+	if a symbol is found in an expression.
+	(resolve_allocate_expr): Check whether the STAT variable is
+	itself allocated in the same statement.  Use the call above to
+	check whether any of the allocated arrays are used in array
+	specifications in the same statement.
+
 2006-10-03  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* arith.c (gfc_check_real_range):  Use correct exponent range for
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 854d3b4..7639eb7 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3319,6 +3319,81 @@ resolve_deallocate_expr (gfc_expr * e)
   return SUCCESS;
 }
 
+/* Returns true if the expression e contains a reference the symbol sym.  */
+static bool
+find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+{
+  gfc_actual_arglist *arg;
+  gfc_ref *ref;
+  int i;
+  bool rv = false;
+
+  if (e == NULL)
+    return rv;
+
+  switch (e->expr_type)
+    {
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+	rv = rv || find_sym_in_expr (sym, arg->expr);
+      break;
+
+    /* If the variable is not the same as the dependent, 'sym', and
+       it is not marked as being declared and it is in the same
+       namespace as 'sym', add it to the local declarations.  */
+    case EXPR_VARIABLE:
+      if (sym == e->symtree->n.sym)
+	return true;
+      break;
+
+    case EXPR_OP:
+      rv = rv || find_sym_in_expr (sym, e->value.op.op1);
+      rv = rv || find_sym_in_expr (sym, e->value.op.op2);
+      break;
+
+    default:
+      break;
+    }
+
+  if (e->ref)
+    {
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_ARRAY:
+	      for (i = 0; i < ref->u.ar.dimen; i++)
+		{
+		  rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
+		  rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
+		  rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
+		}
+	      break;
+
+	    case REF_SUBSTRING:
+	      rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
+	      rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
+	      break;
+
+	    case REF_COMPONENT:
+	      if (ref->u.c.component->ts.type == BT_CHARACTER
+		    && ref->u.c.component->ts.cl->length->expr_type
+						!= EXPR_CONSTANT)
+		rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
+
+	      if (ref->u.c.component->as)
+	        for (i = 0; i < ref->u.c.component->as->rank; i++)
+		  {
+		    rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
+		    rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
+		  }
+	      break;
+	    }
+	}
+    }
+  return rv;
+}
+
 
 /* Given the expression node e for an allocatable/pointer of derived type to be
    allocated, get the expression node to be initialized afterwards (needed for
@@ -3363,10 +3438,17 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
   gfc_array_ref *ar;
   gfc_code *init_st;
   gfc_expr *init_e;
+  gfc_symbol *sym;
+  gfc_alloc *a;
 
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
+  if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
+    sym = code->expr->symtree->n.sym;
+  else
+    sym = NULL;
+
   /* Make sure the expression is allocatable or a pointer.  If it is
      pointer, the next-to-last reference must be a pointer.  */
 
@@ -3387,6 +3469,14 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
       pointer = e->symtree->n.sym->attr.pointer;
       dimension = e->symtree->n.sym->attr.dimension;
 
+      if (sym == e->symtree->n.sym)
+	{
+	  gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
+		     "not be allocated in the same statement at %L",
+		      sym->name, &e->where);
+	  return FAILURE;
+	}
+
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
 	switch (ref->type)
 	  {
@@ -3449,34 +3539,51 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
       return FAILURE;
     }
 
-  if (ref2->u.ar.type == AR_ELEMENT)
-    return SUCCESS;
-
   /* Make sure that the array section reference makes sense in the
     context of an ALLOCATE specification.  */
 
   ar = &ref2->u.ar;
 
   for (i = 0; i < ar->dimen; i++)
-    switch (ar->dimen_type[i])
-      {
-      case DIMEN_ELEMENT:
-	break;
+    {
+      if (ref2->u.ar.type == AR_ELEMENT)
+	goto check_symbols;
 
-      case DIMEN_RANGE:
-	if (ar->start[i] != NULL
-	    && ar->end[i] != NULL
-	    && ar->stride[i] == NULL)
+      switch (ar->dimen_type[i])
+	{
+	case DIMEN_ELEMENT:
 	  break;
 
-	/* Fall Through...  */
+	case DIMEN_RANGE:
+	  if (ar->start[i] != NULL
+	      && ar->end[i] != NULL
+	      && ar->stride[i] == NULL)
+	    break;
 
-      case DIMEN_UNKNOWN:
-      case DIMEN_VECTOR:
-	gfc_error ("Bad array specification in ALLOCATE statement at %L",
-		   &e->where);
-	return FAILURE;
-      }
+	  /* Fall Through...  */
+
+	case DIMEN_UNKNOWN:
+	case DIMEN_VECTOR:
+	  gfc_error ("Bad array specification in ALLOCATE statement at %L",
+		     &e->where);
+	  return FAILURE;
+	}
+
+check_symbols:
+
+      for (a = code->ext.alloc_list; a; a = a->next)
+	{
+	  sym = a->expr->symtree->n.sym;
+	  if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
+		 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
+	    {
+	      gfc_error ("'%s' must not appear an the array specification at "
+			 "%L in the same ALLOCATE statement where it is "
+			 "itself allocated", sym->name, &ar->where);
+	      return FAILURE;
+	    }
+	}
+    }
 
   return SUCCESS;
 }
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5e3a75b..ea575ee 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,11 @@
 2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/20779
+	PR fortran/20891
+	* gfortran.dg/alloc_alloc_expr_1.f90: New test.
+
+2006-10-03  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/29284
 	* gfortran.dg/optional_assumed_charlen_1.f90: New test.
 
diff --git a/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 b/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
new file mode 100644
index 0000000..4776438
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+program fc011
+! Tests fix for PR20779 and PR20891.
+! Submitted by Walt Brainerd, The Fortran Company
+! and by Joost VandeVondele  <jv244@cam.ac.uk> 
+
+! This program violates requirements of 6.3.1 of the F95 standard.
+
+! An allocate-object, or a subobject of an allocate-object, shall not appear
+! in a bound in the same ALLOCATE statement. The stat-variable shall not appear
+! in a bound in the same ALLOCATE statement.
+
+! The stat-variable shall not be allocated within the ALLOCATE statement in which
+! it appears; nor shall it depend on the value, bounds, allocation status, or
+! association status of any allocate-object or subobject of an allocate-object
+! allocated in the same statement.
+
+  integer, pointer :: PTR
+  integer, allocatable :: ALLOCS(:)
+
+  allocate (PTR, stat=PTR) ! { dg-error "allocated in the same statement" }
+
+  allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "allocated in the same statement" }
+
+  ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
+
+  print *, 'This program has three errors', PTR, ALLOC(1)
+
+end program fc011