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