[gcc/devel/omp/gcc-16] Fortran/OpenMP: Split-off resolve_omp_allocate_clauses

https://gcc.gnu.org/g:7c3b4ed268209484a2928a6d85fce995008f1378

commit 7c3b4ed268209484a2928a6d85fce995008f1378
Author: Tobias Burnus <[email protected]>
Date:   Mon Jun 22 10:03:26 2026 +0200

    Fortran/OpenMP: Split-off resolve_omp_allocate_clauses
    
    Move the code for ALLOCATE clause checking out of resolve_omp_clauses into
    a new function. Additionally, the all-enclosing if condition block is
    replaced by an early return; likewise, an inner if condition block that
    stretched to the end of the outer one is replaced by a second early
    return. Hence, a lot of code could be shifted 4 or 8 columns to the left.
    
    Except for the re-indentation, the early exit changes to the two if
    conditions and to two variable declarations, the code is identical.
    
    gcc/fortran/ChangeLog:
    
            * openmp.cc (resolve_omp_allocate_clauses): New function for
            resolving 'allocate' clauses, splitt-off from ...
            (resolve_omp_clauses): ... here. Call the new function.
    
    Suggested-by: Julian Brown <[email protected]>
    (cherry picked from commit aa4a1608ea2744108ec62e7baba99c7fa99800ad)

Diff:
---
 gcc/fortran/openmp.cc | 463 ++++++++++++++++++++++++++------------------------
 1 file changed, 237 insertions(+), 226 deletions(-)

diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 3ca46aa62a4b..6072fbe47eb9 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -9206,6 +9206,242 @@ gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
 }
 
 
+/* Resolve the OpenMP ALLOCATE clauses.  */
+
+static void
+resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
+			      gfc_namespace *ns)
+{
+  gfc_omp_namelist *n;
+  enum gfc_omp_list_type list;
+
+  if (!omp_clauses->lists[OMP_LIST_ALLOCATE])
+    return;
+  for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+    {
+      if (n->u2.allocator
+	  && (!gfc_resolve_expr (n->u2.allocator)
+	      || n->u2.allocator->ts.type != BT_INTEGER
+	      || n->u2.allocator->rank != 0
+	      || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
+	{
+	  gfc_error ("Expected integer expression of the "
+		     "%<omp_allocator_handle_kind%> kind at %L",
+		     &n->u2.allocator->where);
+	  break;
+	}
+      if (!n->u.align)
+	continue;
+      HOST_WIDE_INT alignment = 0;
+      if (!gfc_resolve_expr (n->u.align)
+	  || n->u.align->ts.type != BT_INTEGER
+	  || n->u.align->rank != 0
+	  || n->u.align->expr_type != EXPR_CONSTANT
+	  || gfc_extract_hwi (n->u.align, &alignment)
+	  || alignment <= 0
+	  || !pow2p_hwi (alignment))
+	{
+	  gfc_error ("ALIGN requires a scalar positive constant integer "
+		     "alignment expression at %L that is a power of two",
+		     &n->u.align->where);
+	  break;
+	}
+    }
+
+  /* Check for 2 things here.
+      1.  There is no duplication of variable in allocate clause.
+      2.  Variable in allocate clause are also present in some
+	  privatization clase (non-composite case).  */
+  for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+    if (n->sym)
+      n->sym->mark = 0;
+
+  gfc_omp_namelist *prev = NULL;
+  for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
+    {
+      if (n->sym == NULL)
+	{
+	  n = n->next;
+	  continue;
+	}
+      if (n->sym->mark == 1)
+	{
+	  gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
+		       "%<allocate%> at %L" , n->sym->name, &n->where);
+	  /* We have already seen this variable so it is a duplicate.
+	     Remove it.  */
+	  if (prev != NULL && prev->next == n)
+	    {
+	      prev->next = n->next;
+	      n->next = NULL;
+	      gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
+	      n = prev->next;
+	    }
+	  continue;
+	}
+      n->sym->mark = 1;
+      prev = n;
+      n = n->next;
+    }
+
+  /* Non-composite constructs.  */
+  if (code && code->op < EXEC_OMP_DO_SIMD)
+    {
+      for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
+	   list = gfc_omp_list_type (list + 1))
+	switch (list)
+	  {
+	  case OMP_LIST_PRIVATE:
+	  case OMP_LIST_FIRSTPRIVATE:
+	  case OMP_LIST_LASTPRIVATE:
+	  case OMP_LIST_REDUCTION:
+	  case OMP_LIST_REDUCTION_INSCAN:
+	  case OMP_LIST_REDUCTION_TASK:
+	  case OMP_LIST_IN_REDUCTION:
+	  case OMP_LIST_TASK_REDUCTION:
+	  case OMP_LIST_LINEAR:
+	    for (n = omp_clauses->lists[list]; n; n = n->next)
+		 n->sym->mark = 0;
+	    break;
+	  default:
+	    break;
+	  }
+
+      for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+	if (n->sym->mark == 1)
+	  gfc_error ("%qs specified in %<allocate%> clause at %L but not "
+		     "in an explicit privatization clause",
+		     n->sym->name, &n->where);
+    }
+  if (!(code
+	&& (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
+	&& code->block
+	&& code->block->next
+	&& code->block->next->op == EXEC_ALLOCATE))
+    return;
+
+  if (code->op == EXEC_OMP_ALLOCATE)
+    gfc_warning (OPT_Wdeprecated_openmp,
+		 "The use of one or more %<allocate%> directives with "
+		 "an associated %<allocate%> statement at %L is "
+		 "deprecated since OpenMP 5.2, use an %<allocators%> "
+		 "directive", &code->loc);
+  gfc_alloc *a;
+  gfc_omp_namelist *n_null = NULL;
+  bool missing_allocator = false;
+  gfc_symbol *missing_allocator_sym = NULL;
+  for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+    {
+      if (n->u2.allocator == NULL)
+	{
+	  if (!missing_allocator_sym)
+	    missing_allocator_sym = n->sym;
+	  missing_allocator = true;
+	}
+      if (n->sym == NULL)
+	{
+	  n_null = n;
+	  continue;
+	}
+      if (n->sym->attr.codimension)
+	gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
+			   n->sym->name, &n->where);
+      for (a = code->block->next->ext.alloc.list; a; a = a->next)
+	if (a->expr->expr_type == EXPR_VARIABLE
+	    && a->expr->symtree->n.sym == n->sym)
+	  {
+	    gfc_ref *ref;
+	    for (ref = a->expr->ref; ref; ref = ref->next)
+	      if (ref->type == REF_COMPONENT)
+		break;
+	    if (ref == NULL)
+	      break;
+	  }
+      if (a == NULL)
+	gfc_error ("%qs specified in %<allocate%> at %L but not "
+		   "in the associated ALLOCATE statement",
+		   n->sym->name, &n->where);
+    }
+  /* If there is an ALLOCATE directive without list argument, a
+     namelist with its allocator/align clauses and n->sym = NULL is
+     created during parsing; here, we add all not otherwise specified
+     items from the Fortran allocate to that list.
+     For an ALLOCATORS directive, not listed items use the normal
+     Fortran way.
+     The behavior of an ALLOCATE directive that does not list all
+     arguments but there is no directive without list argument is not
+     well specified.  Thus, we reject such code below. In OpenMP 5.2
+     the executable ALLOCATE directive is deprecated and in 6.0
+     deleted such that no spec clarification is to be expected.  */
+  for (a = code->block->next->ext.alloc.list; a; a = a->next)
+    if (a->expr->expr_type == EXPR_VARIABLE)
+      {
+	for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+	  if (a->expr->symtree->n.sym == n->sym)
+	    {
+	      gfc_ref *ref;
+	      for (ref = a->expr->ref; ref; ref = ref->next)
+		if (ref->type == REF_COMPONENT)
+		  break;
+	      if (ref == NULL)
+		break;
+	    }
+	if (n == NULL && n_null == NULL)
+	  {
+	    /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
+		   that should use the default allocator of OpenMP or the
+		   Fortran allocator. Thus, just reject it.  */
+	    if (code->op == EXEC_OMP_ALLOCATE)
+	      gfc_error ("%qs listed in %<allocate%> statement at %L "
+			 "but it is neither explicitly in listed in "
+			 "the %<!$OMP ALLOCATE%> directive nor exists"
+			 " a directive without argument list",
+			 a->expr->symtree->n.sym->name,
+			 &a->expr->where);
+	    break;
+	  }
+	if (n == NULL)
+	  {
+	    if (a->expr->symtree->n.sym->attr.codimension)
+	      gfc_error ("Unexpected coarray %qs in %<allocate%> at "
+			 "%L, implicitly listed in %<!$OMP ALLOCATE%>"
+			 " at %L", a->expr->symtree->n.sym->name,
+			 &a->expr->where, &n_null->where);
+	    break;
+	  }
+      }
+  gfc_namespace *prog_unit = ns;
+  while (prog_unit->parent)
+    prog_unit = prog_unit->parent;
+  gfc_namespace *fn_ns = ns;
+  while (fn_ns)
+    {
+      if (ns->proc_name
+	  && (ns->proc_name->attr.subroutine
+	      || ns->proc_name->attr.function))
+	break;
+      fn_ns = fn_ns->parent;
+    }
+  if (missing_allocator
+      && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
+      && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
+	  || omp_clauses->contained_in_target_construct))
+    {
+      if (code->op == EXEC_OMP_ALLOCATORS)
+	gfc_error ("ALLOCATORS directive at %L inside a target region "
+		   "must specify an ALLOCATOR modifier for %qs",
+		   &code->loc, missing_allocator_sym->name);
+      else if (missing_allocator_sym)
+	gfc_error ("ALLOCATE directive at %L inside a target region "
+		   "must specify an ALLOCATOR clause for %qs",
+		   &code->loc, missing_allocator_sym->name);
+      else
+	gfc_error ("ALLOCATE directive at %L inside a target region "
+		   "must specify an ALLOCATOR clause", &code->loc);
+    }
+}
+
+
 /* OpenMP directive resolving routines.  */
 
 static void
@@ -9757,232 +9993,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 	n->sym->mark = 1;
     }
 
-  if (omp_clauses->lists[OMP_LIST_ALLOCATE])
-    {
-      for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
-	{
-	  if (n->u2.allocator
-	      && (!gfc_resolve_expr (n->u2.allocator)
-		  || n->u2.allocator->ts.type != BT_INTEGER
-		  || n->u2.allocator->rank != 0
-		  || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
-	    {
-	      gfc_error ("Expected integer expression of the "
-			 "%<omp_allocator_handle_kind%> kind at %L",
-			 &n->u2.allocator->where);
-	      break;
-	    }
-	  if (!n->u.align)
-	    continue;
-	  HOST_WIDE_INT alignment = 0;
-	  if (!gfc_resolve_expr (n->u.align)
-	      || n->u.align->ts.type != BT_INTEGER
-	      || n->u.align->rank != 0
-	      || n->u.align->expr_type != EXPR_CONSTANT
-	      || gfc_extract_hwi (n->u.align, &alignment)
-	      || alignment <= 0
-	      || !pow2p_hwi (alignment))
-	    {
-	      gfc_error ("ALIGN requires a scalar positive constant integer "
-			 "alignment expression at %L that is a power of two",
-			 &n->u.align->where);
-	      break;
-	    }
-	}
-
-      /* Check for 2 things here.
-	 1.  There is no duplication of variable in allocate clause.
-	 2.  Variable in allocate clause are also present in some
-	     privatization clase (non-composite case).  */
-      for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
-	if (n->sym)
-	  n->sym->mark = 0;
-
-      gfc_omp_namelist *prev = NULL;
-      for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
-	{
-	  if (n->sym == NULL)
-	    {
-	      n = n->next;
-	      continue;
-	    }
-	  if (n->sym->mark == 1)
-	    {
-	      gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
-			   "%<allocate%> at %L" , n->sym->name, &n->where);
-	      /* We have already seen this variable so it is a duplicate.
-		 Remove it.  */
-	      if (prev != NULL && prev->next == n)
-		{
-		  prev->next = n->next;
-		  n->next = NULL;
-		  gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
-		  n = prev->next;
-		}
-	      continue;
-	    }
-	  n->sym->mark = 1;
-	  prev = n;
-	  n = n->next;
-	}
-
-      /* Non-composite constructs.  */
-      if (code && code->op < EXEC_OMP_DO_SIMD)
-	{
-	  for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
-	       list = gfc_omp_list_type (list + 1))
-	    switch (list)
-	    {
-	      case OMP_LIST_PRIVATE:
-	      case OMP_LIST_FIRSTPRIVATE:
-	      case OMP_LIST_LASTPRIVATE:
-	      case OMP_LIST_REDUCTION:
-	      case OMP_LIST_REDUCTION_INSCAN:
-	      case OMP_LIST_REDUCTION_TASK:
-	      case OMP_LIST_IN_REDUCTION:
-	      case OMP_LIST_TASK_REDUCTION:
-	      case OMP_LIST_LINEAR:
-		for (n = omp_clauses->lists[list]; n; n = n->next)
-		  n->sym->mark = 0;
-		break;
-	      default:
-		break;
-	    }
-
-	  for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
-	    if (n->sym->mark == 1)
-	      gfc_error ("%qs specified in %<allocate%> clause at %L but not "
-			 "in an explicit privatization clause",
-			 n->sym->name, &n->where);
-	}
-      if (code
-	  && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
-	  && code->block
-	  && code->block->next
-	  && code->block->next->op == EXEC_ALLOCATE)
-	{
-	  if (code->op == EXEC_OMP_ALLOCATE)
-	    gfc_warning (OPT_Wdeprecated_openmp,
-			 "The use of one or more %<allocate%> directives with "
-			 "an associated %<allocate%> statement at %L is "
-			 "deprecated since OpenMP 5.2, use an %<allocators%> "
-			 "directive", &code->loc);
-	  gfc_alloc *a;
-	  gfc_omp_namelist *n_null = NULL;
-	  bool missing_allocator = false;
-	  gfc_symbol *missing_allocator_sym = NULL;
-	  for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
-	    {
-	      if (n->u2.allocator == NULL)
-		{
-		  if (!missing_allocator_sym)
-		    missing_allocator_sym = n->sym;
-		  missing_allocator = true;
-		}
-	      if (n->sym == NULL)
-		{
-		  n_null = n;
-		  continue;
-		}
-	      if (n->sym->attr.codimension)
-		gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
-			   n->sym->name, &n->where);
-	      for (a = code->block->next->ext.alloc.list; a; a = a->next)
-		if (a->expr->expr_type == EXPR_VARIABLE
-		  && a->expr->symtree->n.sym == n->sym)
-		  {
-		    gfc_ref *ref;
-		    for (ref = a->expr->ref; ref; ref = ref->next)
-		      if (ref->type == REF_COMPONENT)
-			break;
-		    if (ref == NULL)
-		      break;
-		  }
-	      if (a == NULL)
-		gfc_error ("%qs specified in %<allocate%> at %L but not "
-			   "in the associated ALLOCATE statement",
-			   n->sym->name, &n->where);
-	    }
-	  /* If there is an ALLOCATE directive without list argument, a
-	     namelist with its allocator/align clauses and n->sym = NULL is
-	     created during parsing; here, we add all not otherwise specified
-	     items from the Fortran allocate to that list.
-	     For an ALLOCATORS directive, not listed items use the normal
-	     Fortran way.
-	     The behavior of an ALLOCATE directive that does not list all
-	     arguments but there is no directive without list argument is not
-	     well specified.  Thus, we reject such code below. In OpenMP 5.2
-	     the executable ALLOCATE directive is deprecated and in 6.0
-	     deleted such that no spec clarification is to be expected.  */
-	  for (a = code->block->next->ext.alloc.list; a; a = a->next)
-	    if (a->expr->expr_type == EXPR_VARIABLE)
-	      {
-		for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
-		  if (a->expr->symtree->n.sym == n->sym)
-		    {
-		      gfc_ref *ref;
-		      for (ref = a->expr->ref; ref; ref = ref->next)
-			if (ref->type == REF_COMPONENT)
-			  break;
-		      if (ref == NULL)
-			break;
-		    }
-		if (n == NULL && n_null == NULL)
-		  {
-		    /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
-		       that should use the default allocator of OpenMP or the
-		       Fortran allocator. Thus, just reject it.  */
-		    if (code->op == EXEC_OMP_ALLOCATE)
-		      gfc_error ("%qs listed in %<allocate%> statement at %L "
-				 "but it is neither explicitly in listed in "
-				 "the %<!$OMP ALLOCATE%> directive nor exists"
-				 " a directive without argument list",
-				 a->expr->symtree->n.sym->name,
-				 &a->expr->where);
-		    break;
-		  }
-		if (n == NULL)
-		  {
-		    if (a->expr->symtree->n.sym->attr.codimension)
-		      gfc_error ("Unexpected coarray %qs in %<allocate%> at "
-				 "%L, implicitly listed in %<!$OMP ALLOCATE%>"
-				 " at %L", a->expr->symtree->n.sym->name,
-				 &a->expr->where, &n_null->where);
-		    break;
-		  }
-	    }
-	  gfc_namespace *prog_unit = ns;
-	  while (prog_unit->parent)
-	    prog_unit = prog_unit->parent;
-	  gfc_namespace *fn_ns = ns;
-	  while (fn_ns)
-	    {
-	      if (ns->proc_name
-		  && (ns->proc_name->attr.subroutine
-		      || ns->proc_name->attr.function))
-		break;
-	      fn_ns = fn_ns->parent;
-	    }
-	  if (missing_allocator
-	      && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
-	      && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
-		  || omp_clauses->contained_in_target_construct))
-	    {
-	      if (code->op == EXEC_OMP_ALLOCATORS)
-		gfc_error ("ALLOCATORS directive at %L inside a target region "
-			   "must specify an ALLOCATOR modifier for %qs",
-			   &code->loc, missing_allocator_sym->name);
-	      else if (missing_allocator_sym)
-		gfc_error ("ALLOCATE directive at %L inside a target region "
-			   "must specify an ALLOCATOR clause for %qs",
-			   &code->loc, missing_allocator_sym->name);
-	      else
-		gfc_error ("ALLOCATE directive at %L inside a target region "
-			   "must specify an ALLOCATOR clause", &code->loc);
-	    }
-
-	}
-    }
+  resolve_omp_allocate_clauses (code, omp_clauses, ns);
 
   /* OpenACC reductions.  */
   if (openacc)