Fortran/OpenMP: Add parsing support for allocators/allocate directives

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_omp_namelist): Update allocator, fix
	align dump.
	(show_omp_node, show_code_node): Handle EXEC_OMP_ALLOCATE.
	* gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE and ..._EXEC.
	(enum gfc_exec_op): Add EXEC_OMP_ALLOCATE.
	(struct gfc_omp_namelist): Add 'allocator' to 'u2' union.
	(struct gfc_namespace): Add omp_allocate.
	(gfc_resolve_omp_allocate): New.
	* match.cc (gfc_free_omp_namelist): Free 'u2.allocator'.
	* match.h (gfc_match_omp_allocate, gfc_match_omp_allocators): New.
	* openmp.cc (gfc_omp_directives): Uncomment allocate/allocators.
	(gfc_match_omp_variable_list): Add bool arg for
	rejecting listening common-block vars separately.
	(gfc_match_omp_clauses): Update for u2.allocators.
	(OMP_ALLOCATORS_CLAUSES, gfc_match_omp_allocate,
	gfc_match_omp_allocators, is_predefined_allocator,
	gfc_resolve_omp_allocate): New.
	(resolve_omp_clauses): Update 'allocate' clause checks.
	(omp_code_to_statement, gfc_resolve_omp_directive): Handle
	OMP ALLOCATE/ALLOCATORS.
	* parse.cc (in_exec_part): New global var.
	(check_omp_allocate_stmt, parse_openmp_allocate_block): New.
	(decode_omp_directive, case_exec_markers, case_omp_decl,
	gfc_ascii_statement, parse_omp_structured_block): Handle
	OMP allocate/allocators.
	(verify_st_order, parse_executable): Set in_exec_part.
	* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle
	allocate/allocators.
	* st.cc (gfc_free_statement): Likewise.
	* trans.cc (trans_code): Likewise.
	* trans-openmp.cc (gfc_trans_omp_directive): Likewise.
	(gfc_trans_omp_clauses, gfc_split_omp_clauses): Update for
	u2.allocator, fix for u.align.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/allocate-4.f90: Update dg-error.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/allocate-2.f90: Update dg-error.
	* gfortran.dg/gomp/allocate-4.f90: New test.
	* gfortran.dg/gomp/allocate-5.f90: New test.
	* gfortran.dg/gomp/allocate-6.f90: New test.
	* gfortran.dg/gomp/allocate-7.f90: New test.
	* gfortran.dg/gomp/allocators-1.f90: New test.
	* gfortran.dg/gomp/allocators-2.f90: New test.

1 files changed, 182 insertions, 2 deletions

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5e2a956..9730ab0 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -39,6 +39,7 @@ static jmp_buf eof_buf;
 
 gfc_state_data *gfc_state_stack;
 static bool last_was_use_stmt = false;
+bool in_exec_part;
 
 /* TODO: Re-order functions to kill these forward decls.  */
 static void check_statement_label (gfc_statement);
@@ -745,6 +746,82 @@ decode_oacc_directive (void)
   return ST_GET_FCN_CHARACTERISTICS;
 }
 
+/* Checks for the ST_OMP_ALLOCATE. First, check whether all list items
+   are allocatables/pointers - and if so, assume it is associated with a Fortran
+   ALLOCATE stmt.  If not, do some initial parsing-related checks and append
+   namelist to namespace.
+   The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP
+   construct before a directive associated with an allocate statement
+   (-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of
+   ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative.  */
+
+bool
+check_omp_allocate_stmt (locus *loc)
+{
+  gfc_omp_namelist *n;
+
+  if (new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
+    {
+      gfc_error ("%qs directive at %L must either have a variable argument or, "
+		 "if associated with an ALLOCATE stmt, must be preceded by an "
+		 "executable statement or OpenMP construct",
+		 gfc_ascii_statement (ST_OMP_ALLOCATE), loc);
+      return false;
+    }
+  bool has_allocatable = false;
+  bool has_non_allocatable = false;
+  for (n = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+    {
+      if (n->expr)
+	{
+	  gfc_error ("Structure-component expression at %L in %qs directive not"
+		     " permitted in declarative directive; as directive "
+		     "associated with an ALLOCATE stmt it must be preceded by "
+		     "an executable statement or OpenMP construct",
+		      &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
+	  return false;
+	}
+      bool alloc_ptr;
+      if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
+	alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
+		     || CLASS_DATA (n->sym)->attr.class_pointer);
+      else
+	alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer
+		     || n->sym->attr.proc_pointer);
+      if (alloc_ptr
+	  || (n->sym->ns && n->sym->ns->proc_name
+	      && (n->sym->ns->proc_name->attr.allocatable
+		  || n->sym->ns->proc_name->attr.pointer
+		  || n->sym->ns->proc_name->attr.proc_pointer)))
+	has_allocatable = true;
+      else
+	has_non_allocatable = true;
+    }
+  /* All allocatables - assume it is allocated with an ALLOCATE stmt.  */
+  if (has_allocatable && !has_non_allocatable)
+    {
+      gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be "
+		 "preceded by an executable statement or OpenMP construct; "
+		 "note the variables in the list all have the allocatable or "
+		 "pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE),
+		 loc);
+      return false;
+    }
+  if (!gfc_current_ns->omp_allocate)
+    gfc_current_ns->omp_allocate
+      = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+  else
+    {
+      for (n = gfc_current_ns->omp_allocate; n->next; n = n->next)
+	;
+      n->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+    }
+  new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
+  gfc_free_omp_clauses (new_st.ext.omp_clauses);
+  return true;
+}
+
+
 /* Like match, but set a flag simd_matched if keyword matched
    and if spec_only, goto do_spec_only without actually matching.  */
 #define matchs(keyword, subr, st)				\
@@ -885,6 +962,11 @@ decode_omp_directive (void)
   switch (c)
     {
     case 'a':
+      if (in_exec_part)
+	matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC);
+      else
+	matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
+      matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
       /* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
       if (!flag_openmp && gfc_match ("assumes") == MATCH_YES)
 	break;
@@ -918,6 +1000,7 @@ decode_omp_directive (void)
       break;
     case 'e':
       matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
+      matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
       matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
       matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
       matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
@@ -1174,6 +1257,9 @@ decode_omp_directive (void)
 	  return ST_NONE;
 	}
     }
+  if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus))
+    goto error_handling;
+
   switch (ret)
     {
     /* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET.
@@ -1723,7 +1809,7 @@ next_statement (void)
   case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
   case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
   case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
-  case ST_OMP_ASSUME: \
+  case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
   case ST_CRITICAL: \
   case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
   case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@@ -1741,7 +1827,7 @@ next_statement (void)
 
 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
   case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
-  case ST_OMP_DECLARE_VARIANT: case ST_OMP_ASSUMES: \
+  case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
   case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
 
 /* Block end statements.  Errors associated with interchanging these
@@ -2362,6 +2448,13 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
     case ST_OACC_END_ATOMIC:
       p = "!$ACC END ATOMIC";
       break;
+    case ST_OMP_ALLOCATE:
+    case ST_OMP_ALLOCATE_EXEC:
+      p = "!$OMP ALLOCATE";
+      break;
+    case ST_OMP_ALLOCATORS:
+      p = "!$OMP ALLOCATORS";
+      break;
     case ST_OMP_ASSUME:
       p = "!$OMP ASSUME";
       break;
@@ -2416,6 +2509,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
     case ST_OMP_DO_SIMD:
       p = "!$OMP DO SIMD";
       break;
+    case ST_OMP_END_ALLOCATORS:
+      p = "!$OMP END ALLOCATORS";
+      break;
     case ST_OMP_END_ASSUME:
       p = "!$OMP END ASSUME";
       break;
@@ -2983,6 +3079,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
     {
     case ST_NONE:
       p->state = ORDER_START;
+      in_exec_part = false;
       break;
 
     case ST_USE:
@@ -3056,6 +3153,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
     case_exec_markers:
       if (p->state < ORDER_EXEC)
 	p->state = ORDER_EXEC;
+      in_exec_part = true;
       break;
 
     default:
@@ -5532,6 +5630,77 @@ parse_oacc_loop (gfc_statement acc_st)
 }
 
 
+/* Parse an OpenMP allocate block, including optional ALLOCATORS
+   end directive.  */
+
+static gfc_statement
+parse_openmp_allocate_block (gfc_statement omp_st)
+{
+  gfc_statement st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+  bool empty_list = false;
+  locus empty_list_loc;
+  gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+
+  if (omp_st == ST_OMP_ALLOCATE_EXEC
+      && new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
+    {
+      empty_list = true;
+      empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+    }
+
+  accept_statement (omp_st);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+
+  st = next_statement ();
+  while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC)
+    {
+      if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
+	{
+	  locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+	  gfc_error_now ("%s statements at %L and %L have both no list item but"
+			 " only one may", gfc_ascii_statement (st),
+			 &empty_list_loc, loc);
+	  empty_list = false;
+	}
+      if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
+	{
+	  empty_list = true;
+	  empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+	}
+      for ( ; n_first->next; n_first = n_first->next)
+	;
+      n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+      new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
+      gfc_free_omp_clauses (new_st.ext.omp_clauses);
+
+      accept_statement (ST_NONE);
+      st = next_statement ();
+    }
+  if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC)
+    gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
+		   gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
+  else if (st != ST_ALLOCATE)
+    gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
+		   gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
+  accept_statement (st);
+  pop_state ();
+  st = next_statement ();
+  if (omp_st == ST_OMP_ALLOCATORS && st == ST_OMP_END_ALLOCATORS)
+    {
+      accept_statement (st);
+      st = next_statement ();
+    }
+  return st;
+}
+
+
 /* Parse the statements of an OpenMP structured block.  */
 
 static gfc_statement
@@ -5687,6 +5856,11 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 		  parse_forall_block ();
 		  break;
 
+		case ST_OMP_ALLOCATE_EXEC:
+		case ST_OMP_ALLOCATORS:
+		  st = parse_openmp_allocate_block (st);
+		  continue;
+
 		case ST_OMP_ASSUME:
 		case ST_OMP_PARALLEL:
 		case ST_OMP_PARALLEL_MASKED:
@@ -5819,6 +5993,7 @@ static gfc_statement
 parse_executable (gfc_statement st)
 {
   int close_flag;
+  in_exec_part = true;
 
   if (st == ST_NONE)
     st = next_statement ();
@@ -5929,6 +6104,11 @@ parse_executable (gfc_statement st)
 	  parse_oacc_structured_block (st);
 	  break;
 
+	case ST_OMP_ALLOCATE_EXEC:
+	case ST_OMP_ALLOCATORS:
+	  st = parse_openmp_allocate_block (st);
+	  continue;
+
 	case ST_OMP_ASSUME:
 	case ST_OMP_PARALLEL:
 	case ST_OMP_PARALLEL_MASKED: