re PR fortran/40632 (Support F2008's contiguous attribute)

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

        PR fortran/40632
        * interface.c (compare_parameter): Add gfc_is_simply_contiguous
        checks.
        * symbol.c (gfc_add_contiguous): New function.
        (gfc_copy_attr, check_conflict): Handle contiguous attribute.
        * decl.c (match_attr_spec): Ditto.
        (gfc_match_contiguous): New function.
        * resolve.c (resolve_fl_derived, resolve_symbol): Handle
        contiguous.
        * gfortran.h (symbol_attribute): Add contiguous.
        (gfc_is_simply_contiguous): Add prototype.
        (gfc_add_contiguous): Add prototype.
        * match.h (gfc_match_contiguous): Add prototype.
        * parse.c (decode_specification_statement,
        decode_statement): Handle contiguous attribute.
        * expr.c (gfc_is_simply_contiguous): New function.
        * dump-parse-tree.c (show_attr): Handle contiguous.
        * module.c (ab_attribute, attr_bits, mio_symbol_attribute):
        Ditto.
        * trans-expr.c (gfc_add_interface_mapping): Copy
        attr.contiguous.
        * trans-array.c (gfc_conv_descriptor_stride_get,
        gfc_conv_array_parameter): Handle contiguous arrays.
        * trans-types.c (gfc_build_array_type, gfc_build_array_type,
        gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info):
        Ditto.
        * trans.h (gfc_array_kind): Ditto.
        * trans-decl.c (gfc_get_symbol_decl): Ditto.

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

        PR fortran/40632
        * gfortran.dg/contiguous_1.f90: New.
        * gfortran.dg/contiguous_2.f90: New.
        * gfortran.dg/contiguous_3.f90: New.

From-SVN: r161079

gcc/fortran/ChangeLog

+2010-06-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40632
+	* interface.c (compare_parameter): Add gfc_is_simply_contiguous
+	checks.
+	* symbol.c (gfc_add_contiguous): New function.
+	(gfc_copy_attr, check_conflict): Handle contiguous attribute.
+	* decl.c (match_attr_spec): Ditto.
+	(gfc_match_contiguous): New function.
+	* resolve.c (resolve_fl_derived, resolve_symbol): Handle
+	contiguous.
+	* gfortran.h (symbol_attribute): Add contiguous.
+	(gfc_is_simply_contiguous): Add prototype.
+	(gfc_add_contiguous): Add prototype.
+	* match.h (gfc_match_contiguous): Add prototype.
+	* parse.c (decode_specification_statement,
+	decode_statement): Handle contiguous attribute.
+	* expr.c (gfc_is_simply_contiguous): New function.
+	* dump-parse-tree.c (show_attr): Handle contiguous.
+	* module.c (ab_attribute, attr_bits, mio_symbol_attribute):
+	Ditto.
+	* trans-expr.c (gfc_add_interface_mapping): Copy
+	attr.contiguous.
+	* trans-array.c (gfc_conv_descriptor_stride_get,
+	gfc_conv_array_parameter): Handle contiguous arrays.
+	* trans-types.c (gfc_build_array_type, gfc_build_array_type,
+	gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info):
+	Ditto.
+	* trans.h (gfc_array_kind): Ditto.
+	* trans-decl.c (gfc_get_symbol_decl): Ditto.
+
 2010-06-20  Joseph Myers  <joseph@codesourcery.com>
 
 	* options.c (gfc_handle_option): Don't handle N_OPTS.

gcc/fortran/decl.c

@@ -2875,8 +2875,8 @@ match_attr_spec (void)
     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
-    DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE,
-    GFC_DECL_END /* Sentinel */
+    DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
+    DECL_NONE, GFC_DECL_END /* Sentinel */
   }
   decl_types;
 
@@ -2939,6 +2939,7 @@ match_attr_spec (void)
 		    }
 		  break;
 		}
+	      break;
 
 	    case 'b':
 	      /* Try and match the bind(c).  */
@@ -2950,8 +2951,24 @@ match_attr_spec (void)
 	      break;
 
 	    case 'c':
-	      if (match_string_p ("codimension"))
-		d = DECL_CODIMENSION;
+	      gfc_next_ascii_char ();
+	      if ('o' != gfc_next_ascii_char ())
+		break;
+	      switch (gfc_next_ascii_char ())
+		{
+		case 'd':
+		  if (match_string_p ("imension"))
+		    {
+		      d = DECL_CODIMENSION;
+		      break;
+		    }
+		case 'n':
+		  if (match_string_p ("tiguous"))
+		    {
+		      d = DECL_CONTIGUOUS;
+		      break;
+		    }
+		}
 	      break;
 
 	    case 'd':
@@ -3144,6 +3161,9 @@ match_attr_spec (void)
 	  case DECL_CODIMENSION:
 	    attr = "CODIMENSION";
 	    break;
+	  case DECL_CONTIGUOUS:
+	    attr = "CONTIGUOUS";
+	    break;
 	  case DECL_DIMENSION:
 	    attr = "DIMENSION";
 	    break;
@@ -3214,7 +3234,7 @@ match_attr_spec (void)
       if (gfc_current_state () == COMP_DERIVED
 	  && d != DECL_DIMENSION && d != DECL_CODIMENSION
 	  && d != DECL_POINTER   && d != DECL_PRIVATE
-	  && d != DECL_PUBLIC && d != DECL_NONE)
+	  && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
 	{
 	  if (d == DECL_ALLOCATABLE)
 	    {
@@ -3283,6 +3303,15 @@ match_attr_spec (void)
 	  t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
 	  break;
 
+	case DECL_CONTIGUOUS:
+	  if (gfc_notify_std (GFC_STD_F2008,
+			      "Fortran 2008: CONTIGUOUS attribute at %C")
+	      == FAILURE)
+	    t = FAILURE;
+	  else
+	    t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
+	  break;
+
 	case DECL_DIMENSION:
 	  t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
 	  break;
@@ -6121,6 +6150,20 @@ gfc_match_codimension (void)
 
 
 match
+gfc_match_contiguous (void)
+{
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  gfc_clear_attr (&current_attr);
+  current_attr.contiguous = 1;
+
+  return attr_decl ();
+}
+
+
+match
 gfc_match_dimension (void)
 {
   gfc_clear_attr (&current_attr);

gcc/fortran/dependency.c

@@ -1588,4 +1588,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
 
   return fin_dep == GFC_DEP_OVERLAP;
 }
-

gcc/fortran/dependency.h

@@ -43,3 +43,4 @@ int gfc_expr_is_one (gfc_expr *, int);
 
 int gfc_dep_resolver(gfc_ref *, gfc_ref *);
 int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
+

gcc/fortran/dump-parse-tree.c

@@ -598,6 +598,8 @@ show_attr (symbol_attribute *attr)
     fputs (" CODIMENSION", dumpfile);
   if (attr->dimension)
     fputs (" DIMENSION", dumpfile);
+  if (attr->contiguous)
+    fputs (" CONTIGUOUS", dumpfile);
   if (attr->external)
     fputs (" EXTERNAL", dumpfile);
   if (attr->intrinsic)

gcc/fortran/expr.c

@@ -4080,3 +4080,105 @@ gfc_has_ultimate_pointer (gfc_expr *e)
   else
     return false;
 }
+
+
+/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
+   Note: A scalar is not regarded as "simply contiguous" by the standard.
+   if bool is not strict, some futher checks are done - for instance,
+   a "(::1)" is accepted.  */
+
+bool
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+{
+  bool colon;
+  int i;
+  gfc_array_ref *ar = NULL;
+  gfc_ref *ref, *part_ref = NULL;
+
+  if (expr->expr_type == EXPR_FUNCTION)
+    return expr->value.function.esym
+	   ? expr->value.function.esym->result->attr.contiguous : false;
+  else if (expr->expr_type != EXPR_VARIABLE)
+    return false;
+
+  if (expr->rank == 0)
+    return false;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ar)
+	return false; /* Array shall be last part-ref. */
+
+      if (ref->type == REF_COMPONENT)
+	part_ref  = ref;
+      else if (ref->type == REF_SUBSTRING)
+	return false;
+      else if (ref->u.ar.type != AR_ELEMENT)
+	ar = &ref->u.ar;
+    }
+
+  if ((part_ref && !part_ref->u.c.component->attr.contiguous
+       && part_ref->u.c.component->attr.pointer)
+      || (!part_ref && !expr->symtree->n.sym->attr.contiguous
+	  && (expr->symtree->n.sym->attr.pointer
+	      || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
+    return false;
+
+  if (!ar || ar->type == AR_FULL)
+    return true;
+
+  gcc_assert (ar->type == AR_SECTION);
+
+  /* Check for simply contiguous array */
+  colon = true;
+  for (i = 0; i < ar->dimen; i++)
+    {
+      if (ar->dimen_type[i] == DIMEN_VECTOR)
+	return false;
+
+      if (ar->dimen_type[i] == DIMEN_ELEMENT)
+	{
+	  colon = false;
+	  continue;
+	}
+
+      gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
+
+
+      /* If the previous section was not contiguous, that's an error,
+	 unless we have effective only one element and checking is not
+	 strict.  */
+      if (!colon && (strict || !ar->start[i] || !ar->end[i]
+		     || ar->start[i]->expr_type != EXPR_CONSTANT
+		     || ar->end[i]->expr_type != EXPR_CONSTANT
+		     || mpz_cmp (ar->start[i]->value.integer,
+				 ar->end[i]->value.integer) != 0))
+	return false;
+
+      /* Following the standard, "(::1)" or - if known at compile time -
+	 "(lbound:ubound)" are not simply contigous; if strict
+	 is false, they are regarded as simply contiguous.  */
+      if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
+			    || ar->stride[i]->ts.type != BT_INTEGER
+			    || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
+	return false;
+
+      if (ar->start[i]
+	  && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
+	      || !ar->as->lower[i]
+	      || ar->as->lower[i]->expr_type != EXPR_CONSTANT
+	      || mpz_cmp (ar->start[i]->value.integer,
+			  ar->as->lower[i]->value.integer) != 0))
+	colon = false;
+
+      if (ar->end[i]
+	  && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
+	      || !ar->as->upper[i]
+	      || ar->as->upper[i]->expr_type != EXPR_CONSTANT
+	      || mpz_cmp (ar->end[i]->value.integer,
+			  ar->as->upper[i]->value.integer) != 0))
+	colon = false;
+    }
+  
+  return true;
+}

gcc/fortran/gfortran.h

@@ -665,7 +665,8 @@ typedef struct
   unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1,
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
-    implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1;
+    implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1,
+    contiguous:1;
 
   /* For CLASS containers, the pointer attribute is sometimes set internally
      even though it was not directly specified.  In this case, keep the
@@ -2437,6 +2438,7 @@ gfc_try gfc_add_attribute (symbol_attribute *, locus *);
 gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *);
 gfc_try gfc_add_allocatable (symbol_attribute *, locus *);
 gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *);
+gfc_try gfc_add_contiguous (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_external (symbol_attribute *, locus *);
 gfc_try gfc_add_intrinsic (symbol_attribute *, locus *);
@@ -2614,6 +2616,7 @@ void gfc_free_actual_arglist (gfc_actual_arglist *);
 gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 const char *gfc_extract_int (gfc_expr *, int *);
 bool is_subref_array (gfc_expr *);
+bool gfc_is_simply_contiguous (gfc_expr *, bool);
 
 gfc_expr *gfc_build_conversion (gfc_expr *);
 void gfc_free_ref_list (gfc_ref *);

gcc/fortran/interface.c

@@ -1435,6 +1435,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 1;
     }
 
+  /* F2008, C1241.  */
+  if (formal->attr.pointer && formal->attr.contiguous
+      && !gfc_is_simply_contiguous (actual, true))
+    {
+      if (where)
+	gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+		   "must be simply contigous", formal->name, &actual->where);
+      return 0;
+    }
+
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && !gfc_compare_types (&formal->ts, &actual->ts))
     {
@@ -1502,6 +1512,34 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 			: actual->symtree->n.sym->as->corank);
 	  return 0;
 	}
+
+      /* F2008, 12.5.2.8.  */
+      if (formal->attr.dimension
+	  && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+	  && !gfc_is_simply_contiguous (actual, true))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be simply "
+		       "contiguous", formal->name, &actual->where);
+	  return 0;
+	}
+    }
+
+  /* F2008, C1239/C1240.  */
+  if (actual->expr_type == EXPR_VARIABLE
+      && (actual->symtree->n.sym->attr.asynchronous
+         || actual->symtree->n.sym->attr.volatile_)
+      &&  (formal->attr.asynchronous || formal->attr.volatile_)
+      && actual->rank && !gfc_is_simply_contiguous (actual, true)
+      && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+	  || formal->attr.contiguous))
+    {
+      if (where)
+	gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+		   "array without CONTIGUOUS attribute - as actual argument at"
+		   " %L is not simply contiguous and both are ASYNCHRONOUS "
+		   "or VOLATILE", formal->name, &actual->where);
+      return 0;
     }
 
   if (symbol_rank (formal) == actual->rank)

gcc/fortran/match.h

@@ -168,6 +168,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int);
 match gfc_match_allocatable (void);
 match gfc_match_asynchronous (void);
 match gfc_match_codimension (void);
+match gfc_match_contiguous (void);
 match gfc_match_dimension (void);
 match gfc_match_external (void);
 match gfc_match_gcc_attributes (void);

gcc/fortran/module.c

@@ -1675,7 +1675,7 @@ typedef enum
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   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_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS
 }
 ab_attribute;
 
@@ -1685,6 +1685,7 @@ static const mstring attr_bits[] =
     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
     minit ("DIMENSION", AB_DIMENSION),
     minit ("CODIMENSION", AB_CODIMENSION),
+    minit ("CONTIGUOUS", AB_CONTIGUOUS),
     minit ("EXTERNAL", AB_EXTERNAL),
     minit ("INTRINSIC", AB_INTRINSIC),
     minit ("OPTIONAL", AB_OPTIONAL),
@@ -1807,6 +1808,8 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
       if (attr->codimension)
 	MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
+      if (attr->contiguous)
+	MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
       if (attr->external)
 	MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
       if (attr->intrinsic)
@@ -1915,6 +1918,9 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_CODIMENSION:
 	      attr->codimension = 1;
 	      break;
+	    case AB_CONTIGUOUS:
+	      attr->contiguous = 1;
+	      break;
 	    case AB_EXTERNAL:
 	      attr->external = 1;
 	      break;

gcc/fortran/parse.c

@@ -139,6 +139,7 @@ decode_specification_statement (void)
 
     case 'c':
       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
+      match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
       break;
 
     case 'd':
@@ -346,6 +347,7 @@ decode_statement (void)
       match ("call", gfc_match_call, ST_CALL);
       match ("close", gfc_match_close, ST_CLOSE);
       match ("continue", gfc_match_continue, ST_CONTINUE);
+      match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
       match ("cycle", gfc_match_cycle, ST_CYCLE);
       match ("case", gfc_match_case, ST_CASE);
       match ("common", gfc_match_common, ST_COMMON);

gcc/fortran/resolve.c

@@ -10826,6 +10826,14 @@ resolve_fl_derived (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
+      /* F2008, C448.  */
+      if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+	{
+	  gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
+		     "is not an array pointer", c->name, &c->loc);
+	  return FAILURE;
+	}
+
       if (c->attr.proc_pointer && c->ts.interface)
 	{
 	  if (c->ts.interface->attr.procedure && !sym->attr.vtype)
@@ -11397,6 +11405,7 @@ resolve_symbol (gfc_symbol *sym)
 	  sym->attr.pure = ifc->attr.pure;
 	  sym->attr.elemental = ifc->attr.elemental;
 	  sym->attr.dimension = ifc->attr.dimension;
+	  sym->attr.contiguous = ifc->attr.contiguous;
 	  sym->attr.recursive = ifc->attr.recursive;
 	  sym->attr.always_explicit = ifc->attr.always_explicit;
           sym->attr.ext_attr |= ifc->attr.ext_attr;
@@ -11442,6 +11451,18 @@ resolve_symbol (gfc_symbol *sym)
       return;
     }
 
+
+  /* F2008, C530. */
+  if (sym->attr.contiguous
+      && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
+				   && !sym->attr.pointer)))
+    {
+      gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
+		  "array pointer or an assumed-shape array", sym->name,
+		  &sym->declared_at);
+      return;
+    }
+
   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
 
@@ -11500,6 +11521,7 @@ resolve_symbol (gfc_symbol *sym)
 		  sym->attr.dimension = sym->result->attr.dimension;
 		  sym->attr.pointer = sym->result->attr.pointer;
 		  sym->attr.allocatable = sym->result->attr.allocatable;
+		  sym->attr.contiguous = sym->result->attr.contiguous;
 		}
 	    }
 	}

gcc/fortran/symbol.c

@@ -372,7 +372,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
     *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
-    *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION";
+    *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
+    *contiguous = "CONTIGUOUS";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -518,6 +519,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (cray_pointer, cray_pointee);
   conf (cray_pointer, dimension);
   conf (cray_pointer, codimension);
+  conf (cray_pointer, contiguous);
   conf (cray_pointer, pointer);
   conf (cray_pointer, target);
   conf (cray_pointer, allocatable);
@@ -529,6 +531,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (cray_pointer, entry);
 
   conf (cray_pointee, allocatable);
+  conf (cray_pointer, contiguous);
   conf (cray_pointer, codimension);
   conf (cray_pointee, intent);
   conf (cray_pointee, optional);
@@ -613,6 +616,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (dummy);
       conf2 (volatile_);
       conf2 (asynchronous);
+      conf2 (contiguous);
       conf2 (pointer);
       conf2 (is_protected);
       conf2 (target);
@@ -720,6 +724,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (function);
       conf2 (subroutine);
       conf2 (entry);
+      conf2 (contiguous);
       conf2 (pointer);
       conf2 (is_protected);
       conf2 (target);
@@ -928,6 +933,18 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
 
 
 gfc_try
+gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return FAILURE;
+
+  attr->contiguous = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+gfc_try
 gfc_add_external (symbol_attribute *attr, locus *where)
 {
 
@@ -1715,6 +1732,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
     goto fail;
   if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
     goto fail;
+  if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->optional && gfc_add_optional (dest, where) == FAILURE)
     goto fail;
   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)

gcc/fortran/trans-array.c

@@ -285,7 +285,9 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
   tree type = TREE_TYPE (desc);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
   if (integer_zerop (dim)
-      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+      && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
     return gfc_index_one_node;
 
   return gfc_conv_descriptor_stride (desc, dim);
@@ -5522,6 +5524,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 
   ultimate_ptr_comp = false;
   ultimate_alloc_comp = false;
+
   for (ref = expr->ref; ref; ref = ref->next)
     {
       if (ref->next == NULL)
@@ -5608,7 +5611,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
   contiguous = g77 && !this_array_result && contiguous;
 
   /* There is no need to pack and unpack the array, if it is contiguous
-     and not deferred or assumed shape.  */
+     and not a deferred- or assumed-shape array, or if it is simply
+     contiguous.  */
   no_pack = ((sym && sym->as
 		  && !sym->attr.pointer
 		  && sym->as->type != AS_DEFERRED
@@ -5616,7 +5620,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 		      ||
 	     (ref && ref->u.ar.as
 		  && ref->u.ar.as->type != AS_DEFERRED
-		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
+		      ||
+	     gfc_is_simply_contiguous (expr, false));
 
   no_pack = contiguous && no_pack;
 
@@ -5680,9 +5686,24 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
       gfc_add_expr_to_block (&se->post, tmp);
     }
 
-  if (g77)
+  if (g77 || (fsym && fsym->attr.contiguous
+	      && !gfc_is_simply_contiguous (expr, false)))
     {
+      tree origptr = NULL_TREE;
+
       desc = se->expr;
+
+      /* For contiguous arrays, save the original value of the descriptor.  */
+      if (!g77)
+	{
+	  origptr = gfc_create_var (pvoid_type_node, "origptr");
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+	  tmp = gfc_conv_array_data (tmp);
+	  tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (origptr), origptr,
+			     fold_convert (TREE_TYPE (origptr), tmp));
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+
       /* Repack the array.  */
       if (gfc_option.warn_array_temp)
 	{
@@ -5706,7 +5727,15 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 
       ptr = gfc_evaluate_now (ptr, &se->pre);
 
-      se->expr = ptr;
+      /* Use the packed data for the actual argument, except for contiguous arrays,
+	 where the descriptor's data component is set.  */
+      if (g77)
+	se->expr = ptr;
+      else
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, desc);
+	  gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+	}
 
       if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
 	{
@@ -5768,6 +5797,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
       gfc_add_block_to_block (&block, &se->post);
 
       gfc_init_block (&se->post);
+
+      /* Reset the descriptor pointer.  */
+      if (!g77)
+        {
+          tmp = build_fold_indirect_ref_loc (input_location, desc);
+          gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+        }
+
       gfc_add_block_to_block (&se->post, &block);
     }
 }

gcc/fortran/trans-decl.c

@@ -1213,7 +1213,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       /* Create variables to hold the non-constant bits of array info.  */
       gfc_build_qualified_array (decl, sym);
 
-      if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
+      if (sym->attr.contiguous
+	  || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
 	GFC_DECL_PACKED_ARRAY (decl) = 1;
     }
 

gcc/fortran/trans-expr.c

@@ -1718,6 +1718,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   new_sym->as = gfc_copy_array_spec (sym->as);
   new_sym->attr.referenced = 1;
   new_sym->attr.dimension = sym->attr.dimension;
+  new_sym->attr.contiguous = sym->attr.contiguous;
   new_sym->attr.codimension = sym->attr.codimension;
   new_sym->attr.pointer = sym->attr.pointer;
   new_sym->attr.allocatable = sym->attr.allocatable;

gcc/fortran/trans-types.c

@@ -1202,7 +1202,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
 
 static tree
 gfc_build_array_type (tree type, gfc_array_spec * as,
-		      enum gfc_array_kind akind, bool restricted)
+		      enum gfc_array_kind akind, bool restricted,
+		      bool contiguous)
 {
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
@@ -1219,7 +1220,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
     }
 
   if (as->type == AS_ASSUMED_SHAPE)
-    akind = GFC_ARRAY_ASSUMED_SHAPE;
+    akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
+		       : GFC_ARRAY_ASSUMED_SHAPE;
   return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
 				    ubound, 0, akind, restricted);
 }
@@ -1799,10 +1801,12 @@ gfc_sym_type (gfc_symbol * sym)
 	{
 	  enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
 	  if (sym->attr.pointer)
-	    akind = GFC_ARRAY_POINTER;
+	    akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+					 : GFC_ARRAY_POINTER;
 	  else if (sym->attr.allocatable)
 	    akind = GFC_ARRAY_ALLOCATABLE;
-	  type = gfc_build_array_type (type, sym->as, akind, restricted);
+	  type = gfc_build_array_type (type, sym->as, akind, restricted,
+				       sym->attr.contiguous);
 	}
     }
   else
@@ -2121,14 +2125,16 @@ gfc_get_derived_type (gfc_symbol * derived)
 	    {
 	      enum gfc_array_kind akind;
 	      if (c->attr.pointer)
-		akind = GFC_ARRAY_POINTER;
+		akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+					   : GFC_ARRAY_POINTER;
 	      else
 		akind = GFC_ARRAY_ALLOCATABLE;
 	      /* Pointers to arrays aren't actually pointer types.  The
 	         descriptors are separate, but the data is common.  */
 	      field_type = gfc_build_array_type (field_type, c->as, akind,
 						 !c->attr.target
-						 && !c->attr.pointer);
+						 && !c->attr.pointer,
+						 c->attr.contiguous);
 	    }
 	  else
 	    field_type = gfc_get_nodesc_array_type (field_type, c->as,
@@ -2516,7 +2522,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
   if (int_size_in_bytes (etype) <= 0)
     return false;
   /* Nor non-constant lower bounds in assumed shape arrays.  */
-  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
+      || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
     {
       for (dim = 0; dim < rank; dim++)
 	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
@@ -2565,7 +2572,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
     info->allocated = build2 (NE_EXPR, boolean_type_node,
 			      info->data_location, null_pointer_node);
-  else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
+  else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+	   || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
     info->associated = build2 (NE_EXPR, boolean_type_node,
 			       info->data_location, null_pointer_node);
 
@@ -2579,7 +2587,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
 		  size_binop (PLUS_EXPR, dim_off, upper_suboff));
       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
       info->dimen[dim].upper_bound = t;
-      if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+      if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
+	  || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
 	{
 	  /* Assumed shape arrays have known lower bounds.  */
 	  info->dimen[dim].upper_bound

gcc/fortran/trans.h

@@ -620,14 +620,17 @@ extern GTY(()) tree gfor_fndecl_sr_kind;
 /* True if node is an integer constant.  */
 #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
 
-/* G95-specific declaration information.  */
+/* gfortran-specific declaration information, the _CONT versions denote
+   arrays with CONTIGUOUS attribute.  */
 
 enum gfc_array_kind
 {
   GFC_ARRAY_UNKNOWN,
   GFC_ARRAY_ASSUMED_SHAPE,
+  GFC_ARRAY_ASSUMED_SHAPE_CONT,
   GFC_ARRAY_ALLOCATABLE,
-  GFC_ARRAY_POINTER
+  GFC_ARRAY_POINTER,
+  GFC_ARRAY_POINTER_CONT
 };
 
 /* Array types only.  */

gcc/testsuite/ChangeLog

+2010-06-21  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/40632
+	* gfortran.dg/contiguous_1.f90: New.
+	* gfortran.dg/contiguous_2.f90: New.
+	* gfortran.dg/contiguous_3.f90: New.
+
 2010-06-21  Kai Tietz  <kai.tietz@onevision.com>
 
 	* gcc.target/x86_64/abi/callabi/leaf-1.c: New.

gcc/testsuite/gfortran.dg/contiguous_1.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests
+!
+
+! C448: Must be an array with POINTER attribute
+type t1
+  integer, contiguous :: ca(5) ! { dg-error "Component .ca. at .1. has the CONTIGUOUS" }
+end type t1
+type t2
+  integer, contiguous, allocatable :: cb(:) ! { dg-error "Component .cb. at .1. has the CONTIGUOUS" }
+end type t2
+type t3
+  integer, contiguous, pointer :: cc(:) ! OK
+end type t3
+type t4
+  integer, pointer, contiguous :: cd ! { dg-error "Component .cd. at .1. has the CONTIGUOUS" }
+end type t4
+end
+
+! C530: Must be an array and (a) a POINTER or (b) assumed shape.
+subroutine test(x, y)
+  integer, pointer :: x(:)
+  integer, intent(in) :: y(:)
+  contiguous :: x, y
+
+  integer, contiguous :: a(5) ! { dg-error ".a. at .1. has the CONTIGUOUS attribute" }
+  integer, contiguous, allocatable :: b(:) ! { dg-error ".b. at .1. has the CONTIGUOUS attribute" }
+  integer, contiguous, pointer :: c(:) ! OK
+  integer, pointer, contiguous :: d ! { dg-error ".d. at .1. has the CONTIGUOUS attribute" }
+end
+
+! Pointer assignment check:
+! If the pointer object has the CONTIGUOUS attribute, the pointer target shall be contiguous.
+! Note: This is not compile-time checkable; but F2008, 5.3.7 except in a very few cases.
+subroutine ptr_assign()
+  integer, pointer, contiguous :: ptr1(:)
+  integer, target :: tgt(5)
+  ptr1 => tgt
+end subroutine
+
+
+! C1239 (R1223) If an actual argument is a nonpointer array that has the ASYNCHRONOUS or VOLATILE
+! attribute but is not simply contiguous (6.5.4), and the corresponding dummy argument has either the
+! VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an assumed-shape array
+! that does not have the CONTIGUOUS attribute.
+
+subroutine C1239
+  type t
+    integer :: e(4)
+  end type t
+  type(t), volatile :: f
+  integer, asynchronous :: a(4), b(4)
+  integer, volatile :: c(4), d(4)
+  call test (a,b,c)      ! OK
+  call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" }
+  call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+
+  call test (a,b,f%e)      ! OK
+  call test (a,f%e,c)      ! OK
+  call test (f%e,b,c)      ! OK
+  call test (a,b,f%e(::2)) ! OK
+  call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" }
+  call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+contains
+  subroutine test(u, v, w)
+    integer, asynchronous :: u(:), v(*)
+    integer, volatile :: w(:)
+    contiguous :: u
+  end subroutine test
+end subroutine C1239
+
+
+! C1240 (R1223) If an actual argument is an array pointer that has the ASYNCHRONOUS or VOLATILE
+! attribute but does not have the CONTIGUOUS attribute, and the corresponding dummy argument has
+! either the VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an array pointer
+! or an assumed-shape array that does not have the CONTIGUOUS attribute.
+
+subroutine C1240
+  type t
+    integer,pointer :: e(:)
+  end type t
+  type(t), volatile :: f
+  integer, pointer, asynchronous :: a(:), b(:)
+  integer,pointer, volatile :: c(:), d(:)
+  call test (a,b,c)      ! { dg-error "array without CONTIGUOUS" }
+  call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" }
+  call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+
+  call test (a,b,f%e)      ! { dg-error "array without CONTIGUOUS" }
+  call test (a,f%e,c)      ! { dg-error "array without CONTIGUOUS" }
+  call test (f%e,b,c)      ! { dg-error "array without CONTIGUOUS" }
+  call test (a,b,f%e(::2)) ! { dg-error "array without CONTIGUOUS" }
+  call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" }
+  call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+
+  call test2(a,b)
+  call test3(a,b)
+  call test2(c,d)
+  call test3(c,d)
+  call test2(f%e,d)
+  call test3(c,f%e)
+contains
+  subroutine test(u, v, w)
+    integer, asynchronous :: u(:), v(*)
+    integer, volatile :: w(:)
+    contiguous :: u
+  end subroutine test
+  subroutine test2(x,y)
+    integer, asynchronous :: x(:)
+    integer, volatile :: y(:)
+  end subroutine test2 
+  subroutine test3(x,y)
+    integer, pointer, asynchronous :: x(:)
+    integer, pointer, volatile :: y(:)
+  end subroutine test3
+end subroutine C1240
+
+
+
+! 12.5.2.7 Pointer dummy variables
+! C1241 The actual argument corresponding to a dummy pointer with the CONTIGUOUS attribute shall be
+! simply contiguous (6.5.4).
+
+subroutine C1241
+  integer, pointer, contiguous :: a(:)
+  integer, pointer :: b(:)
+  call test(a)
+  call test(b) ! { dg-error "must be simply contigous" }
+contains
+  subroutine test(x)
+    integer, pointer, contiguous :: x(:)
+  end subroutine test
+end subroutine C1241
+
+
+! 12.5.2.8 Coarray dummy variables
+! If the dummy argument is an array coarray that has the CONTIGUOUS attribute or is not of assumed shape,
+! the corresponding actual argument shall be simply contiguous
+
+subroutine sect12528(cob)
+  integer, save :: coa(6)[*]
+  integer :: cob(:)[*]
+
+  call test(coa)
+  call test2(coa)
+  call test3(coa)
+
+  call test(cob) ! { dg-error "must be simply contiguous" }
+  call test2(cob) ! { dg-error "must be simply contiguous" }
+  call test3(cob)
+contains
+  subroutine test(x)
+    integer, contiguous :: x(:)[*]
+  end subroutine test
+  subroutine test2(x)
+    integer :: x(*)[*]
+  end subroutine test2
+  subroutine test3(x)
+    integer :: x(:)[*]
+  end subroutine test3
+end subroutine sect12528
+
+
+
+subroutine test34
+  implicit none
+  integer, volatile,pointer :: a(:,:),i
+  call foo(a(2,2:3:2)) ! { dg-error "must be simply contigous" }
+contains
+  subroutine foo(x)
+    integer, pointer, contiguous, volatile :: x(:)
+  end subroutine
+end subroutine test34

gcc/testsuite/gfortran.dg/contiguous_2.f90

+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests
+!
+
+integer, pointer, contiguous :: a(:) ! { dg-error "Fortran 2008:" }
+integer, pointer :: b(:)
+contiguous :: b ! { dg-error "Fortran 2008:" }
+end

gcc/testsuite/gfortran.dg/contiguous_3.f90

+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests: Check that contigous
+! works properly.
+
+subroutine test1(a,b)
+  integer, pointer, contiguous :: test1_a(:)
+  call foo(test1_a)
+  call foo(test1_a(::1))
+  call foo(test1_a(::2))
+contains
+  subroutine foo(b)
+    integer :: b(*)
+  end subroutine foo
+end subroutine test1
+
+! For the first two no pack is done; for the third one, an array descriptor
+! (cf. below test3) is created for packing.
+!
+! { dg-final { scan-tree-dump-times "_internal_pack.*test1_a" 0 "original" } }
+! { dg-final { scan-tree-dump-times "_internal_unpack.*test1_a" 0 "original" } }
+
+
+subroutine t2(a1,b1,c2,d2)
+  integer, pointer, contiguous :: a1(:), b1(:)
+  integer, pointer :: c2(:), d2(:)
+  a1 = b1
+  c2 = d2
+end subroutine t2
+
+! { dg-final { scan-tree-dump-times "= a1->dim.0..stride;" 0 "original" } }
+! { dg-final { scan-tree-dump-times "= b1->dim.0..stride;" 0 "original" } }
+! { dg-final { scan-tree-dump-times "= c2->dim.0..stride;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "= d2->dim.0..stride;" 1 "original" } }
+
+
+subroutine test3()
+  implicit none
+  integer :: test3_a(8),i
+  test3_a = [(i,i=1,8)]
+  call foo(test3_a(::1))
+  call foo(test3_a(::2))
+  call bar(test3_a(::1))
+  call bar(test3_a(::2))
+contains
+  subroutine foo(x)
+    integer, contiguous :: x(:)
+    print *, x
+  end subroutine
+  subroutine bar(x)
+    integer :: x(:)
+    print *, x
+  end subroutine bar
+end subroutine test3
+
+! Once for test1 (third call), once for test3 (second call)
+! { dg-final { scan-tree-dump-times "data = origptr" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack .&parm" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack .&parm" 2 "original" } }
+
+
+! { dg-final { cleanup-tree-dump "original" } }