[PATCH 10/17] Add parsing support for allocate directive (OpenMP 5.0)

[Andrew Stubbs <ams@codesourcery.com>]

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


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

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (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.cc (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.cc (decode_omp_directive): Handle ST_OMP_ALLOCATE.
	(next_statement): Likewise.
	(gfc_ascii_statement): Likewise.
	* resolve.cc (gfc_resolve_code): Handle EXEC_OMP_ALLOCATE.
	* st.cc (gfc_free_statement): Likewise.
	* trans.cc (trans_code): Likewise
---
 gcc/fortran/dump-parse-tree.cc                |   3 +
 gcc/fortran/gfortran.h                        |   4 +-
 gcc/fortran/match.h                           |   1 +
 gcc/fortran/openmp.cc                         | 199 +++++++++++++++++-
 gcc/fortran/parse.cc                          |  10 +-
 gcc/fortran/resolve.cc                        |   1 +
 gcc/fortran/st.cc                             |   1 +
 gcc/fortran/trans.cc                          |   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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0010-Add-parsing-support-for-allocate-directive-OpenMP-5..patch --]
[-- Type: text/x-patch; name="0010-Add-parsing-support-for-allocate-directive-OpenMP-5..patch", Size: 20254 bytes --]

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 5352008a63d..e0c6c0d9d96 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2003,6 +2003,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;
@@ -2204,6 +2205,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)
@@ -3329,6 +3331,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 696aadd7db6..755469185a6 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,
@@ -1398,6 +1398,7 @@ enum
   OMP_LIST_USE_DEVICE_ADDR,
   OMP_LIST_NONTEMPORAL,
   OMP_LIST_ALLOCATE,
+  OMP_LIST_ALLOCATOR,
   OMP_LIST_HAS_DEVICE_ADDR,
   OMP_LIST_ENTER,
   OMP_LIST_NUM /* Must be the last.  */
@@ -2908,6 +2909,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 495c93e0b5c..fe43d4b3fd3 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.cc b/gcc/fortran/openmp.cc
index 91bf8a3c50d..38003890bb0 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -986,6 +986,7 @@ enum omp_mask2
   OMP_CLAUSE_FINALIZE,
   OMP_CLAUSE_ATTACH,
   OMP_CLAUSE_NOHOST,
+  OMP_CLAUSE_ALLOCATOR,
   OMP_CLAUSE_HAS_DEVICE_ADDR,  /* OpenMP 5.1  */
   OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
   /* This must come last.  */
@@ -3784,6 +3785,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	\
@@ -6001,6 +6003,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
@@ -6482,7 +6542,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", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER" };
+	"NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "ALLOCATOR" };
   STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
 
   if (omp_clauses == NULL)
@@ -9006,6 +9066,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:
@@ -9486,6 +9548,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)
@@ -9627,6 +9821,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.cc b/gcc/fortran/parse.cc
index 0b4c596996c..97d182d46ad 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -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);
@@ -1673,9 +1674,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: \
@@ -2352,6 +2353,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.cc b/gcc/fortran/resolve.cc
index 2ebf076f730..65f24b88067 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12368,6 +12368,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.cc b/gcc/fortran/st.cc
index 73f30c2137f..7b282e96c3d 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -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.cc b/gcc/fortran/trans.cc
index 912a206f2ed..a9d5714be22 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2174,6 +2174,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