[PATCH 1/5] [gfortran] Add parsing support for allocate directive (OpenMP 5.0).

[Hafiz Abid Qadeer <abidh@codesourcery.com>]

Currently we only make use of this directive when it is associated
with an allocate statement.

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
-- 
2.25.1