Subversion Repositories openrisc

! { dg-do compile }

!

! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected

!

! Original test case by Arjen Markus 

! Modified by Janus Weil 

module m

  implicit none

  type :: rectangle

    real :: width, height

    procedure(get_area_ai), pointer :: get_area => get_my_area  ! { dg-error "Type/rank mismatch" }

  end type rectangle

  abstract interface

    real function get_area_ai( this )

      import                       :: rectangle

      class(rectangle), intent(in) :: this

    end function get_area_ai

  end interface

contains

  real function get_my_area( this )

    type(rectangle), intent(in) :: this

    get_my_area = 3.0 * this%width * this%height

  end function get_my_area

end

!-------------------------------------------------------------------------------

program p

  implicit none

  type :: rectangle

    real :: width, height

    procedure(get_area_ai), pointer :: get_area

  end type rectangle

  abstract interface

    real function get_area_ai (this)

      import                       :: rectangle

      class(rectangle), intent(in) :: this

    end function get_area_ai

  end interface

  type(rectangle) :: rect

  rect  = rectangle (1.0, 2.0, get1)

  rect  = rectangle (3.0, 4.0, get2)  ! { dg-error "Type/rank mismatch" }

contains

  real function get1 (this)

    class(rectangle), intent(in) :: this

    get1 = 1.0 * this%width * this%height

  end function get1

  real function get2 (this)

    type(rectangle), intent(in) :: this

    get2 = 2.0 * this%width * this%height

  end function get2

end

! { dg-final { cleanup-modules "m" } }