[og12] Fix 'omp_allocator_handle_kind' example in 'gfortran.dg/gomp/allocate-4.f90' (was: [PATCH 1/5] [gfortran] Add parsing support for allocate directive (OpenMP 5.0).)

[Thomas Schwinge <thomas@codesourcery.com>]

[-- Attachment #1: Type: text/plain, Size: 27265 bytes --]

Hi!

On 2022-01-13T14:53:16+0000, Hafiz Abid Qadeer <abidh@codesourcery.com> wrote:
> Currently we only make use of this directive when it is associated
> with an allocate statement.

These changes (or a variant thereof; haven't checked)
are present on devel/omp/gcc-12 branch as
commit 491478d12b83e102f72858e8a871a25c951df293
"Add parsing support for allocate directive (OpenMP 5.0)".


I've noticed that while this new test case
'gfortran.dg/gomp/allocate-4.f90':

> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
> @@ -0,0 +1,112 @@
> +! { dg-do compile }
> +
> +module test
> +  integer, allocatable :: mvar1
> +  integer, allocatable :: mvar2
> +  integer, allocatable :: mvar3
> +end module
> +
> +subroutine foo(x, y)
> +  use omp_lib
> +  implicit none
> +  integer  :: x
> +  integer  :: y
> +
> +  integer, allocatable :: var1(:)
> +  integer, allocatable :: var2(:)
> +  integer, allocatable :: var3(:)
> +  integer, allocatable :: var4(:)
> +  integer, allocatable :: var5(:)
> +  integer, allocatable :: var6(:)
> +  integer, allocatable :: var7(:)
> +  integer, allocatable :: var8(:)
> +  integer, allocatable :: var9(:)
> +
> +  !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
> +  allocate (var1(x))
> +
> +  !$omp allocate (var2)  ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
> +  allocate (var3(x))
> +[...]

... is all-PASS for x86_64-pc-linux-gnu (default) '-m64' testing, is does
have one FAIL for '-m32' testing: 'test for errors, line 25'.  Here's the
'diff':

    @@ -1,8 +1,3 @@
    -source-gcc/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90:25:34:
    -
    -   25 |   !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
    -      |                                  1
    -Error: Expected integer expression of the ‘omp_allocator_handle_kind’ kind at (1)
     source-gcc/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90:28:130:

        28 |   !$omp allocate (var2)  ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }

OK to push to devel/omp/gcc-12 branch the attached
"Fix 'omp_allocator_handle_kind' example in 'gfortran.dg/gomp/allocate-4.f90'",
or is a different solution called for?


Grüße
 Thomas


> gcc/fortran/ChangeLog:
>
>       * dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_ALLOCATE.
>       (show_code_node): Likewise.
>       * gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE.
>       (OMP_LIST_ALLOCATOR): New enum value.
>       (enum gfc_exec_op): Add EXEC_OMP_ALLOCATE.
>       * match.h (gfc_match_omp_allocate): New function.
>       * openmp.c (enum omp_mask1): Add OMP_CLAUSE_ALLOCATOR.
>       (OMP_ALLOCATE_CLAUSES): New define.
>       (gfc_match_omp_allocate): New function.
>       (resolve_omp_clauses): Add ALLOCATOR in clause_names.
>       (omp_code_to_statement): Handle EXEC_OMP_ALLOCATE.
>       (EMPTY_VAR_LIST): New define.
>       (check_allocate_directive_restrictions): New function.
>       (gfc_resolve_omp_allocate): Likewise.
>       (gfc_resolve_omp_directive): Handle EXEC_OMP_ALLOCATE.
>       * parse.c (decode_omp_directive): Handle ST_OMP_ALLOCATE.
>       (next_statement): Likewise.
>       (gfc_ascii_statement): Likewise.
>       * resolve.c (gfc_resolve_code): Handle EXEC_OMP_ALLOCATE.
>       * st.c (gfc_free_statement): Likewise.
>       * trans.c (trans_code): Likewise
>
> gcc/testsuite/ChangeLog:
>
>       * gfortran.dg/gomp/allocate-4.f90: New test.
>       * gfortran.dg/gomp/allocate-5.f90: New test.
> ---
>  gcc/fortran/dump-parse-tree.c                 |   3 +
>  gcc/fortran/gfortran.h                        |   4 +-
>  gcc/fortran/match.h                           |   1 +
>  gcc/fortran/openmp.c                          | 199 +++++++++++++++++-
>  gcc/fortran/parse.c                           |  10 +-
>  gcc/fortran/resolve.c                         |   1 +
>  gcc/fortran/st.c                              |   1 +
>  gcc/fortran/trans.c                           |   1 +
>  gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 112 ++++++++++
>  gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 |  73 +++++++
>  10 files changed, 400 insertions(+), 5 deletions(-)
>  create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
>  create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
>
> diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
> index 7459f4b89a9..38fef42150a 100644
> --- a/gcc/fortran/dump-parse-tree.c
> +++ b/gcc/fortran/dump-parse-tree.c
> @@ -1993,6 +1993,7 @@ show_omp_node (int level, gfc_code *c)
>      case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
>      case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
>      case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
> +    case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break;
>      case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
>      case EXEC_OMP_BARRIER: name = "BARRIER"; break;
>      case EXEC_OMP_CANCEL: name = "CANCEL"; break;
> @@ -2194,6 +2195,7 @@ show_omp_node (int level, gfc_code *c)
>        || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
>        || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
>        || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
> +      || c->op == EXEC_OMP_ALLOCATE
>        || (c->op == EXEC_OMP_ORDERED && c->block == NULL))
>      return;
>    if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
> @@ -3314,6 +3316,7 @@ show_code_node (int level, gfc_code *c)
>      case EXEC_OACC_CACHE:
>      case EXEC_OACC_ENTER_DATA:
>      case EXEC_OACC_EXIT_DATA:
> +    case EXEC_OMP_ALLOCATE:
>      case EXEC_OMP_ATOMIC:
>      case EXEC_OMP_CANCEL:
>      case EXEC_OMP_CANCELLATION_POINT:
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 3b791a4f6be..79a43a2fdf0 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -259,7 +259,7 @@ enum gfc_statement
>    ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP,
>    ST_OACC_SERIAL_LOOP, ST_OACC_END_SERIAL_LOOP, ST_OACC_SERIAL,
>    ST_OACC_END_SERIAL, ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE,
> -  ST_OACC_ATOMIC, ST_OACC_END_ATOMIC,
> +  ST_OACC_ATOMIC, ST_OACC_END_ATOMIC, ST_OMP_ALLOCATE,
>    ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC,
>    ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED,
>    ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
> @@ -1392,6 +1392,7 @@ enum
>    OMP_LIST_USE_DEVICE_PTR,
>    OMP_LIST_USE_DEVICE_ADDR,
>    OMP_LIST_NONTEMPORAL,
> +  OMP_LIST_ALLOCATOR,
>    OMP_LIST_NUM
>  };
>
> @@ -2893,6 +2894,7 @@ enum gfc_exec_op
>    EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE,
>    EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA,
>    EXEC_OACC_ATOMIC, EXEC_OACC_DECLARE,
> +  EXEC_OMP_ALLOCATE,
>    EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
>    EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
>    EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
> diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
> index 65ee3b6cb41..9f0449eda0e 100644
> --- a/gcc/fortran/match.h
> +++ b/gcc/fortran/match.h
> @@ -149,6 +149,7 @@ match gfc_match_oacc_routine (void);
>
>  /* OpenMP directive matchers.  */
>  match gfc_match_omp_eos_error (void);
> +match gfc_match_omp_allocate (void);
>  match gfc_match_omp_atomic (void);
>  match gfc_match_omp_barrier (void);
>  match gfc_match_omp_cancel (void);
> diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
> index 86c412a4334..ee7c39980bb 100644
> --- a/gcc/fortran/openmp.c
> +++ b/gcc/fortran/openmp.c
> @@ -921,6 +921,7 @@ enum omp_mask1
>    OMP_CLAUSE_FAIL,  /* OpenMP 5.1.  */
>    OMP_CLAUSE_WEAK,  /* OpenMP 5.1.  */
>    OMP_CLAUSE_NOWAIT,
> +  OMP_CLAUSE_ALLOCATOR,
>    /* This must come last.  */
>    OMP_MASK1_LAST
>  };
> @@ -3568,6 +3569,7 @@ cleanup:
>  }
>
>
> +#define OMP_ALLOCATE_CLAUSES (omp_mask (OMP_CLAUSE_ALLOCATOR))
>  #define OMP_PARALLEL_CLAUSES \
>    (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE           \
>     | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION    \
> @@ -5762,6 +5764,64 @@ gfc_match_omp_ordered_depend (void)
>    return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
>  }
>
> +/* omp allocate (list) [clause-list]
> +   - clause-list:  allocator
> +*/
> +
> +match
> +gfc_match_omp_allocate (void)
> +{
> +  gfc_omp_clauses *c = gfc_get_omp_clauses ();
> +  gfc_expr *allocator = NULL;
> +  match m;
> +
> +  m = gfc_match (" (");
> +  if (m == MATCH_YES)
> +    {
> +      m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATOR],
> +                                    true, NULL);
> +
> +      if (m != MATCH_YES)
> +     {
> +       /* If the list was empty, we must find closing ')'.  */
> +       m = gfc_match (")");
> +       if (m != MATCH_YES)
> +         return m;
> +     }
> +    }
> +
> +  if (gfc_match (" allocator ( ") == MATCH_YES)
> +    {
> +      m = gfc_match_expr (&allocator);
> +      if (m != MATCH_YES)
> +     {
> +       gfc_error ("Expected allocator at %C");
> +       return MATCH_ERROR;
> +     }
> +      if (gfc_match (" ) ") != MATCH_YES)
> +     {
> +       gfc_error ("Expected ')' at %C");
> +       gfc_free_expr (allocator);
> +       return MATCH_ERROR;
> +     }
> +    }
> +
> +  if (gfc_match_omp_eos () != MATCH_YES)
> +    {
> +      gfc_free_expr (allocator);
> +      gfc_error ("Unexpected junk after $OMP allocate at %C");
> +      return MATCH_ERROR;
> +    }
> +  gfc_omp_namelist *n;
> +  for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next)
> +      n->expr = gfc_copy_expr (allocator);
> +
> +  new_st.op = EXEC_OMP_ALLOCATE;
> +  new_st.ext.omp_clauses = c;
> +  gfc_free_expr (allocator);
> +  return MATCH_YES;
> +}
> +
>
>  /* omp atomic [clause-list]
>     - atomic-clause:  read | write | update
> @@ -6243,7 +6303,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
>       "IN_REDUCTION", "TASK_REDUCTION",
>       "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
>       "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
> -     "NONTEMPORAL" };
> +     "NONTEMPORAL", "ALLOCATOR" };
>    STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
>
>    if (omp_clauses == NULL)
> @@ -8507,6 +8567,8 @@ omp_code_to_statement (gfc_code *code)
>  {
>    switch (code->op)
>      {
> +    case EXEC_OMP_ALLOCATE:
> +      return ST_OMP_ALLOCATE;
>      case EXEC_OMP_PARALLEL:
>        return ST_OMP_PARALLEL;
>      case EXEC_OMP_PARALLEL_MASKED:
> @@ -8987,6 +9049,138 @@ gfc_resolve_oacc_routines (gfc_namespace *ns)
>      }
>  }
>
> +static void
> +check_allocate_directive_restrictions (gfc_symbol *sym, gfc_expr *omp_al,
> +                                    gfc_namespace *ns, locus loc)
> +{
> +  if (sym->attr.save != SAVE_NONE || sym->attr.in_common == 1
> +      || sym->module != NULL)
> +    {
> +      int tmp;
> +      /*  Assumption here is that we can extract an integer then
> +       it is a predefined thing.  */
> +      if (!omp_al || gfc_extract_int (omp_al, &tmp))
> +       gfc_error ("%qs should use predefined allocator at %L", sym->name,
> +                  &loc);
> +    }
> +  if (ns != sym->ns)
> +    gfc_error ("%qs is not in the same scope as %<allocate%>"
> +            " directive at %L", sym->name, &loc);
> +}
> +
> +#define EMPTY_VAR_LIST(node) \
> +  (node->ext.omp_clauses->lists[OMP_LIST_ALLOCATOR] == NULL)
> +
> +static void
> +gfc_resolve_omp_allocate (gfc_code *code, gfc_namespace *ns)
> +{
> +  gfc_alloc *al;
> +  gfc_omp_namelist *n = NULL;
> +  gfc_omp_namelist *cn = NULL;
> +  gfc_omp_namelist *p, *tail;
> +  gfc_code *cur;
> +  hash_set<gfc_symbol*> vars;
> +
> +  gfc_omp_clauses *clauses = code->ext.omp_clauses;
> +  gcc_assert (clauses);
> +  cn = clauses->lists[OMP_LIST_ALLOCATOR];
> +  gfc_expr *omp_al = cn ? cn->expr : NULL;
> +
> +  if (omp_al && (omp_al->ts.type != BT_INTEGER
> +      || omp_al->ts.kind != gfc_c_intptr_kind))
> +    gfc_error ("Expected integer expression of the "
> +            "%<omp_allocator_handle_kind%> kind at %L", &omp_al->where);
> +
> +  /* Check that variables in this allocate directive are not duplicated
> +     in this directive or others coming directly after it.  */
> +  for (cur = code; cur != NULL && cur->op == EXEC_OMP_ALLOCATE;
> +      cur = cur->next)
> +    {
> +      gfc_omp_clauses *c = cur->ext.omp_clauses;
> +      gcc_assert (c);
> +      for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next)
> +     {
> +       if (vars.contains (n->sym))
> +         gfc_error ("%qs is used in multiple %<allocate%> "
> +                    "directives at %L", n->sym->name, &cur->loc);
> +       /* This helps us avoid duplicate error messages.  */
> +       if (cur == code)
> +         vars.add (n->sym);
> +     }
> +    }
> +
> +  if (cur == NULL || cur->op != EXEC_ALLOCATE)
> +    {
> +      /*  There is no allocate statement right after allocate directive.
> +       We don't support this case at the moment.  */
> +      for (n = cn; n != NULL; n = n->next)
> +     {
> +       gfc_symbol *sym = n->sym;
> +       if (sym->attr.allocatable == 1)
> +         gfc_error ("%qs with ALLOCATABLE attribute is not allowed in "
> +                    "%<allocate%> directive at %L as this directive is not"
> +                    " associated with an %<allocate%> statement.",
> +                    sym->name, &code->loc);
> +     }
> +      sorry_at (code->loc.lb->location, "%<allocate%> directive that is "
> +             "not associated with an %<allocate%> statement is not "
> +             "supported.");
> +      return;
> +    }
> +
> +  /* If there is another allocate directive right after this one, check
> +     that none of them is empty.  Doing it this way, we can check this
> +     thing even when multiple directives are together and generate
> +     error at right location.  */
> +  if (code->next && code->next->op == EXEC_OMP_ALLOCATE
> +      && (EMPTY_VAR_LIST (code) || EMPTY_VAR_LIST (code->next)))
> +    gfc_error ("Empty variable list is not allowed at %L when multiple "
> +            "%<allocate%> directives are associated with an "
> +            "%<allocate%> statement.",
> +            EMPTY_VAR_LIST (code) ? &code->loc : &code->next->loc);
> +
> +  if (EMPTY_VAR_LIST (code))
> +    {
> +      /* Empty namelist means allocate directive applies to all
> +      variables in allocate statement.  'cur' points to associated
> +      allocate statement.  */
> +      for (al = cur->ext.alloc.list; al != NULL; al = al->next)
> +     if (al->expr && al->expr->symtree && al->expr->symtree->n.sym)
> +       {
> +         check_allocate_directive_restrictions (al->expr->symtree->n.sym,
> +                                                omp_al, ns, code->loc);
> +         p = gfc_get_omp_namelist ();
> +         p->sym = al->expr->symtree->n.sym;
> +         p->expr = omp_al;
> +         p->where = code->loc;
> +         if (cn == NULL)
> +           cn = tail = p;
> +         else
> +           {
> +             tail->next = p;
> +             tail = tail->next;
> +           }
> +       }
> +      clauses->lists[OMP_LIST_ALLOCATOR]= cn;
> +    }
> +  else
> +    {
> +      for (n = cn; n != NULL; n = n->next)
> +     {
> +       for (al = cur->ext.alloc.list; al != NULL; al = al->next)
> +         if (al->expr && al->expr->symtree && al->expr->symtree->n.sym
> +             && al->expr->symtree->n.sym == n->sym)
> +           break;
> +       if (al == NULL)
> +         gfc_error ("%qs in %<allocate%> directive at %L is not present "
> +                    "in associated %<allocate%> statement.",
> +                    n->sym->name, &code->loc);
> +       check_allocate_directive_restrictions (n->sym, omp_al, ns,
> +                                              code->loc);
> +     }
> +    }
> +}
> +
>
>  void
>  gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
> @@ -9128,6 +9322,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
>        code->ext.omp_clauses->if_present = false;
>        resolve_omp_clauses (code, code->ext.omp_clauses, ns);
>        break;
> +    case EXEC_OMP_ALLOCATE:
> +      gfc_resolve_omp_allocate (code, ns);
> +      break;
>      default:
>        break;
>      }
> diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
> index c04ad774f25..fda36433129 100644
> --- a/gcc/fortran/parse.c
> +++ b/gcc/fortran/parse.c
> @@ -886,6 +886,7 @@ decode_omp_directive (void)
>      {
>      case 'a':
>        matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
> +      matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
>        break;
>      case 'b':
>        matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
> @@ -1672,9 +1673,9 @@ next_statement (void)
>    case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
>    case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
>    case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
> -  case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
> -  case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
> -  case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
> +  case ST_OMP_ALLOCATE: case ST_ERROR_STOP: case ST_OMP_SCAN: \
> +  case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: \
> +  case ST_UNLOCK: case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
>    case ST_END_TEAM: case ST_SYNC_TEAM: \
>    case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
>    case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
> @@ -2351,6 +2352,9 @@ gfc_ascii_statement (gfc_statement st)
>      case ST_OACC_END_ATOMIC:
>        p = "!$ACC END ATOMIC";
>        break;
> +    case ST_OMP_ALLOCATE:
> +      p = "!$OMP ALLOCATE";
> +      break;
>      case ST_OMP_ATOMIC:
>        p = "!$OMP ATOMIC";
>        break;
> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 43eeefee07f..991cd4fe874 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c
> @@ -12306,6 +12306,7 @@ start:
>         gfc_resolve_oacc_directive (code, ns);
>         break;
>
> +     case EXEC_OMP_ALLOCATE:
>       case EXEC_OMP_ATOMIC:
>       case EXEC_OMP_BARRIER:
>       case EXEC_OMP_CANCEL:
> diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
> index 73f30c2137f..7b282e96c3d 100644
> --- a/gcc/fortran/st.c
> +++ b/gcc/fortran/st.c
> @@ -214,6 +214,7 @@ gfc_free_statement (gfc_code *p)
>      case EXEC_OACC_ENTER_DATA:
>      case EXEC_OACC_EXIT_DATA:
>      case EXEC_OACC_ROUTINE:
> +    case EXEC_OMP_ALLOCATE:
>      case EXEC_OMP_ATOMIC:
>      case EXEC_OMP_CANCEL:
>      case EXEC_OMP_CANCELLATION_POINT:
> diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
> index 26f0815b5ea..a2248c83623 100644
> --- a/gcc/fortran/trans.c
> +++ b/gcc/fortran/trans.c
> @@ -2140,6 +2140,7 @@ trans_code (gfc_code * code, tree cond)
>         res = gfc_trans_dt_end (code);
>         break;
>
> +     case EXEC_OMP_ALLOCATE:
>       case EXEC_OMP_ATOMIC:
>       case EXEC_OMP_BARRIER:
>       case EXEC_OMP_CANCEL:
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
> new file mode 100644
> index 00000000000..3f512d66495
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
> @@ -0,0 +1,112 @@
> +! { dg-do compile }
> +
> +module test
> +  integer, allocatable :: mvar1
> +  integer, allocatable :: mvar2
> +  integer, allocatable :: mvar3
> +end module
> +
> +subroutine foo(x, y)
> +  use omp_lib
> +  implicit none
> +  integer  :: x
> +  integer  :: y
> +
> +  integer, allocatable :: var1(:)
> +  integer, allocatable :: var2(:)
> +  integer, allocatable :: var3(:)
> +  integer, allocatable :: var4(:)
> +  integer, allocatable :: var5(:)
> +  integer, allocatable :: var6(:)
> +  integer, allocatable :: var7(:)
> +  integer, allocatable :: var8(:)
> +  integer, allocatable :: var9(:)
> +
> +  !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
> +  allocate (var1(x))
> +
> +  !$omp allocate (var2)  ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
> +  allocate (var3(x))
> +
> +  !$omp allocate (x) ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." }
> +  x = 2
> +
> +  !$omp allocate (var4) ! { dg-error "'var4' with ALLOCATABLE attribute is not allowed in 'allocate' directive at .1. as this directive is not associated with an 'allocate' statement." }
> +  ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." "" { target *-*-* } .-1 }
> +  y = 2
> +
> +  !$omp allocate (var5)
> +  !$omp allocate  ! { dg-error "Empty variable list is not allowed at .1. when multiple 'allocate' directives are associated with an 'allocate' statement." }
> +  allocate (var5(x))
> +
> +  !$omp allocate (var6)
> +  !$omp allocate (var7)  ! { dg-error "'var7' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
> +  !$omp allocate (var8)  ! { dg-error "'var8' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
> +  allocate (var6(x))
> +
> +  !$omp allocate (var9)
> +  !$omp allocate (var9)  ! { dg-error "'var9' is used in multiple 'allocate' directives at .1." }
> +  allocate (var9(x))
> +
> +end subroutine
> +
> +function outer(a)
> +  IMPLICIT NONE
> +
> +  integer :: outer, a
> +  integer, allocatable :: var1
> +
> +  outer = inner(a) + 5
> +  return
> +
> +  contains
> +
> +    integer function inner(x)
> +    integer :: x
> +    integer, allocatable :: var2
> +
> +    !$omp allocate (var1, var2) ! { dg-error "'var1' is not in the same scope as 'allocate' directive at .1." }
> +    allocate (var1, var2)
> +
> +    inner = x + 10
> +    return
> +    end function inner
> +
> +end function outer
> +
> +subroutine bar(s)
> +  use omp_lib
> +  use test
> +  integer  :: s
> +  integer, save, allocatable :: svar1
> +  integer, save, allocatable :: svar2
> +  integer, save, allocatable :: svar3
> +
> +  type (omp_alloctrait) :: traits(3)
> +  integer (omp_allocator_handle_kind) :: a
> +
> +  traits = [omp_alloctrait (omp_atk_alignment, 64), &
> +            omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
> +            omp_alloctrait (omp_atk_pool_size, 8192)]
> +  a = omp_init_allocator (omp_default_mem_space, 3, traits)
> +  if (a == omp_null_allocator) stop 1
> +
> +  !$omp allocate (mvar1) allocator(a) ! { dg-error "'mvar1' should use predefined allocator at .1." }
> +  allocate (mvar1)
> +
> +  !$omp allocate (mvar2) ! { dg-error "'mvar2' should use predefined allocator at .1." }
> +  allocate (mvar2)
> +
> +  !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc)
> +  allocate (mvar3)
> +
> +  !$omp allocate (svar1)  allocator(a) ! { dg-error "'svar1' should use predefined allocator at .1." }
> +  allocate (svar1)
> +
> +  !$omp allocate (svar2) ! { dg-error "'svar2' should use predefined allocator at .1." }
> +  allocate (svar2)
> +
> +  !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc)
> +  allocate (svar3)
> +end subroutine
> +
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
> new file mode 100644
> index 00000000000..761b6dede28
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
> @@ -0,0 +1,73 @@
> +! { dg-do compile }
> +
> +module omp_lib_kinds
> +  use iso_c_binding, only: c_int, c_intptr_t
> +  implicit none
> +  private :: c_int, c_intptr_t
> +  integer, parameter :: omp_allocator_handle_kind = c_intptr_t
> +
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_null_allocator = 0
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_default_mem_alloc = 1
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_large_cap_mem_alloc = 2
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_const_mem_alloc = 3
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_high_bw_mem_alloc = 4
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_low_lat_mem_alloc = 5
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_cgroup_mem_alloc = 6
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_pteam_mem_alloc = 7
> +  integer (kind=omp_allocator_handle_kind), &
> +     parameter :: omp_thread_mem_alloc = 8
> +end module
> +
> +subroutine foo(x, y)
> +  use omp_lib_kinds
> +  implicit none
> +  integer  :: x
> +  integer  :: y
> +
> +  integer, allocatable :: var1(:)
> +  integer, allocatable :: var2(:)
> +  integer, allocatable :: var3(:)
> +  integer, allocatable :: var4(:,:)
> +  integer, allocatable :: var5(:)
> +  integer, allocatable :: var6(:)
> +  integer, allocatable :: var7(:)
> +  integer, allocatable :: var8(:)
> +  integer, allocatable :: var9(:)
> +  integer, allocatable :: var10(:)
> +  integer, allocatable :: var11(:)
> +  integer, allocatable :: var12(:)
> +
> +  !$omp allocate (var1) allocator(omp_default_mem_alloc)
> +  allocate (var1(x))
> +
> +  !$omp allocate (var2)
> +  allocate (var2(x))
> +
> +  !$omp allocate (var3, var4) allocator(omp_large_cap_mem_alloc)
> +  allocate (var3(x),var4(x,y))
> +
> +  !$omp allocate()
> +  allocate (var5(x))
> +
> +  !$omp allocate
> +  allocate (var6(x))
> +
> +  !$omp allocate () allocator(omp_default_mem_alloc)
> +  allocate (var7(x))
> +
> +  !$omp allocate allocator(omp_default_mem_alloc)
> +  allocate (var8(x))
> +
> +  !$omp allocate (var9) allocator(omp_default_mem_alloc)
> +  !$omp allocate (var10) allocator(omp_large_cap_mem_alloc)
> +  allocate (var9(x), var10(x))
> +
> +end subroutine


-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

[-- Attachment #2: 0001-Fix-omp_allocator_handle_kind-example-in-gfortr.og12.patch --]
[-- Type: text/x-diff, Size: 3777 bytes --]

From e07fb2a36377a6504dda088f0a1c5185ff51d652 Mon Sep 17 00:00:00 2001
From: Thomas Schwinge <thomas@codesourcery.com>
Date: Wed, 1 Feb 2023 12:30:28 +0100
Subject: [PATCH] Fix 'omp_allocator_handle_kind' example in
 'gfortran.dg/gomp/allocate-4.f90'
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

I've noticed that while 'gfortran.dg/gomp/allocate-4.f90' is all-PASS for
x86_64-pc-linux-gnu (default) '-m64' testing, it does have one FAIL for
'-m32' testing: 'test for errors, line 25'.  Here's the 'diff':

    @@ -1,8 +1,3 @@
    -source-gcc/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90:25:34:
    -
    -   25 |   !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
    -      |                                  1
    -Error: Expected integer expression of the ‘omp_allocator_handle_kind’ kind at (1)
     source-gcc/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90:28:130:

        28 |   !$omp allocate (var2)  ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }

I understand that's due to an "accidental" non-match vs. match of
'10' vs. 'omp_allocator_handle_kind' ('c_intptr_t') data types:

> --- a/gcc/fortran/openmp.c
> +++ b/gcc/fortran/openmp.c

> +static void
> +gfc_resolve_omp_allocate (gfc_code *code, gfc_namespace *ns)
> +{
> +  gfc_alloc *al;
> +  gfc_omp_namelist *n = NULL;
> +  gfc_omp_namelist *cn = NULL;
> +  gfc_omp_namelist *p, *tail;
> +  gfc_code *cur;
> +  hash_set<gfc_symbol*> vars;
> +
> +  gfc_omp_clauses *clauses = code->ext.omp_clauses;
> +  gcc_assert (clauses);
> +  cn = clauses->lists[OMP_LIST_ALLOCATOR];
> +  gfc_expr *omp_al = cn ? cn->expr : NULL;
> +
> +  if (omp_al && (omp_al->ts.type != BT_INTEGER
> +      || omp_al->ts.kind != gfc_c_intptr_kind))
> +    gfc_error ("Expected integer expression of the "
> +	       "%<omp_allocator_handle_kind%> kind at %L", &omp_al->where);

    $ git grep -i parameter.\*omp_allocator_handle_kind -- libgomp/omp_lib.*
    libgomp/omp_lib.f90.in:        integer, parameter :: omp_allocator_handle_kind = c_intptr_t
    libgomp/omp_lib.h.in:      parameter (omp_allocator_handle_kind = @INTPTR_T_KIND@)

Fix-up for og12 commit 491478d12b83e102f72858e8a871a25c951df293
"Add parsing support for allocate directive (OpenMP 5.0)".

	gcc/testsuite/
	* gfortran.dg/gomp/allocate-4.f90: Fix 'omp_allocator_handle_kind'
	example.
---
 gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
index 3f512d66495..c9b9c3f6c1d 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
@@ -22,7 +22,12 @@ subroutine foo(x, y)
   integer, allocatable :: var8(:)
   integer, allocatable :: var9(:)
 
-  !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
+  ! Don't do this (..., but it does pass the checks).
+  !$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+  allocate (var1(x))
+
+  ! Assumtion is that 'omp_allocator_handle_kind' ('c_intptr_t') isn't 1.
+  !$omp allocate (var1) allocator(10_1) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
   allocate (var1(x))
 
   !$omp allocate (var2)  ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
-- 
2.25.1