backport: re PR fortran/46752 (OpenMP - Seg fault for unallocated allocatable array in firstprivate clause)

Merge from gomp-3_1-branch branch:

2011-08-02  Jakub Jelinek  <jakub@redhat.com>

gcc/
	* c-parser.c (enum c_parser_prec): New enum, moved from within
	c_parser_binary_expression.
	(c_parser_binary_expression): Add PREC argument.  Stop parsing
	if operator has lower or equal precedence than PREC.
	(c_parser_conditional_expression, c_parser_omp_for_loop): Adjust
	callers.
	(c_parser_omp_atomic): Handle parsing OpenMP 3.1 atomics.
	Adjust c_finish_omp_atomic caller.
	(c_parser_omp_taskyield): New function.
	(c_parser_pragma): Handle PRAGMA_OMP_TASKYIELD.
	(c_parser_omp_clause_name): Handle final and mergeable clauses.
	(c_parser_omp_clause_final, c_parser_omp_clause_mergeable): New
	functions.
	(c_parser_omp_all_clauses): Handle PRAGMA_OMP_CLAUSE_FINAL
	and PRAGMA_OMP_CLAUSE_MERGEABLE.
	(OMP_TASK_CLAUSE_MASK): Allow final and mergeable clauses.
	(c_parser_omp_clause_reduction): Handle min and max.
	* c-typeck.c (c_finish_omp_clauses): Don't complain about
	const qualified predetermined vars in firstprivate clause.
	andle OMP_CLAUSE_FINAL and OMP_CLAUSE_MERGEABLE.
	Handle MIN_EXPR and MAX_EXPR.
	* tree-pretty-print.c (dump_omp_clause): Handle OMP_CLAUSE_FINAL
	and OMP_CLAUSE_MERGEABLE.
	(dump_generic_node): Handle OMP_ATOMIC_READ, OMP_ATOMIC_CAPTURE_OLD
	and OMP_ATOMIC_CAPTURE_NEW.
	* tree.c (omp_clause_num_ops): Add OMP_CLAUSE_FINAL and
	OMP_CLAUSE_MERGEABLE.
	(omp_clause_code_name): Likewise.
	(walk_tree_1): Handle OMP_CLAUSE_FINAL and OMP_CLAUSE_MERGEABLE.
	* tree.h (enum omp_clause_code): Add OMP_CLAUSE_FINAL
	and OMP_CLAUSE_MERGEABLE.
	(OMP_CLAUSE_FINAL_EXPR): Define.
	* omp-low.c (scan_sharing_clauses): Handle OMP_CLAUSE_FINAL and
	OMP_CLAUSE_MERGEABLE.
	(expand_task_call): Likewise.
	(expand_omp_atomic_load, expand_omp_atomic_store): New functions.
	(expand_omp_atomic_fetch_op): Handle cases where old or new
	value is needed afterwards.
	(expand_omp_atomic): Call expand_omp_atomic_load resp.
	expand_omp_atomic_store.
	* gimplify.c (gimplify_omp_atomic, gimplify_expr): Handle
	OMP_ATOMIC_READ, OMP_ATOMIC_CAPTURE_OLD and OMP_ATOMIC_CAPTURE_NEW.
	(gimplify_scan_omp_clauses, gimplify_adjust_omp_clauses): Handle
	OMP_CLAUSE_FINAL and OMP_CLAUSE_MERGEABLE.
	* tree-nested.c (convert_nonlocal_omp_clauses,
	convert_local_omp_clauses): Likewise.
	* tree.def (OMP_ATOMIC_READ, OMP_ATOMIC_CAPTURE_OLD,
	OMP_ATOMIC_CAPTURE_NEW): New.
	* gimple.h (GF_OMP_ATOMIC_NEED_VALUE): New.
	(gimple_omp_atomic_need_value_p, gimple_omp_atomic_set_need_value):
	New inlines.
	* omp-builtins.def (BUILT_IN_GOMP_TASKYIELD): New builtin.
	* doc/generic.texi: Mention OMP_CLAUSE_COLLAPSE,
	OMP_CLAUSE_UNTIED, OMP_CLAUSE_FINAL and OMP_CLAUSE_MERGEABLE.
gcc/c-family/
	* c-common.h (c_finish_omp_atomic): Adjust prototype.
	(c_finish_omp_taskyield): New prototype.
	* c-omp.c (c_finish_omp_atomic): Add OPCODE, V, LHS1 and RHS1
	arguments. Handle OMP_ATOMIC_READ, OMP_ATOMIC_CAPTURE_OLD and
	OMP_ATOMIC_CAPTURE_NEW in addition to OMP_ATOMIC.  If LHS1
	or RHS1 have side-effects, evaluate those too in the right spot,
	if it is a decl and LHS is also a decl, error out if they
	aren't the same.
	(c_finish_omp_taskyield): New function.
	* c-cppbuiltin.c (c_cpp_builtins): Change _OPENMP to 201107.
	* c-pragma.c (omp_pragmas): Add taskyield.
	* c-pragma.h (enum pragma_kind): Add PRAGMA_OMP_TASKYIELD.
	(enum pragma_omp_clause): Add PRAGMA_OMP_CLAUSE_FINAL and
	PRAGMA_OMP_CLAUSE_MERGEABLE.
gcc/cp/
	* cp-tree.h (finish_omp_atomic): Adjust prototype.
	(cxx_omp_const_qual_no_mutable): New prototype.
	(finish_omp_taskyield): New prototype.
	* parser.c (cp_parser_omp_atomic): (cp_parser_omp_atomic): Handle
	parsing OpenMP 3.1 atomics.  Adjust finish_omp_atomic caller.
	(cp_parser_omp_clause_name): Handle final and mergeable clauses.
	(cp_parser_omp_clause_final, cp_parser_omp_clause_mergeable): New
	functions.
	(cp_parser_omp_all_clauses): Handle PRAGMA_OMP_CLAUSE_FINAL
	and PRAGMA_OMP_CLAUSE_MERGEABLE.
	(OMP_TASK_CLAUSE_MASK): Allow final and mergeable clauses.
	(cp_parser_omp_taskyield): New function.
	(cp_parser_pragma): Handle PRAGMA_OMP_TASKYIELD.
	(cp_parser_omp_clause_reduction): Handle min and max.
	* pt.c (tsubst_expr) <case OMP_ATOMIC>: Handle OpenMP 3.1 atomics.
	(tsubst_omp_clauses): Handle OMP_CLAUSE_FINAL and
	OMP_CLAUSE_MERGEABLE.
	* semantics.c (finish_omp_atomic): Add OPCODE, V, LHS1 and RHS1
	arguments.  Handle OpenMP 3.1 atomics.  Adjust c_finish_omp_atomic
	caller.
	(finish_omp_clauses): Don't complain about const qualified
	predetermined vars and static data members in firstprivate clause.
	Handle OMP_CLAUSE_FINAL and OMP_CLAUSE_MERGEABLE. Handle MIN_EXPR
	and MAX_EXPR.
	(finish_omp_taskyield): New function.
	* cp-gimplify.c (cxx_omp_const_qual_no_mutable): New function.
	(cxx_omp_predetermined_sharing): Use it.
gcc/fortran/
	PR fortran/46752
	* cpp.c (cpp_define_builtins): Change _OPENMP to 201107.
	* openmp.c (gfc_free_omp_clauses): Free also final_expr.
	(OMP_CLAUSE_FINAL, OMP_CLAUSE_MERGEABLE): Define.
	(gfc_match_omp_clauses): Handle parsing final and mergeable
	clauses.
	(OMP_TASK_CLAUSES): Allow final and mergeable clauses.
	(gfc_match_omp_taskyield): New function.
	(resolve_omp_clauses): Resolve final clause.  Allow POINTERs and
	Cray pointers in clauses other than REDUCTION.
	(gfc_match_omp_atomic): Match optional
	read/write/update/capture keywords after !$omp atomic.
	(resolve_omp_atomic): Handle all OpenMP 3.1 atomic forms.
	* dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_TASKYIELD,
	print final and mergeable clauses.
	(show_code_node): Handle EXEC_OMP_TASKYIELD.
	* trans-openmp.c (gfc_trans_omp_clauses): Handle final and
	mergeable clauses.
	(gfc_trans_omp_taskyield): New function.
	(gfc_trans_omp_directive): Handle EXEC_OMP_TASKYIELD.
	(gfc_trans_omp_atomic): Handle all OpenMP 3.1 atomic forms.
	(gfc_omp_clause_copy_ctor): Handle non-allocated allocatable.
	(gfc_omp_predetermined_sharing): Adjust comment.
	* gfortran.h (gfc_statement): Add ST_OMP_TASKYIELD and
	ST_OMP_END_ATOMIC.
	(gfc_omp_clauses): Add final_expr and mergeable fields.
	(gfc_exec_op): Add EXEC_OMP_TASKYIELD.
	(gfc_omp_atomic_op): New enum typedef.
	(struct gfc_code): Add ext.omp_atomic.
	* trans.c (trans_code): Handle EXEC_OMP_TASKYIELD.
	* frontend-passes.c (gfc_code_walker): Also walk final_expr.
	* resolve.c (gfc_resolve_blocks, resolve_code): Handle
	EXEC_OMP_TASKYIELD.
	* st.c (gfc_free_statement): Likewise.
	* match.h (gfc_match_omp_taskyield): New prototype.
	* parse.c (decode_omp_directive): Handle taskyield directive.
	Handle !$omp end atomic.
	(case_executable): Add ST_OMP_TASKYIELD case.
	(gfc_ascii_statement): Handle ST_OMP_TASKYIELD.
	(parse_omp_atomic): Return gfc_statement instead of void.
	For !$omp atomic capture parse two assignments instead of
	just one and require !$omp end atomic afterwards, for
	other !$omp atomic forms just allow !$omp end atomic at the
	end.
	(parse_omp_structured_block, parse_executable): Adjust
	parse_omp_atomic callers.

2011-08-02  Tobias Burnus  <burnus@net-b.de>

	* intrinsic.c (OMP_LIB): Updated openmp_version's
	value to 201107.
	* gfortran.texi (OpenMP): Update ref to OpenMP 3.1.
	* intrinsic.texi (OpenMP Modules): Update ref to OpenMP 3.1;
	remove deleted omp_integer_kind and omp_logical_kind constants.
gcc/testsuite/
	PR fortran/46752
	* gcc.dg/gomp/atomic-5.c: Adjust expected diagnostics.
	* gcc.dg/gomp/atomic-15.c: New test.
	* g++.dg/gomp/atomic-5.C: Adjust expected diagnostics.
	* g++.dg/gomp/atomic-15.C: New test.
	* g++.dg/gomp/private-1.C: New test.
	* g++.dg/gomp/sharing-2.C: New test.
	* gfortran.dg/gomp/crayptr1.f90: Don't expect error
	about Cray pointer in FIRSTPRIVATE/LASTPRIVATE.
	* gfortran.dg/gomp/omp_atomic2.f90: New test.
libgomp/
	PR fortran/42041
	PR fortran/46752
	* omp.h.in (omp_in_final): New prototype.
	* omp_lib.f90.in (omp_in_final): New interface.
	(omp_integer_kind, omp_logical_kind): Remove
	and replace all its uses in the module with 4.
	(openmp_version): Change to 201107.
	* omp_lib.h.in (omp_sched_static, omp_sched_dynamic,
	omp_sched_guided, omp_sched_auto): Use omp_sched_kind
	kind for the parameters.
	(omp_in_final): New external.
	(openmp_version): Change to 201107.
	* task.c (omp_in_final): New function.
	(gomp_init_task): Initialize final_task.
	(GOMP_task): Remove unused attribute from flags.  Handle final
	tasks.
	(GOMP_taskyield): New function.
	(omp_in_final): Return true if if (false) or final (true) task
	or descendant of final (true).
	* fortran.c (omp_in_final_): New function.
	* libgomp.map (OMP_3.1): Export omp_in_final and omp_in_final_.
	(GOMP_3.0): Export GOMP_taskyield.
	* env.c (gomp_nthreads_var_list, gomp_nthreads_var_list_len): New
	variables.
	(parse_unsigned_long_list): New function.
	(initialize_env): Use it for OMP_NUM_THREADS.  Call parse_boolean
	with "OMP_PROC_BIND".  If OMP_PROC_BIND=true, call gomp_init_affinity
	even if parse_affinity returned false.
	* config/linux/affinity.c (gomp_init_affinity): Handle
	gomp_cpu_affinity_len == 0.
	* libgomp_g.h (GOMP_taskyield): New prototype.
	* libgomp.h (struct gomp_task): Add final_task field.
	(gomp_nthreads_var_list, gomp_nthreads_var_list_len): New externs.
	* team.c (gomp_team_start): Override new task's nthreads_var icv
	if list form OMP_NUM_THREADS has been used and it has value for
	the new nesting level.

	* testsuite/libgomp.c/atomic-11.c: New test.
	* testsuite/libgomp.c/atomic-12.c: New test.
	* testsuite/libgomp.c/atomic-13.c: New test.
	* testsuite/libgomp.c/atomic-14.c: New test.
	* testsuite/libgomp.c/reduction-6.c: New test.
	* testsuite/libgomp.c/task-5.c: New test.
	* testsuite/libgomp.c++/atomic-2.C: New test.
	* testsuite/libgomp.c++/atomic-3.C: New test.
	* testsuite/libgomp.c++/atomic-4.C: New test.
	* testsuite/libgomp.c++/atomic-5.C: New test.
	* testsuite/libgomp.c++/atomic-6.C: New test.
	* testsuite/libgomp.c++/atomic-7.C: New test.
	* testsuite/libgomp.c++/atomic-8.C: New test.
	* testsuite/libgomp.c++/atomic-9.C: New test.
	* testsuite/libgomp.c++/task-8.C: New test.
	* testsuite/libgomp.c++/reduction-4.C: New test.
	* testsuite/libgomp.fortran/allocatable7.f90: New test.
	* testsuite/libgomp.fortran/allocatable8.f90: New test.
	* testsuite/libgomp.fortran/crayptr3.f90: New test.
	* testsuite/libgomp.fortran/omp_atomic3.f90: New test.
	* testsuite/libgomp.fortran/omp_atomic4.f90: New test.
	* testsuite/libgomp.fortran/pointer1.f90: New test.
	* testsuite/libgomp.fortran/pointer2.f90: New test.
	* testsuite/libgomp.fortran/task4.f90: New test.

2011-08-02  Tobias Burnus  <burnus@net-b.de>

	* libgomp.texi: Update OpenMP spec references to 3.1.
	(omp_in_final,OMP_PROC_BIND): New sections.
	(OMP_NUM_THREADS): Document that the value can be now a list.
	(GOMP_STACKSIZE,GOMP_CPU_AFFINITY): Update @ref.

From-SVN: r177194

1 files changed, 191 insertions, 10 deletions

diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 69a6bca..f5a5877 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1,5 +1,5 @@
 /* OpenMP directive matching and resolving.
-   Copyright (C) 2005, 2006, 2007, 2008, 2010
+   Copyright (C) 2005, 2006, 2007, 2008, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Jakub Jelinek
 
@@ -66,6 +66,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
     return;
 
   gfc_free_expr (c->if_expr);
+  gfc_free_expr (c->final_expr);
   gfc_free_expr (c->num_threads);
   gfc_free_expr (c->chunk_size);
   for (i = 0; i < OMP_LIST_NUM; i++)
@@ -182,6 +183,8 @@ cleanup:
 #define OMP_CLAUSE_ORDERED	(1 << 11)
 #define OMP_CLAUSE_COLLAPSE	(1 << 12)
 #define OMP_CLAUSE_UNTIED	(1 << 13)
+#define OMP_CLAUSE_FINAL	(1 << 14)
+#define OMP_CLAUSE_MERGEABLE	(1 << 15)
 
 /* Match OpenMP directive clauses. MASK is a bitmask of
    clauses that are allowed for a particular directive.  */
@@ -205,6 +208,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
       if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
 	  && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
 	continue;
+      if ((mask & OMP_CLAUSE_FINAL) && c->final_expr == NULL
+	  && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
+	continue;
       if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
 	  && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
 	continue;
@@ -383,6 +389,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
 	  c->untied = needs_space = true;
 	  continue;
 	}
+      if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
+	  && gfc_match ("mergeable") == MATCH_YES)
+	{
+	  c->mergeable = needs_space = true;
+	  continue;
+	}
       if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
 	{
 	  gfc_expr *cexpr = NULL;
@@ -435,7 +447,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
 #define OMP_TASK_CLAUSES \
   (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED	\
-   | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
+   | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED		\
+   | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE)
 
 match
 gfc_match_omp_parallel (void)
@@ -476,6 +489,20 @@ gfc_match_omp_taskwait (void)
 
 
 match
+gfc_match_omp_taskyield (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_error ("Unexpected junk after TASKYIELD clause at %C");
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_TASKYIELD;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+
+match
 gfc_match_omp_critical (void)
 {
   char n[GFC_MAX_SYMBOL_LEN+1];
@@ -700,13 +727,22 @@ gfc_match_omp_ordered (void)
 match
 gfc_match_omp_atomic (void)
 {
+  gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
+  if (gfc_match ("% update") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_UPDATE;
+  else if (gfc_match ("% read") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_READ;
+  else if (gfc_match ("% write") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_WRITE;
+  else if (gfc_match ("% capture") == MATCH_YES)
+    op = GFC_OMP_ATOMIC_CAPTURE;
   if (gfc_match_omp_eos () != MATCH_YES)
     {
       gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
       return MATCH_ERROR;
     }
   new_st.op = EXEC_OMP_ATOMIC;
-  new_st.ext.omp_clauses = NULL;
+  new_st.ext.omp_atomic = op;
   return MATCH_YES;
 }
 
@@ -783,6 +819,14 @@ resolve_omp_clauses (gfc_code *code)
 	gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
 		   &expr->where);
     }
+  if (omp_clauses->final_expr)
+    {
+      gfc_expr *expr = omp_clauses->final_expr;
+      if (gfc_resolve_expr (expr) == FAILURE
+	  || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+	gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
+		   &expr->where);
+    }
   if (omp_clauses->num_threads)
     {
       gfc_expr *expr = omp_clauses->num_threads;
@@ -940,15 +984,20 @@ resolve_omp_clauses (gfc_code *code)
 			    n->sym->name, name, &code->loc);
 		if (list != OMP_LIST_PRIVATE)
 		  {
-		    if (n->sym->attr.pointer)
+		    if (n->sym->attr.pointer
+			&& list >= OMP_LIST_REDUCTION_FIRST
+			&& list <= OMP_LIST_REDUCTION_LAST)
 		      gfc_error ("POINTER object '%s' in %s clause at %L",
 				 n->sym->name, name, &code->loc);
 		    /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
-		    if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
-		        n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
+		    if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
+			 && n->sym->ts.type == BT_DERIVED
+			 && n->sym->ts.u.derived->attr.alloc_comp)
 		      gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
 				 name, n->sym->name, &code->loc);
-		    if (n->sym->attr.cray_pointer)
+		    if (n->sym->attr.cray_pointer
+			&& list >= OMP_LIST_REDUCTION_FIRST
+			&& list <= OMP_LIST_REDUCTION_LAST)
 		      gfc_error ("Cray pointer '%s' in %s clause at %L",
 				 n->sym->name, name, &code->loc);
 		  }
@@ -1095,12 +1144,18 @@ is_conversion (gfc_expr *expr, bool widening)
 static void
 resolve_omp_atomic (gfc_code *code)
 {
+  gfc_code *atomic_code = code;
   gfc_symbol *var;
-  gfc_expr *expr2;
+  gfc_expr *expr2, *expr2_tmp;
 
   code = code->block->next;
   gcc_assert (code->op == EXEC_ASSIGN);
-  gcc_assert (code->next == NULL);
+  gcc_assert ((atomic_code->ext.omp_atomic != GFC_OMP_ATOMIC_CAPTURE
+	       && code->next == NULL)
+	      || (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE
+		  && code->next != NULL
+		  && code->next->op == EXEC_ASSIGN
+		  && code->next->next == NULL));
 
   if (code->expr1->expr_type != EXPR_VARIABLE
       || code->expr1->symtree == NULL
@@ -1118,7 +1173,86 @@ resolve_omp_atomic (gfc_code *code)
   var = code->expr1->symtree->n.sym;
   expr2 = is_conversion (code->expr2, false);
   if (expr2 == NULL)
-    expr2 = code->expr2;
+    {
+      if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_READ
+	  || atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+	expr2 = is_conversion (code->expr2, true);
+      if (expr2 == NULL)
+	expr2 = code->expr2;
+    }
+
+  switch (atomic_code->ext.omp_atomic)
+    {
+    case GFC_OMP_ATOMIC_READ:
+      if (expr2->expr_type != EXPR_VARIABLE
+	  || expr2->symtree == NULL
+	  || expr2->rank != 0
+	  || (expr2->ts.type != BT_INTEGER
+	      && expr2->ts.type != BT_REAL
+	      && expr2->ts.type != BT_COMPLEX
+	      && expr2->ts.type != BT_LOGICAL))
+	gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
+		   "variable of intrinsic type at %L", &expr2->where);
+      return;
+    case GFC_OMP_ATOMIC_WRITE:
+      if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
+	gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
+		   "must be scalar and cannot reference var at %L",
+		   &expr2->where);
+      return;
+    case GFC_OMP_ATOMIC_CAPTURE:
+      expr2_tmp = expr2;
+      if (expr2 == code->expr2)
+	{
+	  expr2_tmp = is_conversion (code->expr2, true);
+	  if (expr2_tmp == NULL)
+	    expr2_tmp = expr2;
+	}
+      if (expr2_tmp->expr_type == EXPR_VARIABLE)
+	{
+	  if (expr2_tmp->symtree == NULL
+	      || expr2_tmp->rank != 0
+	      || (expr2_tmp->ts.type != BT_INTEGER
+		  && expr2_tmp->ts.type != BT_REAL
+		  && expr2_tmp->ts.type != BT_COMPLEX
+		  && expr2_tmp->ts.type != BT_LOGICAL)
+	      || expr2_tmp->symtree->n.sym == var)
+	    {
+	      gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
+			 "a scalar variable of intrinsic type at %L",
+			 &expr2_tmp->where);
+	      return;
+	    }
+	  var = expr2_tmp->symtree->n.sym;
+	  code = code->next;
+	  if (code->expr1->expr_type != EXPR_VARIABLE
+	      || code->expr1->symtree == NULL
+	      || code->expr1->rank != 0
+	      || (code->expr1->ts.type != BT_INTEGER
+		  && code->expr1->ts.type != BT_REAL
+		  && code->expr1->ts.type != BT_COMPLEX
+		  && code->expr1->ts.type != BT_LOGICAL))
+	    {
+	      gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
+			 "a scalar variable of intrinsic type at %L",
+			 &code->expr1->where);
+	      return;
+	    }
+	  if (code->expr1->symtree->n.sym != var)
+	    {
+	      gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
+			 "different variable than update statement writes "
+			 "into at %L", &code->expr1->where);
+	      return;
+	    }
+	  expr2 = is_conversion (code->expr2, false);
+	  if (expr2 == NULL)
+	    expr2 = code->expr2;
+	}
+      break;
+    default:
+      break;
+    }
 
   if (expr2->expr_type == EXPR_OP)
     {
@@ -1320,6 +1454,53 @@ resolve_omp_atomic (gfc_code *code)
   else
     gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
 	       "on right hand side at %L", &expr2->where);
+
+  if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE && code->next)
+    {
+      code = code->next;
+      if (code->expr1->expr_type != EXPR_VARIABLE
+	  || code->expr1->symtree == NULL
+	  || code->expr1->rank != 0
+	  || (code->expr1->ts.type != BT_INTEGER
+	      && code->expr1->ts.type != BT_REAL
+	      && code->expr1->ts.type != BT_COMPLEX
+	      && code->expr1->ts.type != BT_LOGICAL))
+	{
+	  gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
+		     "a scalar variable of intrinsic type at %L",
+		     &code->expr1->where);
+	  return;
+	}
+
+      expr2 = is_conversion (code->expr2, false);
+      if (expr2 == NULL)
+	{
+	  expr2 = is_conversion (code->expr2, true);
+	  if (expr2 == NULL)
+	    expr2 = code->expr2;
+	}
+
+      if (expr2->expr_type != EXPR_VARIABLE
+	  || expr2->symtree == NULL
+	  || expr2->rank != 0
+	  || (expr2->ts.type != BT_INTEGER
+	      && expr2->ts.type != BT_REAL
+	      && expr2->ts.type != BT_COMPLEX
+	      && expr2->ts.type != BT_LOGICAL))
+	{
+	  gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
+		     "from a scalar variable of intrinsic type at %L",
+		     &expr2->where);
+	  return;
+	}
+      if (expr2->symtree->n.sym != var)
+	{
+	  gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
+		     "different variable than update statement writes "
+		     "into at %L", &expr2->where);
+	  return;
+	}
+    }
 }