re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

2011-06-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.h (gfc_check_vardef_context): Update prototype.
        (iso_fortran_env_symbol): Handle derived types.
        (symbol_attribute): Add lock_comp.
        * expr.c (gfc_check_vardef_context): Add LOCK_TYPE check.
        * interface.c (compare_parameter, gfc_procedure_use): Handle
        LOCK_TYPE.
        (compare_actual_formal): Update
        gfc_check_vardef_context call.
        * check.c (gfc_check_atomic_def, gfc_check_atomic_ref): Ditto.
        * intrinsic.c (check_arglist): Ditto.
        * io.c (resolve_tag, gfc_resolve_dt, gfc_resolve_inquire):
        * Ditto.
        * iso-fortran-env.def (ISOFORTRAN_LOCK_TYPE): Add.
        * intrinsic.texi (ISO_FORTRAN_ENV): Document LOCK_TYPE.
        * module.c (mio_symbol_attribute): Handle lock_comp.
        (create_derived_type): New function.
        (use_iso_fortran_env_module): Call it to handle LOCK_TYPE.
        * parse.c (parse_derived): Add constraint check for LOCK_TYPE.
        * resolve.c (resolve_symbol, resolve_lock_unlock): Add
        * constraint
        checks for LOCK_TYPE.
        (gfc_resolve_iterator, resolve_deallocate_expr,
        resolve_allocate_expr, resolve_code, resolve_transfer): Update
        gfc_check_vardef_context call.
        * trans-stmt.h (gfc_trans_lock_unlock): New prototype.
        * trans-stmt.c (gfc_trans_lock_unlock): New function.
        * trans.c (trans_code): Handle LOCK and UNLOCK.

2011-06-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_lock_1.f90: Update dg-error.
        * gfortran.dg/coarray_lock_3.f90: New.
        * gfortran.dg/coarray/lock_1.f90: New.

From-SVN: r175228

15 files changed, 293 insertions, 35 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 08c666a..2e73625 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,32 @@
+2011-06-20  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.h (gfc_check_vardef_context): Update prototype.
+	(iso_fortran_env_symbol): Handle derived types.
+	(symbol_attribute): Add lock_comp.
+	* expr.c (gfc_check_vardef_context): Add LOCK_TYPE check.
+	* interface.c (compare_parameter, gfc_procedure_use): Handle
+	LOCK_TYPE.
+	(compare_actual_formal): Update
+	gfc_check_vardef_context call.
+	* check.c (gfc_check_atomic_def, gfc_check_atomic_ref): Ditto.
+	* intrinsic.c (check_arglist): Ditto.
+	* io.c (resolve_tag, gfc_resolve_dt, gfc_resolve_inquire): Ditto.
+	* iso-fortran-env.def (ISOFORTRAN_LOCK_TYPE): Add.
+	* intrinsic.texi (ISO_FORTRAN_ENV): Document LOCK_TYPE.
+	* module.c (mio_symbol_attribute): Handle lock_comp.
+	(create_derived_type): New function.
+	(use_iso_fortran_env_module): Call it to handle LOCK_TYPE.
+	* parse.c (parse_derived): Add constraint check for LOCK_TYPE.
+	* resolve.c (resolve_symbol, resolve_lock_unlock): Add constraint
+	checks for LOCK_TYPE.
+	(gfc_resolve_iterator, resolve_deallocate_expr,
+	resolve_allocate_expr, resolve_code, resolve_transfer): Update
+	gfc_check_vardef_context call.
+	* trans-stmt.h (gfc_trans_lock_unlock): New prototype.
+	* trans-stmt.c (gfc_trans_lock_unlock): New function.
+	* trans.c (trans_code): Handle LOCK and UNLOCK.
+
 2011-06-18  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/49400
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 972b290..79e1c95 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1011,7 +1011,7 @@ gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
   if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
     return FAILURE;
 
-  if (gfc_check_vardef_context (atom, false, NULL) == FAILURE)
+  if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
     {
       gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
 		 "definable", gfc_current_intrinsic, &atom->where);
@@ -1028,7 +1028,7 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
   if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
     return FAILURE;
 
-  if (gfc_check_vardef_context (value, false, NULL) == FAILURE)
+  if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
     {
       gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
 		 "definable", gfc_current_intrinsic, &value->where);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f881bb1..4a7a951 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4373,7 +4373,8 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
    and just the return status (SUCCESS / FAILURE) be requested.  */
 
 gfc_try
-gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
+gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
+			  const char* context)
 {
   gfc_symbol* sym = NULL;
   bool is_pointer;
@@ -4441,6 +4442,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
       return FAILURE;
     }
 
+  /* F2008, C1303.  */
+  if (!alloc_obj
+      && (attr.lock_comp
+	  || (e->ts.type == BT_DERIVED
+	      && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	      && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
+    {
+      if (context)
+	gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
+		   context, &e->where);
+      return FAILURE;
+    }
+
   /* INTENT(IN) dummy argument.  Check this, unless the object itself is
      the component of sub-component of a pointer.  Obviously,
      procedure pointers are of no interest here.  */
@@ -4555,7 +4569,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
 	}
 
       /* Target must be allowed to appear in a variable definition context.  */
-      if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE)
+      if (gfc_check_vardef_context (assoc->target, pointer, false, NULL)
+	  == FAILURE)
 	{
 	  if (context)
 	    gfc_error ("Associate-name '%s' can not appear in a variable"
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f23fbbd4..8b834ab 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -596,6 +596,7 @@ gfc_reverse;
 #define NAMED_INTCST(a,b,c,d) a,
 #define NAMED_KINDARRAY(a,b,c,d) a,
 #define NAMED_FUNCTION(a,b,c,d) a,
+#define NAMED_DERIVED_TYPE(a,b,c,d) a,
 typedef enum
 {
   ISOFORTRANENV_INVALID = -1,
@@ -606,6 +607,7 @@ iso_fortran_env_symbol;
 #undef NAMED_INTCST
 #undef NAMED_KINDARRAY
 #undef NAMED_FUNCTION
+#undef NAMED_DERIVED_TYPE
 
 #define NAMED_INTCST(a,b,c,d) a,
 #define NAMED_REALCST(a,b,c) a,
@@ -774,7 +776,7 @@ typedef struct
      possibly nested.  zero_comp is true if the derived type has no
      component at all.  */
   unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
-	   private_comp:1, zero_comp:1, coarray_comp:1;
+	   private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1;
 
   /* This is a temporary selector for SELECT TYPE.  */
   unsigned select_type_temporary:1;
@@ -2735,7 +2737,7 @@ bool gfc_has_ultimate_allocatable (gfc_expr *);
 bool gfc_has_ultimate_pointer (gfc_expr *);
 
 gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...);
-gfc_try gfc_check_vardef_context (gfc_expr*, bool, const char*);
+gfc_try gfc_check_vardef_context (gfc_expr*, bool, bool, const char*);
 
 
 /* st.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e787187..dcf6c4e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1618,7 +1618,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		       "contiguous", formal->name, &actual->where);
 	  return 0;
 	}
-    }
+
+      /* F2008, C1303 and C1304.  */
+      if (formal->attr.intent != INTENT_INOUT
+	  && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+	       && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	       && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+	      || formal->attr.lock_comp))
+
+    	{
+	  if (where)
+	    gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
+		       "which is LOCK_TYPE or has a LOCK_TYPE component",
+		       formal->name, &actual->where);
+	  return 0;
+	}
+      }
 
   /* F2008, C1239/C1240.  */
   if (actual->expr_type == EXPR_VARIABLE
@@ -2294,10 +2309,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 				 : NULL);
 
 	  if (f->sym->attr.pointer
-	      && gfc_check_vardef_context (a->expr, true, context)
+	      && gfc_check_vardef_context (a->expr, true, false, context)
 		   == FAILURE)
 	    return 0;
-	  if (gfc_check_vardef_context (a->expr, false, context)
+	  if (gfc_check_vardef_context (a->expr, false, false, context)
 		== FAILURE)
 	    return 0;
 	}
@@ -2749,6 +2764,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 			"for procedure '%s' at %L", sym->name, &a->expr->where);
 	      break;
 	    }
+
+	  /* F2008, C1303 and C1304.  */
+	  if (a->expr
+	      && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+	      && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+		   && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+		  || gfc_expr_attr (a->expr).lock_comp))
+	    {
+	      gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
+			"component at %L requires an explicit interface for "
+			"procedure '%s'", &a->expr->where, sym->name);
+	      break;
+	    }
 	}
 
       return;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 1cce144..a72da91 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3642,7 +3642,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
 				 : NULL);
 
 	  /* No pointer arguments for intrinsics.  */
-	  if (gfc_check_vardef_context (actual->expr, false, context)
+	  if (gfc_check_vardef_context (actual->expr, false, false, context)
 		== FAILURE)
 	    return FAILURE;
 	}
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index cb46a77..57338f1 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -12963,6 +12963,16 @@ Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
 denote that the lock variable is unlocked. (Fortran 2008 or later.)
 @end table
 
+The module provides the following derived type:
+
+@table @asis
+@item @code{LOCK_TYPE}:
+Derived type with private components to be use with the @code{LOCK} and
+@code{UNLOCK} statement. A variable of its type has to be always declared
+as coarray and may not appear in a variable-definition context.
+(Fortran 2008 or later.)
+@end table
+
 The module also provides the following intrinsic procedures:
 @ref{COMPILER_OPTIONS} and @ref{COMPILER_VERSION}.
 
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index c2d46af..58c942f 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1531,7 +1531,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e)
       char context[64];
 
       sprintf (context, _("%s tag"), tag->name);
-      if (gfc_check_vardef_context (e, false, context) == FAILURE)
+      if (gfc_check_vardef_context (e, false, false, context) == FAILURE)
 	return FAILURE;
     }
   
@@ -2836,8 +2836,8 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
       /* If we are writing, make sure the internal unit can be changed.  */
       gcc_assert (k != M_PRINT);
       if (k == M_WRITE
-	  && gfc_check_vardef_context (e, false, _("internal unit in WRITE"))
-	       == FAILURE)
+	  && gfc_check_vardef_context (e, false, false,
+				       _("internal unit in WRITE")) == FAILURE)
 	return FAILURE;
     }
 
@@ -2866,7 +2866,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 	  gfc_try t;
 
 	  e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
-	  t = gfc_check_vardef_context (e, false, NULL);
+	  t = gfc_check_vardef_context (e, false, false, NULL);
 	  gfc_free_expr (e);
 
 	  if (t == FAILURE)
@@ -4032,7 +4032,7 @@ gfc_resolve_inquire (gfc_inquire *inquire)
     { \
       char context[64]; \
       sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
-      if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \
+      if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
 	return FAILURE; \
     }
   INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index 8ec7074..240a022 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -110,7 +110,14 @@ NAMED_FUNCTION (ISOFORTRAN_COMPILER_OPTIONS, "compiler_options", \
 NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
                 GFC_ISYM_COMPILER_VERSION, GFC_STD_F2008)
 
+#ifndef NAMED_DERIVED_TYPE
+# define NAMED_DERIVED_TYPE(a,b,c,d)
+#endif
+
+NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
+              get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
 
 #undef NAMED_INTCST
 #undef NAMED_KINDARRAY
 #undef NAMED_FUNCTION
+#undef NAMED_DERIVED_TYPE
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 89281a5..4afe467 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1673,7 +1673,7 @@ typedef enum
   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
   AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
-  AB_VALUE, AB_VOLATILE, AB_PROTECTED,
+  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@@ -1716,6 +1716,7 @@ static const mstring attr_bits[] =
     minit ("VALUE", AB_VALUE),
     minit ("ALLOC_COMP", AB_ALLOC_COMP),
     minit ("COARRAY_COMP", AB_COARRAY_COMP),
+    minit ("LOCK_COMP", AB_LOCK_COMP),
     minit ("POINTER_COMP", AB_POINTER_COMP),
     minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
@@ -1889,6 +1890,8 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
       if (attr->coarray_comp)
 	MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
+      if (attr->lock_comp)
+	MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
       if (attr->zero_comp)
 	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
       if (attr->is_class)
@@ -2028,6 +2031,9 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_COARRAY_COMP:
 	      attr->coarray_comp = 1;
 	      break;
+	    case AB_LOCK_COMP:
+	      attr->lock_comp = 1;
+	      break;
 	    case AB_POINTER_COMP:
 	      attr->pointer_comp = 1;
 	      break;
@@ -5469,6 +5475,37 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value,
 }
 
 
+/* Add an derived type for a given module.  */
+
+static void
+create_derived_type (const char *name, const char *modname,
+		      intmod_id module, int id)
+{
+  gfc_symtree *tmp_symtree;
+  gfc_symbol *sym;
+
+  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+  if (tmp_symtree != NULL)
+    {
+      if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+	return;
+      else
+	gfc_error ("Symbol '%s' already declared", name);
+    }
+
+  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+  sym = tmp_symtree->n.sym;
+
+  sym->module = gfc_get_string (modname);
+  sym->from_intmod = module;
+  sym->intmod_sym_id = id;
+  sym->attr.flavor = FL_DERIVED;
+  sym->attr.private_comp = 1;
+  sym->attr.zero_comp = 1;
+  sym->attr.use_assoc = 1;
+}
+
+
 
 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
 
@@ -5489,6 +5526,9 @@ use_iso_fortran_env_module (void)
 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
 #include "iso-fortran-env.def"
 #undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
+#include "iso-fortran-env.def"
+#undef NAMED_DERIVED_TYPE
 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
 #include "iso-fortran-env.def"
 #undef NAMED_FUNCTION
@@ -5573,6 +5613,16 @@ use_iso_fortran_env_module (void)
 #include "iso-fortran-env.def"
 #undef NAMED_KINDARRAY
 
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+		case a:
+#include "iso-fortran-env.def"
+                  create_derived_type (u->local_name[0] ? u->local_name
+							: u->use_name,
+				       mod, INTMOD_ISO_FORTRAN_ENV,
+				       symbol[i].id);
+		  break;
+#undef NAMED_DERIVED_TYPE
+
 #define NAMED_FUNCTION(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
@@ -5626,6 +5676,14 @@ use_iso_fortran_env_module (void)
 #include "iso-fortran-env.def"
 #undef NAMED_KINDARRAY
 
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+	  case a:
+#include "iso-fortran-env.def"
+	    create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
+				 symbol[i].id);
+	    break;
+#undef NAMED_DERIVED_TYPE
+
 #define NAMED_FUNCTION(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 5ce5c1e..ba28648 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2143,6 +2143,13 @@ endType:
 	  || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
 	sym->attr.coarray_comp = 1;
 
+      /* Looking for lock_type components.  */
+      if (c->attr.lock_comp
+	  || (sym->ts.type == BT_DERIVED
+	      && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	      && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))
+	sym->attr.lock_comp = 1;
+
       /* Look for private components.  */
       if (sym->component_access == ACCESS_PRIVATE
 	  || c->attr.access == ACCESS_PRIVATE
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index cec45ca..f484a22 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6235,7 +6235,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
       == FAILURE)
     return FAILURE;
 
-  if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+  if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
       == FAILURE)
     return FAILURE;
 
@@ -6502,9 +6502,11 @@ resolve_deallocate_expr (gfc_expr *e)
     }
 
   if (pointer
-      && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+      && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+	 == FAILURE)
     return FAILURE;
-  if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+  if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+      == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -6796,6 +6798,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 		      &e->where, &code->expr3->where);
 	  goto failure;
 	}
+
+      /* Check F2008, C642.  */
+      if (code->expr3->ts.type == BT_DERIVED
+	  && ((codimension &&  gfc_expr_attr (code->expr3).lock_comp)
+	      || (code->expr3->ts.u.derived->from_intmod
+		     == INTMOD_ISO_FORTRAN_ENV
+		  && code->expr3->ts.u.derived->intmod_sym_id
+		     == ISOFORTRAN_LOCK_TYPE)))
+	{
+	  gfc_error ("The source-expr at %L shall neither be of type "
+		     "LOCK_TYPE nor have a LOCK_TYPE component if "
+		      "allocate-object at %L is a coarray",
+		      &code->expr3->where, &e->where);
+	  goto failure;
+	}
     }
 
   /* Check F08:C629.  */
@@ -6814,9 +6831,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   e2 = remove_last_array_ref (e);
   t = SUCCESS;
   if (t == SUCCESS && pointer)
-    t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+    t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
   if (t == SUCCESS)
-    t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+    t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
   gfc_free_expr (e2);
   if (t == FAILURE)
     goto failure;
@@ -6992,7 +7009,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
   /* Check the stat variable.  */
   if (stat)
     {
-      gfc_check_vardef_context (stat, false, _("STAT variable"));
+      gfc_check_vardef_context (stat, false, false, _("STAT variable"));
 
       if ((stat->ts.type != BT_INTEGER
 	   && !(stat->ref && (stat->ref->type == REF_ARRAY
@@ -7035,7 +7052,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 	gfc_warning ("ERRMSG at %L is useless without a STAT tag",
 		     &errmsg->where);
 
-      gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
+      gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
 
       if ((errmsg->ts.type != BT_CHARACTER
 	   && !(errmsg->ref
@@ -8100,7 +8117,8 @@ resolve_transfer (gfc_code *code)
      code->ext.dt may be NULL if the TRANSFER is related to
      an INQUIRE statement -- but in this case, we are not reading, either.  */
   if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
-      && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
+      && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+	 == FAILURE)
     return;
 
   sym = exp->symtree->n.sym;
@@ -8201,13 +8219,15 @@ find_reachable_labels (gfc_code *block)
 static void
 resolve_lock_unlock (gfc_code *code)
 {
-  /* FIXME: Add more lock-variable checks. For now, always reject it.
-     Note that ISO_FORTRAN_ENV's LOCK_TYPE is not yet available.  */
-  /* if (code->expr2->ts.type != BT_DERIVED
-	 || code->expr2->rank != 0
-	 || code->expr2->expr_type != EXPR_VARIABLE)  */
-  gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
-	     &code->expr1->where);
+  if (code->expr1->ts.type != BT_DERIVED
+      || code->expr1->expr_type != EXPR_VARIABLE
+      || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+      || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+      || code->expr1->rank != 0
+      || !(gfc_expr_attr (code->expr1).codimension
+	   || gfc_is_coindexed (code->expr1)))
+    gfc_error ("Lock variable at %L must be a scalar coarray of type "
+	       "LOCK_TYPE", &code->expr1->where);
 
   /* Check STAT.  */
   if (code->expr2
@@ -8216,6 +8236,11 @@ resolve_lock_unlock (gfc_code *code)
     gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
 	       &code->expr2->where);
 
+  if (code->expr2
+      && gfc_check_vardef_context (code->expr2, false, false,
+				   _("STAT variable")) == FAILURE)
+    return;
+
   /* Check ERRMSG.  */
   if (code->expr3
       && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
@@ -8223,12 +8248,22 @@ resolve_lock_unlock (gfc_code *code)
     gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
 	       &code->expr3->where);
 
+  if (code->expr3
+      && gfc_check_vardef_context (code->expr3, false, false,
+				   _("ERRMSG variable")) == FAILURE)
+    return;
+
   /* Check ACQUIRED_LOCK.  */
   if (code->expr4
       && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
 	  || code->expr4->expr_type != EXPR_VARIABLE))
     gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
 	       "variable", &code->expr4->where);
+
+  if (code->expr4
+      && gfc_check_vardef_context (code->expr4, false, false,
+				   _("ACQUIRED_LOCK variable")) == FAILURE)
+    return;
 }
 
 
@@ -9143,8 +9178,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
-	  if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
-		== FAILURE)
+	  if (gfc_check_vardef_context (code->expr1, false, false,
+					_("assignment")) == FAILURE)
 	    break;
 
 	  if (resolve_ordinary_assign (code, ns))
@@ -9182,9 +9217,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	       array ref may be present on the LHS and fool gfc_expr_attr
 	       used in gfc_check_vardef_context.  Remove it.  */
 	    e = remove_last_array_ref (code->expr1);
-	    t = gfc_check_vardef_context (e, true, _("pointer assignment"));
+	    t = gfc_check_vardef_context (e, true, false,
+					  _("pointer assignment"));
 	    if (t == SUCCESS)
-	      t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+	      t = gfc_check_vardef_context (e, false, false,
+					    _("pointer assignment"));
 	    gfc_free_expr (e);
 	    if (t == FAILURE)
 	      break;
@@ -12340,6 +12377,17 @@ resolve_symbol (gfc_symbol *sym)
 			 sym->ts.u.derived->name) == FAILURE)
     return;
 
+  /* F2008, C1302.  */
+  if (sym->ts.type == BT_DERIVED
+      && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+      && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
+      && !sym->attr.codimension)
+    {
+      gfc_error ("Variable '%s' at %L of type LOCK_TYPE must be a coarray",
+		 sym->name, &sym->declared_at);
+      return;
+    }
+
   /* An assumed-size array with INTENT(OUT) shall not be of a type for which
      default initialization is defined (5.1.2.4.4).  */
   if (sym->ts.type == BT_DERIVED
@@ -12360,6 +12408,12 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  /* F2008, C542.  */
+  if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+      && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+    gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+	       "INTENT(OUT)", sym->name, &sym->declared_at);
+
   /* F2008, C526.  */
   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
        || sym->attr.codimension)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 183778f..a5f2d9e 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -653,6 +653,48 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
 
 
 tree
+gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
+{
+  gfc_se se, argse;
+  tree stat = NULL_TREE, lock_acquired = NULL_TREE;
+
+  /* Short cut: For single images without STAT= or LOCK_ACQUIRED
+     return early. (ERRMSG= is always untouched for -fcoarray=single.)  */
+  if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
+    return NULL_TREE; 
+
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  if (code->expr2)
+    {
+      gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr2);
+      stat = argse.expr;
+    }
+
+  if (code->expr4)
+    {
+      gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr4);
+      lock_acquired = argse.expr;
+    }
+
+  if (stat != NULL_TREE)
+    gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+  if (lock_acquired != NULL_TREE)
+    gfc_add_modify (&se.pre, lock_acquired,
+		    fold_convert (TREE_TYPE (lock_acquired),
+				  boolean_true_node));
+
+  return gfc_finish_block (&se.pre);
+}
+
+
+tree
 gfc_trans_sync (gfc_code *code, gfc_exec_op type)
 {
   gfc_se se, argse;
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 8b77750..2d0faf1 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -54,6 +54,7 @@ tree gfc_trans_do (gfc_code *, tree);
 tree gfc_trans_do_while (gfc_code *);
 tree gfc_trans_select (gfc_code *);
 tree gfc_trans_sync (gfc_code *, gfc_exec_op);
+tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
 tree gfc_trans_forall (gfc_code *);
 tree gfc_trans_where (gfc_code *);
 tree gfc_trans_allocate (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index ee35387..33593c5 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1318,6 +1318,11 @@ trans_code (gfc_code * code, tree cond)
 	  res = gfc_trans_sync (code, code->op);
 	  break;
 
+	case EXEC_LOCK:
+	case EXEC_UNLOCK:
+	  res = gfc_trans_lock_unlock (code, code->op);
+	  break;
+
 	case EXEC_FORALL:
 	  res = gfc_trans_forall (code);
 	  break;