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.

From-SVN: r182951

gcc/fortran/ChangeLog

+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-05  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/PR48946

gcc/fortran/expr.c

 /* Routines for manipulation of expression nodes.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010, 2011
+   2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -4264,13 +4264,17 @@ gfc_is_coarray (gfc_expr *e)
     {
       case REF_COMPONENT:
 	comp = ref->u.c.component;
-        if (comp->attr.pointer || comp->attr.allocatable)
+	if (comp->ts.type == BT_CLASS && comp->attr.class_ok
+	    && (CLASS_DATA (comp)->attr.class_pointer
+		|| CLASS_DATA (comp)->attr.allocatable))
 	  {
 	    coindexed = false;
-	    if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
-	      coarray = CLASS_DATA (comp)->attr.codimension;
-	    else
-	      coarray = comp->attr.codimension;
+	    coarray = CLASS_DATA (comp)->attr.codimension;
+	  }
+        else if (comp->attr.pointer || comp->attr.allocatable)
+	  {
+	    coindexed = false;
+	    coarray = comp->attr.codimension;
 	  }
         break;
 

gcc/fortran/libgfortran.h

 /* Header file to the Fortran front-end and runtime library
-   Copyright (C) 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
 
 This file is part of GCC.
@@ -105,7 +105,7 @@ typedef enum
   GFC_STAT_UNLOCKED = 0,
   GFC_STAT_LOCKED,
   GFC_STAT_LOCKED_OTHER_IMAGE,
-  GFC_STAT_STOPPED_IMAGE /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
+  GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
 }
 libgfortran_stat_codes;
 

gcc/fortran/trans-array.c

@@ -4938,7 +4938,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
-		    tree errlen, gfc_expr *expr3)
+		    tree errlen, tree label_finish, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -5064,7 +5064,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   /* The allocatable variant takes the old pointer as first argument.  */
   if (allocatable)
     gfc_allocate_allocatable (&elseblock, pointer, size, token,
-			      status, errmsg, errlen, expr);
+			      status, errmsg, errlen, label_finish, expr);
   else
     gfc_allocate_using_malloc (&elseblock, pointer, size, status);
 
@@ -5127,24 +5127,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 /*GCC ARRAYS*/
 
 tree
-gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
+gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
+		      tree label_finish, gfc_expr* expr)
 {
   tree var;
   tree tmp;
   stmtblock_t block;
+  bool coarray = gfc_is_coarray (expr);
 
   gfc_start_block (&block);
+
   /* Get a pointer to the data.  */
   var = gfc_conv_descriptor_data_get (descriptor);
   STRIP_NOPS (var);
 
   /* Parameter is the address of the data component.  */
-  tmp = gfc_deallocate_with_status (var, pstat, false, expr);
+  tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
+				    errlen, label_finish, false, expr, coarray);
   gfc_add_expr_to_block (&block, tmp);
 
-  /* Zero the data pointer.  */
+  /* Zero the data pointer; only for coarrays an error can occur and then
+     the allocation status may not be changed.  */
   tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
 			 var, build_int_cst (TREE_TYPE (var), 0));
+  if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree cond;
+      tree stat = build_fold_indirect_ref_loc (input_location, pstat);
+
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      stat, build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     cond, tmp, build_empty_stmt (input_location));
+    }
+
   gfc_add_expr_to_block (&block, tmp);
 
   return gfc_finish_block (&block);
@@ -7055,7 +7071,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 /* Generate code to deallocate an array, if it is allocated.  */
 
 tree
-gfc_trans_dealloc_allocated (tree descriptor)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
 { 
   tree tmp;
   tree var;
@@ -7069,7 +7085,9 @@ gfc_trans_dealloc_allocated (tree descriptor)
   /* Call array_deallocate with an int * present in the second argument.
      Although it is ignored here, it's presence ensures that arrays that
      are already deallocated are ignored.  */
-  tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
+  tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
+				    NULL_TREE, NULL_TREE, NULL_TREE, true,
+				    NULL, coarray);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
@@ -7358,7 +7376,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    {
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      tmp = gfc_trans_dealloc_allocated (comp);
+	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  else if (c->attr.allocatable)
@@ -7388,7 +7406,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
 
 	      if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
-	        tmp = gfc_trans_dealloc_allocated (comp);
+	        tmp = gfc_trans_dealloc_allocated (comp,
+					CLASS_DATA (c)->attr.codimension);
 	      else
 		{
 		  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
@@ -8094,7 +8113,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
       && !sym->attr.save && !sym->attr.result)
     {
-      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
+      tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
+					 sym->attr.codimension);
       gfc_add_expr_to_block (&cleanup, tmp);
     }
 

gcc/fortran/trans-array.h

 /* Header for array handling functions
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -20,11 +20,12 @@ along with GCC; see the file COPYING3.  If not see
 <http://www.gnu.org/licenses/>.  */
 
 /* Generate code to free an array.  */
-tree gfc_array_deallocate (tree, tree, gfc_expr*);
+tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
 
 /* Generate code to initialize and 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, tree, tree, gfc_expr *);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
+			 gfc_expr *);
 
 /* 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 *,
@@ -42,7 +43,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
 /* Generate entry and exit code for g77 calling convention arrays.  */
 void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate code to deallocate an array, if it is allocated.  */
-tree gfc_trans_dealloc_allocated (tree);
+tree gfc_trans_dealloc_allocated (tree, bool);
 
 tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
 

gcc/fortran/trans-decl.c

 /* Backend function setup
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -121,6 +121,7 @@ tree gfor_fndecl_associated;
 tree gfor_fndecl_caf_init;
 tree gfor_fndecl_caf_finalize;
 tree gfor_fndecl_caf_register;
+tree gfor_fndecl_caf_deregister;
 tree gfor_fndecl_caf_critical;
 tree gfor_fndecl_caf_end_critical;
 tree gfor_fndecl_caf_sync_all;
@@ -3163,7 +3164,11 @@ gfc_build_builtin_function_decls (void)
       gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
         size_type_node, integer_type_node, ppvoid_type_node, pint_type,
-        build_pointer_type (pchar_type_node), integer_type_node);
+        pchar_type_node, integer_type_node);
+
+      gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
+        ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
 
       gfor_fndecl_caf_critical = gfc_build_library_function_decl (
 	get_identifier (PREFIX("caf_critical")), void_type_node, 0);
@@ -3688,6 +3693,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	{
 	  if (!sym->attr.save)
 	    {
+	      tree descriptor = NULL_TREE;
+
 	      /* Nullify and automatic deallocation of allocatable
 		 scalars.  */
 	      e = gfc_lval_expr_from_sym (sym);
@@ -3712,6 +3719,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      else
 		{
 		  gfc_conv_expr (&se, e);
+		  descriptor = se.expr;
 		  se.expr = gfc_conv_descriptor_data_addr (se.expr);
 		  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 		}
@@ -3761,9 +3769,18 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
 	      if (!sym->attr.result && !sym->attr.dummy)
-		tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
-							 NULL, sym->ts);
-
+		{
+		  if (sym->ts.type == BT_CLASS
+		      && CLASS_DATA (sym)->attr.codimension)
+		    tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
+						      NULL_TREE, NULL_TREE,
+						      NULL_TREE, true, NULL,
+						      true);
+		  else
+		    tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
+							     true, NULL,
+							     sym->ts);
+		}
 	      if (sym->ts.type == BT_CLASS)
 		{
 		  /* Initialize _vptr to declared type.  */

gcc/fortran/trans-expr.c

@@ -3525,7 +3525,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 		      gfc_init_block  (&block);
 		      tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
-							true, NULL);
+							NULL_TREE, NULL_TREE,
+							NULL_TREE, true, NULL,
+							false);
 		      gfc_add_expr_to_block (&block, tmp);
 		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 					     void_type_node, parmse.expr,
@@ -3665,7 +3667,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  tmp = build_fold_indirect_ref_loc (input_location,
 						     parmse.expr);
-		  tmp = gfc_trans_dealloc_allocated (tmp);
+		  tmp = gfc_trans_dealloc_allocated (tmp, false);
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
 		      && e->symtree->n.sym->attr.optional)
@@ -4335,7 +4337,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	  /* Finally free the temporary's data field.  */
 	  tmp = gfc_conv_descriptor_data_get (tmp2);
-	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+					    NULL_TREE, NULL_TREE, true,
+					    NULL, false);
 	  gfc_add_expr_to_block (&se->pre, tmp);
 	}
     }

gcc/fortran/trans-intrinsic.c

 /* Intrinsic translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -7355,7 +7356,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
   gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
 
   tmp = gfc_conv_descriptor_data_get (to_se.expr);
-  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr);
+  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
+				    NULL_TREE, true, to_expr, false);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Move the pointer and update the array descriptor data.  */

gcc/fortran/trans-openmp.c

 /* OpenMP directive translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Jakub Jelinek <jakub@redhat.com>
 
@@ -326,7 +326,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
 
   /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
      to be deallocated if they were allocated.  */
-  return gfc_trans_dealloc_allocated (decl);
+  return gfc_trans_dealloc_allocated (decl, false);
 }
 
 
@@ -708,7 +708,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       gfc_start_block (&block);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
 			     true));
-      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
+      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false));
       stmt = gfc_finish_block (&block);
     }
   else

gcc/fortran/trans.c

 /* Code translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -653,7 +653,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
 				boolean_type_node, pointer,
 				build_int_cst (prvoid_type_node, 0));
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-			 gfc_unlikely(error_cond), on_error,
+			 gfc_unlikely (error_cond), on_error,
 			 build_empty_stmt (input_location));
 
   gfc_add_expr_to_block (block, tmp);
@@ -738,7 +738,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
     and variable name in case a runtime error has to be printed.  */
 void
 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
-			  tree status, tree errmsg, tree errlen, gfc_expr* expr)
+			  tree status, tree errmsg, tree errlen, tree label_finish,
+			  gfc_expr* expr)
 {
   stmtblock_t alloc_block;
   tree tmp, null_mem, alloc, error;
@@ -757,8 +758,23 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
 
   if (gfc_option.coarray == GFC_FCOARRAY_LIB
       && gfc_expr_attr (expr).codimension)
-    gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
-			    errmsg, errlen);
+    {
+      tree cond;
+
+      gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
+			      errmsg, errlen);
+      if (status != NULL_TREE)
+	{
+	  TREE_USED (label_finish) = 1;
+	  tmp = build1_v (GOTO_EXPR, label_finish);
+	  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  status, build_zero_cst (TREE_TYPE (status)));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (cond), tmp,
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&alloc_block, tmp);
+	}
+    }
   else
     gfc_allocate_using_malloc (&alloc_block, mem, size, status);
 
@@ -852,13 +868,27 @@ gfc_call_free (tree var)
    each procedure).
    
    If a runtime-message is possible, `expr' must point to the original
-   expression being deallocated for its locus and variable name.  */
+   expression being deallocated for its locus and variable name.
+
+   For coarrays, "pointer" must be the array descriptor and not its
+   "data" component.  */
 tree
-gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
-			    gfc_expr* expr)
+gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
+			    tree errlen, tree label_finish,
+			    bool can_fail, gfc_expr* expr, bool coarray)
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
+  tree status_type = NULL_TREE;
+  tree caf_decl = NULL_TREE;
+
+  if (coarray)
+    {
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
+      caf_decl = pointer;
+      pointer = gfc_conv_descriptor_data_get (caf_decl);
+      STRIP_NOPS (pointer);
+    }
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 			  build_int_cst (TREE_TYPE (pointer), 0));
@@ -884,9 +914,9 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
-      tree status_type = TREE_TYPE (TREE_TYPE (status));
       tree cond2;
 
+      status_type = TREE_TYPE (TREE_TYPE (status));
       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 			       status, build_int_cst (TREE_TYPE (status), 0));
       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
@@ -901,26 +931,90 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
-  tmp = build_call_expr_loc (input_location,
-			     builtin_decl_explicit (BUILT_IN_FREE), 1,
-			     fold_convert (pvoid_type_node, pointer));
-  gfc_add_expr_to_block (&non_null, tmp);
+  if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_FREE), 1,
+				 fold_convert (pvoid_type_node, pointer));
+      gfc_add_expr_to_block (&non_null, tmp);
 
-  if (status != NULL_TREE && !integer_zerop (status))
+      if (status != NULL_TREE && !integer_zerop (status))
+	{
+	  /* We set STATUS to zero if it is present.  */
+	  tree status_type = TREE_TYPE (TREE_TYPE (status));
+	  tree cond2;
+
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   status,
+				   build_int_cst (TREE_TYPE (status), 0));
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+				 fold_build1_loc (input_location, INDIRECT_REF,
+						  status_type, status),
+				 build_int_cst (status_type, 0));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (cond2), tmp,
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&non_null, tmp);
+	}
+    }
+  else
     {
-      /* We set STATUS to zero if it is present.  */
-      tree status_type = TREE_TYPE (TREE_TYPE (status));
-      tree cond2;
+      tree caf_type, token, cond2;
+      tree pstat = null_pointer_node;
 
-      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
-			       status, build_int_cst (TREE_TYPE (status), 0));
-      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
-			     fold_build1_loc (input_location, INDIRECT_REF,
-					      status_type, status),
-			     build_int_cst (status_type, 0));
-      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
-			     tmp, build_empty_stmt (input_location));
+      if (errmsg == NULL_TREE)
+	{
+	  gcc_assert (errlen == NULL_TREE);
+	  errmsg = null_pointer_node;
+	  errlen = build_zero_cst (integer_type_node);
+	}
+      else
+	{
+	  gcc_assert (errlen != NULL_TREE);
+	  if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
+	    errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
+	}
+
+      caf_type = TREE_TYPE (caf_decl);
+
+      if (status != NULL_TREE && !integer_zerop (status))
+	{
+	  gcc_assert (status_type == integer_type_node);
+	  pstat = status;
+	}
+
+      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+	  && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+	token = gfc_conv_descriptor_token (caf_decl);
+      else if (DECL_LANG_SPECIFIC (caf_decl)
+	       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+	token = GFC_DECL_TOKEN (caf_decl);
+      else
+	{
+	  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+		      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+	  token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+	}
+
+      token = gfc_build_addr_expr  (NULL_TREE, token);
+      tmp = build_call_expr_loc (input_location,
+	     gfor_fndecl_caf_deregister, 4,
+	     token, pstat, errmsg, errlen);
       gfc_add_expr_to_block (&non_null, tmp);
+
+      if (status != NULL_TREE)
+	{
+	  tree stat = build_fold_indirect_ref_loc (input_location, status);
+
+	  TREE_USED (label_finish) = 1;
+	  tmp = build1_v (GOTO_EXPR, label_finish);
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   stat, build_zero_cst (TREE_TYPE (stat)));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+        			 gfc_unlikely (cond2), tmp,
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&non_null, tmp);
+	}
     }
 
   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,

gcc/fortran/trans.h

 /* Header for code translation functions
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -587,14 +588,15 @@ 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.  */
-void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree,
+void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree,
 			       tree, tree, tree, gfc_expr*);
 
 /* Allocate memory, with optional status variable.  */
 void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
-tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
+tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
+				 gfc_expr *, bool);
 tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec);
 
 /* Generate code to call realloc().  */
@@ -676,6 +678,7 @@ extern GTY(()) tree gfor_fndecl_associated;
 extern GTY(()) tree gfor_fndecl_caf_init;
 extern GTY(()) tree gfor_fndecl_caf_finalize;
 extern GTY(()) tree gfor_fndecl_caf_register;
+extern GTY(()) tree gfor_fndecl_caf_deregister;
 extern GTY(()) tree gfor_fndecl_caf_critical;
 extern GTY(()) tree gfor_fndecl_caf_end_critical;
 extern GTY(()) tree gfor_fndecl_caf_sync_all;

gcc/testsuite/ChangeLog

+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.
+
 2012-01-06  Andrew Stubbs  <ams@codesourcery.com>
 
 	* gcc.target/arm/headmerge-2.c: Adjust scan pattern.

gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90

+! { dg-do run }
+!
+! Check handling of errmsg.
+!
+implicit none
+integer, allocatable :: a[:], b(:)[:], c, d(:)
+integer :: stat
+character(len=300) :: str
+
+allocate(a[*], b(1)[*], c, d(2), stat=stat)
+
+str = repeat('X', len(str))
+allocate(a[*], stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+str = repeat('Y', len(str))
+allocate(b(2)[*], stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+str = repeat('Q', len(str))
+allocate(c, stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+str = repeat('P', len(str))
+allocate(d(3), stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+end

gcc/testsuite/gfortran.dg/coarray/subobject_1.f90

@@ -24,20 +24,20 @@
   b%a%i = 7
   if (b%a%i /= 7) call abort
   if (any (lcobound(b%a) /= (/ lb /))) call abort
-  if (ucobound(b%a, dim=1) /= this_image() + lb - 1) call abort
+  if (ucobound(b%a, dim=1) /= num_images() + lb - 1) call abort
   if (any (lcobound(b%a%i) /= (/ lb /))) call abort
-  if (ucobound(b%a%i, dim=1) /= this_image() + lb - 1) call abort
+  if (ucobound(b%a%i, dim=1) /= num_images() + lb - 1) call abort
   allocate(c%a(la)[lc:*])
   c%a%i = init
   if (any(c%a%i /= init)) call abort
   if (any (lcobound(c%a) /= (/ lc /))) call abort
-  if (ucobound(c%a, dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a, dim=1) /= num_images() + lc - 1) call abort
   if (any (lcobound(c%a%i) /= (/ lc /))) call abort
-  if (ucobound(c%a%i, dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a%i, dim=1) /= num_images() + lc - 1) call abort
   if (c%a(2)%i /= init(2)) call abort
   if (any (lcobound(c%a(2)) /= (/ lc /))) call abort
-  if (ucobound(c%a(2), dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a(2), dim=1) /= num_images() + lc - 1) call abort
   if (any (lcobound(c%a(2)%i) /= (/ lc /))) call abort
-  if (ucobound(c%a(2)%i, dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a(2)%i, dim=1) /= num_images() + lc - 1) call abort
   deallocate(b%a, c%a)
 end

gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Allocate/deallocate with libcaf.
+!
+
+ integer(4), allocatable :: xx[:], yy(:)[:]
+ integer :: stat
+ character(len=200) :: errmsg
+ allocate(xx[*], stat=stat, errmsg=errmsg)
+ allocate(yy(2)[*], stat=stat, errmsg=errmsg)
+ deallocate(xx,yy,stat=stat, errmsg=errmsg)
+ end
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .4, 1, &xx.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .8, 1, &yy.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Allocate/deallocate with libcaf.
+!
+
+ type t
+ end type t
+ class(t), allocatable :: xx[:], yy(:)[:]
+ integer :: stat
+ character(len=200) :: errmsg
+ allocate(xx[*], stat=stat, errmsg=errmsg)
+ allocate(yy(2)[*], stat=stat, errmsg=errmsg)
+ deallocate(xx,yy,stat=stat, errmsg=errmsg)
+ end
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/deallocate_stat.f90

@@ -69,9 +69,9 @@ program deallocate_stat
    i = 13
    deallocate(a1, stat=i) ;         if (i /= 0) call abort
    deallocate(a2, a1, stat=i) ;     if (i /= 1) call abort
-   deallocate(a1, a3, a2, stat=i) ; if (i /= 2) call abort
+   deallocate(a1, a3, a2, stat=i) ; if (i /= 1) call abort
    deallocate(b4, stat=i) ;         if (i /= 0) call abort
    deallocate(b4, b5, stat=i) ;     if (i /= 1) call abort
-   deallocate(b4, b5, b6, stat=i) ; if (i /= 2) call abort
+   deallocate(b4, b5, b6, stat=i) ; if (i /= 1) call abort
 
 end program deallocate_stat

gcc/testsuite/gfortran.dg/deallocate_stat_2.f90

+! { dg-do run }
+!
+! Check that the error is properly diagnosed and the strings are correctly padded.
+!
+integer, allocatable :: A, B(:)
+integer :: stat
+character(len=5) :: sstr
+character(len=200) :: str
+
+str = repeat('X', len(str))
+deallocate(a, stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") call abort()
+
+str = repeat('Y', len(str))
+deallocate(b, stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") call abort()
+
+sstr = repeat('Q', len(sstr))
+deallocate(a, stat=stat, errmsg=sstr)
+!print *, stat, trim(sstr)
+if (stat == 0 .or. sstr /= "Attem") call abort()
+
+sstr = repeat('P', len(sstr))
+deallocate(b, stat=stat, errmsg=sstr)
+!print *, stat, trim(sstr)
+if (stat == 0 .or. sstr /= "Attem") call abort()
+
+end

libgfortran/ChangeLog

+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.
+
 2011-12-22  Janne Blomqvist  <jb@gcc.gnu.org>
 	Tobias Burnus  <burnus@net-b.de>
 

libgfortran/caf/libcaf.h

 /* Common declarations for all of GNU Fortran libcaf implementations.
-   Copyright (C) 2011
+   Copyright (C) 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Tobias Burnus <burnus@net-b.de>
 
@@ -44,7 +44,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #define STAT_UNLOCKED		0
 #define STAT_LOCKED		1
 #define STAT_LOCKED_OTHER_IMAGE	2
-#define STAT_STOPPED_IMAGE 	3
+#define STAT_STOPPED_IMAGE 	6000
 
 /* Describes what type of array we are registerring. Keep in sync with
    gcc/fortran/trans.h.  */
@@ -67,9 +67,9 @@ caf_static_t;
 void _gfortran_caf_init (int *, char ***, int *, int *);
 void _gfortran_caf_finalize (void);
 
-void * _gfortran_caf_register (ptrdiff_t, caf_register_t, void **, int *,
+void * _gfortran_caf_register (ptrdiff_t, caf_register_t, void ***, int *,
 			       char *, int);
-void _gfortran_caf_deregister (void **, int *, char *, int);
+void _gfortran_caf_deregister (void ***, int *, char *, int);
 
 
 void _gfortran_caf_sync_all (int *, char *, int);

libgfortran/caf/mpi.c

 /* MPI implementation of GNU Fortran Coarray Library
-   Copyright (C) 2011
+   Copyright (C) 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Tobias Burnus <burnus@net-b.de>
 
@@ -119,7 +119,7 @@ _gfortran_caf_finalize (void)
 
 
 void *
-_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
+_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token,
 			int *stat, char *errmsg, int errmsg_len)
 {
   void *local;
@@ -134,18 +134,19 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
 
   /* Token contains only a list of pointers.  */
   local = malloc (size);
-  token = malloc (sizeof (void*) * caf_num_images);
+  *token = malloc (sizeof (void*) * caf_num_images);
 
-  if (unlikely (local == NULL || token == NULL))
+  if (unlikely (local == NULL || *token == NULL))
     goto error;
 
   /* token[img-1] is the address of the token in image "img".  */
-  err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token,
+  err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, *token,
 		       sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
+
   if (unlikely (err))
     {
       free (local);
-      free (token);
+      free (*token);
       goto error;
     }
 
@@ -153,7 +154,7 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
     {
       caf_static_t *tmp = malloc (sizeof (caf_static_t));
       tmp->prev  = caf_static_list;
-      tmp->token = token;
+      tmp->token = *token;
       caf_static_list = tmp;
     }
 
@@ -192,7 +193,7 @@ error:
 
 
 void
-_gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len)
+_gfortran_caf_deregister (void ***token, int *stat, char *errmsg, int errmsg_len)
 {
   if (unlikely (caf_is_finalized))
     {
@@ -220,8 +221,8 @@ _gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len)
   if (stat)
     *stat = 0;
 
-  free (token[caf_this_image-1]);
-  free (token);
+  free ((*token)[caf_this_image-1]);
+  free (*token);
 }
 
 

libgfortran/caf/single.c

 /* Single-image implementation of GNU Fortran Coarray Library
-   Copyright (C) 2011
+   Copyright (C) 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Tobias Burnus <burnus@net-b.de>
 
@@ -81,14 +81,14 @@ _gfortran_caf_finalize (void)
 
 
 void *
-_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
+_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token,
 			int *stat, char *errmsg, int errmsg_len)
 {
   void *local;
 
   local = malloc (size);
-  token = malloc (sizeof (void*) * 1);
-  token[0] = local;
+  *token = malloc (sizeof (void*) * 1);
+  (*token)[0] = local;
 
   if (unlikely (local == NULL || token == NULL))
     {
@@ -117,7 +117,7 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
     {
       caf_static_t *tmp = malloc (sizeof (caf_static_t));
       tmp->prev  = caf_static_list;
-      tmp->token = token;
+      tmp->token = *token;
       caf_static_list = tmp;
     }
   return local;
@@ -125,12 +125,12 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
 
 
 void
-_gfortran_caf_deregister (void **token, int *stat,
+_gfortran_caf_deregister (void ***token, int *stat,
 			  char *errmsg __attribute__ ((unused)),
 			  int errmsg_len __attribute__ ((unused)))
 {
+  free ((*token)[0]);
   free (*token);
-  free (token);
 
   if (stat)
     *stat = 0;