mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-18 10:00:35 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/46067 ([F03] invalid procedure pointer assignment not detected)

Browse Source 
2010-10-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46067
	* interface.c (gfc_compare_interfaces): Switch arguments of type
	comparison (important for polymorphic variables).


2010-10-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46067
	* gfortran.dg/dummy_procedure_4.f90: New.
	* gfortran.dg/proc_ptr_30.f90: New.

From-SVN: r165755
This commit is contained in:
Janus Weil 2010-10-21 11:25:17 +02:00
parent 5490de28a2
commit acee848666
5 changed files with 99 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2010-10-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/46067
* interface.c (gfc_compare_interfaces): Switch arguments of type
comparison (important for polymorphic variables).
2010-10-21 Tobias Burnus <burnus@net-b.de>
PR fortran/46100

2
gcc/fortran/interface.c
View File

@ -1056,7 +1056,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
}
/* Check type and rank. */
if (!compare_type_rank (f1->sym, f2->sym))
if (!compare_type_rank (f2->sym, f1->sym))
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2010-10-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/46067
* gfortran.dg/dummy_procedure_4.f90: New.
* gfortran.dg/proc_ptr_30.f90: New.
2010-10-21 Tobias Burnus <burnus@net-b.de>
PR fortran/46100

48
gcc/testsuite/gfortran.dg/dummy_procedure_4.f90 Normal file
View File

@ -0,0 +1,48 @@
! { dg-do compile }
!
! PR 46067: [F03] invalid procedure pointer assignment not detected
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
type test_type
integer :: id = 1
end type
contains
real function fun1 (t,x)
real, intent(in) :: x
type(test_type) :: t
print *," id = ", t%id
fun1 = cos(x)
end function
end module
use m
implicit none
call test (fun1) ! { dg-error "Interface mismatch in dummy procedure" }
contains
subroutine test(proc)
interface
real function proc(t,x)
import :: test_type
real, intent(in) :: x
class(test_type) :: t
end function
end interface
type(test_type) :: funs
real :: r
r = proc(funs,0.)
print *, " proc(0) ",r
end subroutine
end
! { dg-final { cleanup-modules "m" } }

38
gcc/testsuite/gfortran.dg/proc_ptr_30.f90 Normal file
View File

@ -0,0 +1,38 @@
! { dg-do compile }
!
! PR 46067: [F03] invalid procedure pointer assignment not detected
!
! Contributed by Stephen J. Bespalko <sjbespa@comcast.net>
implicit none
type test_type
integer :: id = 1
end type
abstract interface
real function fun_interface(t,x)
import :: test_type
real, intent(in) :: x
class(test_type) :: t
end function
end interface
type(test_type) :: funs
real :: r
procedure(fun_interface), pointer :: pp
pp => fun1 ! { dg-error "Interface mismatch in procedure pointer assignment" }
r = pp(funs,0.)
print *, " pp(0) ", r
contains
real function fun1 (t,x)
real, intent(in) :: x
type(test_type) :: t
print *," id = ", t%id
fun1 = cos(x)
end function
end