diff mbox

[Fortran] PR 49755 - Multiple allocations.

Message ID 4E2F1F85.7000203@gmail.com
State New
Headers show

Commit Message

Daniel Carrera July 26, 2011, 8:11 p.m. UTC 
The attached patch fixes PR 49755, allowing GFortran to behave correctly 
when faced with multiple allocations:


     allocate(A(20,20))
     A = 42

     ! Allocate of already allocated variable
     allocate (A(5,5), stat=stat)


The patch fixes an error in the test suite (multiple_allocation_1.f90) 
and introduces a new test for the suite (attached). The ChangeLog is 
also attached. The ChangeLog has two parts, which are set to go to 
gcc/fortran and gcc/testsuite respectively.

Ok for trunk?


Cheers,
Daniel.

Comments

Tobias Burnus July 27, 2011, 7:58 a.m. UTC | #1 
On 07/26/2011 10:11 PM, Daniel Carrera wrote:
> The attached patch fixes PR 49755, allowing GFortran to behave 
> correctly when faced with multiple allocations:
> Ok for trunk?
>
> 	* trans-array.c (gfc_array_init_size): New parameter "desciptor_block".

Typo: desc(r)iptor_block.

> 	* trans-openmp.c (gfc_omp_clause_default_ctor): Replace a call to
> 	gfc_allocate_allocatable with gfc_allocate_using_malloc.
> 	(gfc_omp_clause_copy_ctor): Ditto.
> 	(gfc_trans_omp_array_reduction): Ditto.

You can combine changes different functions in a single file as in

     * trans-openmp.c (gfc_omp_clause_default_ctor,
     gfc_omp_clause_copy_ctor, gfc_trans_omp_array_reduction): ...

> 	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. Tests PR 49755.

The "Tests PR 49755." is redundant as one already has "PR fortran/49755".



Your patch  does *not* compile for me as you missed to add gfc_likely to 
trans.h:

gcc/fortran/trans-array.c:4554:4: error: 'gfc_likely' was not declared 
in this scope


> Index: gcc/testsuite/gfortran.dg/multiple_allocation_1.f90
> ===================================================================
> --- gcc/testsuite/gfortran.dg/multiple_allocation_1.f90	(revision 176622)
> +++ gcc/testsuite/gfortran.dg/multiple_allocation_1.f90	(working copy)
> @@ -10,3 +10,3 @@ program alloc_test
>     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)

For later reference, I would prefer to add a comment stating that the 
testcase has been modified to fix PR 49755. It's not really needed but 
sometimes convenient to go back to all PRs which were involved in 
creating/modifying the test case.

Otherwise, the patch is OK.

Tobias
diff mbox

Patch

Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 176622)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -4146,3 +4146,3 @@  gfc_conv_descriptor_cosize (tree desc, i
 	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);
@@ -4164,4 +4164,4 @@  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)
 {
@@ -4191,3 +4191,3 @@  gfc_array_init_size (tree descriptor, in
   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)));
 
@@ -4224,4 +4224,4 @@  gfc_array_init_size (tree descriptor, in
 	}
-      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;
@@ -4240,3 +4240,3 @@  gfc_array_init_size (tree descriptor, in
 
-      gfc_conv_descriptor_ubound_set (pblock, descriptor,
+      gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], se.expr);
@@ -4245,3 +4245,3 @@  gfc_array_init_size (tree descriptor, in
       /* Store the stride.  */
-      gfc_conv_descriptor_stride_set (pblock, descriptor,
+      gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], stride);
@@ -4305,4 +4305,4 @@  gfc_array_init_size (tree descriptor, in
 	}
-      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);
 
@@ -4314,3 +4314,3 @@  gfc_array_init_size (tree descriptor, in
 	  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);
@@ -4397,2 +4397,4 @@  gfc_array_allocate (gfc_se * se, gfc_exp
   tree cond;
+  tree set_descriptor;
+  stmtblock_t set_descriptor_block;
   stmtblock_t elseblock;
@@ -4463,5 +4465,8 @@  gfc_array_allocate (gfc_se * se, gfc_exp
   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)
@@ -4493,3 +4498,3 @@  gfc_array_allocate (gfc_se * se, gfc_exp
   gfc_start_block (&elseblock);
-  
+
   /* Allocate memory to store the data.  */
@@ -4500,11 +4505,6 @@  gfc_array_allocate (gfc_se * se, gfc_exp
   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);
 
@@ -4522,4 +4522,19 @@  gfc_array_allocate (gfc_se * se, gfc_exp
 
+  /* 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);
 
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c	(revision 176622)
+++ gcc/fortran/trans-openmp.c	(working copy)
@@ -190,6 +190,7 @@  gfc_omp_clause_default_ctor (tree clause
   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);
@@ -243,6 +244,7 @@  gfc_omp_clause_copy_ctor (tree clause, t
   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,
@@ -665,6 +667,7 @@  gfc_trans_omp_array_reduction (tree c, g
       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,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 176622)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -4869,11 +4869,6 @@  gfc_trans_allocate (gfc_code * code)
 	  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);
 
@@ -4903,3 +4898,3 @@  gfc_trans_allocate (gfc_code * code)
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-				 parm, tmp,
+				 gfc_unlikely(parm), tmp,
 				     build_empty_stmt (input_location));
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(revision 176622)
+++ gcc/fortran/trans.c	(working copy)
@@ -584,7 +584,7 @@  gfc_call_malloc (stmtblock_t * block, tr
     }  */
-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;
@@ -596,6 +596,3 @@  gfc_allocate_using_malloc (stmtblock_t *
 
-  /* 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)
@@ -606,5 +603,4 @@  gfc_allocate_using_malloc (stmtblock_t *
   /* 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,
@@ -625,12 +621,10 @@  gfc_allocate_using_malloc (stmtblock_t *
 
+  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_unlikely(error_cond), 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));
-
-  return res;
+  gfc_add_expr_to_block (block, tmp);
 }
@@ -650,7 +644,7 @@  gfc_allocate_using_malloc (stmtblock_t *
     }  */
-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;
 
@@ -661,5 +655,2 @@  gfc_allocate_using_lib (stmtblock_t * bl
 
-  /* Create a variable to hold the result.  */
-  res = gfc_create_var (prvoid_type_node, NULL);
-
   /* The allocation itself.  */
@@ -677,15 +668,16 @@  gfc_allocate_using_lib (stmtblock_t * bl
 
-  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);
 }
@@ -707,8 +699,3 @@  gfc_allocate_using_lib (stmtblock_t * bl
 	if (stat)
-	{
-	  free (mem);
-	  mem = allocate (size, stat);
 	  stat = LIBERROR_ALLOCATION;
-	  return mem;
-	}
 	else
@@ -720,3 +707,3 @@  gfc_allocate_using_lib (stmtblock_t * bl
     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,
@@ -725,3 +712,3 @@  gfc_allocate_allocatable (stmtblock_t * 
   stmtblock_t alloc_block;
-  tree res, tmp, null_mem, alloc, error;
+  tree tmp, null_mem, alloc, error;
   tree type = TREE_TYPE (mem);
@@ -731,4 +718,2 @@  gfc_allocate_allocatable (stmtblock_t * 
 
-  /* Create a variable to hold the result.  */
-  res = gfc_create_var (type, NULL);
   null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
@@ -743,8 +728,7 @@  gfc_allocate_allocatable (stmtblock_t * 
       && 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);
@@ -774,16 +758,5 @@  gfc_allocate_allocatable (stmtblock_t * 
       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));
     }
@@ -793,4 +766,2 @@  gfc_allocate_allocatable (stmtblock_t * 
   gfc_add_expr_to_block (block, tmp);
-
-  return res;
 }
@@ -1621,1 +1592,17 @@  gfc_unlikely (tree 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;
+}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 176622)
+++ gcc/fortran/trans.h	(working copy)
@@ -543,3 +543,3 @@  tree gfc_build_memcpy_call (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*);
@@ -547,4 +547,4 @@  tree gfc_allocate_allocatable (stmtblock
 /* 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);
 
Index: gcc/testsuite/gfortran.dg/multiple_allocation_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/multiple_allocation_1.f90	(revision 176622)
+++ gcc/testsuite/gfortran.dg/multiple_allocation_1.f90	(working copy)
@@ -10,3 +10,3 @@  program alloc_test
   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)
@@ -14,3 +14,4 @@  program alloc_test
   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