From: Paul Thomas Date: Thu, 26 Feb 2009 18:43:50 +0000 (+0000) Subject: re PR fortran/39295 (Too strict interface conformance check) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=489ec4e3bd232d184845a5b71322dfe18e65529f;p=gcc.git re PR fortran/39295 (Too strict interface conformance check) 2009-02-26 Paul Thomas 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 PR fortran/39295 * gfortran.dg/interface_25.f90: New test. * gfortran.dg/interface_26.f90: New test. From-SVN: r144449 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 859e423d8dd..4bf46250472 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-02-26 Paul Thomas + + 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 PR fortran/39292 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5b2bdd10665..88638070d3c 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index adbfc024b5e..4b9936e9564 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-02-26 Paul Thomas + + PR fortran/39295 + * gfortran.dg/interface_25.f90: New test. + * gfortran.dg/interface_26.f90: New test. + 2009-02-26 Paul Thomas 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 index 00000000000..0118cd563c7 --- /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 +! +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 index 00000000000..9f7fa4ef3f6 --- /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 +! +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