Patchwork [Fortran] Deregister allocatable COARRAYS, fixes to (de)allocate

login
register
mail settings
Submitter Tobias Burnus
Date Dec. 30, 2011, 2:07 p.m.
Message ID <4EFDC5AD.6060405@net-b.de>
Download mbox | patch
Permalink /patch/133645/
State New
Headers show

Comments

Tobias Burnus - Dec. 30, 2011, 2:07 p.m.
Dear all,

first, I want to wish all of you a happy New Year.

Attached you find a patch which calls _gfortran_caf_deregister for 
allocatable coarrays - for -fcoarray=lib. In the caf libraray version, 
coarrays are allocated/deallocated in the library. The 
allocation/deallocation was working before for coarrays in static memory 
("SAVE") and the ALLOCATE ("register") of allocatable coarrays. This 
patch adds the deallocation support ("deregister") both for explicit 
(DEALLOCATE) as well as for the implicit deallocation (when leaving the 
scope).

While implementing this, I fixed and changes some other items:
* The "token" which identifies the coarray in the library was not 
properly implemented in the library.
* ERRMSG= of ALLOCATE/DEALLOCATE did not pad the string
* ALLOCATE of coarrays with -fcoarray=lib: The status and errmsg of 
_gfortran_caf_register were overridden.

Instead of counting the deallocate failures, we now directly abort, 
which makes life a bit easier which coarrays. (Without coarrays, the 
only failure can be that the variable is already deallocated as "free()" 
does not give an error and we currently do not check whether pointer 
targets may be deallocated. With coarrays, additional issues can occur.)

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias

PS: Regarding the stat= value, I got confused and ask at 
http://j3-fortran.org/pipermail/j3/2011-December/004948.html
Tobias Burnus - Jan. 5, 2012, 8:56 p.m.
*ping*

On 30 December 2011, Tobias Burnus wrote:
> Dear all,
>
> first, I want to wish all of you a happy New Year.
>
> Attached you find a patch which calls _gfortran_caf_deregister for 
> allocatable coarrays - for -fcoarray=lib. In the caf libraray version, 
> coarrays are allocated/deallocated in the library. The 
> allocation/deallocation was working before for coarrays in static 
> memory ("SAVE") and the ALLOCATE ("register") of allocatable coarrays. 
> This patch adds the deallocation support ("deregister") both for 
> explicit (DEALLOCATE) as well as for the implicit deallocation (when 
> leaving the scope).
>
> While implementing this, I fixed and changes some other items:
> * The "token" which identifies the coarray in the library was not 
> properly implemented in the library.
> * ERRMSG= of ALLOCATE/DEALLOCATE did not pad the string
> * ALLOCATE of coarrays with -fcoarray=lib: The status and errmsg of 
> _gfortran_caf_register were overridden.
>
> Instead of counting the deallocate failures, we now directly abort, 
> which makes life a bit easier which coarrays. (Without coarrays, the 
> only failure can be that the variable is already deallocated as 
> "free()" does not give an error and we currently do not check whether 
> pointer targets may be deallocated. With coarrays, additional issues 
> can occur.)
>
> Build and regtested on x86-64-linux.
> OK for the trunk?
>
> Tobias
>
> PS: Regarding the stat= value, I got confused and ask at 
> http://j3-fortran.org/pipermail/j3/2011-December/004948.html
Paul Richard Thomas - Jan. 6, 2012, 11:42 a.m.
Dear Tobias,

Please excuse the delay on coming back to you with this.  Since the
power cut the other evening, I have been exceptionally busy.

> Build and regtested on x86-64-linux.
> OK for the trunk?

I have to confess that I do not like /* A better error message may be
possible, but not required.  */ one little bit.  Either write the
better message or eliminate the comment.  I would vote for the latter
:-)

Other than that, it looks fine: OK for trunk

Thanks

Paul

Patch

2011-12-30  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.

2011-12-30  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-30  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.

Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c	(Revision 182728)
+++ gcc/fortran/trans-openmp.c	(Arbeitskopie)
@@ -326,7 +326,7 @@  gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED,
 
   /* 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
       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
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(Revision 182728)
+++ gcc/fortran/trans.c	(Arbeitskopie)
@@ -653,7 +653,7 @@  gfc_allocate_using_malloc (stmtblock_t * block, tr
 				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
     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, tre
 
   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,14 +868,28 @@  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 @@  tree
 
   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 @@  tree
 
   /* 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,
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(Revision 182728)
+++ gcc/fortran/trans.h	(Arbeitskopie)
@@ -583,14 +583,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().  */
@@ -672,6 +673,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;
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 182728)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -3317,7 +3317,9 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 
 		      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,
@@ -3457,7 +3459,7 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 		{
 		  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)
@@ -4124,7 +4126,9 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 
 	  /* 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);
 	}
     }
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(Revision 182728)
+++ gcc/fortran/trans-array.c	(Arbeitskopie)
@@ -4927,7 +4927,7 @@  gfc_array_init_size (tree descriptor, int rank, in
 
 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;
@@ -5053,7 +5053,7 @@  gfc_array_allocate (gfc_se * se, gfc_expr * expr,
   /* 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);
 
@@ -5104,24 +5104,40 @@  gfc_array_allocate (gfc_se * se, gfc_expr * expr,
 /*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);
@@ -7032,7 +7048,7 @@  gfc_conv_array_parameter (gfc_se * se, gfc_expr *
 /* 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;
@@ -7046,7 +7062,9 @@  tree
   /* 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.  */
@@ -7335,7 +7353,7 @@  structure_alloc_comps (gfc_symbol * der_type, tree
 	    {
 	      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)
@@ -7365,7 +7383,8 @@  structure_alloc_comps (gfc_symbol * der_type, tree
 				      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,
@@ -8071,7 +8090,8 @@  gfc_trans_deferred_array (gfc_symbol * sym, gfc_wr
   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);
     }
 
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h	(Revision 182728)
+++ gcc/fortran/trans-array.h	(Arbeitskopie)
@@ -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 *, tre
 /* 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);
 
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(Revision 182728)
+++ gcc/fortran/trans-stmt.c	(Arbeitskopie)
@@ -754,8 +754,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)
@@ -4737,10 +4737,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
 	{
@@ -4751,8 +4751,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;
@@ -4771,7 +4770,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.  */
 
@@ -4891,7 +4891,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);
 
@@ -4918,18 +4918,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);
 	}
@@ -5101,26 +5095,25 @@  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)));
 
@@ -5129,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));
@@ -5141,16 +5134,15 @@  gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* STAT  (ERRMSG only makes sense with STAT).  */
+  /* STAT block.  */
   if (code->expr1)
     {
-      tmp = build1_v (LABEL_EXPR, label_finish);
-      gfc_add_expr_to_block (&block, tmp);
-    }
+      if (TREE_USED (label_finish))
+	{
+	  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);
@@ -5171,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)
@@ -5211,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)
 	    {
@@ -5231,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
@@ -5260,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);
@@ -5274,48 +5281,57 @@  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);
 }
 
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 182728)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -4264,14 +4264,18 @@  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;
 
      case REF_ARRAY:
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h	(Revision 182728)
+++ gcc/fortran/libgfortran.h	(Arbeitskopie)
@@ -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;
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(Revision 182728)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -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,8 +3164,12 @@  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, gf
 	{
 	  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, gf
 	      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, gf
 	      /* 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.  */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(Revision 182728)
+++ gcc/fortran/trans-intrinsic.c	(Arbeitskopie)
@@ -7351,7 +7351,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.  */
Index: libgfortran/caf/single.c
===================================================================
--- libgfortran/caf/single.c	(Revision 182728)
+++ libgfortran/caf/single.c	(Arbeitskopie)
@@ -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 @@  void *
     {
       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 @@  void *
 
 
 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;
Index: libgfortran/caf/mpi.c
===================================================================
--- libgfortran/caf/mpi.c	(Revision 182728)
+++ libgfortran/caf/mpi.c	(Arbeitskopie)
@@ -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 @@  void *
 
   /* 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 @@  void *
     {
       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 @@  void
   if (stat)
     *stat = 0;
 
-  free (token[caf_this_image-1]);
-  free (token);
+  free ((*token)[caf_this_image-1]);
+  free (*token);
 }
 
 
Index: libgfortran/caf/libcaf.h
===================================================================
--- libgfortran/caf/libcaf.h	(Revision 182728)
+++ libgfortran/caf/libcaf.h	(Arbeitskopie)
@@ -44,7 +44,7 @@  see the files COPYING3 and COPYING.RUNTIME respect
 #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);
Index: gcc/testsuite/gfortran.dg/deallocate_stat_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deallocate_stat_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/deallocate_stat_2.f90	(Arbeitskopie)
@@ -0,0 +1,30 @@ 
+! { 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
Index: gcc/testsuite/gfortran.dg/deallocate_stat.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deallocate_stat.f90	(Revision 182728)
+++ gcc/testsuite/gfortran.dg/deallocate_stat.f90	(Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90	(Arbeitskopie)
@@ -0,0 +1,36 @@ 
+! { 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
Index: gcc/testsuite/gfortran.dg/coarray/subobject_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray/subobject_1.f90	(Revision 182728)
+++ gcc/testsuite/gfortran.dg/coarray/subobject_1.f90	(Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90	(Arbeitskopie)
@@ -0,0 +1,21 @@ 
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90	(Arbeitskopie)
@@ -0,0 +1,23 @@ 
+! { 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" } }