Patchwork [Fortran] PR 51605 - SELECT TYPE - set target attribute

login
register
mail settings
Submitter Tobias Burnus
Date Dec. 19, 2011, 2:37 p.m.
Message ID <4EEF4C3F.2000603@net-b.de>
Download mbox | patch
Permalink /patch/132245/
State New
Headers show

Comments

Tobias Burnus - Dec. 19, 2011, 2:37 p.m.
This patch addresses three issues:

a) For SELECT TYPE: If the selector has the pointer attribute, the 
associate name is a nonpointer, but it gets the target attribute. 
(Rejects-valid issue; was accepted [for the wrong reasons] before PR 
48887 got fixed.)

b) The example "one" is invalid, but the ICE came before the error was 
printed. After adding three "&& attr.class_ok", the ICE is gone.

c) Some preparatory patches for SELECT TYPE support of polymorphic 
coarrays. (Using them will still fail.)

The ICE with the original test case of the PR is not yet fixed. (It's a 
BLOCK label issue, unrelated to polymorphism.)


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

Tobias
Paul Richard Thomas - Dec. 19, 2011, 3:10 p.m.
Dear Tobias,

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

OK

Thanks for the remarkably rapid turnround!

Paul

Patch

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

	PR fortran/51605
	* match.c (gfc_match_select_type): Handle
	scalar polymophic coarrays.
	(select_type_set_tmp, ): Ditto; avoid segfault if !class_ok.
	* primary.c (gfc_match_rvalue): Avoid segfault if !class_ok.
	* resolve.c (resolve_select_type): Ditto.
	(resolve_assoc_var): Fix setting the TARGET attribute for
	polymorphic selectors which are pointers.

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

	PR fortran/51605
	* gfortran.dg/select_type_25.f90: New.

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0e12730..fd91921 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5154,19 +5154,27 @@  select_type_set_tmp (gfc_typespec *ts)
 
 /* Copy across the array spec to the selector, taking care as to
    whether or not it is a class object or not.  */
-  if (select_type_stack->selector->ts.type == BT_CLASS &&
-      CLASS_DATA (select_type_stack->selector)->attr.dimension)
+  if (select_type_stack->selector->ts.type == BT_CLASS
+      && select_type_stack->selector->attr.class_ok
+      && (CLASS_DATA (select_type_stack->selector)->attr.dimension
+	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
     {
       if (ts->type == BT_CLASS)
 	{
-	  CLASS_DATA (tmp->n.sym)->attr.dimension = 1;
+	  CLASS_DATA (tmp->n.sym)->attr.dimension
+		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
+	  CLASS_DATA (tmp->n.sym)->attr.codimension
+		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
 	  CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
 	  CLASS_DATA (tmp->n.sym)->as
 			= CLASS_DATA (select_type_stack->selector)->as;
 	}
       else
 	{
-	  tmp->n.sym->attr.dimension = 1;
+	  tmp->n.sym->attr.dimension
+		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
+	  tmp->n.sym->attr.codimension
+		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
 	  tmp->n.sym->as = gfc_get_array_spec ();
 	  tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
 	}
@@ -5248,7 +5256,8 @@  gfc_match_select_type (void)
 		  && expr1->ts.type != BT_UNKNOWN
 		  && CLASS_DATA (expr1)
 		  && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
-		  && CLASS_DATA (expr1)->attr.dimension
+		  && (CLASS_DATA (expr1)->attr.dimension
+		      || CLASS_DATA (expr1)->attr.codimension)
 		  && expr1->ref
 		  && expr1->ref->type == REF_ARRAY
 		  && expr1->ref->next == NULL;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index afc4684..f79ed22 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2914,7 +2914,7 @@  gfc_match_rvalue (gfc_expr **result)
 	  break;
 	}
 
-      if (sym->ts.type == BT_CLASS
+      if (sym->ts.type == BT_CLASS && sym->attr.class_ok
 	  && (CLASS_DATA (sym)->attr.dimension
 	      || CLASS_DATA (sym)->attr.codimension))
 	{
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 5e8371a..4bfdb79 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7817,9 +7817,12 @@  resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       sym->attr.asynchronous = tsym->attr.asynchronous;
       sym->attr.volatile_ = tsym->attr.volatile_;
 
-      sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+      if (tsym->ts.type == BT_CLASS)
+	sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer;
+      else
+	sym->attr.target = tsym->attr.target || tsym->attr.pointer;
 
-      if (sym->ts.type == BT_DERIVED && target->symtree->n.sym->ts.type == BT_CLASS)
+      if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS)
 	target->rank = sym->as ? sym->as->rank : 0;
     }
 
@@ -7887,6 +7890,9 @@  resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
       return;
     }
 
+  if (!code->expr1->symtree->n.sym->attr.class_ok)
+    return;
+
   if (code->expr2)
     {
       if (code->expr1->symtree->n.sym->attr.untyped)
--- /dev/null	2011-12-19 07:31:56.575697380 +0100
+++ gcc/gcc/testsuite/gfortran.dg/select_type_25.f90	2011-12-19 15:03:56.000000000 +0100
@@ -0,0 +1,71 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/51605
+!
+
+subroutine one()
+type t
+end type t
+! (a) Invalid (was ICEing before)
+class(t), target :: p1 ! { dg-error "must be dummy, allocatable or pointer" }
+class(t), pointer :: p2
+
+select type(p1)
+  type is(t)
+    p2 => p1
+  class is(t)
+    p2 => p1
+end select
+end subroutine one
+
+subroutine two()
+type t
+end type t
+class(t), allocatable, target :: p1 ! (b) Valid
+class(t), pointer :: p2
+
+select type(p1)
+  type is(t)
+    p2 => p1
+  class is(t)
+    p2 => p1
+end select
+end subroutine two
+
+subroutine three()
+type t
+end type t
+class(t), allocatable :: p1         ! (c) Invalid as not TARGET
+class(t), pointer :: p2
+
+select type(p1)
+  type is(t)
+    p2 => p1 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" }
+  class is(t)
+    p2 => p1 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" }
+end select
+end subroutine three
+
+subroutine four()
+type t
+end type t
+class(t), pointer :: p1             ! (d) Valid
+class(t), pointer :: p2
+
+select type(p1)
+  type is(t)
+    p2 => p1
+  class is(t)
+    p2 => p1
+end select
+end subroutine four
+
+subroutine caf(x)
+  type t
+  end type t
+  class(t) :: x[*]
+  select type(x)
+  type is(t)
+  end select
+end subroutine caf