Fortran: Various fixes on F2018 teams.

gcc/fortran/ChangeLog:

	* match.cc (match_exit_cycle): Allow to exit team block.
	(gfc_match_end_team): Create end_team node also without
	parameter list.
	* trans-intrinsic.cc (conv_stat_and_team): Team and team_number
	only need to be a single pointer.
	* trans-stmt.cc (trans_associate_var): Create a mapping coarray
	token for coarray associations or it is not addressed correctly.
	* trans.h (enum gfc_coarray_regtype): Add mapping mode to
	coarray register.

libgfortran/ChangeLog:

	* caf/libcaf.h: Add mapping mode to coarray's register.
	* caf/single.c (_gfortran_caf_register): Create a token sharing
	another token's memory.
	(check_team): Check team parameters to coindexed expressions are
	valid.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/coindexed_3.f08: Add minimal test for
	get_team().
	* gfortran.dg/team_change_2.f90: Add test for change team with
	label and exiting out of it.
	* gfortran.dg/team_end_2.f90: Check parsing to labeled team
	blocks is correct now.
	* gfortran.dg/team_end_3.f90: Check that end_team call is
	generated for labeled end_teams, too.
	* gfortran.dg/coarray/coindexed_5.f90: New test.

gcc/fortran/match.cc

@@ -3325,6 +3325,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
 
     case COMP_ASSOCIATE:
     case COMP_BLOCK:
+    case COMP_CHANGE_TEAM:
     case COMP_IF:
     case COMP_SELECT:
     case COMP_SELECT_TYPE:
@@ -4162,9 +4163,12 @@ gfc_match_end_team (void)
     goto done;
 
   if (gfc_match_char ('(') != MATCH_YES)
-    /* There could be a team-construct-name following.  Let caller decide
-       about error.  */
-    return MATCH_NO;
+    {
+      /* There could be a team-construct-name following.  Let caller decide
+	 about error.  */
+      new_st.op = EXEC_END_TEAM;
+      return MATCH_NO;
+    }
 
   for (;;)
     {

gcc/fortran/trans-intrinsic.cc

@@ -1183,7 +1183,7 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
     {
       gfc_se team_se;
       gfc_init_se (&team_se, NULL);
-      gfc_conv_expr_reference (&team_se, team_e);
+      gfc_conv_expr (&team_se, team_e);
       *team
 	= gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
 								team_se.expr));
@@ -1198,7 +1198,7 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
     {
       gfc_se team_se;
       gfc_init_se (&team_se, NULL);
-      gfc_conv_expr_reference (&team_se, team_e);
+      gfc_conv_expr (&team_se, team_e);
       *team_no = gfc_build_addr_expr (
 	NULL_TREE,
 	gfc_trans_force_lval (&team_se.pre,

gcc/fortran/trans-stmt.cc

@@ -2056,6 +2056,30 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
       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

gcc/fortran/trans.h

@@ -139,10 +139,10 @@ enum gfc_coarray_regtype
   GFC_CAF_EVENT_STATIC,
   GFC_CAF_EVENT_ALLOC,
   GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY,
-  GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
+  GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY,
+  GFC_CAF_COARRAY_MAP_EXISTING
 };
 
-
 /* Describes the action to take on _caf_deregister.  Keep in sync with
    gcc/fortran/trans.h.  The negative values are not valid for the library and
    are used by the drivers for building the correct call.  */

gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08

@@ -9,6 +9,7 @@ program pr98903
   integer :: a[*]
   type(team_type) :: team
 
+  team = get_team()
   me = this_image()
   n = num_images()
   a = 42

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

@@ -0,0 +1,80 @@
+!{ dg-do run }
+
+! Check coindexes with team= or team_number= are working.
+
+program coindexed_5
+  use, intrinsic :: iso_fortran_env
+
+  type(team_type) :: parentteam, team, formed_team
+  integer :: t_num= 42, stat = 42, lhs
+  integer(kind=2) :: st_num=42
+  integer :: caf(2)[*]
+
+  parentteam = get_team()
+
+  caf = [23, 32]
+  form team(t_num, team, new_index=1)
+  form team(t_num, formed_team)
+
+  change team(team, cell[*] => caf(2))
+    ! for get_from_remote
+    ! Checking against caf_single is very limitted.
+    if (cell[1, team_number=t_num] /= 32) stop 1
+    if (cell[1, team_number=st_num] /= 32) stop 2
+    if (cell[1, team=parentteam] /= 32) stop 3
+
+    ! Check that team_number is validated
+    lhs = cell[1, team_number=5, stat=stat]
+    if (stat /= 1) stop 4
+
+    ! Check that only access to active teams is valid
+    stat = 42
+    lhs = cell[1, team=formed_team, stat=stat]
+    if (stat /= 1) stop 5
+
+    ! for send_to_remote
+    ! Checking against caf_single is very limitted.
+    cell[1, team_number=t_num] = 45
+    if (cell /= 45) stop 11
+    cell[1, team_number=st_num] = 46
+    if (cell /= 46) stop 12
+    cell[1, team=parentteam] = 47
+    if (cell /= 47) stop 13
+
+    ! Check that team_number is validated
+    stat = -1
+    cell[1, team_number=5, stat=stat] = 0
+    if (stat /= 1) stop 14
+
+    ! Check that only access to active teams is valid
+    stat = 42
+    cell[1, team=formed_team, stat=stat] = -1
+    if (stat /= 1) stop 15
+
+    ! for transfer_between_remotes
+    ! Checking against caf_single is very limitted.
+    cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
+    if (cell /= 23) stop 21
+    cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
+    ! cell is an alias for caf(2) and has been overwritten by caf(1)!
+    if (cell /= 23) stop 22
+    cell[1, team=parentteam] = caf(1)[1, team= team]
+    if (cell /= 23) stop 23
+
+    ! Check that team_number is validated
+    stat = -1
+    cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
+    if (stat /= 1) stop 24
+    stat = -1
+    cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
+    if (stat /= 1) stop 25
+
+    ! Check that only access to active teams is valid
+    stat = 42
+    cell[1, team=formed_team, stat=stat] = caf(1)[1]
+    if (stat /= 1) stop 26
+    stat = 42
+    cell[1] = caf(1)[1, team=formed_team, stat=stat]
+    if (stat /= 1) stop 27
+  end team
+end program coindexed_5

gcc/testsuite/gfortran.dg/team_change_2.f90

@@ -74,6 +74,13 @@
     continue
   end team !{ dg-error "Expecting END PROGRAM statement" }
 
+  t: change team(team)
+    exit t
+  end team t
+
+  change team(team)
+    exit t !{ dg-error "EXIT statement at \\(1\\) is not within construct 't'" }
+  end team
 contains
   subroutine foo(team)
     type(team_type) :: team

gcc/testsuite/gfortran.dg/team_end_2.f90

@@ -29,5 +29,14 @@
   change team (team)
     continue
   end team (stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" }
+
+  t: change team (team)
+    continue
+  end team (stat=istat) t ! ok
+
+  t2: change team (team)
+    continue
+  end team   ! { dg-error "Expected block name of 't2' in END TEAM" }
+  end team t2  ! close the team correctly to catch other errors
 end
 

gcc/testsuite/gfortran.dg/team_end_3.f90

@@ -29,10 +29,12 @@
   deallocate(sample, stat=istat)
   if (istat == 0) stop 6
 
-  change team (team)
+  istat = 42
+  t: change team (team)
     continue
-  end team (stat=istat, errmsg=err)
-  if (trim(err) /= 'unchanged') stop 7
+  end team (stat=istat, errmsg=err) t
+  if (istat /= 0) stop 7
+  if (trim(err) /= 'unchanged') stop 8
 end
 
 ! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, 0B, 0\\)" "original" } }

libgfortran/caf/libcaf.h

@@ -55,7 +55,8 @@ typedef enum
 
 /* Describes what type of array we are registerring.  Keep in sync with
    gcc/fortran/trans.h.  */
-typedef enum caf_register_t {
+typedef enum caf_register_t
+{
   CAF_REGTYPE_COARRAY_STATIC,
   CAF_REGTYPE_COARRAY_ALLOC,
   CAF_REGTYPE_LOCK_STATIC,
@@ -64,9 +65,9 @@ typedef enum caf_register_t {
   CAF_REGTYPE_EVENT_STATIC,
   CAF_REGTYPE_EVENT_ALLOC,
   CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY,
-  CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
-}
-caf_register_t;
+  CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY,
+  CAF_REGTYPE_COARRAY_MAP_EXISTING,
+} caf_register_t;
 
 /* Describes the action to take on _caf_deregister.  Keep in sync with
    gcc/fortran/trans.h.  */

libgfortran/caf/single.c

@@ -227,6 +227,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
     local = calloc (size, sizeof (uint32_t));
   else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
     local = NULL;
+  else if (type == CAF_REGTYPE_COARRAY_MAP_EXISTING)
+    local = GFC_DESCRIPTOR_DATA (data);
   else
     local = malloc (size);
 
@@ -248,7 +250,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
 
   single_token = TOKEN (*token);
   single_token->memptr = local;
-  single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
+  single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY
+				&& type != CAF_REGTYPE_COARRAY_MAP_EXISTING;
   single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
 
   if (unlikely (!caf_team_stack))
@@ -620,6 +623,37 @@ _gfortran_caf_get_remote_function_index (const int hash)
   return index;
 }
 
+static bool
+check_team (caf_team_t *team, int *team_number, int *stat)
+{
+  if (team || team_number)
+    {
+      caf_single_team_t cur = caf_team_stack;
+
+      if (team)
+	{
+	  caf_single_team_t single_team = (caf_single_team_t) (*team);
+	  while (cur && cur != single_team)
+	    cur = cur->parent;
+	}
+      else
+	while (cur && cur->team_no != *team_number)
+	  cur = cur->parent;
+
+      if (!cur)
+	{
+	  if (stat)
+	    {
+	      *stat = 1;
+	      return false;
+	    }
+	  else
+	    caf_runtime_error ("requested team not found");
+	}
+    }
+  return true;
+}
+
 void
 _gfortran_caf_get_from_remote (
   caf_token_t token, const gfc_descriptor_t *opt_src_desc,
@@ -628,8 +662,7 @@ _gfortran_caf_get_from_remote (
   size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc,
   const bool may_realloc_dst, const int getter_index, void *add_data,
   const size_t add_data_size __attribute__ ((unused)), int *stat,
-  caf_team_t *team __attribute__ ((unused)),
-  int *team_number __attribute__ ((unused)))
+  caf_team_t *team, int *team_number)
 {
   caf_single_token_t single_token = TOKEN (token);
   void *src_ptr = opt_src_desc ? (void *) opt_src_desc : single_token->memptr;
@@ -644,6 +677,9 @@ _gfortran_caf_get_from_remote (
   if (stat)
     *stat = 0;
 
+  if (!check_team (team, team_number, stat))
+    return;
+
   if (opt_dst_desc && !may_realloc_dst)
     {
       old_dst_data_ptr = opt_dst_desc->base_addr;
@@ -696,8 +732,7 @@ _gfortran_caf_send_to_remote (
   const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc,
   const int accessor_index, void *add_data,
   const size_t add_data_size __attribute__ ((unused)), int *stat,
-  caf_team_t *team __attribute__ ((unused)),
-  int *team_number __attribute__ ((unused)))
+  caf_team_t *team, int *team_number)
 {
   caf_single_token_t single_token = TOKEN (token);
   void *dst_ptr = opt_dst_desc ? (void *) opt_dst_desc : single_token->memptr;
@@ -710,6 +745,9 @@ _gfortran_caf_send_to_remote (
   if (stat)
     *stat = 0;
 
+  if (!check_team (team, team_number, stat))
+    return;
+
   accessor_hash_table[accessor_index].u.receiver (add_data, &image_index,
 						  dst_ptr, src_ptr, &cb_token,
 						  0, opt_dst_charlen,
@@ -727,10 +765,8 @@ _gfortran_caf_transfer_between_remotes (
   const int src_access_index, void *src_add_data,
   const size_t src_add_data_size __attribute__ ((unused)),
   const size_t src_size, const bool scalar_transfer, int *dst_stat,
-  int *src_stat, caf_team_t *dst_team __attribute__ ((unused)),
-  int *dst_team_number __attribute__ ((unused)),
-  caf_team_t *src_team __attribute__ ((unused)),
-  int *src_team_number __attribute__ ((unused)))
+  int *src_stat, caf_team_t *dst_team, int *dst_team_number,
+  caf_team_t *src_team, int *src_team_number)
 {
   caf_single_token_t src_single_token = TOKEN (src_token),
 		     dst_single_token = TOKEN (dst_token);
@@ -749,6 +785,9 @@ _gfortran_caf_transfer_between_remotes (
   if (src_stat)
     *src_stat = 0;
 
+  if (!check_team (src_team, src_team_number, src_stat))
+    return;
+
   if (!scalar_transfer)
     {
       const size_t desc_size = sizeof (*transfer_desc);
@@ -771,6 +810,9 @@ _gfortran_caf_transfer_between_remotes (
   if (dst_stat)
     *dst_stat = 0;
 
+  if (!check_team (dst_team, dst_team_number, dst_stat))
+    return;
+
   if (scalar_transfer)
     transfer_ptr = *(void **) transfer_ptr;