From: Andre Vehreschild <vehre@gmx.de>
Date: Fri, 5 Dec 2014 14:15:27 +0000 (+0100)
Subject: re PR fortran/60414 (internal compiler error: tree check)
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=201678234c69a5acdd6e8d4a49fafe45e15cbb24;p=gcc.git

re PR fortran/60414 (internal compiler error: tree check)

2014-12-05  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/60414
	* interface.c (compare_parameter): Remove class argument rank
	check short circuit.

2014-12-05  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/60414
	* gfortran.dg/unlimited_polymorphism_18.f90: New test.

From-SVN: r218422
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b34084db4c4..6662284cc85 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2014-12-05  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/60414
+	* interface.c (compare_parameter): Remove class argument rank
+	check short circuit.
+
 2014-12-05  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 
 	* error.c (gfc_diagnostic_build_locus_prefix): Use
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index bf07d43d3b7..b390dff6397 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2157,10 +2157,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
     return 1;
 
-  if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
-	&& CLASS_DATA (actual)->as->rank == symbol_rank (formal))
-    return 1;
-
   rank_check = where != NULL && !is_elemental && formal->as
 	       && (formal->as->type == AS_ASSUMED_SHAPE
 		   || formal->as->type == AS_DEFERRED)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 42464ec5820..24388b80c11 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2014-12-05  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/60414
+	* gfortran.dg/unlimited_polymorphism_18.f90: New test.
+
 2014-12-05  Ilya Enkovich  <ilya.enkovich@intel.com>
 
 	PR target/64056
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
new file mode 100644
index 00000000000..345fa6203c4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90
@@ -0,0 +1,69 @@
+! { dg-do run }
+! Testing fix for
+! PR fortran/60414
+!
+module m
+    implicit none
+    Type T
+        real, public :: expectedScalar;
+    contains
+        procedure :: FCheck
+        procedure :: FCheckArr
+        generic :: Check => FCheck, FCheckArr
+    end Type
+
+contains
+
+    subroutine FCheck(this,X)
+        class(T) this
+        class(*) X
+        real :: r
+        select type (X)
+            type is (real)
+                if ( abs (X - this%expectedScalar) > 0.0001 ) then
+                    call abort()
+                end if
+            class default
+                call abort ()
+         end select
+    end subroutine FCheck
+
+    subroutine FCheckArr(this,X)
+        class(T) this
+        class(*) X(:)
+        integer i
+        do i = 1,6
+            this%expectedScalar = i - 1.0
+            call this%FCheck(X(i))
+        end do
+    end subroutine FCheckArr
+
+    subroutine CheckTextVector(vec, n, scal)
+        integer, intent(in) :: n
+        class(*), intent(in) :: vec(n)
+        class(*), intent(in) :: scal
+        integer j
+        Type(T) :: Tester
+
+        ! Check full vector
+        call Tester%Check(vec)
+        ! Check a scalar of the same class like the vector
+        Tester%expectedScalar = 5.0
+        call Tester%Check(scal)
+        ! Check an element of the vector, which is a scalar
+        j=3
+        Tester%expectedScalar = 2.0
+        call Tester%Check(vec(j))
+
+    end subroutine CheckTextVector
+
+end module
+
+program test
+   use :: m
+   implicit none
+
+   real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
+   call checktextvector(vec, 6, 5.0)
+end program test
+