[gcc r17-2855] Fortran: Auto deallocate coarrays, allocated in team blocks [PR126205]

https://gcc.gnu.org/g:75be60856749d85ef29358e6ab4f3c48c128589c

commit r17-2855-g75be60856749d85ef29358e6ab4f3c48c128589c
Author: Paul Thomas <[email protected]>
Date:   Fri Jul 24 15:05:46 2026 +0100

    Fortran: Auto deallocate coarrays, allocated in team blocks [PR126205]
    
    Gfortran was not compliant with F2018(11.1.5.2), which requires that
    coarrays that are allocated within a team block are deallocated immediately
    before END TEAM.
    
    This the fourth variant of the patch; the main differences being whether
    the code is located on resolve.cc, split between resolve.cc and
    trans-stmt.cc or, as here, split between parse.cc, match.cc and st.cc.
    The main attraction of the latter scheme is that coarray.cc and
    resolve.cc do the main job of preparing the code for translation.
    
    The team context is tracked using a vector of team namespaces, which is
    pushed at CHANGE TEAM and popped at END TEAM. The allocate expressions
    are stashed in a vector hash_map, keyed on the namespace. The allocate
    expressions are stored while the ALLOCATE statments are being matched.
    They are then recovered before end in parse_change_team and sent off
    for automatic deallocation in st.cc(deallocate_allocated_coarrays.
    
    The use of st.cc for functions generating chunks of code is a pointer
    to something that I have been eyeing for a long time, which is to
    extract all such functions from class.cc and resolve.cc so that they
    can be refactored to use common chunks. This, however, is for another
    time!
    
    2026-07-24  Paul Thomas  <[email protected]>
    
    gcc/fortran
            PR fortran/126205
            * gfortran.h: Add prototype for deallocate_allocated_coarrays.
            hash_map team_allocated_coarrays, vector team_context_stack and
            prototype for get_current_team_context.
            * match.cc (gfc_match_allocate): Capture allocate expressions
            of allocatable coarrays and stash in team_allocated_coarrays.
            * parse.cc (parse_change_team): Push team context. When end is
            seen, create the code to deallocate allocated coarrays in this
            context, using deallocate_allocated_coarrays.
            * st.cc (get_guarded_dealloc): Generate code to produce
            IF (ALLOCATED (expr)) DEALLOCATE (expr).
            (deallocate_allocated_coarrays): Modify the final array ref of
            the allocate expressions and call get_guarded_dealloc.
    
    gcc/testsuite/
            PR fortran/126205
            * gfortran.dg/coarray/team_allocated_coarrays.f90: New test.

Diff:
---
 gcc/fortran/gfortran.h                             |   5 +-
 gcc/fortran/match.cc                               |  17 ++++
 gcc/fortran/parse.cc                               |  26 ++++++
 gcc/fortran/st.cc                                  |  97 +++++++++++++++++++
 .../coarray/team_allocated_coarrays.f90            | 104 +++++++++++++++++++++
 5 files changed, 248 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a5b2e035c847..807756d6a170 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4179,13 +4179,13 @@ bool has_parameterized_comps (gfc_symbol *);
 
 /* st.cc */
 extern gfc_code new_st;
-
 void gfc_clear_new_st (void);
 gfc_code *gfc_get_code (gfc_exec_op);
 gfc_code *gfc_append_code (gfc_code *, gfc_code *);
 void gfc_free_statement (gfc_code *);
 void gfc_free_statements (gfc_code *);
 void gfc_free_association_list (gfc_association_list *);
+void deallocate_allocated_coarrays (vec<gfc_expr *> *);
 
 /* resolve.cc */
 void gfc_resolve_symbol (gfc_symbol *);
@@ -4362,6 +4362,9 @@ void gfc_global_used (gfc_gsymbol *, locus *);
 gfc_namespace* gfc_build_block_ns (gfc_namespace *);
 gfc_statement match_omp_directive (void);
 bool is_omp_declarative_stmt (gfc_statement);
+extern hash_map<gfc_namespace *, vec<gfc_expr *>> team_allocated_coarrays;
+extern vec<gfc_namespace *> team_context_stack;
+gfc_namespace *get_current_team_context (void);
 
 /* dependency.cc */
 int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool);
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index b09d348e6b52..d61757046d26 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5443,6 +5443,23 @@ gfc_match_allocate (void)
 	  goto cleanup;
 	}
 
+      /* F2018(11.1.5.2): Track coarrays allocated in team blocks.  */
+      gfc_namespace *team_ns = get_current_team_context ();
+      bool codim = tail->expr->symtree->n.sym->attr.codimension
+		   || (tail->expr->symtree->n.sym->as
+		       && tail->expr->symtree->n.sym->as->corank);
+      for (gfc_ref *r = tail->expr->ref; r; r = r->next)
+	if (r->type == REF_COMPONENT && r->u.c.component)
+	  codim = r->u.c.component->attr.codimension
+		  || (r->u.c.component->as && r->u.c.component->as->corank);
+
+      if (flag_coarray == GFC_FCOARRAY_LIB && team_ns && codim)
+	{
+	  gfc_expr *e = gfc_copy_expr (tail->expr);
+	  vec<gfc_expr *> &allocated = team_allocated_coarrays.get_or_insert (team_ns);
+	  allocated.safe_push (e);
+	}
+
       if (gfc_match_char (',') != MATCH_YES)
 	break;
 
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index eeb988655131..c5d79bf2fd04 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5582,12 +5582,28 @@ loop:
   pop_state ();
 }
 
+
+/* F2018(11.1.5.2): Track coarrays allocated within CHANGE TEAM blocks.
+   Map from team namespace to vector of allocated coarray symbols.  */
+hash_map<gfc_namespace *, vec<gfc_expr *>> team_allocated_coarrays;
+
+/* Stack to track current CHANGE TEAM context.  */
+vec<gfc_namespace *> team_context_stack;
+
+gfc_namespace *
+get_current_team_context (void)
+{
+  return team_context_stack.is_empty () ? NULL : team_context_stack.last ();
+}
+
+
 static void
 parse_change_team (void)
 {
   gfc_namespace *my_ns;
   gfc_state_data s;
   gfc_statement st;
+  vec<gfc_expr *> *team_allocs;
 
   gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C");
 
@@ -5605,6 +5621,9 @@ parse_change_team (void)
   accept_statement (ST_CHANGE_TEAM);
   push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name);
 
+  /* Push team context for tracking coarrays allocated in a team block.  */
+  team_context_stack.safe_push (gfc_current_ns);
+
 loop:
   st = parse_executable (ST_NONE);
   switch (st)
@@ -5615,6 +5634,13 @@ loop:
     case_end:
       accept_statement (st);
       my_ns->code = gfc_state_stack->head;
+      /* F2018(11.1.5.2): Deallocate coarray expressions allocated in this
+	 team block,  */
+      team_allocs = team_allocated_coarrays.get (gfc_current_ns);
+      if (team_allocs)
+	deallocate_allocated_coarrays (team_allocs);
+      /* Pop team context.  */
+      team_context_stack.pop ();
       break;
 
     default:
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 4c7e274b72a5..b9c15b2d0f8e 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -369,3 +369,100 @@ gfc_free_association_list (gfc_association_list* assoc)
   gfc_free_association_list (assoc->next);
   free (assoc);
 }
+
+
+/* Function to generate IF (ALLOCATED(expr)) DEALLOCATE(expr)  */
+
+static gfc_code *
+get_guarded_dealloc (gfc_namespace *ns, gfc_expr *expr)
+{
+  gfc_code *dealloc = gfc_get_code (EXEC_IF);
+  dealloc->block = gfc_get_code (EXEC_IF);
+#define ALLOCATED dealloc->block->expr1
+  ALLOCATED = gfc_get_expr ();
+  ALLOCATED->expr_type = EXPR_FUNCTION;
+  ALLOCATED->where = gfc_current_locus;
+  gfc_find_sym_tree ("allocated", ns, 1, &ALLOCATED->symtree);
+  if (!ALLOCATED->symtree)
+    {
+      gfc_get_sym_tree ("allocated", ns, &ALLOCATED->symtree, false);
+      gfc_commit_symbol (ALLOCATED->symtree->n.sym);
+    }
+  ALLOCATED->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  ALLOCATED->symtree->n.sym->attr.intrinsic = 1;
+  ALLOCATED->symtree->n.sym->result = ALLOCATED->symtree->n.sym;
+  ALLOCATED->ts.type = BT_LOGICAL;
+  ALLOCATED->ts.kind = gfc_default_logical_kind;
+  ALLOCATED->value.function.isym
+			= gfc_intrinsic_function_by_id (GFC_ISYM_ALLOCATED);
+  ALLOCATED->value.function.actual = gfc_get_actual_arglist ();
+  ALLOCATED->value.function.actual->expr = gfc_copy_expr (expr);
+#undef ALLOCATED
+  dealloc->block->next = gfc_get_code (EXEC_DEALLOCATE);
+  dealloc->block->next->ext.alloc.list = gfc_get_alloc ();
+  dealloc->block->next->ext.alloc.list->expr = gfc_copy_expr (expr);
+  return dealloc;
+}
+
+
+/* F2018(11.1.5.2): Insert code to deallocate coarrays, allocated within a team
+   block. This uses the previous function to effect a guarded deallocation of
+   allocated coarray expressions. These are gathered in gfc_match_allocate and
+   stashed in team_allocs.  */
+
+void
+deallocate_allocated_coarrays (vec<gfc_expr *> *team_allocs)
+{
+  gfc_code *dealloc, *last_stmt;
+  gfc_ref *ref, *aref = NULL;
+  int i;
+
+  for (gfc_expr *e : *team_allocs)
+    {
+      if (!e)
+	continue;
+
+      /* Get the last array_ref right.  */
+      for (ref = e->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY)
+	  aref = ref;
+
+      if (aref->u.ar.as->rank)
+	{
+	  aref->u.ar.type = AR_FULL;
+	  aref->u.ar.dimen = aref->u.ar.as->rank;
+	  for (i = 0; i < aref->u.ar.dimen; i++)
+	    {
+	      aref->u.ar.dimen_type[i] = DIMEN_RANGE;
+
+	      if (aref->u.ar.start[i]) gfc_free_expr (aref->u.ar.start[i]);
+	      if (aref->u.ar.end[i]) gfc_free_expr (aref->u.ar.end[i]);
+	      if (aref->u.ar.stride[i]) gfc_free_expr (aref->u.ar.stride[i]);
+	      aref->u.ar.start[i] = aref->u.ar.end[i] = aref->u.ar.stride[i] = NULL;
+	    }
+	}
+
+      for (i = aref->u.ar.as->rank;
+	   i < aref->u.ar.as->rank + aref->u.ar.as->corank; i++)
+	 aref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
+
+      /* Insert the deallocation code before the END TEAM statement.  */
+      last_stmt = gfc_current_ns->code;
+      while (last_stmt)
+	{
+	  last_stmt = last_stmt->next;
+	  if (last_stmt->next->op == EXEC_END_TEAM || !last_stmt->next)
+	    {
+	      dealloc = get_guarded_dealloc (gfc_current_ns, e);
+	      if (dealloc)
+		{
+		  dealloc->next = last_stmt->next;
+		  last_stmt->next = dealloc;
+		  break;
+		}
+	    }
+	}
+      gfc_free_expr (e);
+      e = NULL;
+    }
+}
diff --git a/gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90 b/gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90
new file mode 100644
index 000000000000..4ecee7bbff48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90
@@ -0,0 +1,104 @@
+! { dg-do run }
+!
+! F2018(11.1.5.2): Test auto-deallocation of allocatable coarrays that are
+! allocated within a team block.
+!
+program test_nested_teams
+  use iso_fortran_env, only: team_type
+  implicit none
+  type(team_type) :: team1, team2
+  integer, allocatable :: a[:]
+  integer, allocatable :: b[:]
+  integer, allocatable :: outer[:]
+  integer, allocatable :: inner(:)[:] ! Rank and corank
+  logical :: image1
+  integer :: me
+
+  type :: mytype
+    integer, allocatable :: i[:]
+  end type
+  type(mytype) :: dt_a, dt_b, dt_outer, dt_inner
+
+  image1 = this_image () == 1
+  me = this_image ()
+
+  ! Test 1: Simple allocation in single team block
+  form team(1, team1)
+  change team(team1)
+    allocate(a[*])
+    a = 1
+    allocate(dt_a%i[*], source = me)
+  end team
+  if (image1 .and. allocated(a)) stop 1
+  if (image1 .and. allocated(dt_a%i)) stop 2
+
+  ! Test 2: Multiple allocations in single team block
+  form team(1, team1)
+  change team(team1)
+    allocate(a[*], b[*])
+    a = 1
+    b = 2
+    allocate(dt_a%i[*], dt_b%i[*], source = me)
+  end team
+  if (image1 .and. allocated(a)) stop 3
+  if (image1 .and. allocated(b)) stop 4
+  if (image1 .and. allocated(dt_a%i)) stop 5
+  if (image1 .and. allocated(dt_b%i)) stop 6
+
+  ! Test 3: Nested team blocks - allocation in outer team only
+  form team(1, team1)
+  change team(team1)
+    allocate(outer[*])
+    allocate(dt_outer%i[*], source = me)
+    outer = 10
+
+    ! Nested team with no allocations
+    form team(1, team2)
+    change team(team2)
+    end team
+
+    ! Make sure that auto-deallocation occurs in right context
+    if (image1 .and. .not.allocated(outer)) stop 7
+    if (image1 .and. .not.allocated(dt_outer%i)) stop 8
+
+  end team
+  if (image1 .and. allocated(outer)) stop 9
+  if (image1 .and. allocated(dt_outer%i)) stop 10
+
+  ! Test 4: Nested team blocks - allocation in inner team only
+  form team(1, team1)
+  change team(team1)
+
+    form team(1, team2)
+    change team(team2)
+      allocate(inner(4)[*])
+      inner = 20
+      allocate(dt_inner%i[*])
+    end team
+
+    if (image1 .and. allocated(inner)) stop 11
+    if (image1 .and. allocated(dt_inner%i)) stop 12
+  end team
+
+  ! Test 5: Nested team blocks - allocations in both levels
+  form team(1, team1)
+  change team(team1)
+    allocate(outer[*])
+    outer = 30
+    allocate(dt_outer%i[*], source = me)
+
+    form team(1, team2)
+    change team(team2)
+      allocate(inner(2)[*])
+      inner = 40
+      allocate(dt_inner%i[*], source = me)
+    end team
+
+    if (image1 .and. allocated(inner)) stop 13
+    if (image1 .and. allocated(dt_inner%i)) stop 14
+
+  end team
+  if (image1 .and. allocated(outer)) stop 15
+  if (image1 .and. allocated(dt_outer%i)) stop 16
+
+end program test_nested_teams