OSDN Git Service

2010-04-09 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 9 Apr 2010 05:54:29 +0000 (05:54 +0000)
committerMasaki Muranaka <monaka@monami-software.com>
Sun, 23 May 2010 00:52:35 +0000 (09:52 +0900)
        PR fortran/18918
        * decl.c (variable_decl, match_attr_spec): Fix setting the array
        spec.
        * array.c (match_subscript,gfc_match_array_ref): Add coarray
        * support.
        * data.c (gfc_assign_data_value): Ditto.
        * expr.c (gfc_check_pointer_assign): Add check for coarray
        * constraint.
        (gfc_traverse_expr): Traverse also through codimension expressions.
        (gfc_is_coindexed, gfc_has_ultimate_allocatable,
        gfc_has_ultimate_pointer): New functions.
        * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for
        * coarrays.
        (gfc_array_ref): Add codimen.
        (gfc_array_ref): Add in_allocate.
        (gfc_is_coindexed, gfc_has_ultimate_allocatable,
        gfc_has_ultimate_pointer): Add prototypes.
        * interface.c (compare_parameter, compare_actual_formal,
        check_intents): Add coarray constraints.
        * match.c (gfc_match_iterator): Add coarray constraint.
        * match.h (gfc_match_array_ref): Update interface.
        * primary.c (gfc_match_varspec): Handle codimensions.
        * resolve.c (coarray_alloc, inquiry_argument): New static
        * variables.
        (check_class_members): Return gfc_try instead for error recovery.
        (resolve_typebound_function,resolve_typebound_subroutine,
        check_members): Handle return value of check_class_members.
        (resolve_structure_cons, resolve_actual_arglist, resolve_function,
        check_dimension, compare_spec_to_ref, resolve_array_ref,
        resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
        resolve_allocate_expr, resolve_ordinary_assign): Add coarray
        support.
        * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
        Skip over coarray refs.
        (gfc_array_allocate) Add support for references containing coindexes.
        * trans-expr.c (gfc_add_interface_mapping): Copy coarray
        * attribute.
        (gfc_map_intrinsic_function): Ignore codimensions.

2010-04-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_7.f90: New test.
        * gfortran.dg/coarray_8.f90: New test.

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

gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/match.c
gcc/fortran/match.h
gcc/fortran/resolve.c
gcc/fortran/trans-array.c
gcc/fortran/trans-expr.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/coarray_7.f90

index 0b6bfae..96efee0 100644 (file)
@@ -1,3 +1,39 @@
+2010-04-09  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
+       * decl.c (variable_decl, match_attr_spec): Fix setting the array
+       spec.
+       * array.c (match_subscript,gfc_match_array_ref): Add coarray support.
+       * data.c (gfc_assign_data_value): Ditto.
+       * expr.c (gfc_check_pointer_assign): Add check for coarray constraint.
+       (gfc_traverse_expr): Traverse also through codimension expressions.
+       (gfc_is_coindexed, gfc_has_ultimate_allocatable,
+       gfc_has_ultimate_pointer): New functions.
+       * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for coarrays.
+       (gfc_array_ref): Add codimen.
+       (gfc_array_ref): Add in_allocate.
+       (gfc_is_coindexed, gfc_has_ultimate_allocatable,
+       gfc_has_ultimate_pointer): Add prototypes.
+       * interface.c (compare_parameter, compare_actual_formal,
+       check_intents): Add coarray constraints.
+       * match.c (gfc_match_iterator): Add coarray constraint.
+       * match.h (gfc_match_array_ref): Update interface.
+       * primary.c (gfc_match_varspec): Handle codimensions.
+       * resolve.c (coarray_alloc, inquiry_argument): New static variables.
+       (check_class_members): Return gfc_try instead for error recovery.
+       (resolve_typebound_function,resolve_typebound_subroutine,
+       check_members): Handle return value of check_class_members.
+       (resolve_structure_cons, resolve_actual_arglist, resolve_function,
+       check_dimension, compare_spec_to_ref, resolve_array_ref,
+       resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
+       resolve_allocate_expr, resolve_ordinary_assign): Add coarray
+       support.
+       * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
+       Skip over coarray refs.
+       (gfc_array_allocate) Add support for references containing coindexes.
+       * trans-expr.c (gfc_add_interface_mapping): Copy coarray attribute.
+       (gfc_map_intrinsic_function): Ignore codimensions.
+
 2010-04-08  Bud Davis  <bdavis9659@sbcglobal.net>
 
        PR fortran/28039
index 4282fd1..5ceca4b 100644 (file)
@@ -61,12 +61,13 @@ gfc_copy_array_ref (gfc_array_ref *src)
    expression.  */
 
 static match
-match_subscript (gfc_array_ref *ar, int init)
+match_subscript (gfc_array_ref *ar, int init, bool match_star)
 {
   match m;
+  bool star = false;
   int i;
 
-  i = ar->dimen;
+  i = ar->dimen + ar->codimen;
 
   ar->c_where[i] = gfc_current_locus;
   ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
@@ -81,9 +82,12 @@ match_subscript (gfc_array_ref *ar, int init)
     goto end_element;
 
   /* Get start element.  */
-  if (init)
+  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+    star = true;
+
+  if (!star && init)
     m = gfc_match_init_expr (&ar->start[i]);
-  else
+  else if (!star)
     m = gfc_match_expr (&ar->start[i]);
 
   if (m == MATCH_NO)
@@ -92,14 +96,22 @@ match_subscript (gfc_array_ref *ar, int init)
     return MATCH_ERROR;
 
   if (gfc_match_char (':') == MATCH_NO)
-    return MATCH_YES;
+    goto matched;
+
+  if (star)
+    {
+      gfc_error ("Unexpected '*' in coarray subscript at %C");
+      return MATCH_ERROR;
+    }
 
   /* Get an optional end element.  Because we've seen the colon, we
      definitely have a range along this dimension.  */
 end_element:
   ar->dimen_type[i] = DIMEN_RANGE;
 
-  if (init)
+  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+    star = true;
+  else if (init)
     m = gfc_match_init_expr (&ar->end[i]);
   else
     m = gfc_match_expr (&ar->end[i]);
@@ -110,6 +122,12 @@ end_element:
   /* See if we have an optional stride.  */
   if (gfc_match_char (':') == MATCH_YES)
     {
+      if (star)
+       {
+         gfc_error ("Strides not allowed in coarray subscript at %C");
+         return MATCH_ERROR;
+       }
+
       m = init ? gfc_match_init_expr (&ar->stride[i])
               : gfc_match_expr (&ar->stride[i]);
 
@@ -119,6 +137,10 @@ end_element:
        return MATCH_ERROR;
     }
 
+matched:
+  if (star)
+    ar->dimen_type[i] = DIMEN_STAR;
+
   return MATCH_YES;
 }
 
@@ -128,14 +150,23 @@ end_element:
    to consist of init expressions.  */
 
 match
-gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
+                    int corank)
 {
   match m;
+  bool matched_bracket = false;
 
   memset (ar, '\0', sizeof (ar));
 
   ar->where = gfc_current_locus;
   ar->as = as;
+  ar->type = AR_UNKNOWN;
+
+  if (gfc_match_char ('[') == MATCH_YES)
+    {
+       matched_bracket = true;
+       goto coarray;
+    }
 
   if (gfc_match_char ('(') != MATCH_YES)
     {
@@ -144,34 +175,73 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
       return MATCH_YES;
     }
 
-  ar->type = AR_UNKNOWN;
-
   for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
     {
-      m = match_subscript (ar, init);
+      m = match_subscript (ar, init, false);
       if (m == MATCH_ERROR)
-       goto error;
+       return MATCH_ERROR;
 
       if (gfc_match_char (')') == MATCH_YES)
-       goto matched;
+       {
+         ar->dimen++;
+         goto coarray;
+       }
 
       if (gfc_match_char (',') != MATCH_YES)
        {
          gfc_error ("Invalid form of array reference at %C");
-         goto error;
+         return MATCH_ERROR;
        }
     }
 
   gfc_error ("Array reference at %C cannot have more than %d dimensions",
             GFC_MAX_DIMENSIONS);
-
-error:
   return MATCH_ERROR;
 
-matched:
-  ar->dimen++;
+coarray:
+  if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
+    {
+      if (ar->dimen > 0)
+       return MATCH_YES;
+      else
+       return MATCH_ERROR;
+    }
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return MATCH_ERROR;
+    }
+
+  if (corank == 0)
+    {
+       gfc_error ("Unexpected coarray designator at %C");
+       return MATCH_ERROR;
+    }
+
+  for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
+    {
+      m = match_subscript (ar, init, ar->codimen == (corank - 1));
+      if (m == MATCH_ERROR)
+       return MATCH_ERROR;
+
+      if (gfc_match_char (']') == MATCH_YES)
+       {
+         ar->codimen++;
+         return MATCH_YES;
+       }
+
+      if (gfc_match_char (',') != MATCH_YES)
+       {
+         gfc_error ("Invalid form of coarray reference at %C");
+         return MATCH_ERROR;
+       }
+    }
+
+  gfc_error ("Array reference at %C cannot have more than %d dimensions",
+            GFC_MAX_DIMENSIONS);
+  return MATCH_ERROR;
 
-  return MATCH_YES;
 }
 
 
@@ -460,8 +530,8 @@ coarray:
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-       goto cleanup;
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      goto cleanup;
     }
 
   for (;;)
index b376192..a9cd984 100644 (file)
@@ -570,6 +570,62 @@ cleanup:
 
 /************************ Declaration statements *********************/
 
+
+/* Auxilliary function to merge DIMENSION and CODIMENSION array specs.  */
+
+static void
+merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
+{
+  int i;
+
+  if (to->rank == 0 && from->rank > 0)
+    {
+      to->rank = from->rank;
+      to->type = from->type;
+      to->cray_pointee = from->cray_pointee;
+      to->cp_was_assumed = from->cp_was_assumed;
+
+      for (i = 0; i < to->corank; i++)
+       {
+         to->lower[from->rank + i] = to->lower[i];
+         to->upper[from->rank + i] = to->upper[i];
+       }
+      for (i = 0; i < from->rank; i++)
+       {
+         if (copy)
+           {
+             to->lower[i] = gfc_copy_expr (from->lower[i]);
+             to->upper[i] = gfc_copy_expr (from->upper[i]);
+           }
+         else
+           {
+             to->lower[i] = from->lower[i];
+             to->upper[i] = from->upper[i];
+           }
+       }
+    }
+  else if (to->corank == 0 && from->corank > 0)
+    {
+      to->corank = from->corank;
+      to->cotype = from->cotype;
+
+      for (i = 0; i < from->corank; i++)
+       {
+         if (copy)
+           {
+             to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
+             to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+           }
+         else
+           {
+             to->lower[to->rank + i] = from->lower[i];
+             to->upper[to->rank + i] = from->upper[i];
+           }
+       }
+    }
+}
+
+
 /* Match an intent specification.  Since this can only happen after an
    INTENT word, a legal intent-spec must follow.  */
 
@@ -1603,6 +1659,8 @@ variable_decl (int elem)
 
   if (m == MATCH_NO)
     as = gfc_copy_array_spec (current_as);
+  else if (current_as)
+    merge_array_spec (current_as, as, true);
 
   char_len = NULL;
   cl = NULL;
@@ -3050,27 +3108,27 @@ match_attr_spec (void)
       seen[d]++;
       seen_at[d] = gfc_current_locus;
 
-      if (d == DECL_DIMENSION)
+      if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
        {
-         m = gfc_match_array_spec (&current_as, true, false);
+         gfc_array_spec *as = NULL;
 
-         if (m == MATCH_NO)
+         m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+                                   d == DECL_CODIMENSION);
+
+         if (current_as == NULL)
+           current_as = as;
+         else if (m == MATCH_YES)
            {
-             gfc_error ("Missing dimension specification at %C");
-             m = MATCH_ERROR;
+             merge_array_spec (as, current_as, false);
+             gfc_free (as);
            }
 
-         if (m == MATCH_ERROR)
-           goto cleanup;
-       }
-
-      if (d == DECL_CODIMENSION)
-       {
-         m = gfc_match_array_spec (&current_as, false, true);
-
          if (m == MATCH_NO)
            {
-             gfc_error ("Missing codimension specification at %C");
+             if (d == DECL_CODIMENSION)
+               gfc_error ("Missing codimension specification at %C");
+             else
+               gfc_error ("Missing dimension specification at %C");
              m = MATCH_ERROR;
            }
 
index f4f5d52..3668df4 100644 (file)
@@ -1444,13 +1444,15 @@ extern gfc_interface_info current_interface;
 
 enum gfc_array_ref_dimen_type
 {
-  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN
+  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
 };
 
 typedef struct gfc_array_ref
 {
   ar_type type;
   int dimen;                   /* # of components in the reference */
+  int codimen;
+  bool in_allocate;            /* For coarray checks. */
   locus where;
   gfc_array_spec *as;
 
@@ -2642,6 +2644,11 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 
 bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
+bool gfc_is_coindexed (gfc_expr *);
+bool gfc_has_ultimate_allocatable (gfc_expr *);
+bool gfc_has_ultimate_pointer (gfc_expr *);
+
+
 /* st.c */
 extern gfc_code new_st;
 
index 70bf9ac..2709de7 100644 (file)
@@ -949,6 +949,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
   locus start;
   match m;
 
+  e1 = e2 = e3 = NULL;
+
   /* Match the start of an iterator without affecting the symbol table.  */
 
   start = gfc_current_locus;
@@ -962,9 +964,12 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
   if (m != MATCH_YES)
     return MATCH_NO;
 
-  gfc_match_char ('=');
-
-  e1 = e2 = e3 = NULL;
+  /* F2008, C617 & C565.  */
+  if (var->symtree->n.sym->attr.codimension)
+    {
+      gfc_error ("Loop variable at %C cannot be a coarray");
+      goto cleanup;
+    }
 
   if (var->ref != NULL)
     {
@@ -979,6 +984,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
       goto cleanup;
     }
 
+  gfc_match_char ('=');
+
   var->symtree->n.sym->attr.implied_index = 1;
 
   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
index 7a0f847..67e7741 100644 (file)
@@ -216,7 +216,7 @@ match gfc_match_init_expr (gfc_expr **);
 
 /* array.c.  */
 match gfc_match_array_spec (gfc_array_spec **, bool, bool);
-match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
 match gfc_match_array_constructor (gfc_expr **);
 
 /* interface.c.  */
index 3ec454e..5e9b25c 100644 (file)
@@ -77,6 +77,9 @@ static int current_entry_id;
 /* We use bitmaps to determine if a branch target is valid.  */
 static bitmap_obstack labels_obstack;
 
+/* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
+static bool inquiry_argument = false;
+
 int
 gfc_is_formal_arg (void)
 {
@@ -932,12 +935,13 @@ resolve_structure_cons (gfc_expr *expr)
 
       /* F2003, C1272 (3).  */
       if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
-         && gfc_impure_variable (cons->expr->symtree->n.sym))
+         && (gfc_impure_variable (cons->expr->symtree->n.sym)
+             || gfc_is_coindexed (cons->expr)))
        {
          t = FAILURE;
-         gfc_error ("Invalid expression in the derived type constructor for pointer "
-                    "component '%s' at %L in PURE procedure", comp->name,
-                    &cons->expr->where);
+         gfc_error ("Invalid expression in the derived type constructor for "
+                    "pointer component '%s' at %L in PURE procedure",
+                    comp->name, &cons->expr->where);
        }
     }
 
@@ -1319,7 +1323,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_expr *e;
   int save_need_full_assumed_size;
   gfc_component *comp;
-       
+
   for (; arg; arg = arg->next)
     {
       e = arg->expr;
@@ -1549,6 +1553,15 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
                }
            }
        }
+
+      /* Fortran 2008, C1237.  */
+      if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
+          && gfc_has_ultimate_pointer (e))
+        {
+          gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+                    "component", &e->where);
+          return FAILURE;
+        }
     }
 
   return SUCCESS;
@@ -2590,11 +2603,19 @@ resolve_function (gfc_expr *expr)
   if (expr->symtree && expr->symtree->n.sym)
     p = expr->symtree->n.sym->attr.proc;
 
+  if (expr->value.function.isym && expr->value.function.isym->inquiry)
+    inquiry_argument = true;
   no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+
   if (resolve_actual_arglist (expr->value.function.actual,
                              p, no_formal_args) == FAILURE)
+    {
+      inquiry_argument = false;
       return FAILURE;
+    }
 
+  inquiry_argument = false;
   /* Need to setup the call to the correct c_associated, depending on
      the number of cptrs to user gives to compare.  */
   if (sym && sym->attr.is_iso_c == 1)
@@ -3755,6 +3776,17 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
 {
   mpz_t last_value;
 
+  if (ar->dimen_type[i] == DIMEN_STAR)
+    {
+      gcc_assert (ar->stride[i] == NULL);
+      /* This implies [*] as [*:] and [*:3] are not possible.  */
+      if (ar->start[i] == NULL)
+       {
+         gcc_assert (ar->end[i] == NULL);
+         return SUCCESS;
+       }
+    }
+
 /* Given start, end and stride values, calculate the minimum and
    maximum referenced indexes.  */
 
@@ -3763,21 +3795,36 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
     case DIMEN_VECTOR:
       break;
 
+    case DIMEN_STAR:
     case DIMEN_ELEMENT:
       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
        {
-         gfc_warning ("Array reference at %L is out of bounds "
-                      "(%ld < %ld) in dimension %d", &ar->c_where[i],
-                      mpz_get_si (ar->start[i]->value.integer),
-                      mpz_get_si (as->lower[i]->value.integer), i+1);
+         if (i < as->rank)
+           gfc_warning ("Array reference at %L is out of bounds "
+                        "(%ld < %ld) in dimension %d", &ar->c_where[i],
+                        mpz_get_si (ar->start[i]->value.integer),
+                        mpz_get_si (as->lower[i]->value.integer), i+1);
+         else
+           gfc_warning ("Array reference at %L is out of bounds "
+                        "(%ld < %ld) in codimension %d", &ar->c_where[i],
+                        mpz_get_si (ar->start[i]->value.integer),
+                        mpz_get_si (as->lower[i]->value.integer),
+                        i + 1 - as->rank);
          return SUCCESS;
        }
       if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
        {
-         gfc_warning ("Array reference at %L is out of bounds "
-                      "(%ld > %ld) in dimension %d", &ar->c_where[i],
-                      mpz_get_si (ar->start[i]->value.integer),
-                      mpz_get_si (as->upper[i]->value.integer), i+1);
+         if (i < as->rank)
+           gfc_warning ("Array reference at %L is out of bounds "
+                        "(%ld > %ld) in dimension %d", &ar->c_where[i],
+                        mpz_get_si (ar->start[i]->value.integer),
+                        mpz_get_si (as->upper[i]->value.integer), i+1);
+         else
+           gfc_warning ("Array reference at %L is out of bounds "
+                        "(%ld > %ld) in codimension %d", &ar->c_where[i],
+                        mpz_get_si (ar->start[i]->value.integer),
+                        mpz_get_si (as->upper[i]->value.integer),
+                        i + 1 - as->rank);
          return SUCCESS;
        }
 
@@ -3897,10 +3944,32 @@ compare_spec_to_ref (gfc_array_ref *ar)
       return FAILURE;
     }
 
+  /* ar->codimen == 0 is a local array.  */
+  if (as->corank != ar->codimen && ar->codimen != 0)
+    {
+      gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
+                &ar->where, ar->codimen, as->corank);
+      return FAILURE;
+    }
+
   for (i = 0; i < as->rank; i++)
     if (check_dimension (i, ar, as) == FAILURE)
       return FAILURE;
 
+  /* Local access has no coarray spec.  */
+  if (ar->codimen != 0)
+    for (i = as->rank; i < as->rank + as->corank; i++)
+      {
+       if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+         {
+           gfc_error ("Coindex of codimension %d must be a scalar at %L",
+                      i + 1 - as->rank, &ar->where);
+           return FAILURE;
+         }
+       if (check_dimension (i, ar, as) == FAILURE)
+         return FAILURE;
+      }
+
   return SUCCESS;
 }
 
@@ -4069,7 +4138,7 @@ resolve_array_ref (gfc_array_ref *ar)
   int i, check_scalar;
   gfc_expr *e;
 
-  for (i = 0; i < ar->dimen; i++)
+  for (i = 0; i < ar->dimen + ar->codimen; i++)
     {
       check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
 
@@ -4103,6 +4172,9 @@ resolve_array_ref (gfc_array_ref *ar)
          }
     }
 
+  if (ar->type == AR_FULL && ar->as->rank == 0)
+    ar->type = AR_ELEMENT;
+
   /* If the reference type is unknown, figure out what kind it is.  */
 
   if (ar->type == AR_UNKNOWN)
@@ -4307,6 +4379,13 @@ resolve_ref (gfc_expr *expr)
          switch (ref->u.ar.type)
            {
            case AR_FULL:
+             /* Coarray scalar.  */
+             if (ref->u.ar.as->rank == 0)
+               {
+                 current_part_dimension = 0;
+                 break;
+               }
+             /* Fall through.  */
            case AR_SECTION:
              current_part_dimension = 1;
              break;
@@ -4576,6 +4655,47 @@ resolve_procedure:
   if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
     t = FAILURE;
 
+  /* F2008, C617 and C1229.  */
+  if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
+      && gfc_is_coindexed (e))
+    {
+      gfc_ref *ref, *ref2 = NULL;
+
+      if (e->ts.type == BT_CLASS)
+       {
+         gfc_error ("Polymorphic subobject of coindexed object at %L",
+                    &e->where);
+         t = FAILURE;
+       }
+
+      for (ref = e->ref; ref; ref = ref->next)
+       {
+         if (ref->type == REF_COMPONENT)
+           ref2 = ref;
+         if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+           break;
+       }
+
+      for ( ; ref; ref = ref->next)
+       if (ref->type == REF_COMPONENT)
+         break;
+
+      /* Expression itself is coindexed object.  */
+      if (ref == NULL)
+       {
+         gfc_component *c;
+         c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+         for ( ; c; c = c->next)
+           if (c->attr.allocatable && c->ts.type == BT_CLASS)
+             {
+               gfc_error ("Coindexed object with polymorphic allocatable "
+                        "subcomponent at %L", &e->where);
+               t = FAILURE;
+               break;
+             }
+       }
+    }
+
   return t;
 }
 
@@ -5163,7 +5283,7 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
    of f03 OOP.  As soon as vtables are in place and contain pointers
    to methods, this will no longer be necessary.  */
 static gfc_expr *list_e;
-static void check_class_members (gfc_symbol *);
+static gfc_try check_class_members (gfc_symbol *);
 static gfc_try class_try;
 static bool fcn_flag;
 
@@ -5172,11 +5292,11 @@ static void
 check_members (gfc_symbol *derived)
 {
   if (derived->attr.flavor == FL_DERIVED)
-    check_class_members (derived);
+    (void) check_class_members (derived);
 }
 
 
-static void 
+static gfc_try 
 check_class_members (gfc_symbol *derived)
 {
   gfc_expr *e;
@@ -5193,7 +5313,7 @@ check_class_members (gfc_symbol *derived)
     {
       gfc_error ("no typebound available procedure named '%s' at %L",
                 e->value.compcall.name, &e->where);
-      return;
+      return FAILURE;
     }
 
   /* If we have to match a passed class member, force the actual
@@ -5203,6 +5323,9 @@ check_class_members (gfc_symbol *derived)
       if (e->value.compcall.base_object == NULL)
        e->value.compcall.base_object = extract_compcall_passed_object (e);
 
+      if (e->value.compcall.base_object == NULL)
+       return FAILURE;
+
       if (!derived->attr.abstract)
        {
          e->value.compcall.base_object->ts.type = BT_DERIVED;
@@ -5240,6 +5363,8 @@ check_class_members (gfc_symbol *derived)
   /* Burrow down into grandchildren types.  */
   if (derived->f2k_derived)
     gfc_traverse_ns (derived->f2k_derived, check_members);
+
+  return SUCCESS;
 }
 
 
@@ -5393,7 +5518,9 @@ resolve_typebound_function (gfc_expr* e)
   class_try = SUCCESS;
   fcn_flag = true;
   list_e = gfc_copy_expr (e);
-  check_class_members (derived);
+
+  if (check_class_members (derived) == FAILURE)
+    return FAILURE;
 
   class_try = (resolve_compcall (e, true, false) == SUCCESS)
                 ? class_try : FAILURE;
@@ -5453,7 +5580,9 @@ resolve_typebound_subroutine (gfc_code *code)
   class_try = SUCCESS;
   fcn_flag = false;
   list_e = gfc_copy_expr (code->expr1);
-  check_class_members (derived);
+
+  if (check_class_members (derived) == FAILURE)
+    return FAILURE;
 
   class_try = (resolve_typebound_call (code) == SUCCESS)
                 ? class_try : FAILURE;
@@ -5585,10 +5714,16 @@ gfc_try
 gfc_resolve_expr (gfc_expr *e)
 {
   gfc_try t;
+  bool inquiry_save;
 
   if (e == NULL)
     return SUCCESS;
 
+  /* inquiry_argument only applies to variables.  */
+  inquiry_save = inquiry_argument;
+  if (e->expr_type != EXPR_VARIABLE)
+    inquiry_argument = false;
+
   switch (e->expr_type)
     {
     case EXPR_OP:
@@ -5676,6 +5811,8 @@ gfc_resolve_expr (gfc_expr *e)
   if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
     fixup_charlen (e);
 
+  inquiry_argument = inquiry_save;
+
   return t;
 }
 
@@ -6123,6 +6260,7 @@ static gfc_try
 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 {
   int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+  int codimension;
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
@@ -6134,8 +6272,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   /* Check INTENT(IN), unless the object is a sub-component of a pointer.  */
   check_intent_in = 1;
 
+  /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
+     checking of coarrays.  */
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->next == NULL)
+      break;
+
+  if (ref && ref->type == REF_ARRAY)
+    ref->u.ar.in_allocate = true;
+
   if (gfc_resolve_expr (e) == FAILURE)
-    return FAILURE;
+    goto failure;
 
   /* Make sure the expression is allocatable or a pointer.  If it is
      pointer, the next-to-last reference must be a pointer.  */
@@ -6153,6 +6300,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       attr = gfc_expr_attr (e);
       pointer = attr.pointer;
       dimension = attr.dimension;
+      codimension = attr.codimension;
     }
   else
     {
@@ -6161,6 +6309,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
          allocatable = sym->ts.u.derived->components->attr.allocatable;
          pointer = sym->ts.u.derived->components->attr.pointer;
          dimension = sym->ts.u.derived->components->attr.dimension;
+         codimension = sym->ts.u.derived->components->attr.codimension;
          is_abstract = sym->ts.u.derived->components->attr.abstract;
        }
       else
@@ -6168,6 +6317,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
          allocatable = sym->attr.allocatable;
          pointer = sym->attr.pointer;
          dimension = sym->attr.dimension;
+         codimension = sym->attr.codimension;
        }
 
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
@@ -6183,12 +6333,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
                break;
 
              case REF_COMPONENT:
+               /* F2008, C644.  */
+               if (gfc_is_coindexed (e))
+                 {
+                   gfc_error ("Coindexed allocatable object at %L",
+                              &e->where);
+                   goto failure;
+                 }
+
                c = ref->u.c.component;
                if (c->ts.type == BT_CLASS)
                  {
                    allocatable = c->ts.u.derived->components->attr.allocatable;
                    pointer = c->ts.u.derived->components->attr.pointer;
                    dimension = c->ts.u.derived->components->attr.dimension;
+                   codimension = c->ts.u.derived->components->attr.codimension;
                    is_abstract = c->ts.u.derived->components->attr.abstract;
                  }
                else
@@ -6196,6 +6355,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
                    allocatable = c->attr.allocatable;
                    pointer = c->attr.pointer;
                    dimension = c->attr.dimension;
+                   codimension = c->attr.codimension;
                    is_abstract = c->attr.abstract;
                  }
                break;
@@ -6212,7 +6372,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
     {
       gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
                 &e->where);
-      return FAILURE;
+      goto failure;
     }
 
   /* Some checks for the SOURCE tag.  */
@@ -6223,13 +6383,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
        {
          gfc_error ("Type of entity at %L is type incompatible with "
                      "source-expr at %L", &e->where, &code->expr3->where);
-         return FAILURE;
+         goto failure;
        }
 
       /* Check F03:C632 and restriction following Note 6.18.  */
       if (code->expr3->rank > 0
          && conformable_arrays (code->expr3, e) == FAILURE)
-       return FAILURE;
+       goto failure;
 
       /* Check F03:C633.  */
       if (code->expr3->ts.kind != e->ts.kind)
@@ -6237,7 +6397,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
          gfc_error ("The allocate-object at %L and the source-expr at %L "
                      "shall have the same kind type parameter",
                      &e->where, &code->expr3->where);
-         return FAILURE;
+         goto failure;
        }
     }
   else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
@@ -6245,14 +6405,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       gcc_assert (e->ts.type == BT_CLASS);
       gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
                 "type-spec or SOURCE=", sym->name, &e->where);
-      return FAILURE;
+      goto failure;
     }
 
   if (check_intent_in && sym->attr.intent == INTENT_IN)
     {
       gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
                 sym->name, &e->where);
-      return FAILURE;
+      goto failure;
     }
     
   if (!code->expr3)
@@ -6285,16 +6445,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
        }
     }
 
-  if (pointer || dimension == 0)
-    return SUCCESS;
+  if (pointer || (dimension == 0 && codimension == 0))
+    goto success;
 
   /* Make sure the next-to-last reference node is an array specification.  */
 
-  if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
+  if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+      || (dimension && ref2->u.ar.dimen == 0))
     {
       gfc_error ("Array specification required in ALLOCATE statement "
                 "at %L", &e->where);
-      return FAILURE;
+      goto failure;
     }
 
   /* Make sure that the array section reference makes sense in the
@@ -6302,6 +6463,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
   ar = &ref2->u.ar;
 
+  if (codimension && ar->codimen == 0)
+    {
+      gfc_error ("Coarray specification required in ALLOCATE statement "
+                "at %L", &e->where);
+      goto failure;
+    }
+
   for (i = 0; i < ar->dimen; i++)
     {
       if (ref2->u.ar.type == AR_ELEMENT)
@@ -6322,13 +6490,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
        case DIMEN_UNKNOWN:
        case DIMEN_VECTOR:
+       case DIMEN_STAR:
          gfc_error ("Bad array specification in ALLOCATE statement at %L",
                     &e->where);
-         return FAILURE;
+         goto failure;
        }
 
 check_symbols:
-
       for (a = code->ext.alloc.list; a; a = a->next)
        {
          sym = a->expr->symtree->n.sym;
@@ -6345,12 +6513,46 @@ check_symbols:
              gfc_error ("'%s' must not appear in the array specification at "
                         "%L in the same ALLOCATE statement where it is "
                         "itself allocated", sym->name, &ar->where);
-             return FAILURE;
+             goto failure;
            }
        }
     }
 
+  for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
+    {
+      if (ar->dimen_type[i] == DIMEN_ELEMENT
+         || ar->dimen_type[i] == DIMEN_RANGE)
+       {
+         if (i == (ar->dimen + ar->codimen - 1))
+           {
+             gfc_error ("Expected '*' in coindex specification in ALLOCATE "
+                        "statement at %L", &e->where);
+             goto failure;
+           }
+         break;
+       }
+
+      if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
+         && ar->stride[i] == NULL)
+       break;
+
+      gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
+                &e->where);
+      goto failure;
+    }
+
+  if (codimension)
+    {
+      gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
+                "at %L", &e->where);
+      goto failure;
+    }
+
+success:
   return SUCCESS;
+
+failure:
+  return FAILURE;
 }
 
 static void
@@ -8031,17 +8233,35 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
            && lhs->expr_type == EXPR_VARIABLE
            && lhs->ts.u.derived->attr.pointer_comp
            && rhs->expr_type == EXPR_VARIABLE
-           && gfc_impure_variable (rhs->symtree->n.sym))
+           && (gfc_impure_variable (rhs->symtree->n.sym)
+               || gfc_is_coindexed (rhs)))
+       {
+         /* F2008, C1283.  */
+         if (gfc_is_coindexed (rhs))
+           gfc_error ("Coindexed expression at %L is assigned to "
+                       "a derived type variable with a POINTER "
+                       "component in a PURE procedure",
+                       &rhs->where);
+         else
+           gfc_error ("The impure variable at %L is assigned to "
+                       "a derived type variable with a POINTER "
+                       "component in a PURE procedure (12.6)",
+                       &rhs->where);
+         return rval;
+       }
+
+      /* Fortran 2008, C1283.  */
+      if (gfc_is_coindexed (lhs))
        {
-         gfc_error ("The impure variable at %L is assigned to "
-                    "a derived type variable with a POINTER "
-                    "component in a PURE procedure (12.6)",
-                    &rhs->where);
+         gfc_error ("Assignment to coindexed variable at %L in a PURE "
+                    "procedure", &rhs->where);
          return rval;
        }
     }
 
   /* F03:7.4.1.2.  */
+  /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
+     and coindexed; cf. F2008, 7.2.1.2 and PR 43366.  */
   if (lhs->ts.type == BT_CLASS)
     {
       gfc_error ("Variable must not be polymorphic in assignment at %L",
@@ -8049,6 +8269,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
       return false;
     }
 
+  /* F2008, Section 7.2.1.2.  */
+  if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+    {
+      gfc_error ("Coindexed variable must not be have an allocatable ultimate "
+                "component in assignment at %L", &lhs->where);
+      return false;
+    }
+
   gfc_check_assign (lhs, rhs, 1);
   return false;
 }
@@ -10462,8 +10690,8 @@ resolve_fl_derived (gfc_symbol *sym)
   for (c = sym->components; c != NULL; c = c->next)
     {
       /* F2008, C442.  */
-      if (c->attr.codimension
-         && (!c->attr.allocatable || c->as->type != AS_DEFERRED))
+      if (c->attr.codimension /* FIXME: c->as check due to PR 43412.  */
+         && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
        {
          gfc_error ("Coarray component '%s' at %L must be allocatable with "
                     "deferred shape", c->name, &c->loc);
@@ -11351,9 +11579,9 @@ resolve_symbol (gfc_symbol *sym)
     gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
               "component and is not ALLOCATABLE, SAVE nor a "
               "dummy argument", sym->name, &sym->declared_at);
-  /* F2008, C528.  */
+  /* F2008, C528.  */  /* FIXME: sym->as check due to PR 43412.  */
   else if (sym->attr.codimension && !sym->attr.allocatable
-      && sym->as->cotype == AS_DEFERRED)
+      && sym->as && sym->as->cotype == AS_DEFERRED)
     gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
                "deferred shape", sym->name, &sym->declared_at);
   else if (sym->attr.codimension && sym->attr.allocatable
@@ -11548,6 +11776,13 @@ check_data_variable (gfc_data_variable *var, locus *where)
       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
        has_pointer = 1;
 
+      if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+       {
+         gfc_error ("DATA element '%s' at %L cannot have a coindex",
+                    sym->name, where);
+         return FAILURE;
+       }
+
       if (has_pointer
            && ref->type == REF_ARRAY
            && ref->u.ar.type != AR_FULL)
index 75516ce..cbdd8b9 100644 (file)
@@ -2531,6 +2531,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
   gfc_se indexse;
   gfc_se tmpse;
 
+  if (ar->dimen == 0)
+    return;
+
   /* Handle scalarized references separately.  */
   if (ar->type != AR_ELEMENT)
     {
@@ -3958,7 +3961,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   /* Find the last reference in the chain.  */
   while (ref && ref->next != NULL)
     {
-      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+                 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
       prev_ref = ref;
       ref = ref->next;
     }
@@ -3966,6 +3970,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   if (ref == NULL || ref->type != REF_ARRAY)
     return false;
 
+  /* Return if this is a scalar coarray.  */
+  if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
+    {
+      gcc_assert (expr->symtree->n.sym->attr.codimension);
+      return false;
+    }
+  else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
+    {
+      gcc_assert (prev_ref->u.c.component->attr.codimension);
+      return false;
+    }
+
   if (!prev_ref)
     allocatable_array = expr->symtree->n.sym->attr.allocatable;
   else
@@ -6361,6 +6377,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
        continue;
 
       ar = &ref->u.ar;
+
+      if (ar->as->rank == 0)
+       {
+         /* Scalar coarray.  */
+         continue;
+       }
+
       switch (ar->type)
        {
        case AR_ELEMENT:
index 7e95ce1..10716b7 100644 (file)
@@ -1848,6 +1848,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.codimension = sym->attr.codimension;
   new_sym->attr.pointer = sym->attr.pointer;
   new_sym->attr.allocatable = sym->attr.allocatable;
   new_sym->attr.flavor = sym->attr.flavor;
@@ -2076,7 +2077,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
       break;
 
     case GFC_ISYM_SIZE:
-      if (!sym->as)
+      if (!sym->as || sym->as->rank == 0)
        return false;
 
       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
@@ -2114,7 +2115,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
        /* TODO These implementations of lbound and ubound do not limit if
           the size < 0, according to F95's 13.14.53 and 13.14.113.  */
 
-      if (!sym->as)
+      if (!sym->as || sym->as->rank == 0)
        return false;
 
       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
index 8a4fc08..5b77482 100644 (file)
@@ -1,3 +1,9 @@
+2010-04-09  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
+       * gfortran.dg/coarray_7.f90: New test.
+       * gfortran.dg/coarray_8.f90: New test.
+
 2010-04-08  Bud Davis  <bdavis9659@sbcglobal.net>
 
        PR fortran/28039
index 29af0d1..8cd295d 100644 (file)
@@ -91,6 +91,7 @@ type(t), allocatable :: b(:)[:], C[:]
 allocate(b(1)) ! { dg-error "Coarray specification" }
 allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" }
 allocate(c[*]) ! { dg-error "Sorry" }
+allocate(b(3)[5:*]) ! { dg-error "Sorry" }
 allocate(a%a(5)) ! OK
 end subroutine alloc
 
@@ -147,16 +148,34 @@ end subroutine test4
 
 subroutine allocateTest()
   implicit none
-  real, allocatable, codimension[:,:] :: a,b,c
+  real, allocatable,dimension(:,:), codimension[:,:] :: a,b,c
   integer :: n, q
   n = 1
   q = 1
-  allocate(a[q,*]) ! { dg-error "Sorry" }
-  allocate(b[q,*]) ! { dg-error "Sorry" }
-  allocate(c[q,*]) ! { dg-error "Sorry" }
+  allocate(a(n,n)[q,*]) ! { dg-error "Sorry" }
+  allocate(b(n,n)[q,*]) ! { dg-error "Sorry" }
+  allocate(c(n,n)[q,*]) ! { dg-error "Sorry" }
 end subroutine allocateTest
 
 
+subroutine testAlloc3
+implicit none
+integer, allocatable :: a(:,:,:)[:,:]
+integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
+integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
+integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
+integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
+integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
+
+allocate(a(1,2,3)[4,*]) ! { dg-error "Sorry" }
+allocate(b(1,2,3)[4,*]) ! { dg-error "Sorry" }
+allocate(c(1,2)[3,4,*]) ! { dg-error "Sorry" }
+allocate(d(1,2)[3,*])   ! { dg-error "Sorry" }
+allocate(e(1,2)[3,4,*]) ! { dg-error "Sorry" }
+allocate(f(1,2)[3,*]) ! { dg-error "Sorry" }
+end subroutine testAlloc3
+
+
 subroutine testAlloc4()
   implicit none
   type co_double_3