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

1 files changed, 59 insertions, 1 deletions

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"