check.c (coarray_check): Add class ref if needed.

2011-12-19  Tobias Burnus  <burnus@net-b.de>

        * check.c (coarray_check): Add class ref if needed.
        * resolve.c (resolve_fl_var_and_proc,
        resolve_fl_derived0, resolve_symbol): Fix checking
        for BT_CLASS.

2011-12-19  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_poly_3.f90: New.
        * coarray/poly_run_1.f90: Enable some previously commented code.

From-SVN: r182471

gcc/fortran/ChangeLog

+2011-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (coarray_check): Add class ref if needed.
+	* resolve.c (resolve_fl_var_and_proc,
+	resolve_fl_derived0, resolve_symbol): Fix checking
+	for BT_CLASS.
+
 2011-12-15  Paul Thomas  <pault@gcc.gnu.org>
 
 	* trans-expr.c (gfc_walk_function_expr): Detect elemental

gcc/fortran/check.c

@@ -206,6 +206,14 @@ double_check (gfc_expr *d, int n)
 static gfc_try
 coarray_check (gfc_expr *e, int n)
 {
+  if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
+	&& CLASS_DATA (e)->attr.codimension
+	&& CLASS_DATA (e)->as->corank)
+    {
+      gfc_add_class_array_ref (e);
+      return SUCCESS;
+    }
+
   if (!gfc_is_coarray (e))
     {
       gfc_error ("Expected coarray variable as '%s' argument to the %s "
@@ -240,7 +248,7 @@ logical_array_check (gfc_expr *array, int n)
 static gfc_try
 array_check (gfc_expr *e, int n)
 {
-  if (e->ts.type == BT_CLASS
+  if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
 	&& CLASS_DATA (e)->attr.dimension
 	&& CLASS_DATA (e)->as->rank)
     {

gcc/fortran/resolve.c

@@ -10070,17 +10070,39 @@ apply_default_init_local (gfc_symbol *sym)
 static gfc_try
 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 {
+  gfc_array_spec *as;
+
   /* Avoid double diagnostics for function result symbols.  */
   if ((sym->result || sym->attr.result) && !sym->attr.dummy
       && (sym->ns != gfc_current_ns))
     return SUCCESS;
 
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    as = CLASS_DATA (sym)->as;
+  else
+    as = sym->as;
+
   /* Constraints on deferred shape variable.  */
-  if (sym->as == NULL || sym->as->type != AS_DEFERRED)
+  if (as == NULL || as->type != AS_DEFERRED)
     {
-      if (sym->attr.allocatable)
+      bool pointer, allocatable, dimension;
+
+      if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
 	{
-	  if (sym->attr.dimension)
+	  pointer = CLASS_DATA (sym)->attr.class_pointer;
+	  allocatable = CLASS_DATA (sym)->attr.allocatable;
+	  dimension = CLASS_DATA (sym)->attr.dimension;
+	}
+      else
+	{
+	  pointer = sym->attr.pointer;
+	  allocatable = sym->attr.allocatable;
+	  dimension = sym->attr.dimension;
+	}
+
+      if (allocatable)
+	{
+	  if (dimension)
 	    {
 	      gfc_error ("Allocatable array '%s' at %L must have "
 			 "a deferred shape", sym->name, &sym->declared_at);
@@ -10092,7 +10114,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 	    return FAILURE;
 	}
 
-      if (sym->attr.pointer && sym->attr.dimension)
+      if (pointer && dimension)
 	{
 	  gfc_error ("Array pointer '%s' at %L must have a deferred shape",
 		     sym->name, &sym->declared_at);
@@ -11430,7 +11452,10 @@ resolve_fl_derived0 (gfc_symbol *sym)
       return FAILURE;
     }
 
-  for (c = sym->components; c != NULL; c = c->next)
+  c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
+			   : sym->components;
+
+  for ( ; c != NULL; c = c->next)
     {
       /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170.  */
       if (c->ts.type == BT_CHARACTER && c->ts.deferred)
@@ -11658,13 +11683,21 @@ resolve_fl_derived0 (gfc_symbol *sym)
 	}
 
       /* Check type-spec if this is not the parent-type component.  */
-      if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
+      if (((sym->attr.is_class
+	    && (!sym->components->ts.u.derived->attr.extension
+		|| c != sym->components->ts.u.derived->components))
+	   || (!sym->attr.is_class
+	       && (!sym->attr.extension || c != sym->components)))
+	  && !sym->attr.vtype
 	  && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
 	return FAILURE;
 
       /* If this type is an extension, set the accessibility of the parent
 	 component.  */
-      if (super_type && c == sym->components
+      if (super_type
+	  && ((sym->attr.is_class
+	       && c == sym->components->ts.u.derived->components)
+	      || (!sym->attr.is_class && c == sym->components))
 	  && strcmp (super_type->name, c->name) == 0)
 	c->attr.access = super_type->attr.access;
       
@@ -12044,6 +12077,8 @@ resolve_symbol (gfc_symbol *sym)
   gfc_symtree *this_symtree;
   gfc_namespace *ns;
   gfc_component *c;
+  symbol_attribute class_attr;
+  gfc_array_spec *as;
 
   if (sym->attr.flavor == FL_UNKNOWN)
     {
@@ -12100,18 +12135,6 @@ 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;
 
@@ -12137,7 +12160,9 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->ts.type == BT_UNKNOWN)
     {
       if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
-	gfc_set_default_type (sym, 1, NULL);
+	{
+	  gfc_set_default_type (sym, 1, NULL);
+	}
 
       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
 	  && !sym->attr.function && !sym->attr.subroutine
@@ -12170,18 +12195,41 @@ resolve_symbol (gfc_symbol *sym)
   else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
     gfc_resolve_array_spec (sym->result->as, false);
 
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    {
+      as = CLASS_DATA (sym)->as;
+      class_attr = CLASS_DATA (sym)->attr;
+      class_attr.pointer = class_attr.class_pointer;
+    }
+  else
+    {
+      class_attr = sym->attr;
+      as = sym->as;
+    }
+
+  /* F2008, C530. */
+  if (sym->attr.contiguous
+      && (!class_attr.dimension
+	  || (as->type != AS_ASSUMED_SHAPE && !class_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;
+    }
+
   /* Assumed size arrays and assumed shape arrays must be dummy
      arguments.  Array-spec's of implied-shape should have been resolved to
      AS_EXPLICIT already.  */
 
-  if (sym->as)
+  if (as)
     {
-      gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
-      if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
-	   || sym->as->type == AS_ASSUMED_SHAPE)
+      gcc_assert (as->type != AS_IMPLIED_SHAPE);
+      if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
+	   || as->type == AS_ASSUMED_SHAPE)
 	  && sym->attr.dummy == 0)
 	{
-	  if (sym->as->type == AS_ASSUMED_SIZE)
+	  if (as->type == AS_ASSUMED_SIZE)
 	    gfc_error ("Assumed size array at %L must be a dummy argument",
 		       &sym->declared_at);
 	  else
@@ -12393,8 +12441,10 @@ resolve_symbol (gfc_symbol *sym)
     }
 
   /* F2008, C525.  */
-  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
-       || sym->attr.codimension)
+  if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+	 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	     && CLASS_DATA (sym)->attr.coarray_comp))
+       || class_attr.codimension)
       && (sym->attr.result || sym->result == sym))
     {
       gfc_error ("Function result '%s' at %L shall not be a coarray or have "
@@ -12412,9 +12462,11 @@ resolve_symbol (gfc_symbol *sym)
     }
 
   /* F2008, C525.  */
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
-      && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
-	  || sym->attr.allocatable))
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	    && CLASS_DATA (sym)->attr.coarray_comp))
+      && (class_attr.codimension || class_attr.pointer || class_attr.dimension
+	  || class_attr.allocatable))
     {
       gfc_error ("Variable '%s' at %L with coarray component "
 		 "shall be a nonpointer, nonallocatable scalar",
@@ -12423,8 +12475,9 @@ resolve_symbol (gfc_symbol *sym)
     }
 
   /* F2008, C526.  The function-result case was handled above.  */
-  if (sym->attr.codimension
-      && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+  if (class_attr.codimension
+      && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
+	   || sym->attr.select_type_temporary
 	   || sym->ns->save_all
 	   || sym->ns->proc_name->attr.flavor == FL_MODULE
 	   || sym->ns->proc_name->attr.is_main_program
@@ -12434,16 +12487,16 @@ resolve_symbol (gfc_symbol *sym)
 		 "nor a dummy argument", sym->name, &sym->declared_at);
       return;
     }
-  /* F2008, C528.  */  /* FIXME: sym->as check due to PR 43412.  */
-  else if (sym->attr.codimension && !sym->attr.allocatable
-      && sym->as && sym->as->cotype == AS_DEFERRED)
+  /* F2008, C528.  */
+  else if (class_attr.codimension && !sym->attr.select_type_temporary
+	   && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
     {
       gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
 		 "deferred shape", sym->name, &sym->declared_at);
       return;
     }
-  else if (sym->attr.codimension && sym->attr.allocatable
-      && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
+  else if (class_attr.codimension && class_attr.allocatable && as
+	   && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
     {
       gfc_error ("Allocatable coarray variable '%s' at %L must have "
 		 "deferred shape", sym->name, &sym->declared_at);
@@ -12451,8 +12504,10 @@ resolve_symbol (gfc_symbol *sym)
     }
 
   /* F2008, C541.  */
-  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
-       || (sym->attr.codimension && sym->attr.allocatable))
+  if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+	|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	    && CLASS_DATA (sym)->attr.coarray_comp))
+       || (class_attr.codimension && class_attr.allocatable))
       && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
     {
       gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
@@ -12461,7 +12516,7 @@ resolve_symbol (gfc_symbol *sym)
       return;
     }
 
-  if (sym->attr.codimension && sym->attr.dummy
+  if (class_attr.codimension && sym->attr.dummy
       && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
     {
       gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "

gcc/testsuite/ChangeLog

+2011-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.dg/coarray_poly_3.f90: New.
+	* coarray/poly_run_1.f90: Enable some previously commented code.
+
 2011-12-19  Jason Merrill  <jason@redhat.com>
 
 	PR c++/51489

gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90

@@ -14,7 +14,7 @@ else
 end if
 if (allocated(A)) i = 5
 call s(A)
-!call t(A) ! FIXME
+!call st(A) ! FIXME
 
 contains
 
@@ -23,21 +23,29 @@ subroutine s(x)
   if (any (lcobound(x) /= [1, -5])) call abort ()
   if (num_images() == 1) then
     if (any (ucobound(x) /= [4, -5])) call abort ()
-! FIXME: Tree-walking issue?
-!  else
-!    if (ucobound(x,dim=1) /= 4) call abort ()
+  else
+    if (ucobound(x,dim=1) /= 4) call abort ()
   end if
 end subroutine s
 
+subroutine st(x)
+  class(t) :: x(:)[4,2:*]
 ! FIXME
-!subroutine st(x)
-!  class(t),allocatable :: x(:)[:,:]
 !  if (any (lcobound(x) /= [1, 2])) call abort ()
+!  if (lcobound(x, dim=1) /= 1) call abort ()
+!  if (lcobound(x, dim=2) /= 2) call abort ()
+!  if (this_image() == 1) then
+!     if (any (this_image(x) /= lcobound(x))) call abort ()
+!     if (this_image(x, dim=1) /= lcobound(x, dim=1)) call abort ()
+!     if (this_image(x, dim=2) /= lcobound(x, dim=2)) call abort ()
+!  end if
 !  if (num_images() == 1) then
-!    if (any (ucobound(x) /= [4, 2])) call abort ()
+!     if (any (ucobound(x) /= [4, 2])) call abort ()
+!     if (ucobound(x, dim=1) /= 4) call abort ()
+!     if (ucobound(x, dim=2) /= 2) call abort ()
 !  else
 !    if (ucobound(x,dim=1) /= 4) call abort ()
 !  end if
-!end subroutine st
+end subroutine st
 end
 

gcc/testsuite/gfortran.dg/coarray_poly_3.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+
+
+subroutine cont1(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape array" }
+  type t
+  end type t
+  class(t), contiguous, allocatable :: x(:)
+end
+
+subroutine cont2(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape array" }
+  type t
+  end type t
+  class(t), contiguous, allocatable :: x(:)[:]
+end
+
+subroutine cont3(x, y)
+  type t
+  end type t
+  class(t), contiguous, pointer :: x(:)
+  class(t), contiguous :: y(:)
+end
+
+function func() ! { dg-error "shall not be a coarray or have a coarray component" }
+  type t
+  end type t
+  class(t), allocatable :: func[*] ! { dg-error ""
+end
+
+function func2() ! { dg-error "must be dummy, allocatable or pointer" }
+  type t
+    integer, allocatable :: caf[:]
+  end type t
+  class(t) :: func2a ! { dg-error "CLASS variable 'func2a' at .1. must be dummy, allocatable or pointer" }
+  class(t) :: func2 ! {CLASS variable 'func' at (1) must be dummy, allocatable or pointer
+end
+
+subroutine foo1(x1) ! { dg-error "Coarray variable 'x1' at .1. shall not have codimensions with deferred shape" }
+  type t
+  end type t
+  type(t) :: x1(:)[:]
+end
+
+subroutine foo2(x2) ! { dg-error "Coarray variable 'x2' at .1. shall not have codimensions with deferred shape" }
+  type t
+  end type t
+  type(t) :: x2[:]
+end
+
+
+! DITTO FOR CLASS
+
+subroutine foo3(x1) ! { dg-error "Coarray variable 'x1' at .1. shall not have codimensions with deferred shape" }
+  type t
+  end type t
+  class(t) :: x1(:)[:]
+end
+
+subroutine foo4(x2) ! { dg-error "Coarray variable 'x2' at .1. shall not have codimensions with deferred shape" }
+  type t
+  end type t
+  class(t) :: x2[:]
+end
+
+
+
+
+subroutine bar1(y1) ! { dg-error "Allocatable coarray variable 'y1' at .1. must have deferred shape" }
+  type t
+  end type t
+  type(t), allocatable :: y1(:)[5:*]
+end
+
+subroutine bar2(y2) ! { dg-error "Allocatable coarray variable 'y2' at .1. must have deferred shape" }
+  type t
+  end type t
+  type(t), allocatable :: y2[5:*]
+end
+
+subroutine bar3(z1) ! { dg-error "Allocatable coarray variable 'z1' at .1. must have deferred shape" }
+  type t
+  end type t
+  type(t), allocatable :: z1(5)[:]
+end
+
+subroutine bar4(z2) ! { dg-error "Allocatable array 'z2' at .1. must have a deferred shape" }
+  type t
+  end type t
+  type(t), allocatable :: z2(5)
+end subroutine bar4
+
+subroutine bar5(z3) ! { dg-error "Array pointer 'z3' at .1. must have a deferred shape" }
+  type t
+  end type t
+  type(t), pointer :: z3(5)
+end subroutine bar5
+
+
+
+
+! DITTO FOR CLASS
+
+subroutine bar1c(y1) ! { dg-error "Allocatable coarray variable 'y1' at .1. must have deferred shape" }
+  type t
+  end type t
+  class(t), allocatable :: y1(:)[5:*]
+end
+
+subroutine bar2c(y2) ! { dg-error "Allocatable coarray variable 'y2' at .1. must have deferred shape" }
+  type t
+  end type t
+  class(t), allocatable :: y2[5:*]
+end
+
+subroutine bar3c(z1) ! { dg-error "Allocatable coarray variable 'z1' at .1. must have deferred shape" }
+  type t
+  end type t
+  class(t), allocatable :: z1(5)[:]
+end
+
+subroutine bar4c(z2) ! { dg-error "Allocatable array 'z2' at .1. must have a deferred shape" }
+  type t
+  end type t
+  class(t), allocatable :: z2(5)
+end subroutine bar4c
+
+subroutine bar5c(z3) ! { dg-error "Array pointer 'z3' at .1. must have a deferred shape" }
+  type t
+  end type t
+  class(t), pointer :: z3(5)
+end subroutine bar5c
+
+
+subroutine sub()
+  type t
+  end type
+  type(t) :: a(5)
+  class(t), allocatable :: b(:)
+  call inter(a)
+  call inter(b)
+contains
+  subroutine inter(x)
+    class(t) :: x(5)
+  end subroutine inter
+end subroutine sub
+
+subroutine sub2()
+  type t
+  end type
+  type(t) :: a(5)
+contains
+  subroutine inter(x)
+    class(t) :: x(5)
+  end subroutine inter
+end subroutine sub2
+
+subroutine sub3()
+  type t
+  end type
+contains
+  subroutine inter2(x) ! { dg-error "must have a deferred shape" }
+    class(t), pointer :: x(5)
+  end subroutine inter2
+end subroutine sub3