re PR fortran/55172 ([OOP] gfc_variable_attr(): Bad array reference in SELECT TYPE)

2013-01-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55172
	* match.c (copy_ts_from_selector_to_associate): Remove call to
	gfc_resolve_expr and replace it with explicit setting of the
	array reference type.
	* resolve.c (resolve_select_type): It is an error if the
	selector is coindexed.

2013-01-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55172
	* gfortran.dg/select_type_31.f03: New test.

From-SVN: r194916

gcc/fortran/ChangeLog

+2013-01-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55172
+	* match.c (copy_ts_from_selector_to_associate): Remove call to
+	gfc_resolve_expr and replace it with explicit setting of the
+	array reference type.
+	* resolve.c (resolve_select_type): It is an error if the
+	selector is coindexed.
+
 2013-01-04  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/55763

gcc/fortran/match.c

 /* Matching subroutines in all sizes, shapes and colors.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010, 2011, 2012
+   2009, 2010, 2011, 2012, 2013
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -5144,12 +5144,10 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
 {
   gfc_ref *ref;
   gfc_symbol *assoc_sym;
+  int i;
 
   assoc_sym = associate->symtree->n.sym;
 
-  /* Ensure that any array reference is resolved.  */
-  gfc_resolve_expr (selector);
-
   /* At this stage the expression rank and arrayspec dimensions have
      not been completely sorted out. We must get the expr2->rank
      right here, so that the correct class container is obtained.  */
@@ -5161,6 +5159,23 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
 	&& CLASS_DATA (selector)->as
 	&& ref && ref->type == REF_ARRAY)
     {
+      /* Ensure that the array reference type is set.  We cannot use
+	 gfc_resolve_expr at this point, so the usable parts of
+	 resolve.c(resolve_array_ref) are employed to do it.  */
+      if (ref->u.ar.type == AR_UNKNOWN)
+	{
+	  ref->u.ar.type = AR_ELEMENT;
+	  for (i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+	    if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
+		|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR
+		|| (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
+		    && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
+	      {
+		ref->u.ar.type = AR_SECTION;
+		break;
+	      }
+	}
+
       if (ref->u.ar.type == AR_FULL)
 	selector->rank = CLASS_DATA (selector)->as->rank;
       else if (ref->u.ar.type == AR_SECTION)

gcc/fortran/resolve.c

 /* Perform type resolution on the various structures.
    Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010, 2011, 2012
+   2010, 2011, 2012, 2013
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -8349,9 +8349,27 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
       if (code->expr1->symtree->n.sym->attr.untyped)
 	code->expr1->symtree->n.sym->ts = code->expr2->ts;
       selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+
+      /* F2008: C803 The selector expression must not be coindexed.  */
+      if (gfc_is_coindexed (code->expr2))
+	{
+	  gfc_error ("Selector at %L must not be coindexed",
+		     &code->expr2->where);
+	  return;
+	}
+
     }
   else
-    selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
+    {
+      selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
+
+      if (gfc_is_coindexed (code->expr1))
+	{
+	  gfc_error ("Selector at %L must not be coindexed",
+		     &code->expr1->where);
+	  return;
+	}
+    }
 
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)

gcc/testsuite/ChangeLog

+2013-01-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/55172
+	* gfortran.dg/select_type_31.f03: New test.
+
 2013-01-04  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/54526 (again)

gcc/testsuite/gfortran.dg/select_type_31.f03

+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+! Test the fix for PR55172.
+!
+! Contributed by Arjen Markus  <arjen.markus@deltares.nl>
+!
+module gn
+  type :: ncb
+  end type ncb
+  type, public :: tn
+     class(ncb), allocatable, dimension(:) :: cb
+  end type tn
+contains
+  integer function name(self)
+    implicit none
+    class (tn), intent(in) :: self
+    select type (component => self%cb(i)) ! { dg-error "has no IMPLICIT type" }
+    end select
+  end function name
+end module gn
+
+! Further issues, raised by Tobias Burnus in the course of fixing the PR
+
+module gn1
+  type :: ncb1
+  end type ncb1
+  type, public :: tn1
+     class(ncb1), allocatable, dimension(:) :: cb
+  end type tn1
+contains
+  integer function name(self)
+    implicit none
+    class (tn1), intent(in) :: self
+    select type (component => self%cb([4,7+1])) ! { dg-error "needs a temporary" }
+    end select
+  end function name
+end module gn1
+
+module gn2
+  type :: ncb2
+  end type ncb2
+  type, public :: tn2
+     class(ncb2), allocatable :: cb[:]
+  end type tn2
+contains
+  integer function name(self)
+    implicit none
+    class (tn2), intent(in) :: self
+    select type (component => self%cb[4]) ! { dg-error "must not be coindexed" }
+    end select
+  end function name
+end module gn2