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

Submitted by Tobias Burnus on Dec. 19, 2011, 2:37 p.m.

Details

Message ID 4EEF4C3F.2000603@net-b.de
State New
Headers show

Commit Message

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

Comments

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 hide | download patch | download mbox

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