[Patch, fortran] PR fortran/50050 out of bounds whilst freeing an allocate-object.

[Mikael Morin <mikael dot morin at sfr dot fr>]

Hello, 

This fixes an ICE triggered by resolve.c's gfc_expr_to_initialize reseting a 
range array ref into a full array ref, updating the rank, but leaving the 
shape as is, which eventually leads to an out of bound error.

The right fix would probably be to avoid this kind of tricks. But I don't know 
what a patch impleting that would look like.

This patch instead keeps the trick as is. It just frees the shape and re-
resolves the expression, so that rank and shape are updated. It also does a 
bit of refactoring about shape freeing.

I think it should be on the safe side, and I'm testing it on x86_64-unknown-
freebsd8.2. OK for trunk if it passes? What about the branches? It is not a 
regression, but it looks like a genuine bug.

Mikael

2011-08-12  Mikael Morin  <mikael.morin@gcc.gnu.org>

	PR fortran/50050
	* gfortran.h (gfc_clear_shape, gfc_free_shape): New prototypes.
	* expr.c (gfc_clear_shape, gfc_free_shape): New functions.
	(free_expr0): Re-use gfc_free_shape.
	* trans-expr.c (gfc_trans_subarray_assign): Ditto.
	* trans-io.c (transfer_array_component): Ditto.
	* resolve.c (check_host_association): Ditto.
	(gfc_expr_to_initialize): Don't force the rank value and free the shape
	after updating the expression. Recalculate shape and rank.
	(resolve_where_shape): Re-use gfc_clear_shape.
	* array.c (gfc_array_ref_shape): Ditto.

2011-08-12  Mikael Morin  <mikael.morin@gcc.gnu.org>

	* gfortran.dg/alloc_comp_initializer_3.f90: New test.

diff --git a/array.c b/array.c
index 3074275..aa9cc0c 100644
--- a/array.c
+++ b/array.c
@@ -2281,9 +2281,7 @@ gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
     }
 
 cleanup:
-  for (d--; d >= 0; d--)
-    mpz_clear (shape[d]);
-
+  gfc_clear_shape (shape, d);
   return FAILURE;
 }
 
diff --git a/expr.c b/expr.c
index 549feee..c2f1553 100644
--- a/expr.c
+++ b/expr.c
@@ -396,6 +396,25 @@ gfc_copy_expr (gfc_expr *p)
 }
 
 
+void
+gfc_clear_shape (mpz_t *shape, int rank)
+{
+  int i;
+
+  for (i = 0; i < rank; i++)
+    mpz_clear (shape[i]);
+}
+
+
+void
+gfc_free_shape (mpz_t **shape, int rank)
+{
+  gfc_clear_shape (*shape, rank);
+  free (*shape);
+  *shape = NULL;
+}
+
+
 /* Workhorse function for gfc_free_expr() that frees everything
    beneath an expression node, but not the node itself.  This is
    useful when we want to simplify a node and replace it with
@@ -404,8 +423,6 @@ gfc_copy_expr (gfc_expr *p)
 static void
 free_expr0 (gfc_expr *e)
 {
-  int n;
-
   switch (e->expr_type)
     {
     case EXPR_CONSTANT:
@@ -474,12 +491,7 @@ free_expr0 (gfc_expr *e)
 
   /* Free a shape array.  */
   if (e->shape != NULL)
-    {
-      for (n = 0; n < e->rank; n++)
-	mpz_clear (e->shape[n]);
-
-      free (e->shape);
-    }
+    gfc_free_shape (&e->shape, e->rank);
 
   gfc_free_ref_list (e->ref);
 
diff --git a/gfortran.h b/gfortran.h
index 34afae4..09f2fe3 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -2711,6 +2711,8 @@ gfc_expr *gfc_get_int_expr (int, locus *, int);
 gfc_expr *gfc_get_logical_expr (int, locus *, bool);
 gfc_expr *gfc_get_iokind_expr (locus *, io_kind);
 
+void gfc_clear_shape (mpz_t *shape, int rank);
+void gfc_free_shape (mpz_t **shape, int rank);
 void gfc_free_expr (gfc_expr *);
 void gfc_replace_expr (gfc_expr *, gfc_expr *);
 mpz_t *gfc_copy_shape (mpz_t *, int);
diff --git a/resolve.c b/resolve.c
index b8a8ebb..a4645a2 100644
--- a/resolve.c
+++ b/resolve.c
@@ -5198,12 +5198,7 @@ check_host_association (gfc_expr *e)
 	{
 	  /* Clear the shape, since it might not be valid.  */
 	  if (e->shape != NULL)
-	    {
-	      for (n = 0; n < e->rank; n++)
-		mpz_clear (e->shape[n]);
-
-	      free (e->shape);
-	    }
+	    gfc_free_shape (&e->shape, e->rank);
 
 	  /* Give the expression the right symtree!  */
 	  gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
@@ -6558,10 +6553,13 @@ gfc_expr_to_initialize (gfc_expr *e)
 	for (i = 0; i < ref->u.ar.dimen; i++)
 	  ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
 
-	result->rank = ref->u.ar.dimen;
 	break;
       }
 
+  gfc_free_shape (&result->shape, result->rank);
+
+  /* Recalculate rank, shape, etc.  */
+  gfc_resolve_expr (result);
   return result;
 }
 
@@ -8429,11 +8427,8 @@ ignore:
   result = SUCCESS;
 
 over:
-  for (i--; i >= 0; i--)
-    {
-      mpz_clear (shape[i]);
-      mpz_clear (shape2[i]);
-    }
+  gfc_clear_shape (shape, i);
+  gfc_clear_shape (shape2, i);
   return result;
 }
 
diff --git a/trans-expr.c b/trans-expr.c
index 96510c2..b8ed4c5 100644
--- a/trans-expr.c
+++ b/trans-expr.c
@@ -4411,10 +4411,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   gfc_add_block_to_block (&block, &loop.pre);
   gfc_add_block_to_block (&block, &loop.post);
 
-  for (n = 0; n < cm->as->rank; n++)
-    mpz_clear (lss->shape[n]);
-  free (lss->shape);
-
+  gfc_free_shape (&lss->shape, cm->as->rank);
   gfc_cleanup_loop (&loop);
 
   return gfc_finish_block (&block);
diff --git a/trans-io.c b/trans-io.c
index 4e019a3..2ae34d8 100644
--- a/trans-io.c
+++ b/trans-io.c
@@ -1999,10 +1999,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
   gfc_add_block_to_block (&block, &loop.pre);
   gfc_add_block_to_block (&block, &loop.post);
 
-  for (n = 0; n < cm->as->rank; n++)
-    mpz_clear (ss->shape[n]);
-  free (ss->shape);
-
+  gfc_free_shape (&ss->shape, cm->as->rank);
   gfc_cleanup_loop (&loop);
 
   return gfc_finish_block (&block);

! { dg-do compile }
!
! PR fortran/50050
! Out of bound whilst releasing initialization of allocate object
!
! Contributed by someone <sigurdkn@gmail.com>

program bug
  implicit none
  type foo
    integer, pointer :: a => null()
  end type
  type(foo), dimension(:,:), allocatable :: data
  allocate(data(1:1,1)) ! This used to lead to an ICE
end program