Make STAT and ERRMSG work on ALLOCATE, move error handling to library.

This makes STAT and ERRMSG work on ALLOCATE.  It also separates
the allocation of coarrays into two functions: One without error
checking, which is called by compiler-generated code, and one
with error checking for call from user code.

In the course of looking at this, it was also noticed that
allocatable coarrays were not automatically deallocated;
this is now also fixed.  Also, saved allocatable coarrays
are now saved.

gcc/fortran/ChangeLog:

	* trans-array.c (gfc_allocate_shared_coarray): Remove extra
	arguments, just build the call.
	(allocate_shared_coarray_chk): New function.
	(gfc_array_allocate): Adjust where to set the offset.
	Error handling is done in the library for shared coarrays.
	(gfc_trans_deferred_array): No early return for allocatable
	shared coarrays.
	* trans-array.h (gfc_array_allocate): Adjust prototype.
	(gfc_allocate_shared_coarray): Likewise.
	* trans-decl.c: Rename gfor_fndecl_cas_coarray_allocate to
	gfor_fndecl_cas_coarray_alloc for
	brevity.  Add gfor_fndecl_cas_coarray_alloc_chk.
	(gfc_build_builtin_function_decls): Likewise.
	(gfc_trans_shared_coarray): Adjust calling sequence for
	gfc_allocate_shared_coarray.
	(gfc_trans_deferred_vars): Correct handling of saved
	allocatable shared coarrays.
	* trans-stmt.c (gfc_trans_sync): Adjust whitespace.o
	(coarray_alloc_p): Remove.
	(gfc_trans_allocate): Add shared_coarray variable to adjust
	status and errmsg handling.
	* trans.h: Rename gfor_fndecl_cas_coarray_allocate to
	gfor_fndecl_cas_coarray_alloc for brevity.  Add
	gfor_fndecl_cas_coarray_alloc_chk.

libgfortran/ChangeLog:

	* caf_shared/coarraynative.c (test_for_cas_errors): Correct
	handling of stat.
	* caf_shared/libcoarraynative.h (STAT_ERRMSG_ENTRY_CHECK): Use
	unlikely in condition.
	(STAT_ERRMSG_ENTRY_CHECK_RET): Likewise.
	* caf_shared/wrapper.c (cas_coarray_alloc): Adjust arguments.
	Call cas_coarray_alloc_work.
	(cas_coarray_alloc_chk): New function.
	(cas_coarray_alloc_work): New function.

gcc/testsuite/ChangeLog:

	* gfortran.dg/caf-shared/allocate_1.f90: Adjust number of calls to
	sync_all.
	* gfortran.dg/caf-shared/allocate_status_1.f90: New test.
	* gfortran.dg/caf-shared/automatic_deallocate_1.f90: New test.
	* gfortran.dg/caf-shared/save_allocatable_1.f90: New test.

12 files changed, 260 insertions, 144 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 58aaa5f..998ec95 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5982,12 +5982,29 @@ gfc_cas_get_allocation_type (gfc_symbol * sym)
      return GFC_NCA_NORMAL_COARRAY;
 }
 
+/* Allocate a shared coarray from a constructor, without checking.  */
+
+void
+gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int corank,
+			     int alloc_type)
+{
+  gfc_add_expr_to_block (b,
+    build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc,
+			 4, gfc_build_addr_expr (pvoid_type_node, decl),
+			 size, build_int_cst (integer_type_node, corank),
+			 build_int_cst (integer_type_node, alloc_type)));
+}
+
+/* Allocate a shared coarray from user space, with checking.  */
+
 void
-gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank,
-			     int corank, int alloc_type, tree status,
-			     tree errmsg, tree errlen, bool calc_offset)
+allocate_shared_coarray_chk (stmtblock_t *b, tree decl, tree size, int rank,
+				 int corank, int alloc_type, tree status,
+				 tree errmsg, tree errlen)
 {
   tree st, err, elen;
+  int i;
+  tree offset, stride, lbound, mult;
 
   if (status == NULL_TREE)
     st = null_pointer_node;
@@ -5996,28 +6013,25 @@ gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank,
 
   err = errmsg == NULL_TREE ? null_pointer_node : errmsg;
   elen = errlen == NULL_TREE ? build_int_cst (gfc_charlen_type_node, 0) : errlen;
+
   gfc_add_expr_to_block (b,
-	build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_allocate,
-			     7, gfc_build_addr_expr (pvoid_type_node, decl),
-			     size, build_int_cst (integer_type_node, corank),
-			     build_int_cst (integer_type_node, alloc_type),
-			     st, err, elen));
-  if (calc_offset)
-    {
-      int i;
-      tree offset, stride, lbound, mult;
-      offset = build_int_cst (gfc_array_index_type, 0);
-      for (i = 0; i < rank + corank; i++)
-	{
-	  stride = gfc_conv_array_stride (decl, i);
-	  lbound = gfc_conv_array_lbound (decl, i);
-	  mult = fold_build2_loc (input_location, MULT_EXPR,
-				  gfc_array_index_type, stride, lbound);
-	  offset = fold_build2_loc (input_location, MINUS_EXPR,
-				    gfc_array_index_type, offset, mult);
-	}
-      gfc_conv_descriptor_offset_set (b, decl, offset);
+      build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc_chk,
+			   7, gfc_build_addr_expr (pvoid_type_node, decl),
+			   size, build_int_cst (integer_type_node, corank),
+			   build_int_cst (integer_type_node, alloc_type),
+			   st, err, elen));
+
+  offset = build_int_cst (gfc_array_index_type, 0);
+  for (i = 0; i < rank + corank; i++)
+    {
+      stride = gfc_conv_array_stride (decl, i);
+      lbound = gfc_conv_array_lbound (decl, i);
+      mult = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			      stride, lbound);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+				gfc_array_index_type, offset, mult);
     }
+  gfc_conv_descriptor_offset_set (b, decl, offset);
 }
 
 /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
@@ -6028,7 +6042,7 @@ bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 		    tree errlen, tree label_finish, tree expr3_elem_size,
 		    tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
-		    bool e3_has_nodescriptor)
+		    bool e3_has_nodescriptor, bool *shared_coarray)
 {
   tree tmp;
   tree allocation;
@@ -6162,6 +6176,16 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 			      expr3_elem_size, nelems, expr3, e3_arr_desc,
 			      e3_has_nodescriptor, expr, &element_size);
 
+  /* Update the array descriptor with the offset and the span.  */
+  if (dimension)
+    {
+      gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+      tmp = fold_convert (gfc_array_index_type, element_size);
+      gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
+    }
+
+  set_descriptor = gfc_finish_block (&set_descriptor_block);
+
   if (dimension && !(flag_coarray == GFC_FCOARRAY_SHARED && coarray))
     {
       var_overflow = gfc_create_var (integer_type_node, "overflow");
@@ -6224,12 +6248,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 	elem_size = expr3_elem_size;
       else
 	elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(se->expr)));
+
+      /* Setting the descriptor needs to be done before allocation of the
+	 shared coarray.  */
+      gfc_add_expr_to_block (&elseblock, set_descriptor);
+
       int alloc_type
 	     = gfc_cas_get_allocation_type (expr->symtree->n.sym);
-      gfc_allocate_shared_coarray (&elseblock, se->expr, elem_size,
+      allocate_shared_coarray_chk (&elseblock, se->expr, elem_size,
 				   ref->u.ar.as->rank, ref->u.ar.as->corank,
-				   alloc_type, status, errmsg, errlen,
-				   true);
+				   alloc_type, status, errmsg, errlen);
+      *shared_coarray = true;
     }
   /* The allocatable variant takes the old pointer as first argument.  */
   else if (allocatable)
@@ -6255,40 +6284,27 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   else
     allocation = gfc_finish_block (&elseblock);
 
-
-  /* Update the array descriptor with the offset and the span.  */
-  if (dimension)
-    {
-      gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
-      tmp = fold_convert (gfc_array_index_type, element_size);
-      gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
-    }
-
-  set_descriptor = gfc_finish_block (&set_descriptor_block);
-
-  if (status != NULL_TREE)
+  if (status != NULL_TREE && !(coarray && flag_coarray == GFC_FCOARRAY_SHARED))
     {
       cond = fold_build2_loc (input_location, EQ_EXPR,
-			  logical_type_node, status,
-			  build_int_cst (TREE_TYPE (status), 0));
+			      logical_type_node, status,
+			      build_int_cst (TREE_TYPE (status), 0));
 
       if (not_prev_allocated != NULL_TREE)
 	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				logical_type_node, cond, not_prev_allocated);
+				logical_type_node, cond,
+				not_prev_allocated);
 
-      set_descriptor = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-				  cond,
-				  set_descriptor,
-				  build_empty_stmt (input_location));
+      set_descriptor = fold_build3_loc (input_location, COND_EXPR,
+					void_type_node, cond,
+					set_descriptor,
+					build_empty_stmt (input_location));
     }
 
   /* For native coarrays, the size must be set before the allocation routine
      can be called.  */
   if (coarray && flag_coarray == GFC_FCOARRAY_SHARED)
-    {
-      gfc_add_expr_to_block (&se->pre, set_descriptor);
-      gfc_add_expr_to_block (&se->pre, allocation);
-    }
+    gfc_add_expr_to_block (&se->pre, allocation);
   else
     {
       gfc_add_expr_to_block (&se->pre, allocation);
@@ -10994,7 +11010,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   /* Although static, derived types with default initializers and
      allocatable components must not be nulled wholesale; instead they
      are treated component by component.  */
-  if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
+  if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer
+      && !(flag_coarray == GFC_FCOARRAY_SHARED && sym->attr.codimension))
     {
       /* SAVEd variables are not freed on exit.  */
       gfc_trans_static_array_pointer (sym);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2168e9d..bfd174b 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -21,7 +21,7 @@ along with GCC; see the file COPYING3.  If not see
 /* 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, tree,
-			 tree, tree *, gfc_expr *, tree, bool);
+			 tree, tree *, gfc_expr *, tree, bool, bool *);
 
 enum gfc_coarray_allocation_type {
   GFC_NCA_NORMAL_COARRAY = 1,
@@ -31,8 +31,7 @@ enum gfc_coarray_allocation_type {
 
 int gfc_cas_get_allocation_type (gfc_symbol *);
 
-void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int, int,
-				  tree, tree, tree, bool);
+void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int);
 
 /* 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 *,
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index ab2725c..61d5667 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -174,7 +174,8 @@ tree gfor_fndecl_caf_is_present;
 /* Native coarray functions.  */
 
 tree gfor_fndecl_cas_master;
-tree gfor_fndecl_cas_coarray_allocate;
+tree gfor_fndecl_cas_coarray_alloc;
+tree gfor_fndecl_cas_coarray_alloc_chk;
 tree gfor_fndecl_cas_coarray_free;
 tree gfor_fndecl_cas_this_image;
 tree gfor_fndecl_cas_num_images;
@@ -4120,16 +4121,25 @@ gfc_build_builtin_function_decls (void)
       gfor_fndecl_cas_master = gfc_build_library_function_decl_with_spec (
 	 get_identifier (PREFIX("cas_master")), ". r ", integer_type_node, 1,
 	build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)));
-      gfor_fndecl_cas_coarray_allocate = gfc_build_library_function_decl_with_spec (
-	 get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R W W . ", integer_type_node, 7,
-	 pvoid_type_node,	/* desc.  */
-	 size_type_node,	/* elem_size.  */
-	 integer_type_node,	/* corank.  */
-	 integer_type_node,	/* alloc_type.  */
-	 gfc_pint4_type_node,	/* stat.  */
-	 pchar1_type_node,	/* errmsg.  */
-	 gfc_charlen_type_node, /* errmsg_len.  */
-	 NULL_TREE);
+      gfor_fndecl_cas_coarray_alloc_chk = gfc_build_library_function_decl_with_spec (
+	 get_identifier (PREFIX("cas_coarray_alloc_chk")), ". . R R R W W . ",
+	 integer_type_node, 7,
+	 pvoid_type_node,	  /* desc.  */
+	 size_type_node,	  /* elem_size.  */
+	 integer_type_node,	  /* corank.  */
+	 integer_type_node,	  /* alloc_type.  */
+	 gfc_pint4_type_node,	  /* stat.  */
+	 pchar1_type_node,	  /* errmsg.  */
+	 gfc_charlen_type_node);  /* errmsg_len.  */
+      gfor_fndecl_cas_coarray_alloc
+	= gfc_build_library_function_decl_with_spec (
+	   get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R ",
+	   integer_type_node, 4,
+	   pvoid_type_node,	/* desc.  */
+	   size_type_node,	/* elem_size.  */
+	   integer_type_node,	/* corank.  */
+	   integer_type_node);	/* alloc_type.  */
+
       gfor_fndecl_cas_coarray_free = gfc_build_library_function_decl_with_spec (
 	 get_identifier (PREFIX("cas_coarray_free")), ". . R ", integer_type_node, 2,
 	 pvoid_type_node, /* Pointer to the descriptor to be deallocated.  */
@@ -4699,11 +4709,8 @@ gfc_trans_shared_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_symbol *
 			   NULL_TREE, &nelems, NULL,
 			   NULL_TREE, true, NULL, &element_size);
       elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl)));
-      gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->rank,
-				   sym->as->corank, alloc_type,
-				   NULL_TREE, NULL_TREE,
-				   build_int_cst (gfc_charlen_type_node, 0),
-				   false);
+      gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->corank,
+				   alloc_type);
       gfc_conv_descriptor_offset_set (init, decl, offset);
     }
 
@@ -5055,7 +5062,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      else if (flag_coarray == GFC_FCOARRAY_SHARED
 		       && sym->attr.codimension)
 		{
-		  gfc_trans_shared_coarray_inline (block, sym);
+		  if (sym->attr.save == SAVE_EXPLICIT)
+		    gfc_trans_shared_coarray_static (sym);
+		  else
+		    gfc_trans_shared_coarray_inline (block, sym);
 		}
 	      else
 		{
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1f656d4..09f6327 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1336,7 +1336,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
 	  if (TREE_TYPE (stat) == integer_type_node)
 	    stat = gfc_build_addr_expr (NULL, stat);
 
-	  if(type == EXEC_SYNC_MEMORY)
+	  if (type == EXEC_SYNC_MEMORY)
 	    {
 	      /* For shared coarrays, there is no need for a memory
 		 fence here because that is emitted anyway below.  */
@@ -6227,28 +6227,6 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr)
   return NULL;
 }
 
-/* Helper function - return true if a coarray is allcoated via this
-   statement.  */
-
-static bool
-coarray_alloc_p (gfc_code *code)
-{
-  if (code == NULL || code->op != EXEC_ALLOCATE)
-    return false;
-
-  for (gfc_alloc *al = code->ext.alloc.list; al != NULL; al = al->next)
-    {
-      gfc_ref *ref, *last;
-      for (ref = al->expr->ref, last = ref; ref; last = ref, ref = ref->next)
-	;
-
-      ref = last;
-      if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen)
-	return true;
-    }
-  return false;
-}
-
 /* Translate the ALLOCATE statement.  */
 
 tree
@@ -6284,6 +6262,7 @@ gfc_trans_allocate (gfc_code * code)
   gfc_symtree *newsym = NULL;
   symbol_attribute caf_attr;
   gfc_actual_arglist *param_list;
+  bool shared_coarray = false;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
@@ -6815,7 +6794,7 @@ gfc_trans_allocate (gfc_code * code)
 			       label_finish, tmp, &nelems,
 			       e3rhs ? e3rhs : code->expr3,
 			       e3_is == E3_DESC ? expr3 : NULL_TREE,
-			       e3_has_nodescriptor))
+			       e3_has_nodescriptor, &shared_coarray))
 	{
 	  /* A scalar or derived type.  First compute the size to
 	     allocate.
@@ -6972,7 +6951,7 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_block_to_block (&block, &se.pre);
 
       /* Error checking -- Note: ERRMSG only makes sense with STAT.  */
-      if (code->expr1)
+      if (code->expr1 && !shared_coarray)
 	{
 	  tmp = build1_v (GOTO_EXPR, label_errmsg);
 	  parm = fold_build2_loc (input_location, NE_EXPR,
@@ -7193,14 +7172,14 @@ gfc_trans_allocate (gfc_code * code)
       gfc_free_expr (e3rhs);
     }
   /* STAT.  */
-  if (code->expr1)
+  if (code->expr1 && !shared_coarray)
     {
       tmp = build1_v (LABEL_EXPR, label_errmsg);
       gfc_add_expr_to_block (&block, tmp);
     }
 
   /* ERRMSG - only useful if STAT is present.  */
-  if (code->expr1 && code->expr2)
+  if (code->expr1 && code->expr2 && !shared_coarray)
     {
       const char *msg = "Attempt to allocate an allocated object";
       tree slen, dlen, errmsg_str;
@@ -7257,12 +7236,6 @@ gfc_trans_allocate (gfc_code * code)
 				 zero_size);
       gfc_add_expr_to_block (&post, tmp);
     }
-  else if (flag_coarray == GFC_FCOARRAY_SHARED && coarray_alloc_p (code))
-    {
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_sync_all,
-				 1, null_pointer_node);
-      gfc_add_expr_to_block (&post, tmp);
-    }
 
   gfc_add_block_to_block (&block, &se.post);
   gfc_add_block_to_block (&block, &post);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d3340b3..9a3a72c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -906,7 +906,8 @@ extern GTY(()) tree gfor_fndecl_caf_is_present;
 /* Native coarray library function decls.  */
 extern GTY(()) tree gfor_fndecl_cas_this_image;
 extern GTY(()) tree gfor_fndecl_cas_num_images;
-extern GTY(()) tree gfor_fndecl_cas_coarray_allocate;
+extern GTY(()) tree gfor_fndecl_cas_coarray_alloc;
+extern GTY(()) tree gfor_fndecl_cas_coarray_alloc_chk;
 extern GTY(()) tree gfor_fndecl_cas_coarray_free;
 extern GTY(()) tree gfor_fndecl_cas_sync_images;
 extern GTY(()) tree gfor_fndecl_cas_sync_all;
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90
index 0703b42..f2bc8af 100644
--- a/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90
+++ b/gcc/testsuite/gfortran.dg/caf-shared/allocate_1.f90
@@ -5,5 +5,5 @@ program main
   allocate (a[*])
   deallocate (a)
 end program main
-! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 1 "original" } }
 
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90
new file mode 100644
index 0000000..fe66a07
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/allocate_status_1.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+program main
+  integer, allocatable :: a[:]
+  character (len=80) :: errmsg
+  integer :: st
+  st = 42
+  allocate (a[*],stat=st)
+  if (st /= 0) stop 1
+  allocate (a[*], stat=st)
+  if (st == 0) stop 1
+  allocate (a[*], stat=st,errmsg=errmsg)
+  if (st == 0) stop 2
+  if (errmsg /= "Attempting to allocate already allocated variable") stop 3
+end program main
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90
new file mode 100644
index 0000000..3b7374f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/automatic_deallocate_1.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+! { dg-options "-fdump-tree-original" }
+
+program main
+  integer :: n
+  n = 4096
+  do i=1,3
+     block
+       integer, allocatable :: a[:]
+       if (allocated(a)) stop 1
+       allocate (a[*])
+       a = 42
+       n = n * 2
+     end block
+  end do
+end program main
+! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_alloc_chk" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_free" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90
new file mode 100644
index 0000000..182e82e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/save_allocatable_1.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+! { dg-options "-fdump-tree-original" }
+
+program main
+  call test(.true.)
+  call test(.false.)
+contains
+  subroutine test(flag)
+    logical, intent(in) :: flag
+    integer, save, dimension(:), allocatable :: a[:]
+    if (flag) then
+       allocate (a(4)[*])
+       a = this_image()
+    else
+       if (size(a,1) /= 4) stop 1
+       if (any(a /= this_image())) stop 2
+    end if
+  end subroutine test
+end program main
diff --git a/libgfortran/caf_shared/coarraynative.c b/libgfortran/caf_shared/coarraynative.c
index 1f1f396..1ae0c40 100644
--- a/libgfortran/caf_shared/coarraynative.c
+++ b/libgfortran/caf_shared/coarraynative.c
@@ -103,45 +103,63 @@ int
 test_for_cas_errors (int *stat, char *errmsg, size_t errmsg_length)
 {
   size_t errmsg_written_bytes;
-  if (!stat)
-    return 0;
 
   /* This rather strange ordering is mandated by the standard.  */
   if (this_image.m->finished_images)
     {
-      *stat = CAS_STAT_STOPPED_IMAGE;
-      if (errmsg)
+      if (stat)
 	{
-	  errmsg_written_bytes = snprintf (errmsg, errmsg_length,
-					   "Stopped images present (currently "
-					   "%d)",
-					   this_image.m->finished_images);
-	  if (errmsg_written_bytes > errmsg_length - 1)
-	    errmsg_written_bytes = errmsg_length - 1;
-
-	  memset (errmsg + errmsg_written_bytes, ' ',
-		  errmsg_length - errmsg_written_bytes);
+	  *stat = CAS_STAT_STOPPED_IMAGE;
+	  if (errmsg)
+	    {
+	      errmsg_written_bytes
+		= snprintf (errmsg, errmsg_length,
+			    "Stopped images present (currently %d)",
+			    this_image.m->finished_images);
+	      if (errmsg_written_bytes > errmsg_length - 1)
+		errmsg_written_bytes = errmsg_length - 1;
+
+	      memset (errmsg + errmsg_written_bytes, ' ',
+		      errmsg_length - errmsg_written_bytes);
+	    }
+	}
+      else
+	{
+	  fprintf (stderr, "Stopped images present (currently %d)",
+		   this_image.m->finished_images);
+	  exit(1);
 	}
     }
   else if (this_image.m->has_failed_image)
     {
-      *stat = CAS_STAT_FAILED_IMAGE;
-      if (errmsg)
+      if (stat)
 	{
-	  errmsg_written_bytes = snprintf (errmsg, errmsg_length,
-					   "Failed images present (currently "
-					   "%d)",
-					   this_image.m->has_failed_image);
-	  if (errmsg_written_bytes > errmsg_length - 1)
-	    errmsg_written_bytes = errmsg_length - 1;
-
-	  memset (errmsg + errmsg_written_bytes, ' ',
-		  errmsg_length - errmsg_written_bytes);
+	  *stat = CAS_STAT_FAILED_IMAGE;
+	  if (errmsg)
+	    {
+	      errmsg_written_bytes
+		= snprintf (errmsg, errmsg_length,
+			    "Failed images present (currently %d)",
+			    this_image.m->has_failed_image);
+	      if (errmsg_written_bytes > errmsg_length - 1)
+		errmsg_written_bytes = errmsg_length - 1;
+
+	      memset (errmsg + errmsg_written_bytes, ' ',
+		      errmsg_length - errmsg_written_bytes);
+	    }
+	}
+      else
+	{
+	  fprintf (stderr, "Failed images present (currently %d)\n",
+		   this_image.m->has_failed_image);
+	  exit(1);
 	}
     }
   else
     {
-      *stat = 0;
+      if (stat)
+	*stat = 0;
+
       return 0;
     }
   return 1;
diff --git a/libgfortran/caf_shared/libcoarraynative.h b/libgfortran/caf_shared/libcoarraynative.h
index e454965..3cc0123 100644
--- a/libgfortran/caf_shared/libcoarraynative.h
+++ b/libgfortran/caf_shared/libcoarraynative.h
@@ -109,13 +109,13 @@ internal_proto(error_on_missing_images);
 
 #define STAT_ERRMSG_ENTRY_CHECK(stat, errmsg, errmsg_len) \
 	do { \
-	  if (test_for_cas_errors(stat, errmsg, errmsg_len))\
+	  if (unlikely (test_for_cas_errors(stat, errmsg, errmsg_len)))	\
 	    return;\
   	} while(0)
 
 #define STAT_ERRMSG_ENTRY_CHECK_RET(stat, errmsg, errmsg_len, retval) \
 	do { \
-	  if (test_for_cas_errors(stat, errmsg, errmsg_len))\
+	  if (unlikely(test_for_cas_errors(stat, errmsg, errmsg_len)))	\
 	    return retval;\
   	} while(0)
 
diff --git a/libgfortran/caf_shared/wrapper.c b/libgfortran/caf_shared/wrapper.c
index a3d8866..05ee838 100644
--- a/libgfortran/caf_shared/wrapper.c
+++ b/libgfortran/caf_shared/wrapper.c
@@ -44,10 +44,13 @@ enum gfc_coarray_allocation_type
   GFC_NCA_EVENT_COARRAY,
 };
 
-void cas_coarray_alloc (gfc_array_void *, size_t, int, int, int *,
-			char *, size_t);
+void cas_coarray_alloc (gfc_array_void *, size_t, int, int);
 export_proto (cas_coarray_alloc);
 
+void cas_coarray_alloc_chk (gfc_array_void *, size_t, int, int, int *,
+			    char *, size_t);
+export_proto (cas_coarray_alloc_chk);
+
 void cas_coarray_free (gfc_array_void *, int);
 export_proto (cas_coarray_free);
 
@@ -85,9 +88,9 @@ void cas_collsub_broadcast_scalar (void *restrict, size_t, int, int *, char *,
 				   size_t);
 export_proto (cas_collsub_broadcast_scalar);
 
-void
-cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
-		   int alloc_type, int *status, char *errmsg, size_t errmsg_len)
+static void
+cas_coarray_alloc_work (gfc_array_void *desc, size_t elem_size, int corank,
+			int alloc_type)
 {
   int i, last_rank_index;
   int num_coarray_elems, num_elems; /* Excludes the last dimension, because it
@@ -96,10 +99,6 @@ cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
   size_t last_lbound;
   size_t size_in_bytes;
 
-  ensure_initialization (); /* This function might be the first one to be
-			       called, if it is called in a constructor.  */
-
-  STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len);
   if (alloc_type == GFC_NCA_LOCK_COARRAY)
     elem_size = sizeof (pthread_mutex_t);
   else if (alloc_type == GFC_NCA_EVENT_COARRAY)
@@ -152,8 +151,53 @@ cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
   else if (alloc_type == GFC_NCA_EVENT_COARRAY)
     (void)0; // TODO
   else
-    desc->base_addr
-	= get_memory_by_id (&local->ai, size_in_bytes, (intptr_t)desc);
+    desc->base_addr =
+      get_memory_by_id (&local->ai, size_in_bytes, (intptr_t) desc);
+}
+
+void
+cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
+		   int alloc_type)
+{
+  ensure_initialization (); /* This function might be the first one to be
+			       called, if it is called in a constructor.  */
+  cas_coarray_alloc_work (desc, elem_size, corank, alloc_type);
+}
+
+void
+cas_coarray_alloc_chk (gfc_array_void *desc, size_t elem_size, int corank,
+		       int alloc_type, int *status, char *errmsg,
+		       size_t errmsg_len)
+{
+  STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len);
+  if (unlikely(GFC_DESCRIPTOR_DATA (desc) != NULL))
+    {
+      if (status == NULL)
+	{
+	  fprintf (stderr,"Image %d: Attempting to allocate already allocated "
+		   "variable at %p %p\n", this_image.image_num + 1, (void *) desc,
+		   desc->base_addr);
+	  exit (1);
+	}
+      else
+	{
+	  *status = LIBERROR_ALLOCATION;
+	  if (errmsg)
+	    {
+	      size_t errmsg_written_bytes;
+	      errmsg_written_bytes
+		= snprintf (errmsg, errmsg_len, "Attempting to allocate already "
+			    "allocated variable");
+	      if (errmsg_written_bytes > errmsg_len - 1)
+		errmsg_written_bytes = errmsg_len - 1;
+	      memset (errmsg + errmsg_written_bytes, ' ',
+		      errmsg_len - errmsg_written_bytes);
+	    }
+	  return;
+	}
+    }
+  cas_coarray_alloc_work (desc, elem_size, corank, alloc_type);
+  sync_all (&local->si);
 }
 
 void