re PR fortran/25162 (Issue with OpenMP COPYIN and gfortran)

gcc/fortran/
2006-02-14  Jakub Jelinek  <jakub@redhat.com>
	    Richard Henderson  <rth@redhat.com>
	    Diego Novillo  <dnovillo@redhat.com>

	* invoke.texi: Document -fopenmp.
	* gfortran.texi (Extensions): Document OpenMP.

	Backport from gomp-20050608-branch
	* trans-openmp.c: Call build_omp_clause instead of
	make_node when creating OMP_CLAUSE_* trees.
	(gfc_trans_omp_reduction_list): Remove argument 'code'.
	Adjust all callers.

	* trans.h (build4_v): Define.
	* trans-openmp.c: Call build4_v to create OMP_PARALLEL nodes.
	Call build3_v to create OMP_SECTIONS nodes.

	PR fortran/25162
	* openmp.c (gfc_match_omp_variable_list): Call gfc_set_sym_referenced
	on all symbols added to the variable list.

	* openmp.c (gfc_match_omp_clauses): Fix check for non-INTRINSIC
	procedure symbol in REDUCTION.

	* trans-openmp.c (gfc_trans_omp_array_reduction): Use gfc_add
	for MINUS_EXPR OMP_CLAUSE_REDUCTION_CODE.

	* trans-openmp.c (gfc_trans_omp_do): Add PBLOCK argument.  If PBLOCK
	is non-NULL, evaluate INIT/COND/INCR and chunk size expressions in
	that statement block.
	(gfc_trans_omp_parallel_do): Pass non-NULL PBLOCK to gfc_trans_omp_do
	for non-ordered non-static combined loops.
	(gfc_trans_omp_directive): Pass NULL PBLOCK to gfc_trans_omp_do.

	* openmp.c: Include target.h and toplev.h.
	(gfc_match_omp_threadprivate): Emit diagnostic if target does
	not support TLS.
	* Make-lang.in (fortran/openmp.o): Add dependencies on
	target.h and toplev.h.

	* trans-decl.c (gfc_get_fake_result_decl): Set GFC_DECL_RESULT.
	* trans-openmp.c (gfc_omp_privatize_by_reference): Make
	DECL_ARTIFICIAL vars predetermined shared except GFC_DECL_RESULT.
	(gfc_omp_disregard_value_expr): Handle GFC_DECL_RESULT.
	(gfc_trans_omp_variable): New function.
	(gfc_trans_omp_variable_list, gfc_trans_omp_reduction_list): Use it.
	* trans.h (GFC_DECL_RESULT): Define.

	* trans-openmp.c (gfc_omp_firstprivatize_type_sizes): New function.
	* f95-lang.c (LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES): Define.
	* trans.h (gfc_omp_firstprivatize_type_sizes): New prototype.

	* trans-openmp.c (gfc_omp_privatize_by_reference): Return
	true if a pointer has GFC_DECL_SAVED_DESCRIPTOR set.
	(gfc_trans_omp_array_reduction, gfc_trans_omp_reduction_list): New
	functions.
	(gfc_trans_omp_clauses): Add WHERE argument.  Call
	gfc_trans_omp_reduction_list rather than gfc_trans_omp_variable_list
	for reductions.
	(gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do,
	gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare,
	gfc_trans_omp_sections, gfc_trans_omp_single): Adjust
	gfc_trans_omp_clauses callers.

	* openmp.c (omp_current_do_code): New var.
	(gfc_resolve_omp_do_blocks): New function.
	(gfc_resolve_omp_parallel_blocks): Call it.
	(gfc_resolve_do_iterator): Add CODE argument.  Don't propagate
	predetermination if argument is !$omp do or !$omp parallel do
	iteration variable.
	* resolve.c (resolve_code): Call gfc_resolve_omp_do_blocks
	for EXEC_OMP_DO.  Adjust gfc_resolve_do_iterator caller.
	* fortran.h (gfc_resolve_omp_do_blocks): New prototype.
	(gfc_resolve_do_iterator): Add CODE argument.

	* trans.h (gfc_omp_predetermined_sharing,
	gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New
	prototypes.
	(GFC_DECL_COMMON_OR_EQUIV, GFC_DECL_CRAY_POINTEE): Define.
	* trans-openmp.c (gfc_omp_predetermined_sharing,
	gfc_omp_disregard_value_expr, gfc_omp_private_debug_clause): New
	functions.
	* trans-common.c (build_equiv_decl, build_common_decl,
	create_common): Set GFC_DECL_COMMON_OR_EQUIV flag on the decls.
	* trans-decl.c (gfc_finish_cray_pointee): Set GFC_DECL_CRAY_POINTEE
	on the decl.
	* f95-lang.c (LANG_HOOKS_OMP_PREDETERMINED_SHARING,
	LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR,
	LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE): Define.

	* openmp.c (resolve_omp_clauses): Remove extraneous comma.

	* symbol.c (check_conflict): Add conflict between cray_pointee and
	threadprivate.
	* openmp.c (gfc_match_omp_threadprivate): Fail if
	gfc_add_threadprivate returned FAILURE.
	(resolve_omp_clauses): Diagnose Cray pointees in SHARED,
	{,FIRST,LAST}PRIVATE and REDUCTION clauses and Cray pointers in
	{FIRST,LAST}PRIVATE and REDUCTION clauses.

	* resolve.c (omp_workshare_flag): New variable.
	(resolve_function): Diagnose use of non-ELEMENTAL user defined
	function in WORKSHARE construct.
	(resolve_code): Cleanup forall_save use.  Make sure omp_workshare_flag
	is set to correct value in different contexts.

	* openmp.c (resolve_omp_clauses): Replace %s with '%s' when printing
	variable name.
	(resolve_omp_atomic): Likewise.

	PR fortran/24493
	* scanner.c (skip_free_comments): Set at_bol at the beginning of the
	loop, not before it.
	(skip_fixed_comments): Handle ! comments in the middle of line here
	as well.
	(gfc_skip_comments): Use skip_fixed_comments for FIXED_FORM even if
	not at BOL.
	(gfc_next_char_literal): Fix expected canonicalized *$omp string.

	* trans-openmp.c (gfc_trans_omp_do): Use make_node and explicit
	initialization to build OMP_FOR instead of build.

	* trans-decl.c (gfc_gimplify_function): Invoke
	diagnose_omp_structured_block_errors.

	* trans-openmp.c (gfc_trans_omp_master): Use OMP_MASTER.
	(gfc_trans_omp_ordered): Use OMP_ORDERED.

	* gfortran.h (gfc_resolve_do_iterator, gfc_resolve_blocks,
	gfc_resolve_omp_parallel_blocks): New prototypes.
	* resolve.c (resolve_blocks): Renamed to...
	(gfc_resolve_blocks): ... this.  Remove static.
	(gfc_resolve_forall): Adjust caller.
	(resolve_code): Only call gfc_resolve_blocks if code->block != 0
	and not for EXEC_OMP_PARALLEL* directives.  Call
	gfc_resolve_omp_parallel_blocks for EXEC_OMP_PARALLEL* directives.
	Call gfc_resolve_do_iterator if resolved successfully EXEC_DO
	iterator.
	* openmp.c: Include pointer-set.h.
	(omp_current_ctx): New variable.
	(gfc_resolve_omp_parallel_blocks, gfc_resolve_do_iterator): New
	functions.
	* Make-lang.in (fortran/openmp.o): Depend on pointer-set.h.

	* openmp.c (gfc_match_omp_clauses): For max/min/iand/ior/ieor,
	look up symbol if it exists, use its name instead and, if it is not
	INTRINSIC, issue diagnostics.

	* parse.c (parse_omp_do): Handle implied end do properly.
	(parse_executable): If parse_omp_do returned ST_IMPLIED_ENDDO,
	return it instead of continuing.

	* trans-openmp.c (gfc_trans_omp_critical): Update for changed
	operand numbering.
	(gfc_trans_omp_do, gfc_trans_omp_parallel, gfc_trans_omp_parallel_do,
	gfc_trans_omp_parallel_sections, gfc_trans_omp_parallel_workshare,
	gfc_trans_omp_sections, gfc_trans_omp_single): Likewise.

	* trans.h (gfc_omp_privatize_by_reference): New prototype.
	* f95-lang.c (LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE): Redefine
	to gfc_omp_privatize_by_reference.
	* trans-openmp.c (gfc_omp_privatize_by_reference): New function.

	* trans-stmt.h (gfc_trans_omp_directive): Add comment.

	* openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument.
	Disallow COMMON matching if it is set.
	(gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers.
	(resolve_omp_clauses): Show locus in error messages.  Check that
	variable types in reduction clauses are appropriate for reduction
	operators.

	* resolve.c (resolve_symbol): Don't error if a threadprivate module
	variable isn't SAVEd.

	* trans-openmp.c (gfc_trans_omp_do): Put count into BLOCK, not BODY.
	Fix typo in condition.  Fix DOVAR initialization.

	* openmp.c (gfc_match_omp_clauses): Match min/iand/ior/ieor
	rather than .min. etc.

	* trans-openmpc.c (omp_not_yet): Remove.
	(gfc_trans_omp_parallel_do): Keep listprivate clause on parallel.
	Force creation of BIND_EXPR around the workshare construct.
	(gfc_trans_omp_parallel_sections): Likewise.
	(gfc_trans_omp_parallel_workshare): Likewise.

	* types.def (BT_I16, BT_FN_I16_VPTR_I16,
	BT_FN_BOOL_VPTR_I16_I16, BT_FN_I16_VPTR_I16_I16): Add.

	* trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_DEFAULT.
	(gfc_trans_omp_code): New function.
	(gfc_trans_omp_do): Use it, remove omp_not_yet uses.
	(gfc_trans_omp_parallel, gfc_trans_omp_single): Likewise.
	(gfc_trans_omp_sections): Likewise.  Only treat empty last section
	specially if lastprivate clause is present.
	* f95-lang.c (gfc_init_builtin_functions): Create BUILT_IN_TRAP
	builtin.

	* trans-openmp.c (gfc_trans_omp_variable_list): Update for
	OMP_CLAUSE_DECL name change.
	(gfc_trans_omp_do): Likewise.

	* trans-openmp.c (gfc_trans_omp_clauses): Create OMP_CLAUSE_REDUCTION
	clauses.
	(gfc_trans_omp_atomic): Build OMP_ATOMIC instead of expanding
	sync builtins directly.
	(gfc_trans_omp_single): Build OMP_SINGLE statement.

	* trans-openmp.c (gfc_trans_add_clause): New.
	(gfc_trans_omp_variable_list): Take a tree code and build the clause
	node here.  Link it to the head of a list.
	(gfc_trans_omp_clauses): Update to match.
	(gfc_trans_omp_do): Use gfc_trans_add_clause.

	* trans-openmp.c (gfc_trans_omp_clauses): Change second argument to
	gfc_omp_clauses *.  Use gfc_evaluate_now instead of creating
	temporaries by hand.
	(gfc_trans_omp_atomic, gfc_trans_omp_critical): Use buildN_v macros.
	(gfc_trans_omp_do): New function.
	(gfc_trans_omp_master): Dont' check for gfc_trans_code returning NULL.
	(gfc_trans_omp_parallel): Adjust gfc_trans_omp_clauses caller.
	Use buildN_v macros.
	(gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_sections,
	gfc_trans_omp_parallel_workshare, gfc_trans_omp_sections,
	gfc_trans_omp_single, gfc_trans_omp_workshare): New functions.
	(gfc_trans_omp_directive): Use them.
	* parse.c (parse_omp_do): Allow new_st.op == EXEC_NOP.
	* openmp.c (resolve_omp_clauses): Check for list items present
	in multiple clauses.
	(resolve_omp_do): Check that iteration variable is not THREADPRIVATE
	and is not present in any clause variable lists other than PRIVATE
	or LASTPRIVATE.

	* gfortran.h (symbol_attribute): Add threadprivate bit.
	(gfc_common_head): Add threadprivate member, change use_assoc
	and saved into char to save space.
	(gfc_add_threadprivate): New prototype.
	* symbol.c (check_conflict): Handle threadprivate.
	(gfc_add_threadprivate): New function.
	(gfc_copy_attr): Copy threadprivate.
	* trans-openmp.c (gfc_trans_omp_clauses): Avoid creating a temporary
	if IF or NUM_THREADS is constant.  Create OMP_CLAUSE_SCHEDULE and
	OMP_CLAUSE_ORDERED.
	* resolve.c (resolve_symbol): Complain if a THREADPRIVATE symbol
	outside a module and not in COMMON has is not SAVEd.
	(resolve_equivalence): Ensure THREADPRIVATE objects don't get
	EQUIVALENCEd.
	* trans-common.c: Include target.h and rtl.h.
	(build_common_decl): Set DECL_TLS_MODEL if THREADPRIVATE.
	* trans-decl.c: Include rtl.h.
	(gfc_finish_var_decl): Set DECL_TLS_MODEL if THREADPRIVATE.
	* dump-parse-tree.c (gfc_show_attr): Handle THREADPRIVATE.
	* Make-lang.in (fortran/trans-decl.o): Depend on $(RTL_H).
	(fortran/trans-common.o): Depend on $(RTL_H) and $(TARGET_H).
	* openmp.c (gfc_match_omp_variable_list): Ensure COMMON block
	is from current namespace.
	(gfc_match_omp_threadprivate): Rewrite.
	(resolve_omp_clauses): Check some clause restrictions.
	* module.c (ab_attribute): Add AB_THREADPRIVATE.
	(attr_bits): Add THREADPRIVATE.
	(mio_symbol_attribute, mio_symbol_attribute): Handle threadprivate.
	(load_commons, write_common, write_blank_common): Adjust for type
	change of saved, store/load threadprivate bit from the integer
	as well.

	* types.def (BT_FN_UINT_UINT): New.
	(BT_FN_VOID_UINT_UINT): Remove.

	* trans-openmp.c (gfc_trans_omp_clauses, gfc_trans_omp_barrier,
	gfc_trans_omp_critical, gfc_trans_omp_flush, gfc_trans_omp_master,
	gfc_trans_omp_ordered, gfc_trans_omp_parallel): New functions.
	(gfc_trans_omp_directive): Use them.

	* openmp.c (expr_references_sym): Add SE argument, don't look
	into SE tree.
	(is_conversion): New function.
	(resolve_omp_atomic): Adjust expr_references_sym callers.  Handle
	promoted expressions.
	* trans-openmp.c (gfc_trans_omp_atomic): New function.
	(gfc_trans_omp_directive): Call it.

	* f95-lang.c (builtin_type_for_size): New function.
	(gfc_init_builtin_functions): Initialize synchronization and
	OpenMP builtins.
	* types.def: New file.
	* Make-lang.in (f95-lang.o): Depend on $(BUILTINS_DEF) and
	fortran/types.def.

	* trans-openmp.c: Rename GOMP_* tree codes into OMP_*.

	* dump-parse-tree.c (show_symtree): Don't crash if ns->proc_name
	is NULL.

	* dump-parse-tree.c (gfc_show_namelist, gfc_show_omp_node): New
	functions.
	(gfc_show_code_node): Call gfc_show_omp_node for EXEC_OMP_* nodes.

	* parse.c (parse_omp_do): Call pop_state before next_statement.
	* openmp.c (expr_references_sym, resolve_omp_atomic, resolve_omp_do):
	New functions.
	(gfc_resolve_omp_directive): Call them.
	* match.c (match_exit_cycle): Issue error if EXIT or CYCLE statement
	leaves an OpenMP structured block or if EXIT terminates !$omp do
	loop.

	* Make-lang.in (F95_PARSER_OBJS): Add fortran/openmp.o.
	(F95_OBJS): Add fortran/trans-openmp.o.
	(fortran/trans-openmp.o): Depend on $(GFORTRAN_TRANS_DEPS).
	* lang.opt: Add -fopenmp option.
	* options.c (gfc_init_options): Initialize it.
	(gfc_handle_option): Handle it.
	* gfortran.h (ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL,
	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, ST_OMP_END_PARALLEL_WORKSHARE,
	ST_OMP_END_SECTIONS, ST_OMP_END_SINGLE, ST_OMP_END_WORKSHARE,
	ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
	ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
	ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION,
	ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE): New
	statement codes.
	(OMP_LIST_PRIVATE, OMP_LIST_FIRSTPRIVATE, OMP_LIST_LASTPRIVATE,
	OMP_LIST_COPYPRIVATE, OMP_LIST_SHARED, OMP_LIST_COPYIN,
	OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
	OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
	OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
	OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST, OMP_LIST_NUM):
	New OpenMP variable list types.
	(gfc_omp_clauses): New typedef.
	(gfc_get_omp_clauses): Define.
	(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,
	EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
	EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
	EXEC_OMP_END_SINGLE): New OpenMP gfc_exec_op codes.
	(struct gfc_code): Add omp_clauses, omp_name, omp_namelist
	and omp_bool fields to ext union.
	(flag_openmp): Declare.
	(gfc_free_omp_clauses, gfc_resolve_omp_directive): New prototypes.
	* scanner.c (openmp_flag, openmp_locus): New variables.
	(skip_free_comments, skip_fixed_comments, gfc_next_char_literal):
	Handle OpenMP directive lines and conditional compilation magic
	comments.
	* parse.h (COMP_OMP_STRUCTURED_BLOCK): New compile state.
	* parse.c (decode_omp_directive, parse_omp_do, parse_omp_atomic,
	parse_omp_structured_block): New functions.
	(next_free, next_fixed): Parse OpenMP directives.
	(case_executable, case_exec_markers, case_decl): Add ST_OMP_*
	codes.
	(gfc_ascii_statement): Handle ST_OMP_* codes.
	(parse_executable): Rearrange the loop slightly, so that
	parse_omp_do can return next_statement.
	* match.h (gfc_match_omp_eos, gfc_match_omp_atomic,
	gfc_match_omp_barrier, gfc_match_omp_critical, gfc_match_omp_do,
	gfc_match_omp_flush, gfc_match_omp_master, gfc_match_omp_ordered,
	gfc_match_omp_parallel, gfc_match_omp_parallel_do,
	gfc_match_omp_parallel_sections, gfc_match_omp_parallel_workshare,
	gfc_match_omp_sections, gfc_match_omp_single,
	gfc_match_omp_threadprivate, gfc_match_omp_workshare,
	gfc_match_omp_end_nowait, gfc_match_omp_end_single): New prototypes.
	* resolve.c (resolve_blocks): Ignore EXEC_OMP_* block directives.
	(resolve_code): Call gfc_resolve_omp_directive on EXEC_OMP_*
	directives.
	* trans.c (gfc_trans_code): Call gfc_trans_omp_directive for
	EXEC_OMP_* directives.
	* st.c (gfc_free_statement): Handle EXEC_OMP_* statement freeing.
	* trans-stmt.h (gfc_trans_omp_directive): New prototype.
	* openmp.c: New file.
	* trans-openmp.c: New file.

gcc/testsuite/
2006-02-14  Jakub Jelinek  <jakub@redhat.com>
	    Diego Novillo  <dnovillo@redhat.com>
	    Uros Bizjak  <uros@kss-loka.si>

	* gfortran.dg/gomp: New directory.

libgomp/
2006-02-14  Jakub Jelinek  <jakub@redhat.com>

	* testsuite/libgomp.fortran/vla7.f90: Add -w to options.
	Remove tests for returning assumed character length arrays.

Co-Authored-By: Diego Novillo <dnovillo@redhat.com>
Co-Authored-By: Richard Henderson <rth@redhat.com>
Co-Authored-By: Uros Bizjak <uros@kss-loka.si>

From-SVN: r110984

1 files changed, 1325 insertions, 0 deletions

diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
new file mode 100644
index 0000000..312d5a1
--- /dev/null
+++ b/gcc/fortran/openmp.c
@@ -0,0 +1,1325 @@
+/* OpenMP directive matching and resolving.
+   Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+   Contributed by Jakub Jelinek
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "flags.h"
+#include "gfortran.h"
+#include "match.h"
+#include "parse.h"
+#include "pointer-set.h"
+#include "target.h"
+#include "toplev.h"
+
+/* Match an end of OpenMP directive.  End of OpenMP directive is optional
+   whitespace, followed by '\n' or comment '!'.  */
+
+match
+gfc_match_omp_eos (void)
+{
+  locus old_loc;
+  int c;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  c = gfc_next_char ();
+  switch (c)
+    {
+    case '!':
+      do
+	c = gfc_next_char ();
+      while (c != '\n');
+      /* Fall through */
+
+    case '\n':
+      return MATCH_YES;
+    }
+
+  gfc_current_locus = old_loc;
+  return MATCH_NO;
+}
+
+/* Free an omp_clauses structure.  */
+
+void
+gfc_free_omp_clauses (gfc_omp_clauses *c)
+{
+  int i;
+  if (c == NULL)
+    return;
+
+  gfc_free_expr (c->if_expr);
+  gfc_free_expr (c->num_threads);
+  gfc_free_expr (c->chunk_size);
+  for (i = 0; i < OMP_LIST_NUM; i++)
+    gfc_free_namelist (c->lists[i]);
+  gfc_free (c);
+}
+
+/* Match a variable/common block list and construct a namelist from it.  */
+
+static match
+gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
+			     bool allow_common)
+{
+  gfc_namelist *head, *tail, *p;
+  locus old_loc;
+  char n[GFC_MAX_SYMBOL_LEN+1];
+  gfc_symbol *sym;
+  match m;
+  gfc_symtree *st;
+
+  head = tail = NULL;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match (str);
+  if (m != MATCH_YES)
+    return m;
+
+  for (;;)
+    {
+      m = gfc_match_symbol (&sym, 1);
+      switch (m)
+	{
+	case MATCH_YES:
+	  gfc_set_sym_referenced (sym);
+	  p = gfc_get_namelist ();
+	  if (head == NULL)
+	    head = tail = p;
+	  else
+	    {
+	      tail->next = p;
+	      tail = tail->next;
+	    }
+	  tail->sym = sym;
+	  goto next_item;
+	case MATCH_NO:
+	  break;
+	case MATCH_ERROR:
+	  goto cleanup;
+	}
+
+      if (!allow_common)
+	goto syntax;
+
+      m = gfc_match (" / %n /", n);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      if (st == NULL)
+	{
+	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  goto cleanup;
+	}
+      for (sym = st->n.common->head; sym; sym = sym->common_next)
+	{
+	  gfc_set_sym_referenced (sym);
+	  p = gfc_get_namelist ();
+	  if (head == NULL)
+	    head = tail = p;
+	  else
+	    {
+	      tail->next = p;
+	      tail = tail->next;
+	    }
+	  tail->sym = sym;
+	}
+
+    next_item:
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  while (*list)
+    list = &(*list)->next;
+
+  *list = head;
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in OpenMP variable list at %C");
+
+cleanup:
+  gfc_free_namelist (head);
+  gfc_current_locus = old_loc;
+  return MATCH_ERROR;
+}
+
+#define OMP_CLAUSE_PRIVATE	(1 << 0)
+#define OMP_CLAUSE_FIRSTPRIVATE	(1 << 1)
+#define OMP_CLAUSE_LASTPRIVATE	(1 << 2)
+#define OMP_CLAUSE_COPYPRIVATE	(1 << 3)
+#define OMP_CLAUSE_SHARED	(1 << 4)
+#define OMP_CLAUSE_COPYIN	(1 << 5)
+#define OMP_CLAUSE_REDUCTION	(1 << 6)
+#define OMP_CLAUSE_IF		(1 << 7)
+#define OMP_CLAUSE_NUM_THREADS	(1 << 8)
+#define OMP_CLAUSE_SCHEDULE	(1 << 9)
+#define OMP_CLAUSE_DEFAULT	(1 << 10)
+#define OMP_CLAUSE_ORDERED	(1 << 11)
+
+/* Match OpenMP directive clauses. MASK is a bitmask of
+   clauses that are allowed for a particular directive.  */
+
+static match
+gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
+{
+  gfc_omp_clauses *c = gfc_get_omp_clauses ();
+  locus old_loc;
+  bool needs_space = true, first = true;
+
+  *cp = NULL;
+  while (1)
+    {
+      if ((first || gfc_match_char (',') != MATCH_YES)
+	  && (needs_space && gfc_match_space () != MATCH_YES))
+	break;
+      needs_space = false;
+      first = false;
+      gfc_gobble_whitespace ();
+      if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
+	  && gfc_match ("if ( %e )", &c->if_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;
+      if ((mask & OMP_CLAUSE_PRIVATE)
+	  && gfc_match_omp_variable_list ("private (",
+					  &c->lists[OMP_LIST_PRIVATE], true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
+	  && gfc_match_omp_variable_list ("firstprivate (",
+					  &c->lists[OMP_LIST_FIRSTPRIVATE],
+					  true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_LASTPRIVATE)
+	  && gfc_match_omp_variable_list ("lastprivate (",
+					  &c->lists[OMP_LIST_LASTPRIVATE],
+					  true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_COPYPRIVATE)
+	  && gfc_match_omp_variable_list ("copyprivate (",
+					  &c->lists[OMP_LIST_COPYPRIVATE],
+					  true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_SHARED)
+	  && gfc_match_omp_variable_list ("shared (",
+					  &c->lists[OMP_LIST_SHARED], true)
+	     == MATCH_YES)
+	continue;
+      if ((mask & OMP_CLAUSE_COPYIN)
+	  && gfc_match_omp_variable_list ("copyin (",
+					  &c->lists[OMP_LIST_COPYIN], true)
+	     == MATCH_YES)
+	continue;
+      old_loc = gfc_current_locus;
+      if ((mask & OMP_CLAUSE_REDUCTION)
+	  && gfc_match ("reduction ( ") == MATCH_YES)
+	{
+	  int reduction = OMP_LIST_NUM;
+	  char buffer[GFC_MAX_SYMBOL_LEN + 1];
+	  if (gfc_match_char ('+') == MATCH_YES)
+	    reduction = OMP_LIST_PLUS;
+	  else if (gfc_match_char ('*') == MATCH_YES)
+	    reduction = OMP_LIST_MULT;
+	  else if (gfc_match_char ('-') == MATCH_YES)
+	    reduction = OMP_LIST_SUB;
+	  else if (gfc_match (".and.") == MATCH_YES)
+	    reduction = OMP_LIST_AND;
+	  else if (gfc_match (".or.") == MATCH_YES)
+	    reduction = OMP_LIST_OR;
+	  else if (gfc_match (".eqv.") == MATCH_YES)
+	    reduction = OMP_LIST_EQV;
+	  else if (gfc_match (".neqv.") == MATCH_YES)
+	    reduction = OMP_LIST_NEQV;
+	  else if (gfc_match_name (buffer) == MATCH_YES)
+	    {
+	      gfc_symbol *sym;
+	      const char *n = buffer;
+
+	      gfc_find_symbol (buffer, NULL, 1, &sym);
+	      if (sym != NULL)
+		{
+		  if (sym->attr.intrinsic)
+		    n = sym->name;
+		  else if ((sym->attr.flavor != FL_UNKNOWN
+			    && sym->attr.flavor != FL_PROCEDURE)
+			   || sym->attr.external
+			   || sym->attr.generic
+			   || sym->attr.entry
+			   || sym->attr.result
+			   || sym->attr.dummy
+			   || sym->attr.subroutine
+			   || sym->attr.pointer
+			   || sym->attr.target
+			   || sym->attr.cray_pointer
+			   || sym->attr.cray_pointee
+			   || (sym->attr.proc != PROC_UNKNOWN
+			       && sym->attr.proc != PROC_INTRINSIC)
+			   || sym->attr.if_source != IFSRC_UNKNOWN
+			   || sym == sym->ns->proc_name)
+		    {
+		      gfc_error_now ("%s is not INTRINSIC procedure name "
+				     "at %C", buffer);
+		      sym = NULL;
+		    }
+		  else
+		    n = sym->name;
+		}
+	      if (strcmp (n, "max") == 0)
+		reduction = OMP_LIST_MAX;
+	      else if (strcmp (n, "min") == 0)
+		reduction = OMP_LIST_MIN;
+	      else if (strcmp (n, "iand") == 0)
+		reduction = OMP_LIST_IAND;
+	      else if (strcmp (n, "ior") == 0)
+		reduction = OMP_LIST_IOR;
+	      else if (strcmp (n, "ieor") == 0)
+		reduction = OMP_LIST_IEOR;
+	      if (reduction != OMP_LIST_NUM
+		  && sym != NULL
+		  && ! sym->attr.intrinsic
+		  && ! sym->attr.use_assoc
+		  && ((sym->attr.flavor == FL_UNKNOWN
+		       && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
+					  sym->name, NULL) == FAILURE)
+		      || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
+		{
+		  gfc_free_omp_clauses (c);
+		  return MATCH_ERROR;
+		}
+	    }
+	  if (reduction != OMP_LIST_NUM
+	      && gfc_match_omp_variable_list (" :", &c->lists[reduction],
+					      false)
+		 == MATCH_YES)
+	    continue;
+	  else
+	    gfc_current_locus = old_loc;
+	}
+      if ((mask & OMP_CLAUSE_DEFAULT)
+	  && c->default_sharing == OMP_DEFAULT_UNKNOWN)
+	{
+	  if (gfc_match ("default ( shared )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_SHARED;
+	  else if (gfc_match ("default ( private )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_PRIVATE;
+	  else if (gfc_match ("default ( none )") == MATCH_YES)
+	    c->default_sharing = OMP_DEFAULT_NONE;
+	  if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
+	    continue;
+	}
+      old_loc = gfc_current_locus;
+      if ((mask & OMP_CLAUSE_SCHEDULE)
+	  && c->sched_kind == OMP_SCHED_NONE
+	  && gfc_match ("schedule ( ") == MATCH_YES)
+	{
+	  if (gfc_match ("static") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_STATIC;
+	  else if (gfc_match ("dynamic") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_DYNAMIC;
+	  else if (gfc_match ("guided") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_GUIDED;
+	  else if (gfc_match ("runtime") == MATCH_YES)
+	    c->sched_kind = OMP_SCHED_RUNTIME;
+	  if (c->sched_kind != OMP_SCHED_NONE)
+	    {
+	      match m = MATCH_NO;
+	      if (c->sched_kind != OMP_SCHED_RUNTIME)
+		m = gfc_match (" , %e )", &c->chunk_size);
+	      if (m != MATCH_YES)
+		m = gfc_match_char (')');
+	      if (m != MATCH_YES)
+		c->sched_kind = OMP_SCHED_NONE;
+	    }
+	  if (c->sched_kind != OMP_SCHED_NONE)
+	    continue;
+	  else
+	    gfc_current_locus = old_loc;
+	}
+      if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
+	  && gfc_match ("ordered") == MATCH_YES)
+	{
+	  c->ordered = needs_space = true;
+	  continue;
+	}
+
+      break;
+    }
+
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_free_omp_clauses (c);
+      return MATCH_ERROR;
+    }
+
+  *cp = c;
+  return MATCH_YES;
+}
+
+#define OMP_PARALLEL_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED	\
+   | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF		\
+   | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
+#define OMP_DO_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE				\
+   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION			\
+   | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED)
+#define OMP_SECTIONS_CLAUSES \
+  (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE				\
+   | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+
+match
+gfc_match_omp_parallel (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_critical (void)
+{
+  char n[GFC_MAX_SYMBOL_LEN+1];
+
+  if (gfc_match (" ( %n )", n) != MATCH_YES)
+    n[0] = '\0';
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_CRITICAL;
+  new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_do (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_DO;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_flush (void)
+{
+  gfc_namelist *list = NULL;
+  gfc_match_omp_variable_list (" (", &list, true);
+  if (gfc_match_omp_eos () != MATCH_YES)
+    {
+      gfc_free_namelist (list);
+      return MATCH_ERROR;
+    }
+  new_st.op = EXEC_OMP_FLUSH;
+  new_st.ext.omp_namelist = list;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_threadprivate (void)
+{
+  locus old_loc;
+  char n[GFC_MAX_SYMBOL_LEN+1];
+  gfc_symbol *sym;
+  match m;
+  gfc_symtree *st;
+
+  old_loc = gfc_current_locus;
+
+  m = gfc_match (" (");
+  if (m != MATCH_YES)
+    return m;
+
+  if (!targetm.have_tls)
+    {
+      sorry ("threadprivate variables not supported in this target");
+      goto cleanup;
+    }
+
+  for (;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (sym->attr.in_common)
+	    gfc_error_now ("Threadprivate variable at %C is an element of"
+			   " a COMMON block");
+	  else if (gfc_add_threadprivate (&sym->attr, sym->name,
+		   &sym->declared_at) == FAILURE)
+	    goto cleanup;
+	  goto next_item;
+	case MATCH_NO:
+	  break;
+	case MATCH_ERROR:
+	  goto cleanup;
+	}
+
+      m = gfc_match (" / %n /", n);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO || n[0] == '\0')
+	goto syntax;
+
+      st = gfc_find_symtree (gfc_current_ns->common_root, n);
+      if (st == NULL)
+	{
+	  gfc_error ("COMMON block /%s/ not found at %C", n);
+	  goto cleanup;
+	}
+      st->n.common->threadprivate = 1;
+      for (sym = st->n.common->head; sym; sym = sym->common_next)
+	if (gfc_add_threadprivate (&sym->attr, sym->name,
+				   &sym->declared_at) == FAILURE)
+	  goto cleanup;
+
+    next_item:
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
+
+cleanup:
+  gfc_current_locus = old_loc;
+  return MATCH_ERROR;
+}
+
+match
+gfc_match_omp_parallel_do (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
+      != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL_DO;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_parallel_sections (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
+      != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_parallel_workshare (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_sections (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_SECTIONS;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_single (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
+      != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_SINGLE;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_workshare (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_WORKSHARE;
+  new_st.ext.omp_clauses = gfc_get_omp_clauses ();
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_master (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_MASTER;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_ordered (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_ORDERED;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_atomic (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_ATOMIC;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_barrier (void)
+{
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_BARRIER;
+  new_st.ext.omp_clauses = NULL;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_end_nowait (void)
+{
+  bool nowait = false;
+  if (gfc_match ("% nowait") == MATCH_YES)
+    nowait = true;
+  if (gfc_match_omp_eos () != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_END_NOWAIT;
+  new_st.ext.omp_bool = nowait;
+  return MATCH_YES;
+}
+
+match
+gfc_match_omp_end_single (void)
+{
+  gfc_omp_clauses *c;
+  if (gfc_match ("% nowait") == MATCH_YES)
+    {
+      new_st.op = EXEC_OMP_END_NOWAIT;
+      new_st.ext.omp_bool = true;
+      return MATCH_YES;
+    }
+  if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
+    return MATCH_ERROR;
+  new_st.op = EXEC_OMP_END_SINGLE;
+  new_st.ext.omp_clauses = c;
+  return MATCH_YES;
+}
+
+/* OpenMP directive resolving routines.  */
+
+static void
+resolve_omp_clauses (gfc_code *code)
+{
+  gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+  gfc_namelist *n;
+  int list;
+  static const char *clause_names[]
+    = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
+	"COPYIN", "REDUCTION" };
+
+  if (omp_clauses == NULL)
+    return;
+
+  if (omp_clauses->if_expr)
+    {
+      gfc_expr *expr = omp_clauses->if_expr;
+      if (gfc_resolve_expr (expr) == FAILURE
+	  || expr->ts.type != BT_LOGICAL || expr->rank != 0)
+	gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+		   &expr->where);
+    }
+  if (omp_clauses->num_threads)
+    {
+      gfc_expr *expr = omp_clauses->num_threads;
+      if (gfc_resolve_expr (expr) == FAILURE
+	  || expr->ts.type != BT_INTEGER || expr->rank != 0)
+	gfc_error ("NUM_THREADS clause at %L requires a scalar"
+		   " INTEGER expression", &expr->where);
+    }
+  if (omp_clauses->chunk_size)
+    {
+      gfc_expr *expr = omp_clauses->chunk_size;
+      if (gfc_resolve_expr (expr) == FAILURE
+	  || expr->ts.type != BT_INTEGER || expr->rank != 0)
+	gfc_error ("SCHEDULE clause's chunk_size at %L requires"
+		   " a scalar INTEGER expression", &expr->where);
+    }
+
+  /* Check that no symbol appears on multiple clauses, except that
+     a symbol can appear on both firstprivate and lastprivate.  */
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    for (n = omp_clauses->lists[list]; n; n = n->next)
+      n->sym->mark = 0;
+
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
+      for (n = omp_clauses->lists[list]; n; n = n->next)
+	if (n->sym->mark)
+	  gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		     n->sym->name, &code->loc);
+	else
+	  n->sym->mark = 1;
+
+  gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
+  for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
+    for (n = omp_clauses->lists[list]; n; n = n->next)
+      if (n->sym->mark)
+	{
+	  gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		     n->sym->name, &code->loc);
+	  n->sym->mark = 0;
+	}
+
+  for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
+    if (n->sym->mark)
+      gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		 n->sym->name, &code->loc);
+    else
+      n->sym->mark = 1;
+
+  for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+    n->sym->mark = 0;
+
+  for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
+    if (n->sym->mark)
+      gfc_error ("Symbol '%s' present on multiple clauses at %L",
+		 n->sym->name, &code->loc);
+    else
+      n->sym->mark = 1;
+
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    if ((n = omp_clauses->lists[list]) != NULL)
+      {
+	const char *name;
+
+	if (list < OMP_LIST_REDUCTION_FIRST)
+	  name = clause_names[list];
+	else if (list <= OMP_LIST_REDUCTION_LAST)
+	  name = clause_names[OMP_LIST_REDUCTION_FIRST];
+	else
+	  gcc_unreachable ();
+
+	switch (list)
+	  {
+	  case OMP_LIST_COPYIN:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (!n->sym->attr.threadprivate)
+		  gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
+			     " at %L", n->sym->name, &code->loc);
+		if (n->sym->attr.allocatable)
+		  gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
+			     n->sym->name, &code->loc);
+	      }
+	    break;
+	  case OMP_LIST_COPYPRIVATE:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+		  gfc_error ("Assumed size array '%s' in COPYPRIVATE clause"
+			     " at %L", n->sym->name, &code->loc);
+		if (n->sym->attr.allocatable)
+		  gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE"
+			     " at %L", n->sym->name, &code->loc);
+	      }
+	    break;
+	  case OMP_LIST_SHARED:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (n->sym->attr.threadprivate)
+		  gfc_error ("THREADPRIVATE object '%s' in SHARED clause at"
+			     " %L", n->sym->name, &code->loc);
+		if (n->sym->attr.cray_pointee)
+		  gfc_error ("Cray pointee '%s' in SHARED clause at %L",
+			    n->sym->name, &code->loc);
+	      }
+	    break;
+	  default:
+	    for (; n != NULL; n = n->next)
+	      {
+		if (n->sym->attr.threadprivate)
+		  gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
+			     n->sym->name, name, &code->loc);
+		if (n->sym->attr.cray_pointee)
+		  gfc_error ("Cray pointee '%s' in %s clause at %L",
+			    n->sym->name, name, &code->loc);
+		if (list != OMP_LIST_PRIVATE)
+		  {
+		    if (n->sym->attr.pointer)
+		      gfc_error ("POINTER object '%s' in %s clause at %L",
+				 n->sym->name, name, &code->loc);
+		    if (n->sym->attr.allocatable)
+		      gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
+				 name, n->sym->name, &code->loc);
+		    if (n->sym->attr.cray_pointer)
+		      gfc_error ("Cray pointer '%s' in %s clause at %L",
+				 n->sym->name, name, &code->loc);
+		  }
+		if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
+		  gfc_error ("Assumed size array '%s' in %s clause at %L",
+			     n->sym->name, name, &code->loc);
+		if (n->sym->attr.in_namelist
+		    && (list < OMP_LIST_REDUCTION_FIRST
+			|| list > OMP_LIST_REDUCTION_LAST))
+		  gfc_error ("Variable '%s' in %s clause is used in"
+			     " NAMELIST statement at %L",
+			     n->sym->name, name, &code->loc);
+		switch (list)
+		  {
+		  case OMP_LIST_PLUS:
+		  case OMP_LIST_MULT:
+		  case OMP_LIST_SUB:
+		    if (!gfc_numeric_ts (&n->sym->ts))
+		      gfc_error ("%c REDUCTION variable '%s' is %s at %L",
+				 list == OMP_LIST_PLUS ? '+'
+				 : list == OMP_LIST_MULT ? '*' : '-',
+				 n->sym->name, gfc_typename (&n->sym->ts),
+				 &code->loc);
+		    break;
+		  case OMP_LIST_AND:
+		  case OMP_LIST_OR:
+		  case OMP_LIST_EQV:
+		  case OMP_LIST_NEQV:
+		    if (n->sym->ts.type != BT_LOGICAL)
+		      gfc_error ("%s REDUCTION variable '%s' must be LOGICAL"
+				 " at %L",
+				 list == OMP_LIST_AND ? ".AND."
+				 : list == OMP_LIST_OR ? ".OR."
+				 : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
+				 n->sym->name, &code->loc);
+		    break;
+		  case OMP_LIST_MAX:
+		  case OMP_LIST_MIN:
+		    if (n->sym->ts.type != BT_INTEGER
+			&& n->sym->ts.type != BT_REAL)
+		      gfc_error ("%s REDUCTION variable '%s' must be"
+				 " INTEGER or REAL at %L",
+				 list == OMP_LIST_MAX ? "MAX" : "MIN",
+				 n->sym->name, &code->loc);
+		    break;
+		  case OMP_LIST_IAND:
+		  case OMP_LIST_IOR:
+		  case OMP_LIST_IEOR:
+		    if (n->sym->ts.type != BT_INTEGER)
+		      gfc_error ("%s REDUCTION variable '%s' must be INTEGER"
+				 " at %L",
+				 list == OMP_LIST_IAND ? "IAND"
+				 : list == OMP_LIST_MULT ? "IOR" : "IEOR",
+				 n->sym->name, &code->loc);
+		    break;
+		  default:
+		    break;
+		  }
+	      }
+	    break;
+	  }
+      }
+}
+
+/* Return true if SYM is ever referenced in EXPR except in the SE node.  */
+
+static bool
+expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
+{
+  gfc_actual_arglist *arg;
+  if (e == NULL || e == se)
+    return false;
+  switch (e->expr_type)
+    {
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_VARIABLE:
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      if (e->symtree != NULL
+	  && e->symtree->n.sym == s)
+	return true;
+      return false;
+    case EXPR_SUBSTRING:
+      if (e->ref != NULL
+	  && (expr_references_sym (e->ref->u.ss.start, s, se)
+	      || expr_references_sym (e->ref->u.ss.end, s, se)))
+	return true;
+      return false;
+    case EXPR_OP:
+      if (expr_references_sym (e->value.op.op2, s, se))
+	return true;
+      return expr_references_sym (e->value.op.op1, s, se);
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+	if (expr_references_sym (arg->expr, s, se))
+	  return true;
+      return false;
+    default:
+      gcc_unreachable ();
+    }
+}
+
+/* If EXPR is a conversion function that widens the type
+   if WIDENING is true or narrows the type if WIDENING is false,
+   return the inner expression, otherwise return NULL.  */
+
+static gfc_expr *
+is_conversion (gfc_expr *expr, bool widening)
+{
+  gfc_typespec *ts1, *ts2;
+
+  if (expr->expr_type != EXPR_FUNCTION
+      || expr->value.function.isym == NULL
+      || expr->value.function.esym != NULL
+      || expr->value.function.isym->generic_id != GFC_ISYM_CONVERSION)
+    return NULL;
+
+  if (widening)
+    {
+      ts1 = &expr->ts;
+      ts2 = &expr->value.function.actual->expr->ts;
+    }
+  else
+    {
+      ts1 = &expr->value.function.actual->expr->ts;
+      ts2 = &expr->ts;
+    }
+
+  if (ts1->type > ts2->type
+      || (ts1->type == ts2->type && ts1->kind > ts2->kind))
+    return expr->value.function.actual->expr;
+
+  return NULL;
+}
+
+static void
+resolve_omp_atomic (gfc_code *code)
+{
+  gfc_symbol *var;
+  gfc_expr *expr2;
+
+  code = code->block->next;
+  gcc_assert (code->op == EXEC_ASSIGN);
+  gcc_assert (code->next == NULL);
+
+  if (code->expr->expr_type != EXPR_VARIABLE
+      || code->expr->symtree == NULL
+      || code->expr->rank != 0
+      || (code->expr->ts.type != BT_INTEGER
+	  && code->expr->ts.type != BT_REAL
+	  && code->expr->ts.type != BT_COMPLEX
+	  && code->expr->ts.type != BT_LOGICAL))
+    {
+      gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
+		 " intrinsic type at %L", &code->loc);
+      return;
+    }
+
+  var = code->expr->symtree->n.sym;
+  expr2 = is_conversion (code->expr2, false);
+  if (expr2 == NULL)
+    expr2 = code->expr2;
+
+  if (expr2->expr_type == EXPR_OP)
+    {
+      gfc_expr *v = NULL, *e, *c;
+      gfc_intrinsic_op op = expr2->value.op.operator;
+      gfc_intrinsic_op alt_op = INTRINSIC_NONE;
+
+      switch (op)
+	{
+	case INTRINSIC_PLUS:
+	  alt_op = INTRINSIC_MINUS;
+	  break;
+	case INTRINSIC_TIMES:
+	  alt_op = INTRINSIC_DIVIDE;
+	  break;
+	case INTRINSIC_MINUS:
+	  alt_op = INTRINSIC_PLUS;
+	  break;
+	case INTRINSIC_DIVIDE:
+	  alt_op = INTRINSIC_TIMES;
+	  break;
+	case INTRINSIC_AND:
+	case INTRINSIC_OR:
+	  break;
+	case INTRINSIC_EQV:
+	  alt_op = INTRINSIC_NEQV;
+	  break;
+	case INTRINSIC_NEQV:
+	  alt_op = INTRINSIC_EQV;
+	  break;
+	default:
+	  gfc_error ("!$OMP ATOMIC assignment operator must be"
+		     " +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
+		     &expr2->where);
+	  return;
+	}
+
+      /* Check for var = var op expr resp. var = expr op var where
+	 expr doesn't reference var and var op expr is mathematically
+	 equivalent to var op (expr) resp. expr op var equivalent to
+	 (expr) op var.  We rely here on the fact that the matcher
+	 for x op1 y op2 z where op1 and op2 have equal precedence
+	 returns (x op1 y) op2 z.  */
+      e = expr2->value.op.op2;
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree != NULL
+	  && e->symtree->n.sym == var)
+	v = e;
+      else if ((c = is_conversion (e, true)) != NULL
+	       && c->expr_type == EXPR_VARIABLE
+	       && c->symtree != NULL
+	       && c->symtree->n.sym == var)
+	v = c;
+      else
+	{
+	  gfc_expr **p = NULL, **q;
+	  for (q = &expr2->value.op.op1; (e = *q) != NULL; )
+	    if (e->expr_type == EXPR_VARIABLE
+		&& e->symtree != NULL
+		&& e->symtree->n.sym == var)
+	      {
+		v = e;
+		break;
+	      }
+	    else if ((c = is_conversion (e, true)) != NULL)
+	      q = &e->value.function.actual->expr;
+	    else if (e->expr_type != EXPR_OP
+		     || (e->value.op.operator != op
+			 && e->value.op.operator != alt_op)
+		     || e->rank != 0)
+	      break;
+	    else
+	      {
+		p = q;
+		q = &e->value.op.op1;
+	      }
+
+	  if (v == NULL)
+	    {
+	      gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
+			 " or var = expr op var at %L", &expr2->where);
+	      return;
+	    }
+
+	  if (p != NULL)
+	    {
+	      e = *p;
+	      switch (e->value.op.operator)
+		{
+		case INTRINSIC_MINUS:
+		case INTRINSIC_DIVIDE:
+		case INTRINSIC_EQV:
+		case INTRINSIC_NEQV:
+		  gfc_error ("!$OMP ATOMIC var = var op expr not"
+			     " mathematically equivalent to var = var op"
+			     " (expr) at %L", &expr2->where);
+		  break;
+		default:
+		  break;
+		}
+
+	      /* Canonicalize into var = var op (expr).  */
+	      *p = e->value.op.op2;
+	      e->value.op.op2 = expr2;
+	      e->ts = expr2->ts;
+	      if (code->expr2 == expr2)
+		code->expr2 = expr2 = e;
+	      else
+		code->expr2->value.function.actual->expr = expr2 = e;
+
+	      if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
+		{
+		  for (p = &expr2->value.op.op1; *p != v;
+		       p = &(*p)->value.function.actual->expr)
+		    ;
+		  *p = NULL;
+		  gfc_free_expr (expr2->value.op.op1);
+		  expr2->value.op.op1 = v;
+		  gfc_convert_type (v, &expr2->ts, 2);
+		}
+	    }
+	}
+
+      if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
+	{
+	  gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
+		     " must be scalar and cannot reference var at %L",
+		     &expr2->where);
+	  return;
+	}
+    }
+  else if (expr2->expr_type == EXPR_FUNCTION
+	   && expr2->value.function.isym != NULL
+	   && expr2->value.function.esym == NULL
+	   && expr2->value.function.actual != NULL
+	   && expr2->value.function.actual->next != NULL)
+    {
+      gfc_actual_arglist *arg, *var_arg;
+
+      switch (expr2->value.function.isym->generic_id)
+	{
+	case GFC_ISYM_MIN:
+	case GFC_ISYM_MAX:
+	  break;
+	case GFC_ISYM_IAND:
+	case GFC_ISYM_IOR:
+	case GFC_ISYM_IEOR:
+	  if (expr2->value.function.actual->next->next != NULL)
+	    {
+	      gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
+			 "or IEOR must have two arguments at %L",
+			 &expr2->where);
+	      return;
+	    }
+	  break;
+	default:
+	  gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
+		     " MIN, MAX, IAND, IOR or IEOR at %L",
+		     &expr2->where);
+	  return;
+	}
+
+      var_arg = NULL;
+      for (arg = expr2->value.function.actual; arg; arg = arg->next)
+	{
+	  if ((arg == expr2->value.function.actual
+	       || (var_arg == NULL && arg->next == NULL))
+	      && arg->expr->expr_type == EXPR_VARIABLE
+	      && arg->expr->symtree != NULL
+	      && arg->expr->symtree->n.sym == var)
+	    var_arg = arg;
+	  else if (expr_references_sym (arg->expr, var, NULL))
+	    gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
+		       " reference '%s' at %L", var->name, &arg->expr->where);
+	  if (arg->expr->rank != 0)
+	    gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
+		       " at %L", &arg->expr->where);
+	}
+
+      if (var_arg == NULL)
+	{
+	  gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
+		     " be '%s' at %L", var->name, &expr2->where);
+	  return;
+	}
+
+      if (var_arg != expr2->value.function.actual)
+	{
+	  /* Canonicalize, so that var comes first.  */
+	  gcc_assert (var_arg->next == NULL);
+	  for (arg = expr2->value.function.actual;
+	       arg->next != var_arg; arg = arg->next)
+	    ;
+	  var_arg->next = expr2->value.function.actual;
+	  expr2->value.function.actual = var_arg;
+	  arg->next = NULL;
+	}
+    }
+  else
+    gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
+	       " on right hand side at %L", &expr2->where);
+}
+
+struct omp_context
+{
+  gfc_code *code;
+  struct pointer_set_t *sharing_clauses;
+  struct pointer_set_t *private_iterators;
+  struct omp_context *previous;
+} *omp_current_ctx;
+gfc_code *omp_current_do_code;
+
+void
+gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
+{
+  if (code->block->next && code->block->next->op == EXEC_DO)
+    omp_current_do_code = code->block->next;
+  gfc_resolve_blocks (code->block, ns);
+}
+
+void
+gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
+{
+  struct omp_context ctx;
+  gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
+  gfc_namelist *n;
+  int list;
+
+  ctx.code = code;
+  ctx.sharing_clauses = pointer_set_create ();
+  ctx.private_iterators = pointer_set_create ();
+  ctx.previous = omp_current_ctx;
+  omp_current_ctx = &ctx;
+
+  for (list = 0; list < OMP_LIST_NUM; list++)
+    for (n = omp_clauses->lists[list]; n; n = n->next)
+      pointer_set_insert (ctx.sharing_clauses, n->sym);
+
+  if (code->op == EXEC_OMP_PARALLEL_DO)
+    gfc_resolve_omp_do_blocks (code, ns);
+  else
+    gfc_resolve_blocks (code->block, ns);
+
+  omp_current_ctx = ctx.previous;
+  pointer_set_destroy (ctx.sharing_clauses);
+  pointer_set_destroy (ctx.private_iterators);
+}
+
+/* Note a DO iterator variable.  This is special in !$omp parallel
+   construct, where they are predetermined private.  */
+
+void
+gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
+{
+  struct omp_context *ctx;
+
+  if (sym->attr.threadprivate)
+    return;
+
+  /* !$omp do and !$omp parallel do iteration variable is predetermined
+     private just in the !$omp do resp. !$omp parallel do construct,
+     with no implications for the outer parallel constructs.  */
+  if (code == omp_current_do_code)
+    return;
+
+  for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
+    {
+      if (pointer_set_contains (ctx->sharing_clauses, sym))
+	continue;
+
+      if (! pointer_set_insert (ctx->private_iterators, sym))
+	{
+	  gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses;
+	  gfc_namelist *p;
+
+	  p = gfc_get_namelist ();
+	  p->sym = sym;
+	  p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
+	  omp_clauses->lists[OMP_LIST_PRIVATE] = p;
+	}
+    }
+}
+
+static void
+resolve_omp_do (gfc_code *code)
+{
+  gfc_code *do_code;
+  int list;
+  gfc_namelist *n;
+  gfc_symbol *dovar;
+
+  if (code->ext.omp_clauses)
+    resolve_omp_clauses (code);
+
+  do_code = code->block->next;
+  if (do_code->op == EXEC_DO_WHILE)
+    gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
+	       &do_code->loc);
+  else
+    {
+      gcc_assert (do_code->op == EXEC_DO);
+      if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+	gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
+		   &do_code->loc);
+      dovar = do_code->ext.iterator->var->symtree->n.sym;
+      if (dovar->attr.threadprivate)
+	gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L",
+		   &do_code->loc);
+      if (code->ext.omp_clauses)
+	for (list = 0; list < OMP_LIST_NUM; list++)
+	  if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+	    for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
+	      if (dovar == n->sym)
+		{
+		  gfc_error ("!$OMP DO iteration variable present on clause"
+			     " other than PRIVATE or LASTPRIVATE at %L",
+			     &do_code->loc);
+		  break;
+		}
+    }
+}
+
+/* Resolve OpenMP directive clauses and check various requirements
+   of each directive.  */
+
+void
+gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
+{
+  switch (code->op)
+    {
+    case EXEC_OMP_DO:
+    case EXEC_OMP_PARALLEL_DO:
+      resolve_omp_do (code);
+      break;
+    case EXEC_OMP_WORKSHARE:
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+    case EXEC_OMP_PARALLEL:
+    case EXEC_OMP_PARALLEL_SECTIONS:
+    case EXEC_OMP_SECTIONS:
+    case EXEC_OMP_SINGLE:
+      if (code->ext.omp_clauses)
+	resolve_omp_clauses (code);
+      break;
+    case EXEC_OMP_ATOMIC:
+      resolve_omp_atomic (code);
+      break;
+    default:
+      break;
+    }
+}