re PR fortran/49755 (ALLOCATE with STAT= produces invalid code for already allocated vars)

2011-07-26  Daniel Carrera  <dcarrera@gmail.com>

	PR fortran/49755
	* trans.c (gfc_allocate_using_malloc): Change function signature.
	Return nothing. New parameter "pointer". Eliminate temorary variables.
	(gfc_allocate_using_lib): Ditto.
	(gfc_allocate_allocatable): Ditto. Update call to gfc_allocate_using_lib
	and gfc_allocate_using_malloc. Do not free and then reallocate a
	variable that is already allocated.
	(gfc_likely): New function. Basedon gfc_unlikely.
	* trans-array.c (gfc_array_init_size): New parameter "descriptor_block".
	Instructions to modify the array descriptor are stored in this block
	while other instructions continue to be stored in "pblock".
	(gfc_array_allocate): Update call to gfc_array_init_size. Move the
	descriptor_block so that the array descriptor is only updated if
	the array was allocated successfully.
	Update calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
	* trans.h (gfc_allocate_allocatable): Change function signature.
	Function now returns void.
	(gfc_allocate_using_lib): Ditto, and new function parameter.
	(gfc_allocate_using_malloc): Ditto.
	* trans-openmp.c (gfc_omp_clause_default_ctor,
	gfc_omp_clause_copy_ctor,gfc_trans_omp_array_reduction): Replace a call
	to gfc_allocate_allocatable with gfc_allocate_using_malloc.
	* trans-stmt.c (gfc_trans_allocate): Update function calls for
	gfc_allocate_allocatable and gfc_allocate_using_malloc.



2011-07-26  Daniel Carrera  <dcarrera@gmail.com>

	PR fortran/49755
	* gfortran.dg/multiple_allocation_1.f90: Fix test. Allocating an
	allocated array should *not* change its size.
	* gfortran.dg/multiple_allocation_3.f90: New test.

From-SVN: r176822

gcc/fortran/ChangeLog

+2011-07-27  Daniel Carrera  <dcarrera@gmail.com>
+
+	PR fortran/49755
+	* trans.c (gfc_allocate_using_malloc): Change function signature.
+	Return nothing. New parameter "pointer". Eliminate temorary variables. 
+	(gfc_allocate_using_lib): Ditto.
+	(gfc_allocate_allocatable): Ditto. Update call to gfc_allocate_using_lib
+	and gfc_allocate_using_malloc. Do not free and then reallocate a
+	variable that is already allocated.
+	(gfc_likely): New function. Basedon gfc_unlikely.
+	* trans-array.c (gfc_array_init_size): New parameter "descriptor_block".
+	Instructions to modify the array descriptor are stored in this block
+	while other instructions continue to be stored in "pblock".
+	(gfc_array_allocate): Update call to gfc_array_init_size. Move the
+	descriptor_block so that the array descriptor is only updated if
+	the array was allocated successfully.
+	Update calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
+	* trans.h (gfc_allocate_allocatable): Change function signature.
+	Function now returns void.
+	(gfc_allocate_using_lib): Ditto, and new function parameter.
+	(gfc_allocate_using_malloc): Ditto.
+	* trans-openmp.c (gfc_omp_clause_default_ctor,
+	gfc_omp_clause_copy_ctor,gfc_trans_omp_array_reduction): Replace a call
+	to gfc_allocate_allocatable with gfc_allocate_using_malloc.
+	* trans-stmt.c (gfc_trans_allocate): Update function calls for
+	gfc_allocate_allocatable and gfc_allocate_using_malloc.
+
 2011-07-26  Tobias Burnus  <burnus@net-b.de>
 
 	* trans-array.c (CAF_TOKEN_FIELD): New macro constant.

gcc/fortran/trans-array.c

@@ -4164,7 +4164,7 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
 	size = 1 - lbound;
 	a.ubound[n] = specified_upper_bound;
 	a.stride[n] = stride;
-	size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+	size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
 	overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
 	stride = stride * size;
       }
@@ -4182,8 +4182,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
 
 static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
-		     gfc_expr ** lower, gfc_expr ** upper,
-		     stmtblock_t * pblock, tree * overflow)
+		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
+		     stmtblock_t * descriptor_block, tree * overflow)
 {
   tree type;
   tree tmp;
@@ -4209,7 +4209,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
   /* Set the dtype.  */
   tmp = gfc_conv_descriptor_dtype (descriptor);
-  gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
 
   or_expr = boolean_false_node;
 
@@ -4242,8 +4242,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	      ubound = lower[n];
 	    }
 	}
-      gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
-				      se.expr);
+      gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, 
+				      gfc_rank_cst[n], se.expr);
       conv_lbound = se.expr;
 
       /* Work out the offset for this component.  */
@@ -4258,12 +4258,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
       gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
       gfc_add_block_to_block (pblock, &se.pre);
 
-      gfc_conv_descriptor_ubound_set (pblock, descriptor,
+      gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], se.expr);
       conv_ubound = se.expr;
 
       /* Store the stride.  */
-      gfc_conv_descriptor_stride_set (pblock, descriptor,
+      gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], stride);
 
       /* Calculate size and check whether extent is negative.  */
@@ -4323,8 +4323,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	      ubound = lower[n];
 	    }
 	}
-      gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
-				      se.expr);
+      gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, 
+				      gfc_rank_cst[n], se.expr);
 
       if (n < rank + corank - 1)
 	{
@@ -4332,7 +4332,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	  gcc_assert (ubound);
 	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
 	  gfc_add_block_to_block (pblock, &se.pre);
-	  gfc_conv_descriptor_ubound_set (pblock, descriptor,
+	  gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
 					  gfc_rank_cst[n], se.expr);
 	}
     }
@@ -4415,6 +4415,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   tree overflow; /* Boolean storing whether size calculation overflows.  */
   tree var_overflow = NULL_TREE;
   tree cond;
+  tree set_descriptor;
+  stmtblock_t set_descriptor_block;
   stmtblock_t elseblock;
   gfc_expr **lower;
   gfc_expr **upper;
@@ -4481,9 +4483,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
     }
 
   overflow = integer_zero_node;
+
+  gfc_init_block (&set_descriptor_block);
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
-			      &se->pre, &overflow);
+			      &se->pre, &set_descriptor_block, &overflow);
+
   if (dimension)
     {
 
@@ -4511,22 +4516,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
     }
 
   gfc_start_block (&elseblock);
-  
+
   /* Allocate memory to store the data.  */
   pointer = gfc_conv_descriptor_data_get (se->expr);
   STRIP_NOPS (pointer);
 
   /* The allocatable variant takes the old pointer as first argument.  */
   if (allocatable)
-    tmp = gfc_allocate_allocatable (&elseblock, pointer, size,
-				    status, errmsg, errlen, expr);
+    gfc_allocate_allocatable (&elseblock, pointer, size,
+			      status, errmsg, errlen, expr);
   else
-    tmp = gfc_allocate_using_malloc (&elseblock, size, status);
-
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
-			 pointer, tmp);
-
-  gfc_add_expr_to_block (&elseblock, tmp);
+    gfc_allocate_using_malloc (&elseblock, pointer, size, status);
 
   if (dimension)
     {
@@ -4540,8 +4540,23 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 
   gfc_add_expr_to_block (&se->pre, tmp);
 
+  /* Update the array descriptors. */
   if (dimension)
-    gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
+    gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+  
+  set_descriptor = gfc_finish_block (&set_descriptor_block);
+  if (status != NULL_TREE)
+    {
+      cond = fold_build2_loc (input_location, EQ_EXPR,
+			  boolean_type_node, status,
+			  build_int_cst (TREE_TYPE (status), 0));
+      gfc_add_expr_to_block (&se->pre,
+		 fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				  gfc_likely (cond), set_descriptor,
+				  build_empty_stmt (input_location))); 
+    }
+  else
+      gfc_add_expr_to_block (&se->pre, set_descriptor);
 
   if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
 	&& expr->ts.u.derived->attr.alloc_comp)

gcc/fortran/trans-openmp.c

@@ -188,10 +188,11 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			  size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
-  ptr = gfc_allocate_allocatable (&cond_block,
-			  build_int_cst (pvoid_type_node, 0),
-			  size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
+
+  ptr = gfc_create_var (pvoid_type_node, NULL);
+  gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
   gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
+
   then_b = gfc_finish_block (&cond_block);
 
   gfc_init_block (&cond_block);
@@ -241,10 +242,11 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			  size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-  ptr = gfc_allocate_allocatable (&block,
-			  build_int_cst (pvoid_type_node, 0),
-			  size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
+
+  ptr = gfc_create_var (pvoid_type_node, NULL);
+  gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
   gfc_conv_descriptor_data_set (&block, dest, ptr);
+
   call = build_call_expr_loc (input_location,
 			  built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
 			  fold_convert (pvoid_type_node,
@@ -663,10 +665,11 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      size, esize);
       size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-      ptr = gfc_allocate_allocatable (&block,
-			      build_int_cst (pvoid_type_node, 0),
-			      size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
+
+      ptr = gfc_create_var (pvoid_type_node, NULL);
+      gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
       gfc_conv_descriptor_data_set (&block, decl, ptr);
+
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
 			     false));
       stmt = gfc_finish_block (&block);

gcc/fortran/trans-stmt.c

@@ -4867,15 +4867,10 @@ gfc_trans_allocate (gfc_code * code)
 
 	  /* Allocate - for non-pointers with re-alloc checking.  */
 	  if (gfc_expr_attr (expr).allocatable)
-	    tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz,
-					    stat, errmsg, errlen, expr);
+	    gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+				      stat, errmsg, errlen, expr);
 	  else
-	    tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat);
-
-	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
-				 se.expr,
-				 fold_convert (TREE_TYPE (se.expr), tmp));
-	  gfc_add_expr_to_block (&se.pre, tmp);
+	    gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
 
 	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
 	    {
@@ -4901,7 +4896,7 @@ gfc_trans_allocate (gfc_code * code)
 				  boolean_type_node, stat,
 				  build_int_cst (TREE_TYPE (stat), 0));
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-				 parm, tmp,
+				 gfc_unlikely(parm), tmp,
 				     build_empty_stmt (input_location));
 	  gfc_add_expr_to_block (&block, tmp);
 	}

gcc/fortran/trans.c

@@ -582,11 +582,11 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
       }
       return newmem;
     }  */
-tree
-gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
+void
+gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
+			   tree size, tree status)
 {
-  stmtblock_t alloc_block;
-  tree res, tmp, on_error;
+  tree tmp, on_error, error_cond;
   tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
 
   /* Evaluate size only once, and make sure it has the right type.  */
@@ -594,19 +594,15 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
     size = fold_convert (size_type_node, size);
 
-  /* Create a variable to hold the result.  */
-  res = gfc_create_var (prvoid_type_node, NULL);
-
-  /* Set the optional status variable to zero.  */
+  /* If successful and stat= is given, set status to 0.  */
   if (status != NULL_TREE)
       gfc_add_expr_to_block (block,
 	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 			      status, build_int_cst (status_type, 0)));
 
   /* The allocation itself.  */
-  gfc_start_block (&alloc_block);
-  gfc_add_modify (&alloc_block, res,
-	  fold_convert (prvoid_type_node,
+  gfc_add_modify (block, pointer,
+	  fold_convert (TREE_TYPE (pointer),
 		build_call_expr_loc (input_location,
 			     built_in_decls[BUILT_IN_MALLOC], 1,
 			     fold_build2_loc (input_location,
@@ -623,16 +619,14 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
 				 gfc_build_localized_cstring_const
 				 ("Allocation would exceed memory limit")));
 
+  error_cond = fold_build2_loc (input_location, EQ_EXPR,
+				boolean_type_node, pointer,
+				build_int_cst (prvoid_type_node, 0));
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-			 fold_build2_loc (input_location, EQ_EXPR,
-					  boolean_type_node, res,
-					  build_int_cst (prvoid_type_node, 0)),
-			 on_error, build_empty_stmt (input_location));
-
-  gfc_add_expr_to_block (&alloc_block, tmp);
-  gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
+			 gfc_unlikely(error_cond), on_error,
+			 build_empty_stmt (input_location));
 
-  return res;
+  gfc_add_expr_to_block (block, tmp);
 }
 
 
@@ -648,20 +642,17 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
       newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
       return newmem;
     }  */
-tree
-gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
-			tree errmsg, tree errlen)
+void
+gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
+			tree status, tree errmsg, tree errlen)
 {
-  tree res, pstat;
+  tree tmp, pstat;
 
   /* Evaluate size only once, and make sure it has the right type.  */
   size = gfc_evaluate_now (size, block);
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
     size = fold_convert (size_type_node, size);
 
-  /* Create a variable to hold the result.  */
-  res = gfc_create_var (prvoid_type_node, NULL);
-
   /* The allocation itself.  */
   if (status == NULL_TREE)
     pstat  = null_pointer_node;
@@ -675,19 +666,20 @@ gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
       errlen = build_int_cst (integer_type_node, 0);
     }
 
-  gfc_add_modify (block, res,
-	  fold_convert (prvoid_type_node,
-		build_call_expr_loc (input_location,
-		     gfor_fndecl_caf_register, 6,
-		     fold_build2_loc (input_location,
+  tmp = build_call_expr_loc (input_location,
+	     gfor_fndecl_caf_register, 6,
+	     fold_build2_loc (input_location,
 			      MAX_EXPR, size_type_node, size,
 			      build_int_cst (size_type_node, 1)),
-		     build_int_cst (integer_type_node,
+	     build_int_cst (integer_type_node,
 			    GFC_CAF_COARRAY_ALLOC),
-		     null_pointer_node,  /* token  */
-		     pstat, errmsg, errlen)));
+	     null_pointer_node,  /* token  */
+	     pstat, errmsg, errlen);
 
-  return res;
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+			 TREE_TYPE (pointer), pointer,
+			 fold_convert ( TREE_TYPE (pointer), tmp));
+  gfc_add_expr_to_block (block, tmp);
 }
 
 
@@ -705,12 +697,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
       else
       {
 	if (stat)
-	{
-	  free (mem);
-	  mem = allocate (size, stat);
 	  stat = LIBERROR_ALLOCATION;
-	  return mem;
-	}
 	else
 	  runtime_error ("Attempting to allocate already allocated variable");
       }
@@ -718,19 +705,17 @@ gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
     
     expr must be set to the original expression being allocated for its locus
     and variable name in case a runtime error has to be printed.  */
-tree
+void
 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
 			  tree errmsg, tree errlen, gfc_expr* expr)
 {
   stmtblock_t alloc_block;
-  tree res, tmp, null_mem, alloc, error;
+  tree tmp, null_mem, alloc, error;
   tree type = TREE_TYPE (mem);
 
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
     size = fold_convert (size_type_node, size);
 
-  /* Create a variable to hold the result.  */
-  res = gfc_create_var (type, NULL);
   null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
 					    boolean_type_node, mem,
 					    build_int_cst (type, 0)));
@@ -741,12 +726,11 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
 
   if (gfc_option.coarray == GFC_FCOARRAY_LIB
       && gfc_expr_attr (expr).codimension)
-    tmp = gfc_allocate_using_lib (&alloc_block, size, status,
-				  errmsg, errlen);
+    gfc_allocate_using_lib (&alloc_block, mem, size, status,
+			    errmsg, errlen);
   else
-    tmp = gfc_allocate_using_malloc (&alloc_block, size, status);
+    gfc_allocate_using_malloc (&alloc_block, mem, size, status);
 
-  gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
   alloc = gfc_finish_block (&alloc_block);
 
   /* If mem is not NULL, we issue a runtime error or set the
@@ -772,27 +756,14 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
   if (status != NULL_TREE)
     {
       tree status_type = TREE_TYPE (status);
-      stmtblock_t set_status_block;
-
-      gfc_start_block (&set_status_block);
-      tmp = build_call_expr_loc (input_location,
-			     built_in_decls[BUILT_IN_FREE], 1,
-			     fold_convert (pvoid_type_node, mem));
-      gfc_add_expr_to_block (&set_status_block, tmp);
-
-      tmp = gfc_allocate_using_malloc (&set_status_block, size, status);
-      gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 
-      gfc_add_modify (&set_status_block, status,
-		      build_int_cst (status_type, LIBERROR_ALLOCATION));
-      error = gfc_finish_block (&set_status_block);
+      error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+	      status, build_int_cst (status_type, LIBERROR_ALLOCATION));
     }
 
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
 			 error, alloc);
   gfc_add_expr_to_block (block, tmp);
-
-  return res;
 }
 
 
@@ -1619,3 +1590,19 @@ gfc_unlikely (tree cond)
   cond = fold_convert (boolean_type_node, cond);
   return cond;
 }
+
+
+/* Helper function for marking a boolean expression tree as likely.  */
+
+tree
+gfc_likely (tree cond)
+{
+  tree tmp;
+
+  cond = fold_convert (long_integer_type_node, cond);
+  tmp = build_one_cst (long_integer_type_node);
+  cond = build_call_expr_loc (input_location,
+			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+  cond = fold_convert (boolean_type_node, cond);
+  return cond;
+}

gcc/fortran/trans.h

@@ -517,7 +517,8 @@ void gfc_generate_constructors (void);
 /* Get the string length of an array constructor.  */
 bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
 
-/* Mark a condition as unlikely.  */
+/* Mark a condition as likely or unlikely.  */
+tree gfc_likely (tree);
 tree gfc_unlikely (tree);
 
 /* Generate a runtime error call.  */
@@ -541,12 +542,12 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree);
 tree gfc_build_memcpy_call (tree, tree, tree);
 
 /* Allocate memory for allocatable variables, with optional status variable.  */
-tree gfc_allocate_allocatable (stmtblock_t*, tree, tree,
+void gfc_allocate_allocatable (stmtblock_t*, tree, tree,
 			       tree, tree, tree, gfc_expr*);
 
 /* Allocate memory, with optional status variable.  */
-tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree);
-tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree);
+void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
+void gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
 tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);

gcc/testsuite/ChangeLog

+2011-07-27  Daniel Carrera  <dcarrera@gmail.com>
+
+	PR fortran/49755
+	* gfortran.dg/multiple_allocation_1.f90: Fix test. Allocating an
+	allocated array should *not* change its size.
+	* gfortran.dg/multiple_allocation_3.f90: New test.
+
 2011-07-26  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/49776

gcc/testsuite/gfortran.dg/multiple_allocation_1.f90

 ! { dg-do run }
 ! PR 25031 - We didn't cause an error when allocating an already
 !            allocated array.
+!
+! This testcase has been modified to fix PR 49755. 
 program alloc_test
   implicit none
   integer :: i
@@ -8,11 +10,12 @@ program alloc_test
   integer, pointer :: b(:)
 
   allocate(a(4))
-  ! This should set the stat code and change the size.
+  ! This should set the stat code but not change the size.
   allocate(a(3),stat=i)
   if (i == 0) call abort
   if (.not. allocated(a)) call abort
-  if (size(a) /= 3) call abort
+  if (size(a) /= 4) call abort
+
   ! It's OK to allocate pointers twice (even though this causes
   ! a memory leak)
   allocate(b(4))

gcc/testsuite/gfortran.dg/multiple_allocation_3.f90

+! { dg-do run }
+! PR 49755 - If allocating an already allocated array, and stat=
+!            is given, set stat to non zero and do not touch the array.
+program test
+    integer, allocatable :: A(:, :)
+    integer :: stat
+
+    allocate(A(20,20))
+    A = 42
+
+    ! Allocate of already allocated variable
+    allocate (A(5,5), stat=stat)
+
+    ! Expected: Error stat and previous allocation status
+    if (stat == 0) call abort ()
+    if (any (shape (A) /= [20, 20])) call abort ()
+    if (any (A /= 42)) call abort ()
+end program
+