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 05:17:59 +0000 (14:17 +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/match.h
gcc/fortran/resolve.c
gcc/fortran/trans-array.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 bf38ddb..1998155 100644 (file)
@@ -210,7 +210,7 @@ coarray:
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
       return MATCH_ERROR;
     }
 
@@ -531,8 +531,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 c527307..12dcf84 100644 (file)
@@ -3101,7 +3101,18 @@ match_attr_spec (void)
 
       if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
        {
-         m = gfc_match_array_spec (&current_as, true, false);
+         gfc_array_spec *as = NULL;
+
+         m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+                                   d == DECL_CODIMENSION);
+
+         if (current_as == NULL)
+           current_as = as;
+         else if (m == MATCH_YES)
+           {
+             merge_array_spec (as, current_as, false);
+             gfc_free (as);
+           }
 
          if (m == MATCH_NO)
            {
@@ -3115,20 +3126,6 @@ match_attr_spec (void)
          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");
-             m = MATCH_ERROR;
-           }
-
-         if (m == MATCH_ERROR)
-           goto cleanup;
-       }
     }
 
   /* Since we've seen a double colon, we have to be looking at an
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 ce2a5e4..fc8f80b 100644 (file)
@@ -945,12 +945,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);
        }
     }
 
@@ -5311,7 +5312,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;
 
@@ -5320,11 +5321,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;
@@ -5341,7 +5342,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
@@ -5351,6 +5352,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;
@@ -5388,6 +5392,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;
 }
 
 
@@ -5530,10 +5536,13 @@ resolve_typebound_function (gfc_expr* e)
   if (e->value.compcall.tbp->is_generic)
     genname = e->value.compcall.name;
 
-  /* Treat the call as if it is a typebound procedure, in order to roll
-     out the correct name for the specific function.  */
-  resolve_compcall (e, &name);
-  ts = e->ts;
+  /* Resolve the function call for each member of the class.  */
+  class_try = SUCCESS;
+  fcn_flag = true;
+  list_e = gfc_copy_expr (e);
+
+  if (check_class_members (derived) == FAILURE)
+    return FAILURE;
 
   class_try = (resolve_compcall (e, true, false) == SUCCESS)
                 ? class_try : FAILURE;
@@ -5605,8 +5614,12 @@ resolve_typebound_subroutine (gfc_code *code)
   if (code->expr1->value.compcall.tbp->is_generic)
     genname = code->expr1->value.compcall.name;
 
-  resolve_typebound_call (code, &name);
-  ts = code->expr1->ts;
+  class_try = SUCCESS;
+  fcn_flag = false;
+  list_e = gfc_copy_expr (code->expr1);
+
+  if (check_class_members (derived) == FAILURE)
+    return FAILURE;
 
   /* Then convert the expression to a procedure pointer component call.  */
   code->expr1->value.function.esym = NULL;
@@ -6549,7 +6562,23 @@ check_symbols:
                         "itself allocated", sym->name, &ar->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 && ar->as->rank == 0)
+    {
+      gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
+                "at %L", &e->where);
+      goto failure;
     }
 
   for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
@@ -6575,9 +6604,9 @@ check_symbols:
       goto failure;
     }
 
-  if (codimension && ar->as->rank == 0)
+  if (codimension)
     {
-      gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
+      gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
                 "at %L", &e->where);
       goto failure;
     }
@@ -8307,7 +8336,25 @@ 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 ("Assignment to coindexed variable at %L in a PURE "
                     "procedure", &rhs->where);
@@ -10748,8 +10795,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);
@@ -11659,9 +11706,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
index a94c8d2..e1cc8e3 100644 (file)
@@ -4019,6 +4019,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;
index d8bd155..f3c6087 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