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 b34084db4c4b8eed440095730695c69cbd66aae7..6662284cc85ad250c34565b68c8b87e5b4bec5e1 100644 (file)
--- 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 bf07d43d3b7668292a612a0e03343293f059a3fe..b390dff6397dd8e82f82da39fc3af3367392ddb7 100644 (file)
--- 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 42464ec5820cd2d6292684c60cbd23ed6378ccdb..24388b80c116794f4cfc7a6e5cdb1da4d75e105d 100644 (file)
--- 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 (file)
index 0000000..345fa62
--- /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
+