re PR fortran/51605 (internal compiler error gfc_trans_block_construct, at fortran/trans-stmt.c:984)

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.

From-SVN: r182484

6 files changed, 110 insertions, 8 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9d7d7c7..e5e8e7f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,16 @@
 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>
+
 	* check.c (coarray_check): Add class ref if needed.
 	* resolve.c (resolve_fl_var_and_proc,
 	resolve_fl_derived0, resolve_symbol): Fix checking
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)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b1a3762..57a5dc8 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-12-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51605
+	* gfortran.dg/select_type_25.f90: New.
+
 2011-12-19  Martin Jambor  <mjambor@suse.cz>
 
 	PR tree-optimization/51583
diff --git a/gcc/testsuite/gfortran.dg/select_type_25.f90 b/gcc/testsuite/gfortran.dg/select_type_25.f90
new file mode 100644
index 0000000..45fe9af
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_25.f90
@@ -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