Fortran: Improve F2018 TEAM handling [PR87326, PR87556, PR88254, PR103896]

Improve the implementation of F2018 TEAM handling routines. Add
runtime-functions to caf_single to allow testing.

	PR fortran/87326
	PR fortran/87556
	PR fortran/88254
	PR fortran/103796

gcc/fortran/ChangeLog:

	* coarray.cc (split_expr_at_caf_ref): Treat polymorphic types
	correctly.  Ensure resolve of expression after coindex.
	(create_allocated_callback): Fix parameter of allocated function
	for coarrays.
	(coindexed_expr_callback): Improve detection of coarrays in
	allocated function.
	* decl.cc (gfc_match_end): Add team block matching.
	* dump-parse-tree.cc (show_code_node): Dump change team block as
	such.
	* frontend-passes.cc (gfc_code_walker): Recognice team block.
	* gfortran.texi: Add documentation for team api functions.
	* intrinsic.texi: Add documentation about team_type in
	iso_fortran_env module.
	* iso-fortran-env.def (team_type): Use helper to get pointer
	kind.
	* match.cc (gfc_match_associate): Factor out matching of
	association list, because it is used in change team as well.
	(check_coarray_assoc): Ensure, that the association is to a
	coarray.
	(match_association_list): Match a list of association either in
	associate or in change team.
	(gfc_match_form_team): Match form team correctly include
	new_index.
	(gfc_match_change_team): Match change team with association
	list.
	(gfc_match_end_team): Match end team including stat and errmsg.
	(gfc_match_return): Prevent return from team block.
	* parse.cc (decode_statement): Sort team block.
	(next_statement): Same.
	(check_statement_label): Same.
	(accept_statement): Same.
	(verify_st_order): Same.
	(parse_associate): Renamed to move_associates_to_block...
	(move_associates_to_block): ... to enable reuse for change team.
	(parse_change_team): Parse it as block.
	(parse_executable): Same.
	* parse.h (enum gfc_compile_state): Add team block as compiler
	state.
	* resolve.cc (resolve_scalar_argument): New function to resolve
	an argument to a statement as a scalar.
	(resolve_form_team): Resolve its members.
	(resolve_change_team): Same.
	(resolve_branch): Prevent branch from jumping out of team block.
	(check_team): Removed.
	* trans-decl.cc (gfc_build_builtin_function_decls): Add stat and
	errmsg to team API functions and update their arguments.
	* trans-expr.cc (gfc_trans_subcomponent_assign): Also null the
	token when moving memory or an allocated() will not detect a
	free.
	* trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote):
	Adapt to signature change no longer a pointer-pointer.
	* trans-stmt.cc (gfc_trans_form_team): Translate a form team
	including new_index.
	(gfc_trans_change_team): Translate a change team as a block.

libgfortran/ChangeLog:

	* caf/libcaf.h: Remove commented block.
	(_gfortran_caf_form_team): Allow for all relevant arguments.
	(_gfortran_caf_change_team): Same.
	(_gfortran_caf_end_team): Same.
	(_gfortran_caf_sync_team): Same.
	* caf/single.c (struct caf_single_team): Team handling
	structures.
	(_gfortran_caf_init): Initialize initial team.
	(free_team_list): Free all teams and the memory they hold.
	(_gfortran_caf_finalize): Free initial and sibling teams.
	(_gfortran_caf_register): Add memory registered to current team.
	(_gfortran_caf_deregister): Unregister memory from current team.
	(_gfortran_caf_is_present_on_remote): Check token's memptr for
	llocation.  May have been deallocated by an end team.
	(_gfortran_caf_form_team): Push a new team stub to the list.
	(_gfortran_caf_change_team): Push a formed team on top of the
	ctive teams stack.
	(_gfortran_caf_end_team): End the active team, free all memory
	allocated during its livespan.
	(_gfortran_caf_sync_team): Take stat and errmsg into account.

gcc/testsuite/ChangeLog:

	* gfortran.dg/team_change_2.f90: New test.
	* gfortran.dg/team_change_3.f90: New test.
	* gfortran.dg/team_end_2.f90: New test.
	* gfortran.dg/team_end_3.f90: New test.
	* gfortran.dg/team_form_2.f90: New test.
	* gfortran.dg/team_form_3.f90: New test.
	* gfortran.dg/team_sync_2.f90: New test.

1 files changed, 64 insertions, 25 deletions

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e9053b4..e51f83b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11519,6 +11519,62 @@ gfc_resolve_sync_stat (struct sync_stat *sync_stat)
 				  gfc_default_character_kind,
 				  sync_stat->errmsg);
 }
+
+static void
+resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
+			 gfc_expr *e)
+{
+  gfc_resolve_expr (e);
+  if (e
+      && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
+    gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
+	       name, &e->where, gfc_basic_typename (exp_type), exp_kind);
+}
+
+static void
+resolve_form_team (gfc_code *code)
+{
+  resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
+			   code->expr1);
+  resolve_team_argument (code->expr2);
+  resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
+			   code->expr3);
+  gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
+
+static void resolve_block_construct (gfc_code *);
+
+static void
+resolve_change_team (gfc_code *code)
+{
+  resolve_team_argument (code->expr1);
+  gfc_resolve_sync_stat (&code->ext.block.sync_stat);
+  resolve_block_construct (code);
+  /* Map the coarray bounds as selected.  */
+  for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
+    if (a->ar)
+      {
+	gfc_array_spec *src = a->ar->as, *dst;
+	if (a->st->n.sym->ts.type == BT_CLASS)
+	  dst = CLASS_DATA (a->st->n.sym)->as;
+	else
+	  dst = a->st->n.sym->as;
+	dst->corank = src->corank;
+	dst->cotype = src->cotype;
+	for (int i = 0; i < src->corank; ++i)
+	  {
+	    dst->lower[dst->rank + i] = src->lower[i];
+	    dst->upper[dst->rank + i] = src->upper[i];
+	    src->lower[i] = src->upper[i] = nullptr;
+	  }
+	gfc_free_array_spec (src);
+	free (a->ar);
+	a->ar = nullptr;
+	dst->resolved = false;
+	gfc_resolve_array_spec (dst, 0);
+      }
+}
+
 static void
 resolve_sync_team (gfc_code *code)
 {
@@ -11665,8 +11721,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 
   if (code->here == label)
     {
-      gfc_warning (0,
-		   "Branch at %L may result in an infinite loop", &code->loc);
+      gfc_warning (0, "Branch at %L may result in an infinite loop",
+		   &code->loc);
       return;
     }
 
@@ -11689,6 +11745,10 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 		   && bitmap_bit_p (stack->reachable_labels, label->value))
 	    gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
 		      "for label at %L", &code->loc, &label->where);
+	  else if (stack->current->op == EXEC_CHANGE_TEAM
+		   && bitmap_bit_p (stack->reachable_labels, label->value))
+	    gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
+		      "for label at %L", &code->loc, &label->where);
 	}
 
       return;
@@ -13325,23 +13385,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
 }
 
 
-static bool
-check_team (gfc_expr *team, const char *intrinsic)
-{
-  if (team->rank != 0
-      || team->ts.type != BT_DERIVED
-      || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
-      || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
-    {
-      gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
-		 "of type TEAM_TYPE", intrinsic, &team->where);
-      return false;
-    }
-
-  return true;
-}
-
-
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -13530,15 +13573,11 @@ start:
 	  break;
 
 	case EXEC_FORM_TEAM:
-	  if (code->expr1 != NULL
-	      && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
-	    gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
-		       "a scalar INTEGER", &code->expr1->where);
-	  check_team (code->expr2, "FORM TEAM");
+	  resolve_form_team (code);
 	  break;
 
 	case EXEC_CHANGE_TEAM:
-	  check_team (code->expr1, "CHANGE TEAM");
+	  resolve_change_team (code);
 	  break;
 
 	case EXEC_END_TEAM: