trans.c (gfc_allocate_with_status): Split into two functions…

trans.c (gfc_allocate_with_status): Split into two functions gfc_allocate_using_malloc and gfc_allocate_usig_lib.

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

	* trans.c (gfc_allocate_with_status): Split into two functions
	gfc_allocate_using_malloc and gfc_allocate_usig_lib.
	(gfc_allocate_using_malloc): The status parameter is now the
	actual status rather than a pointer. Code cleanup.
	(gfc_allocate_using_lib): Ditto. Add new parametrs errmsg and
	errlen. Pass these to the coarray lib.
	* trans-openmp.c (gfc_omp_clause_default_ctor): Update calls to
	gfc_allocate_allocatable.
	(gfc_omp_clause_copy_ctor): Ditto.
	(gfc_trans_omp_array_reduction): Ditto.
	* trans-stmt.c (gfc_trans_allocate): Ditto. Update call to
	gfc_allocate_using_malloc. Pass stat rather than pstat to the allocate
	fuctions. If using coarray lib, pass errmsg and errlen to the allocate
	functions. Move error checking outside the if (!gfc_array_allocate)
	block so that it also affects trees produced by gfc_array_allocate.
	* trans-array.c (gfc_array_allocate): Add new parameters errmsg
	and errlen. Replace parameter pstat by status. Code cleanup. Update
	calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
	* trans-array.h (gfc_array_allocate): Update signature of
	gfc_array_allocate.

From-SVN: r176606

gcc/fortran/ChangeLog

+2011-07-21  Daniel Carrera  <dcarrera@gmail.com>
+
+	* trans.c (gfc_allocate_with_status): Split into two functions
+	gfc_allocate_using_malloc and gfc_allocate_usig_lib.
+	(gfc_allocate_using_malloc): The status parameter is now the
+	actual status rather than a pointer. Code cleanup.
+	(gfc_allocate_using_lib): Ditto. Add new parametrs errmsg and
+	errlen. Pass these to the coarray lib.
+	* trans-openmp.c (gfc_omp_clause_default_ctor): Update calls to
+	gfc_allocate_allocatable.
+	(gfc_omp_clause_copy_ctor): Ditto.
+	(gfc_trans_omp_array_reduction): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Ditto. Update call to
+	gfc_allocate_using_malloc. Pass stat rather than pstat to the allocate
+	fuctions. If using coarray lib, pass errmsg and errlen to the allocate
+	functions. Move error checking outside the if (!gfc_array_allocate)
+	block so that it also affects trees produced by gfc_array_allocate.
+	* trans-array.c (gfc_array_allocate): Add new parameters errmsg
+	and errlen. Replace parameter pstat by status. Code cleanup. Update
+	calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
+	* trans-array.h (gfc_array_allocate): Update signature of
+	gfc_array_allocate.
+
 2011-07-21  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* gfortran.texi: Remove a duplicate word.

gcc/fortran/trans-array.c

@@ -4383,7 +4383,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 /*GCC ARRAYS*/
 
 bool
-gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
+		    tree errlen)
 {
   tree tmp;
   tree pointer;
@@ -4478,22 +4479,15 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
 				   1, msg);
     }
 
-  if (pstat != NULL_TREE && !integer_zerop (pstat))
+  if (status != NULL_TREE)
     {
-      /* Set the status variable if it's present.  */
+      tree status_type = TREE_TYPE (status);
       stmtblock_t set_status_block;
-      tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
 
       gfc_start_block (&set_status_block);
-      gfc_add_modify (&set_status_block,
-  		      fold_build1_loc (input_location, INDIRECT_REF,
-  				       status_type, pstat),
-  			   build_int_cst (status_type, LIBERROR_ALLOCATION));
-
-      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-  			     pstat, build_int_cst (TREE_TYPE (pstat), 0));
-      error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
-  			       error, gfc_finish_block (&set_status_block));
+      gfc_add_modify (&set_status_block, status,
+		      build_int_cst (status_type, LIBERROR_ALLOCATION));
+      error = gfc_finish_block (&set_status_block);
     }
 
   gfc_start_block (&elseblock);
@@ -4502,14 +4496,15 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   pointer = gfc_conv_descriptor_data_get (se->expr);
   STRIP_NOPS (pointer);
 
-  /* The allocate_array variants take the old pointer as first argument.  */
+  /* The allocatable variant takes the old pointer as first argument.  */
   if (allocatable)
-    tmp = gfc_allocate_allocatable_with_status (&elseblock,
-						pointer, size, pstat, expr);
+    tmp = gfc_allocate_allocatable (&elseblock, pointer, size,
+				    status, errmsg, errlen, expr);
   else
-    tmp = gfc_allocate_with_status (&elseblock, size, pstat, false);
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
-			 tmp);
+    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);
 

gcc/fortran/trans-array.h

@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, gfc_expr*);
 
 /* Generate code to initialize an allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
-bool gfc_array_allocate (gfc_se *, gfc_expr *, tree);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,

gcc/fortran/trans-openmp.c

@@ -188,9 +188,9 @@ 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_with_status (&cond_block,
-					      build_int_cst (pvoid_type_node, 0),
-					      size, NULL, NULL);
+  ptr = gfc_allocate_allocatable (&cond_block,
+			  build_int_cst (pvoid_type_node, 0),
+			  size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
   gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
   then_b = gfc_finish_block (&cond_block);
 
@@ -241,9 +241,9 @@ 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_with_status (&block,
-					      build_int_cst (pvoid_type_node, 0),
-					      size, NULL, NULL);
+  ptr = gfc_allocate_allocatable (&block,
+			  build_int_cst (pvoid_type_node, 0),
+			  size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
   gfc_conv_descriptor_data_set (&block, dest, ptr);
   call = build_call_expr_loc (input_location,
 			  built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
@@ -663,9 +663,9 @@ 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_with_status (&block,
-						  build_int_cst (pvoid_type_node, 0),
-						  size, NULL, NULL);
+      ptr = gfc_allocate_allocatable (&block,
+			      build_int_cst (pvoid_type_node, 0),
+			      size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
       gfc_conv_descriptor_data_set (&block, decl, ptr);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
 			     false));

gcc/fortran/trans-stmt.c

@@ -4686,8 +4686,10 @@ gfc_trans_allocate (gfc_code * code)
   tree tmp;
   tree parm;
   tree stat;
-  tree pstat;
-  tree error_label;
+  tree errmsg;
+  tree errlen;
+  tree label_errmsg;
+  tree label_finish;
   tree memsz;
   tree expr3;
   tree slen3;
@@ -4699,21 +4701,39 @@ gfc_trans_allocate (gfc_code * code)
   if (!code->ext.alloc.list)
     return NULL_TREE;
 
-  pstat = stat = error_label = tmp = memsz = NULL_TREE;
+  stat = tmp = memsz = NULL_TREE;
+  label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
 
   gfc_init_block (&block);
   gfc_init_block (&post);
 
-  /* Either STAT= and/or ERRMSG is present.  */
-  if (code->expr1 || code->expr2)
+  /* STAT= (and maybe ERRMSG=) is present.  */
+  if (code->expr1)
     {
+      /* STAT=.  */
       tree gfc_int4_type_node = gfc_get_int_type (4);
-
       stat = gfc_create_var (gfc_int4_type_node, "stat");
-      pstat = gfc_build_addr_expr (NULL_TREE, stat);
 
-      error_label = gfc_build_label_decl (NULL_TREE);
-      TREE_USED (error_label) = 1;
+      /* ERRMSG= only makes sense with STAT=.  */
+      if (code->expr2)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_lhs (&se, code->expr2);
+
+	  errlen = gfc_get_expr_charlen (code->expr2);
+	  errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+	}
+      else
+	{
+	  errmsg = null_pointer_node;
+	  errlen = build_int_cst (gfc_charlen_type_node, 0);
+	}
+
+      /* GOTO destinations.  */
+      label_errmsg = gfc_build_label_decl (NULL_TREE);
+      label_finish = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (label_errmsg) = 1;
+      TREE_USED (label_finish) = 1;
     }
 
   expr3 = NULL_TREE;
@@ -4732,7 +4752,7 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (!gfc_array_allocate (&se, expr, pstat))
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
 	{
 	  /* A scalar or derived type.  */
 
@@ -4847,28 +4867,16 @@ gfc_trans_allocate (gfc_code * code)
 
 	  /* Allocate - for non-pointers with re-alloc checking.  */
 	  if (gfc_expr_attr (expr).allocatable)
-	    tmp = gfc_allocate_allocatable_with_status (&se.pre, se.expr, memsz,
-							pstat, expr);
+	    tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+					    stat, errmsg, errlen, expr);
 	  else
-	    tmp = gfc_allocate_with_status (&se.pre, memsz, pstat, false);
+	    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);
 
-	  if (code->expr1 || code->expr2)
-	    {
-	      tmp = build1_v (GOTO_EXPR, error_label);
-	      parm = fold_build2_loc (input_location, NE_EXPR,
-				      boolean_type_node, stat,
-				      build_int_cst (TREE_TYPE (stat), 0));
-	      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-				     parm, tmp,
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se.pre, tmp);
-	    }
-
 	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
 	    {
 	      tmp = build_fold_indirect_ref_loc (input_location, se.expr);
@@ -4879,6 +4887,25 @@ gfc_trans_allocate (gfc_code * code)
 
       gfc_add_block_to_block (&block, &se.pre);
 
+      /* Error checking -- Note: ERRMSG only makes sense with STAT.  */
+      if (code->expr1)
+	{
+	  /* The coarray library already sets the errmsg.  */
+	  if (gfc_option.coarray == GFC_FCOARRAY_LIB
+	      && gfc_expr_attr (expr).codimension)
+	    tmp = build1_v (GOTO_EXPR, label_finish);
+	  else
+	    tmp = build1_v (GOTO_EXPR, label_errmsg);
+
+	  parm = fold_build2_loc (input_location, NE_EXPR,
+				  boolean_type_node, stat,
+				  build_int_cst (TREE_TYPE (stat), 0));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 parm, tmp,
+				     build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+ 
       if (code->expr3 && !code->expr3->mold)
 	{
 	  /* Initialization via SOURCE block
@@ -5005,16 +5032,11 @@ gfc_trans_allocate (gfc_code * code)
 
     }
 
-  /* STAT block.  */
+  /* STAT  (ERRMSG only makes sense with STAT).  */
   if (code->expr1)
     {
-      tmp = build1_v (LABEL_EXPR, error_label);
+      tmp = build1_v (LABEL_EXPR, label_errmsg);
       gfc_add_expr_to_block (&block, tmp);
-
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr1);
-      tmp = convert (TREE_TYPE (se.expr), stat);
-      gfc_add_modify (&block, se.expr, tmp);
     }
 
   /* ERRMSG block.  */
@@ -5022,7 +5044,7 @@ gfc_trans_allocate (gfc_code * code)
     {
       /* A better error message may be possible, but not required.  */
       const char *msg = "Attempt to allocate an allocated object";
-      tree errmsg, slen, dlen;
+      tree slen, dlen;
 
       gfc_init_se (&se, NULL);
       gfc_conv_expr_lhs (&se, code->expr2);
@@ -5050,6 +5072,22 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  /* STAT  (ERRMSG only makes sense with STAT).  */
+  if (code->expr1)
+    {
+      tmp = build1_v (LABEL_EXPR, label_finish);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* STAT block.  */
+  if (code->expr1)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr1);
+      tmp = convert (TREE_TYPE (se.expr), stat);
+      gfc_add_modify (&block, se.expr, tmp);
+    }
+
   gfc_add_block_to_block (&block, &se.post);
   gfc_add_block_to_block (&block, &post);
 

gcc/fortran/trans.h

@@ -541,11 +541,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_with_status (stmtblock_t*,
-					   tree, tree, tree, gfc_expr*);
+tree gfc_allocate_allocatable (stmtblock_t*, tree, tree,
+			       tree, tree, tree, gfc_expr*);
 
 /* Allocate memory, with optional status variable.  */
-tree gfc_allocate_with_status (stmtblock_t *, tree, tree, bool);
+tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree);
+tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
 tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);