+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
}
/* 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'",
+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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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