OSDN Git Service

2010-06-20 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 21 Jun 2010 14:15:56 +0000 (14:15 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 21 Jun 2010 14:15:56 +0000 (14:15 +0000)
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161079 138bc75d-0d04-0410-961f-82ee72b054a4

22 files changed:
gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/dependency.c
gcc/fortran/dependency.h
gcc/fortran/dump-parse-tree.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/interface.c
gcc/fortran/match.h
gcc/fortran/module.c
gcc/fortran/parse.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-types.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/contiguous_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/contiguous_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/contiguous_3.f90 [new file with mode: 0644]

index 077c42e..1385318 100644 (file)
@@ -1,3 +1,34 @@
+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.
index c9b46a2..f7f4800 100644 (file)
@@ -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);
index 87f60df..fcf5b25 100644 (file)
@@ -1588,4 +1588,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
 
   return fin_dep == GFC_DEP_OVERLAP;
 }
-
index 6fa0416..dd786be 100644 (file)
@@ -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 *);
+
index 0163b65..940455d 100644 (file)
@@ -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)
index b645205..c876fdd 100644 (file)
@@ -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;
+}
index d77a6c5..4a9b5f0 100644 (file)
@@ -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 *);
index 284622f..ee164fc 100644 (file)
@@ -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)
index 09740fb..501049e 100644 (file)
@@ -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);
index 335fd27..b42a9e8 100644 (file)
@@ -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;
index 7b887bc..26ea73a 100644 (file)
@@ -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);
index 2f05b23..20def44 100644 (file)
@@ -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;
                }
            }
        }
index 11a0395..df6ada9 100644 (file)
@@ -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)
index 575dd02..7eb8e75 100644 (file)
@@ -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);
     }
 }
index 972d843..d75a195 100644 (file)
@@ -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;
     }
 
index 416e67d..0164c16 100644 (file)
@@ -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;
index 38bae7d..2f5b759 100644 (file)
@@ -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
index 946ce2e..02361fc 100644 (file)
@@ -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.  */
index 428e33b..5ac708a 100644 (file)
@@ -1,3 +1,10 @@
+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.
diff --git a/gcc/testsuite/gfortran.dg/contiguous_1.f90 b/gcc/testsuite/gfortran.dg/contiguous_1.f90
new file mode 100644 (file)
index 0000000..e75c08d
--- /dev/null
@@ -0,0 +1,177 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/contiguous_2.f90 b/gcc/testsuite/gfortran.dg/contiguous_2.f90
new file mode 100644 (file)
index 0000000..782d23d
--- /dev/null
@@ -0,0 +1,12 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/contiguous_3.f90 b/gcc/testsuite/gfortran.dg/contiguous_3.f90
new file mode 100644 (file)
index 0000000..aac5536
--- /dev/null
@@ -0,0 +1,65 @@
+! { 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" } }