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

1 files changed, 102 insertions, 0 deletions

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b645205..c876fdd 100644
--- a/gcc/fortran/expr.c
+++ b/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;
+}