re PR fortran/39295 (Too strict interface conformance check)

2009-03-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/39295
	* interface.c (compare_type_rank_if): Return 1 if the symbols
	are the same and deal with external procedures where one is
	identified to be a function or subroutine by usage but the
	other is not.

2009-03-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/39295
	* gfortran.dg/interface_25.f90: New test.
	* gfortran.dg/interface_26.f90: New test.

From-SVN: r144695

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 00aefcb241b661600d49dd6393ddc9bc43f0535f..9063d51ad8cef8aa903260b599eaa9c00bb45041 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2009-03-07  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/39295
+       * interface.c (compare_type_rank_if): Return 1 if the symbols
+       are the same and deal with external procedures where one is
+       identified to be a function or subroutine by usage but the
+       other is not.
+
 2009-03-07  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/39292

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 49c7b665d37842a8bfdf5243f70ae26f01c77f77..35c0daa3377c00a53ecd384e957c6cce1adcc08f 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -492,17 +492,26 @@ compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
   if (s1 == NULL || s2 == NULL)
     return s1 == s2 ? 1 : 0;
 
+  if (s1 == s2)
+    return 1;
+
   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
     return compare_type_rank (s1, s2);
 
   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
     return 0;
 
-  /* At this point, both symbols are procedures.  */
-  if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
-      || (s2->attr.function == 0 && s2->attr.subroutine == 0))
-    return 0;
+  /* At this point, both symbols are procedures.  It can happen that
+     a external procedures are compared where one is identified by usage
+     to be a function or subroutine but the other is not.  Check TKR
+     nonetheless for these cases.  */
+  if (s1->attr.function == 0 && s1->attr.subroutine == 0)
+    return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+
+  if (s2->attr.function == 0 && s2->attr.subroutine == 0)
+    return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
 
+  /* Now the type of procedure has been identified.  */
   if (s1->attr.function != s2->attr.function
       || s1->attr.subroutine != s2->attr.subroutine)
     return 0;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9d269c2140a27f130e683994df885771cbcf5e92..150ca6ce9c707bfb9667d522312a27ab7107cf31 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2009-03-07  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/39295
+       * gfortran.dg/interface_25.f90: New test.
+       * gfortran.dg/interface_26.f90: New test.
+
 2009-03-07  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/39292

diff --git a/gcc/testsuite/gfortran.dg/interface_25.f90 b/gcc/testsuite/gfortran.dg/interface_25.f90
new file mode 100644 (file)
index 0000000..0118cd5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_25.f90
@@ -0,0 +1,45 @@
+! { dg-do compile }
+! Tests the fix for PR39295, in which the check of the interfaces
+! at lines 25 and 42 failed because opfunc1 is identified as a 
+! function by usage, whereas opfunc2 is not.
+!
+! Contributed by Jon Hurst <jhurst@ucar.edu>
+!
+MODULE  funcs
+CONTAINS
+  INTEGER FUNCTION test1(a,b,opfunc1) 
+    INTEGER :: a,b
+    INTEGER, EXTERNAL :: opfunc1
+    test1 = opfunc1( a, b ) 
+  END FUNCTION test1
+  INTEGER FUNCTION sumInts(a,b)
+    INTEGER :: a,b
+    sumInts = a + b
+  END FUNCTION sumInts
+END MODULE funcs
+
+PROGRAM test
+  USE funcs 
+  INTEGER :: rs
+  INTEGER, PARAMETER :: a = 2, b = 1
+  rs = recSum( a, b, test1, sumInts )
+  write(*,*) "Results", rs
+CONTAINS
+  RECURSIVE INTEGER FUNCTION recSum( a,b,UserFunction,UserOp ) RESULT( res )
+    IMPLICIT NONE
+    INTEGER :: a,b
+    INTERFACE 
+       INTEGER FUNCTION UserFunction(a,b,opfunc2) 
+         INTEGER :: a,b
+         INTEGER, EXTERNAL :: opfunc2
+       END FUNCTION UserFunction
+    END INTERFACE
+    INTEGER, EXTERNAL :: UserOp 
+
+    res = UserFunction( a,b, UserOp )
+
+    if( res .lt. 10 ) then
+       res = recSum( a, res, UserFunction, UserOp ) 
+    end if
+  END FUNCTION recSum
+END PROGRAM test

diff --git a/gcc/testsuite/gfortran.dg/interface_26.f90 b/gcc/testsuite/gfortran.dg/interface_26.f90
new file mode 100644 (file)
index 0000000..9f7fa4e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_26.f90
@@ -0,0 +1,46 @@
+! { dg-do compile }
+! Tests the fix for PR39295, in which the check of the interfaces
+! at lines 26 and 43 failed because opfunc1 is identified as a 
+! function by usage, whereas opfunc2 is not. This testcase checks
+! that TKR is stll OK in these cases.
+!
+! Contributed by Jon Hurst <jhurst@ucar.edu>
+!
+MODULE  funcs
+CONTAINS
+  INTEGER FUNCTION test1(a,b,opfunc1) 
+    INTEGER :: a,b
+    INTEGER, EXTERNAL :: opfunc1
+    test1 = opfunc1( a, b ) 
+  END FUNCTION test1
+  INTEGER FUNCTION sumInts(a,b)
+    INTEGER :: a,b
+    sumInts = a + b
+  END FUNCTION sumInts
+END MODULE funcs
+
+PROGRAM test
+  USE funcs 
+  INTEGER :: rs
+  INTEGER, PARAMETER :: a = 2, b = 1
+  rs = recSum( a, b, test1, sumInts ) ! { dg-error "Type/rank mismatch in argument" }
+  write(*,*) "Results", rs
+CONTAINS
+  RECURSIVE INTEGER FUNCTION recSum( a,b,UserFunction,UserOp ) RESULT( res )
+    IMPLICIT NONE
+    INTEGER :: a,b
+    INTERFACE 
+       INTEGER FUNCTION UserFunction(a,b,opfunc2) 
+         INTEGER :: a,b
+         REAL, EXTERNAL :: opfunc2
+       END FUNCTION UserFunction
+    END INTERFACE
+    INTEGER, EXTERNAL :: UserOp 
+
+    res = UserFunction( a,b, UserOp )
+
+    if( res .lt. 10 ) then
+       res = recSum( a, res, UserFunction, UserOp ) 
+    end if
+  END FUNCTION recSum
+END PROGRAM test