Patchwork [Fortran] Polymorphism fixes: resolve checks, ucobound

login
register
mail settings
Submitter Tobias Burnus
Date Dec. 16, 2011, 9:10 p.m.
Message ID <4EEBB3E0.7030308@net-b.de>
Download mbox | patch
Permalink /patch/131904/
State New
Headers show

Comments

Tobias Burnus - Dec. 16, 2011, 9:10 p.m.
Dear all,

this patch fixes on of the FIXMEs in coarray/poly_run_1.f90 [and extends 
the test case] by doing in check.c the same for coarrays as already done 
for arrays.

Additionally, I encountered bugs in the constraint checking for 
polymorphic variables, thus, I fixed those and added a test case.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias

PS: There are still issues with polymophic coarrays; in particular, 
argument passing [cf. coarray/poly_run_1.f90] and SELECT TYPE still fail 
in various ways.

Patch

2011-12-16  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-16  Tobias Burnus  <burnus@net-b.de>

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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index dca97cb..cb6b94f 100644
--- a/gcc/fortran/check.c
+++ b/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)
     {
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e99e199..b98c822 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10070,17 +10070,25 @@  apply_default_init_local (gfc_symbol *sym)
 static gfc_try
 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 {
+  symbol_attribute attr;
+  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;
 
+  as = (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+       ? CLASS_DATA (sym)->as : sym->as;
+  attr = (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+	 ? CLASS_DATA (sym)->attr : sym->attr;
+
   /* 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)
+      if (attr.allocatable)
 	{
-	  if (sym->attr.dimension)
+	  if (attr.dimension)
 	    {
 	      gfc_error ("Allocatable array '%s' at %L must have "
 			 "a deferred shape", sym->name, &sym->declared_at);
@@ -10092,7 +10100,7 @@  resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 	    return FAILURE;
 	}
 
-      if (sym->attr.pointer && sym->attr.dimension)
+      if (attr.pointer && attr.dimension)
 	{
 	  gfc_error ("Array pointer '%s' at %L must have a deferred shape",
 		     sym->name, &sym->declared_at);
@@ -11430,7 +11438,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 +11669,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 +12063,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 +12121,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 +12146,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
@@ -12174,14 +12185,30 @@  resolve_symbol (gfc_symbol *sym)
      arguments.  Array-spec's of implied-shape should have been resolved to
      AS_EXPLICIT already.  */
 
-  if (sym->as)
+  class_attr = sym->ts.type == BT_CLASS && sym->attr.class_ok
+	       ? CLASS_DATA (sym)->attr : sym->attr;
+  as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+       ? CLASS_DATA (sym)->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;
+    }
+
+  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 +12420,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 +12441,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 +12454,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 +12466,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 +12483,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 +12495,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) "
diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
index a371aef..436c1d4 100644
--- a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
+++ b/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
 
--- /dev/null	2011-12-14 20:10:08.555534201 +0100
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_3.f90	2011-12-16 22:08:32.000000000 +0100
@@ -0,0 +1,132 @@ 
+! { 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