1 files changed, 199 insertions, 105 deletions

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 37f8aca..487b768 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -721,6 +721,15 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
   return gfc_finish_block (&se.pre);
 }
 
+tree
+trans_exit ()
+{
+  const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+  gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+  tree tmp = gfc_get_symbol_decl (exsym);
+  return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+}
+
 /* Translate the FAIL IMAGE statement.  */
 
 tree
@@ -730,11 +739,49 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
     return build_call_expr_loc (input_location,
 				gfor_fndecl_caf_fail_image, 0);
   else
+    return trans_exit ();
+}
+
+void
+gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat,
+		     tree *errmsg, tree *errmsg_len)
+{
+  gfc_se argse;
+
+  if (sync_stat->stat)
     {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr (&argse, sync_stat->stat);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+
+      if (TREE_TYPE (argse.expr) != integer_type_node)
+	{
+	  tree tstat = gfc_create_var (integer_type_node, "stat");
+	  TREE_THIS_VOLATILE (tstat) = 1;
+	  gfc_add_modify (&se->pre, tstat,
+			  fold_convert (integer_type_node, argse.expr));
+	  gfc_add_modify (&se->post, argse.expr,
+			  fold_convert (TREE_TYPE (argse.expr), tstat));
+	  *stat = build_fold_addr_expr (tstat);
+	}
+      else
+	*stat = build_fold_addr_expr (argse.expr);
+    }
+  else
+    *stat = null_pointer_node;
+
+  if (sync_stat->errmsg)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_reference (&argse, sync_stat->errmsg);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      *errmsg = argse.expr;
+      *errmsg_len = fold_convert (size_type_node, argse.string_length);
+    }
+  else
+    {
+      *errmsg = null_pointer_node;
+      *errmsg_len = build_zero_cst (size_type_node);
     }
 }
 
@@ -745,38 +792,42 @@ gfc_trans_form_team (gfc_code *code)
 {
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      gfc_se se;
-      gfc_se argse1, argse2;
-      tree team_id, team_type, tmp;
+      gfc_se se, argse;
+      tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp;
 
       gfc_init_se (&se, NULL);
-      gfc_init_se (&argse1, NULL);
-      gfc_init_se (&argse2, NULL);
-      gfc_start_block (&se.pre);
+      gfc_init_se (&argse, NULL);
 
-      gfc_conv_expr_val (&argse1, code->expr1);
-      gfc_conv_expr_val (&argse2, code->expr2);
-      team_id = fold_convert (integer_type_node, argse1.expr);
-      team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr);
+      gfc_conv_expr_val (&argse, code->expr1);
+      team_id = fold_convert (integer_type_node, argse.expr);
+      gfc_conv_expr_reference (&argse, code->expr2);
+      team_type = argse.expr;
 
-      gfc_add_block_to_block (&se.pre, &argse1.pre);
-      gfc_add_block_to_block (&se.pre, &argse2.pre);
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_caf_form_team, 3,
-				 team_id, team_type,
-				 integer_zero_node);
+      /* NEW_INDEX=.  */
+      if (code->expr3)
+	{
+	  gfc_conv_expr_reference (&argse, code->expr3);
+	  new_index = argse.expr;
+	}
+      else
+	new_index = null_pointer_node;
+
+      gfc_add_block_to_block (&se.post, &argse.post);
+
+      gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+			   &errmsg_len);
+
+      gfc_add_block_to_block (&se.pre, &argse.pre);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6,
+				 team_id, team_type, new_index, stat, errmsg,
+				 errmsg_len);
       gfc_add_expr_to_block (&se.pre, tmp);
-      gfc_add_block_to_block (&se.pre, &argse1.post);
-      gfc_add_block_to_block (&se.pre, &argse2.post);
+      gfc_add_block_to_block (&se.pre, &se.post);
       return gfc_finish_block (&se.pre);
-    }
+     }
   else
-    {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
-    }
+    return trans_exit ();
 }
 
 /* Translate the CHANGE TEAM statement.  */
@@ -786,47 +837,56 @@ gfc_trans_change_team (gfc_code *code)
 {
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      gfc_se argse;
-      tree team_type, tmp;
+      stmtblock_t block;
+      gfc_se se;
+      tree team_type, stat, errmsg, errmsg_len, tmp;
 
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr_val (&argse, code->expr1);
-      team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+      gfc_init_se (&se, NULL);
+      gfc_start_block (&block);
 
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_caf_change_team, 2, team_type,
-				 integer_zero_node);
-      gfc_add_expr_to_block (&argse.pre, tmp);
-      gfc_add_block_to_block (&argse.pre, &argse.post);
-      return gfc_finish_block (&argse.pre);
+      gfc_conv_expr_val (&se, code->expr1);
+      team_type = se.expr;
+
+      gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg,
+			   &errmsg_len);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4,
+				 team_type, stat, errmsg, errmsg_len);
+
+      gfc_add_expr_to_block (&se.pre, tmp);
+      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_add_block_to_block (&block, &se.pre);
+      gfc_add_expr_to_block (&block, gfc_trans_block_construct (code));
+      return gfc_finish_block (&block);
     }
   else
-    {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
-    }
+    return trans_exit ();
 }
 
 /* Translate the END TEAM statement.  */
 
 tree
-gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED)
+gfc_trans_end_team (gfc_code *code)
 {
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      return build_call_expr_loc (input_location,
-				  gfor_fndecl_caf_end_team, 1,
-				  build_int_cst (pchar_type_node, 0));
+      gfc_se se;
+      tree stat, errmsg, errmsg_len, tmp;
+
+      gfc_init_se (&se, NULL);
+      gfc_start_block (&se.pre);
+
+      gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+			   &errmsg_len);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3,
+				 stat, errmsg, errmsg_len);
+      gfc_add_expr_to_block (&se.pre, tmp);
+      gfc_add_block_to_block (&se.pre, &se.post);
+      return gfc_finish_block (&se.pre);
     }
   else
-    {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
-    }
+    return trans_exit ();
 }
 
 /* Translate the SYNC TEAM statement.  */
@@ -836,28 +896,25 @@ gfc_trans_sync_team (gfc_code *code)
 {
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      gfc_se argse;
-      tree team_type, tmp;
+      gfc_se se;
+      tree team_type, stat, errmsg, errmsg_len, tmp;
 
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr_val (&argse, code->expr1);
-      team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+      gfc_init_se (&se, NULL);
 
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_caf_sync_team, 2,
-				 team_type,
-				 integer_zero_node);
-      gfc_add_expr_to_block (&argse.pre, tmp);
-      gfc_add_block_to_block (&argse.pre, &argse.post);
-      return gfc_finish_block (&argse.pre);
+      gfc_conv_expr_val (&se, code->expr1);
+      team_type = se.expr;
+
+      gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+			   &errmsg_len);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4,
+				 team_type, stat, errmsg, errmsg_len);
+      gfc_add_expr_to_block (&se.pre, tmp);
+      gfc_add_block_to_block (&se.pre, &se.post);
+      return gfc_finish_block (&se.pre);
     }
   else
-    {
-      const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
-      gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
-      tree tmp = gfc_get_symbol_decl (exsym);
-      return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
-    }
+    return trans_exit ();
 }
 
 tree
@@ -1280,8 +1337,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
 	{
 	  tree cond2;
 	  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
-				     2, integer_zero_node,
-				     build_int_cst (integer_type_node, -1));
+				     2, null_pointer_node, null_pointer_node);
 	  cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
 				  images2, tmp);
 	  cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
@@ -1609,35 +1665,41 @@ gfc_trans_arithmetic_if (gfc_code * code)
 
 
 /* Translate a CRITICAL block.  */
+
 tree
 gfc_trans_critical (gfc_code *code)
-{
-  stmtblock_t block;
-  tree tmp, token = NULL_TREE;
+ {
+   stmtblock_t block;
+   tree tmp, token = NULL_TREE;
+   tree stat = NULL_TREE, errmsg, errmsg_len;
 
-  gfc_start_block (&block);
+   gfc_start_block (&block);
 
-  if (flag_coarray == GFC_FCOARRAY_LIB)
-    {
-      tree zero_size = build_zero_cst (size_type_node);
-      token = gfc_get_symbol_decl (code->resolved_sym);
-      token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
-				 token, zero_size, integer_one_node,
-				 null_pointer_node, null_pointer_node,
-				 null_pointer_node, zero_size);
-      gfc_add_expr_to_block (&block, tmp);
+   if (flag_coarray == GFC_FCOARRAY_LIB)
+     {
+       gfc_se se;
 
-      /* It guarantees memory consistency within the same segment */
-      tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
-	tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
-			  gfc_build_string_const (1, ""),
-			  NULL_TREE, NULL_TREE,
-			  tree_cons (NULL_TREE, tmp, NULL_TREE),
-			  NULL_TREE);
-      ASM_VOLATILE_P (tmp) = 1;
+       gfc_init_se (&se, NULL);
+       gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+			    &errmsg_len);
+       gfc_add_block_to_block (&block, &se.pre);
 
-      gfc_add_expr_to_block (&block, tmp);
+       token = gfc_get_symbol_decl (code->resolved_sym);
+       token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
+       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
+				  token, integer_zero_node, integer_one_node,
+				  null_pointer_node, stat, errmsg, errmsg_len);
+       gfc_add_expr_to_block (&block, tmp);
+       gfc_add_block_to_block (&block, &se.post);
+
+       /* It guarantees memory consistency within the same segment.  */
+       tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"),
+       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
+			 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
+			 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
+       ASM_VOLATILE_P (tmp) = 1;
+
+       gfc_add_expr_to_block (&block, tmp);
     }
 
   tmp = gfc_trans_code (code->block->next);
@@ -1645,11 +1707,19 @@ gfc_trans_critical (gfc_code *code)
 
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
-      tree zero_size = build_zero_cst (size_type_node);
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
-				 token, zero_size, integer_one_node,
-				 null_pointer_node, null_pointer_node,
-				 zero_size);
+      /* END CRITICAL does not accept STAT or ERRMSG arguments.
+       * If STAT= is specified for CRITICAL, pass a stat argument to
+       * _gfortran_caf_lock_unlock to prevent termination in the event of an
+       * error, but ignore any value assigned to it.
+       */
+      tmp = build_call_expr_loc (
+	input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node,
+	integer_one_node,
+	stat != NULL_TREE
+	  ? gfc_build_addr_expr (NULL,
+				 gfc_create_var (integer_type_node, "stat"))
+	  : null_pointer_node,
+	null_pointer_node, integer_zero_node);
       gfc_add_expr_to_block (&block, tmp);
 
       /* It guarantees memory consistency within the same segment */
@@ -1981,11 +2051,35 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
 	}
 
-      if (sym->attr.codimension && !sym->attr.dimension)
+      if (sym->attr.codimension)
 	se.want_coarray = 1;
 
       gfc_conv_expr_descriptor (&se, e);
 
+      if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+	{
+	  tree token = gfc_conv_descriptor_token (se.expr),
+	       size
+	       = sym->attr.dimension
+		   ? fold_build2 (MULT_EXPR, gfc_array_index_type,
+				  gfc_conv_descriptor_size (se.expr, e->rank),
+				  gfc_conv_descriptor_span_get (se.expr))
+		   : gfc_conv_descriptor_span_get (se.expr);
+	  /* Create a new token, because in the token the modified descriptor
+	     is stored.  The modified descriptor is needed for accesses on the
+	     remote image.  In the scalar case, the base address needs to be
+	     associated correctly, which also needs a new token.
+	     The token is freed automatically be the end team statement.  */
+	  gfc_add_expr_to_block (
+	    &se.pre,
+	    build_call_expr_loc (
+	      input_location, gfor_fndecl_caf_register, 7, size,
+	      build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING),
+	      gfc_build_addr_expr (pvoid_type_node, token),
+	      gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node,
+	      null_pointer_node, integer_zero_node));
+	}
+
       if (sym->ts.type == BT_CHARACTER
 	  && !sym->attr.select_type_temporary
 	  && sym->ts.u.cl->backend_decl