OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
2009-02-26  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-02-26  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: r144449
This commit is contained in:
Paul Thomas 2009-02-26 18:43:50 +00:00
parent ebb9cc41a8
commit 489ec4e3bd
5 changed files with 118 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2009-02-26 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-02-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/39292

17
gcc/fortran/interface.c
View File

@ -491,17 +491,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
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;

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2009-02-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/39295
* gfortran.dg/interface_25.f90: New test.
* gfortran.dg/interface_26.f90: New test.
2009-02-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/39292

45
gcc/testsuite/gfortran.dg/interface_25.f90 Normal file
View File

@ -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

46
gcc/testsuite/gfortran.dg/interface_26.f90 Normal file
View File

@ -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