Patchwork [Fortran] (coarray) Add LOCK_TYPE

login
register
mail settings
Submitter Tobias Burnus
Date June 16, 2011, 6:27 a.m.
Message ID <4DF9A24E.1040800@net-b.de>
Download mbox | patch
Permalink /patch/100593/
State New
Headers show

Comments

Tobias Burnus - June 16, 2011, 6:27 a.m.
This patch adds ISO_Fortran_Env's LOCK_TYPE, tons of constraint checks 
and a simple implementation for -fcoarray=single.

With the implementation of LOCK_TYPE and (UN)LOCK, gfortran can now 
parse all coarrays constructs of Fortran 2008. (However, there are still 
known deficits and bugs in the resolving/code-producing stage; for 
instance, allocatable scalar coarrays are not yet implemented.)

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
Tobias Burnus - June 20, 2011, 2:45 p.m.
*PING*

On 06/16/2011 08:27 AM, Tobias Burnus wrote:
> This patch adds ISO_Fortran_Env's LOCK_TYPE, tons of constraint checks 
> and a simple implementation for -fcoarray=single.
>
> With the implementation of LOCK_TYPE and (UN)LOCK, gfortran can now 
> parse all coarrays constructs of Fortran 2008. (However, there are 
> still known deficits and bugs in the resolving/code-producing stage; 
> for instance, allocatable scalar coarrays are not yet implemented.)
>
> Build and regtested on x86-64-linux.
> OK for the trunk?
>
> Tobias
Paul Richard Thomas - June 20, 2011, 7:08 p.m.
Dear Tobias,

I have checked out the code for any obvious style or other minor
errors and all looks well.  However, I had a look at 8.5.6 "LOCK and
UNLOCK statements" in the standard and can only confess to feeling
very stupid tonight because I could not make head nor tail of the
example.  Thus, I can offer no judgement on the functionality of your
patch.

In light of this and the rather thorough protection of the core F95
compiler from co-arrays, I would just go ahead and commit the patch,
if I were you.

OK for trunk

Paul

PS Please give me a co-array tutorial sometime!

On Mon, Jun 20, 2011 at 4:45 PM, Tobias Burnus <burnus@net-b.de> wrote:
> *PING*
>
> On 06/16/2011 08:27 AM, Tobias Burnus wrote:
>>
>> This patch adds ISO_Fortran_Env's LOCK_TYPE, tons of constraint checks and
>> a simple implementation for -fcoarray=single.
>>
>> With the implementation of LOCK_TYPE and (UN)LOCK, gfortran can now parse
>> all coarrays constructs of Fortran 2008. (However, there are still known
>> deficits and bugs in the resolving/code-producing stage; for instance,
>> allocatable scalar coarrays are not yet implemented.)
>>
>> Build and regtested on x86-64-linux.
>> OK for the trunk?
>>
>> Tobias
>

Patch

2011-06-16  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-16  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.


diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 1178967..04cd188 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 f23fbbd..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 46f9d14..19adf8a 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 533246d..d524aee 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;
@@ -5467,6 +5473,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.  */
 
@@ -5487,6 +5524,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
@@ -5571,6 +5611,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"
@@ -5624,6 +5674,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 6013931..4f88411 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2141,6 +2141,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 b2c3189..e7c2e8a 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;
@@ -12338,6 +12375,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
@@ -12358,6 +12406,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..31b2e10 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -653,6 +653,47 @@  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->expr2->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, code->expr2);
+      lock_acquired = argse.expr;
+    }
+
+  if (stat != NULL_TREE)
+    gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+  if (stat != NULL_TREE)
+    gfc_add_modify (&se.pre, lock_acquired,
+		    build_int_cst (TREE_TYPE (lock_acquired), 0));
+
+  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;
diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_1.f90
index 419ba47..f9ef581 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lock_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lock_1.f90
@@ -10,6 +10,6 @@  integer :: s
 character(len=3) :: c
 logical :: bool
 
-LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" }
-UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" }
+LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
 end
--- /dev/null	2011-06-15 19:51:47.947868702 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lock_3.f90	2011-06-16 01:45:19.000000000 +0200
@@ -0,0 +1,107 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+!
+! LOCK/LOCK_TYPE checks 
+!
+subroutine extends()
+use iso_fortran_env
+type t
+end type t
+type, extends(t) :: t2 ! { dg-error "coarray component, parent type .t. shall also have one" }
+  type(lock_type), allocatable :: c(:)[:]
+end type t2
+end subroutine extends
+
+module m
+  use iso_fortran_env
+
+  type t
+    type(lock_type), allocatable :: x(:)[:]
+  end type t
+
+  type t2
+    type(lock_type), allocatable :: x
+  end type t2
+end module m
+
+subroutine sub(x)
+  use iso_fortran_env
+  type(lock_type), intent(out) :: x[*] ! OK
+end subroutine sub
+
+subroutine sub1(x) ! { dg-error "is INTENT.OUT. and can thus not be an allocatable coarray or have coarray components" }
+  use iso_fortran_env
+  type(lock_type), allocatable, intent(out) :: x(:)[:]
+end subroutine sub1
+
+subroutine sub2(x) ! { dg-error "is INTENT.OUT. and can thus not be an allocatable coarray or have coarray components" }
+  use m
+  type(t), intent(out) :: x
+end subroutine sub2
+
+subroutine sub3(x) ! { dg-error "with coarray component shall be a nonpointer, nonallocatable scalar" }
+  use m
+  type(t), intent(inout) :: x[*]
+end subroutine sub3
+
+subroutine sub4(x)
+  use m
+  type(t2), intent(inout) :: x[*] ! OK
+end subroutine sub4
+
+subroutine lock_test
+  use iso_fortran_env
+  type t
+  end type t
+  type(lock_type) :: lock ! { dg-error "type LOCK_TYPE must be a coarray" }
+end subroutine lock_test
+
+subroutine lock_test2
+  use iso_fortran_env
+  implicit none
+  type t
+  end type t
+  type(t) :: x
+  type(lock_type), save :: lock[*],lock2(2)[*]
+  lock(t) ! { dg-error "Syntax error in LOCK statement" }
+  lock(x) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+  lock(lock)
+  lock(lock2(1))
+  lock(lock2) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+  lock(lock[1]) ! { dg-error "must be a scalar coarray of type LOCK_TYPE" }
+end subroutine lock_test2
+
+
+subroutine lock_test3
+  use iso_fortran_env
+  type(lock_type), save :: a[*], b[*]
+  a = b ! { dg-error "LOCK_TYPE in variable definition context" }
+  b = lock_type() ! { dg-error "LOCK_TYPE in variable definition context" }
+  print *, a ! { dg-error "cannot have PRIVATE components" }
+end subroutine lock_test3
+
+
+subroutine lock_test4
+  use iso_fortran_env
+  type(lock_type), allocatable :: A(:)[:]
+  logical :: ob
+  allocate(A(1)[*])
+  lock(A(1), acquired_lock=ob)
+  unlock(A(1))
+  deallocate(A)
+end subroutine lock_test4
+
+
+subroutine argument_check()
+  use iso_fortran_env
+  type(lock_type), SAVE :: ll[*]
+  call no_interface(ll) ! { dg-error "Actual argument of LOCK_TYPE or with LOCK_TYPE component at .1. requires an explicit interface" }
+  call test(ll) ! { dg-error "non-INTENT.INOUT. dummy .x. at .1., which is LOCK_TYPE or has a LOCK_TYPE component" }
+contains
+  subroutine test(x)
+    type(lock_type), intent(in) :: x[*]
+  end subroutine test
+end subroutine argument_check
+
+! { dg-final { cleanup-modules "m" } }