2012-01-06 Tobias Burnus <burnus@net-b.de>

        * trans-openmp.c (gfc_omp_clause_dtor,
        * gfc_trans_omp_array_reduction):
        Update call to gfc_trans_dealloc_allocated.
        * trans.c (gfc_allocate_using_malloc): Fix spacing.
        (gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to
        label_finish when an error occurs.
        (gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib.
        * trans.h (gfc_allocate_allocatable,
        * gfc_deallocate_with_status):
        Update prototype.
        (gfor_fndecl_caf_deregister): New tree symbol.
        * trans-expr.c (gfc_conv_procedure_call): Update
        gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls.
        * trans-array.c (gfc_array_allocate,
        * gfc_trans_dealloc_allocated,
        structure_alloc_comps, gfc_trans_deferred_array): Ditto.
        (gfc_array_deallocate): Handle coarrays with -fcoarray=lib.
        * trans-array.h (gfc_array_deallocate, gfc_array_allocate,
        gfc_trans_dealloc_allocated): Update prototypes.
        * trans-stmt.c (gfc_trans_sync): Fix indentation.
        (gfc_trans_allocate): Fix errmsg padding and label handling.
        (gfc_trans_deallocate): Ditto and handle -fcoarray=lib.
        * expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS.
        * libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value
        to avoid other stats accidentally matching this one.
        * trans-decl.c (gfor_fndecl_caf_deregister): New global var.
        (gfc_build_builtin_function_decls): Fix prototype decl of caf_register
        and add decl for caf_deregister.
        (gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to
        gfc_deallocate_with_status.

2012-01-06  Tobias Burnus <burnus@net-b.de>

        * caf/single.c (_gfortran_caf_register,
        * _gfortran_caf_deregister):
        Fix token handling.
        * caf/mpi.c  (_gfortran_caf_register, _gfortran_caf_deregister):
        * Ditto.
        * caf/libcaf.h (STAT_STOPPED_IMAGE): Sync with libgfortran.h.
        (_gfortran_caf_register, _gfortran_caf_deregister): Update prototype.

2012-01-06  Tobias Burnus <burnus@net-b.de>

        * gfortran.dg/deallocate_stat_2.f90: New.
        * coarray/allocate_errgmsg.f90: New.
        * gfortran.dg/coarray_lib_alloc_1.f90: New.
        * gfortran.dg/coarray_lib_alloc_2.f90: New.
        * coarray/subobject_1.f90: Fix for num_images > 1.
        * gfortran.dg/deallocate_stat.f90: Update due to changed
        stat= handling.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182951 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 91 insertions, 77 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 92f7f43729b..9456e2d3b05 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1,6 +1,6 @@
 /* Statement translation -- generate GCC trees from gfc_code.
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -755,8 +755,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
    if (gfc_option.coarray == GFC_FCOARRAY_LIB)
      {
        tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
-	tmp = build_call_expr_loc (input_location, tmp, 0);
-	gfc_add_expr_to_block (&se.pre, tmp);
+       tmp = build_call_expr_loc (input_location, tmp, 0);
+       gfc_add_expr_to_block (&se.pre, tmp);
      }
 
   if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
@@ -4738,10 +4738,10 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr2)
 	{
 	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
 	  gfc_conv_expr_lhs (&se, code->expr2);
-
-	  errlen = gfc_get_expr_charlen (code->expr2);
-	  errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+	  errmsg = se.expr;
+	  errlen = se.string_length;
 	}
       else
 	{
@@ -4752,8 +4752,7 @@ gfc_trans_allocate (gfc_code * code)
       /* 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;
+      TREE_USED (label_finish) = 0;
     }
 
   expr3 = NULL_TREE;
@@ -4772,7 +4771,8 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3))
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+			       code->expr3))
 	{
 	  /* A scalar or derived type.  */
 
@@ -4892,7 +4892,7 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Allocate - for non-pointers with re-alloc checking.  */
 	  if (gfc_expr_attr (expr).allocatable)
 	    gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
-				      stat, errmsg, errlen, expr);
+				      stat, errmsg, errlen, label_finish, expr);
 	  else
 	    gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
 
@@ -4919,18 +4919,12 @@ gfc_trans_allocate (gfc_code * code)
       /* 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);
-
+	  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,
-				 gfc_unlikely(parm), tmp,
+				 gfc_unlikely (parm), tmp,
 				     build_empty_stmt (input_location));
 	  gfc_add_expr_to_block (&block, tmp);
 	}
@@ -5102,26 +5096,24 @@ gfc_trans_allocate (gfc_code * code)
       gfc_free_expr (expr);
     }
 
-  /* STAT  (ERRMSG only makes sense with STAT).  */
+  /* STAT.  */
   if (code->expr1)
     {
       tmp = build1_v (LABEL_EXPR, label_errmsg);
       gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* ERRMSG block.  */
-  if (code->expr2)
+  /* ERRMSG - only useful if STAT is present.  */
+  if (code->expr1 && code->expr2)
     {
-      /* A better error message may be possible, but not required.  */
       const char *msg = "Attempt to allocate an allocated object";
-      tree slen, dlen;
+      tree slen, dlen, errmsg_str;
+      stmtblock_t errmsg_block;
 
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr2);
+      gfc_init_block (&errmsg_block);
 
-      errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
-
-      gfc_add_modify (&block, errmsg,
+      errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+      gfc_add_modify (&errmsg_block, errmsg_str,
 		gfc_build_addr_expr (pchar_type_node,
 			gfc_build_localized_cstring_const (msg)));
 
@@ -5130,9 +5122,9 @@ gfc_trans_allocate (gfc_code * code)
       slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
 			      slen);
 
-      dlen = build_call_expr_loc (input_location,
-				  builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
-		gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+			     slen, errmsg_str, gfc_default_character_kind);
+      dlen = gfc_finish_block (&errmsg_block);
 
       tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
 			     build_int_cst (TREE_TYPE (stat), 0));
@@ -5142,16 +5134,15 @@ 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)
     {
+      if (TREE_USED (label_finish))
+	{
+	  tmp = build1_v (LABEL_EXPR, label_finish);
+	  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);
@@ -5172,29 +5163,39 @@ gfc_trans_deallocate (gfc_code *code)
 {
   gfc_se se;
   gfc_alloc *al;
-  tree apstat, astat, pstat, stat, tmp;
+  tree apstat, pstat, stat, errmsg, errlen, tmp;
+  tree label_finish, label_errmsg;
   stmtblock_t block;
 
-  pstat = apstat = stat = astat = tmp = NULL_TREE;
+  pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
+  label_finish = label_errmsg = NULL_TREE;
 
   gfc_start_block (&block);
 
   /* Count the number of failed deallocations.  If deallocate() was
      called with STAT= , then set STAT to the count.  If deallocate
      was called with ERRMSG, then set ERRMG to a string.  */
-  if (code->expr1 || code->expr2)
+  if (code->expr1)
     {
       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);
 
-      /* Running total of possible deallocation failures.  */
-      astat = gfc_create_var (gfc_int4_type_node, "astat");
-      apstat = gfc_build_addr_expr (NULL_TREE, astat);
+      /* GOTO destinations.  */
+      label_errmsg = gfc_build_label_decl (NULL_TREE);
+      label_finish = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (label_finish) = 0;
+    }
 
-      /* Initialize astat to 0.  */
-      gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
+  /* Set ERRMSG - only needed if STAT is available.  */
+  if (code->expr1 && code->expr2)
+    {
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      gfc_conv_expr_lhs (&se, code->expr2);
+      errmsg = se.expr;
+      errlen = se.string_length;
     }
 
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
@@ -5212,7 +5213,7 @@ gfc_trans_deallocate (gfc_code *code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (expr->rank || gfc_expr_attr (expr).codimension)
+      if (expr->rank || gfc_is_coarray (expr))
 	{
 	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
 	    {
@@ -5232,7 +5233,8 @@ gfc_trans_deallocate (gfc_code *code)
 		  gfc_add_expr_to_block (&se.pre, tmp);
 		}
 	    }
-	  tmp = gfc_array_deallocate (se.expr, pstat, expr);
+	  tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
+				      label_finish, expr);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 	}
       else
@@ -5261,13 +5263,17 @@ gfc_trans_deallocate (gfc_code *code)
 	    }
 	}
 
-      /* Keep track of the number of failed deallocations by adding stat
-	 of the last deallocation to the running total.  */
-      if (code->expr1 || code->expr2)
+      if (code->expr1)
 	{
-	  apstat = fold_build2_loc (input_location, PLUS_EXPR,
-				    TREE_TYPE (stat), astat, stat);
-	  gfc_add_modify (&se.pre, astat, apstat);
+          tree cond;
+
+	  cond = 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,
+				 gfc_unlikely (cond),
+				 build1_v (GOTO_EXPR, label_errmsg),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&se.pre, tmp);
 	}
 
       tmp = gfc_finish_block (&se.pre);
@@ -5275,48 +5281,56 @@ gfc_trans_deallocate (gfc_code *code)
       gfc_free_expr (expr);
     }
 
-  /* Set STAT.  */
   if (code->expr1)
     {
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr1);
-      tmp = convert (TREE_TYPE (se.expr), astat);
-      gfc_add_modify (&block, se.expr, tmp);
+      tmp = build1_v (LABEL_EXPR, label_errmsg);
+      gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* Set ERRMSG.  */
-  if (code->expr2)
+  /* Set ERRMSG - only needed if STAT is available.  */
+  if (code->expr1 && code->expr2)
     {
-      /* A better error message may be possible, but not required.  */
       const char *msg = "Attempt to deallocate an unallocated object";
-      tree errmsg, slen, dlen;
+      stmtblock_t errmsg_block;
+      tree errmsg_str, slen, dlen, cond;
 
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr2);
+      gfc_init_block (&errmsg_block);
 
-      errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
-
-      gfc_add_modify (&block, errmsg,
+      errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+      gfc_add_modify (&errmsg_block, errmsg_str,
 		gfc_build_addr_expr (pchar_type_node,
                         gfc_build_localized_cstring_const (msg)));
-
       slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
       dlen = gfc_get_expr_charlen (code->expr2);
-      slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
-			      slen);
 
-      dlen = build_call_expr_loc (input_location,
-				  builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
-		gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+			     slen, errmsg_str, gfc_default_character_kind);
+      tmp = gfc_finish_block (&errmsg_block);
 
-      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
-			     build_int_cst (TREE_TYPE (astat), 0));
+      cond = 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,
+			     gfc_unlikely (cond), tmp,
+			     build_empty_stmt (input_location));
 
-      tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
 
+  if (code->expr1 && TREE_USED (label_finish))
+    {
+      tmp = build1_v (LABEL_EXPR, label_finish);
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  /* Set STAT.  */
+  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);
+    }
+
   return gfc_finish_block (&block);
 }