Re: [Patch, fortran] PR20779 and PR20891 - allocation of STAT or specification variables in same call

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

Bother!  Sorry about forgetting the patch.

Paul

> :ADDPATCH fortran:
>
> This patch provides a diagnostic of standard violating code, which has:
>
> allocate (i, x(i)) or allocate (i, stat = i) ;
>
> ie. allocation of objects used in specification expressions or of the 
> stat variable, within the same allocate statement.  The bit of the 
> patch that deals with the stat variable being allocated is straight 
> forward; each new variable to be allocated has its symbol checked 
> against the symbol for stat.  If the two are the same, this is an 
> error.  The specification expressions are a bit more complicated; each 
> symbol to be allocated is checked by a new recursive function against 
> the symbols referenced in all the specification expressions in the 
> allocate statement.  The testcase combines those received from each 
> reporter.
>
> Regtested on FC5/Athlon - OK for trunk and 4.1?
>
> Paul
>
> 2006-09-17 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-09-17 Paul Thomas <pault@gcc.gnu.org>
>
>    PR fortran/20779
>    PR fortran/20891
>    * gfortran.dg/alloc_alloc_expr_1.f90: New test.

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(révision 116697)
+++ gcc/fortran/resolve.c	(copie de travail)
@@ -3308,6 +3308,81 @@
   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
@@ -3352,10 +3427,17 @@
   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.  */
 
@@ -3376,6 +3458,14 @@
       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)
 	  {
@@ -3438,8 +3528,8 @@
       return FAILURE;
     }
 
-  if (ref2->u.ar.type == AR_ELEMENT)
-    return SUCCESS;
+/*  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.  */
@@ -3447,25 +3537,45 @@
   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;
 }
Index: gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90	(révision 0)
+++ gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90	(révision 0)
@@ -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