1! { dg-do compile } 2! 3! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected 4! 5! Original test case by Arjen Markus <arjen.markus895@gmail.com> 6! Modified by Janus Weil <janus@gcc.gnu.org> 7 8module m 9 10 implicit none 11 12 type :: rectangle 13 real :: width, height 14 procedure(get_area_ai), pointer :: get_area => get_my_area ! { dg-error "Type mismatch in argument" } 15 end type rectangle 16 17 abstract interface 18 real function get_area_ai( this ) 19 import :: rectangle 20 class(rectangle), intent(in) :: this 21 end function get_area_ai 22 end interface 23 24contains 25 26 real function get_my_area( this ) 27 type(rectangle), intent(in) :: this 28 get_my_area = 3.0 * this%width * this%height 29 end function get_my_area 30 31end 32 33!------------------------------------------------------------------------------- 34 35program p 36 37 implicit none 38 39 type :: rectangle 40 real :: width, height 41 procedure(get_area_ai), pointer :: get_area 42 end type rectangle 43 44 abstract interface 45 real function get_area_ai (this) 46 import :: rectangle 47 class(rectangle), intent(in) :: this 48 end function get_area_ai 49 end interface 50 51 type(rectangle) :: rect 52 53 rect = rectangle (1.0, 2.0, get1) 54 rect = rectangle (3.0, 4.0, get2) ! { dg-error "Type mismatch in argument" } 55 56contains 57 58 real function get1 (this) 59 class(rectangle), intent(in) :: this 60 get1 = 1.0 * this%width * this%height 61 end function get1 62 63 real function get2 (this) 64 type(rectangle), intent(in) :: this 65 get2 = 2.0 * this%width * this%height 66 end function get2 67 68end 69