1! { dg-do compile }
2!
3! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure
4! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check
5!
6! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
7
8module base_mod
9  implicit none
10  type base_type
11    integer :: kind
12  contains
13    procedure, pass(map)  :: clone    => base_clone
14  end type
15contains
16  subroutine  base_clone(map,mapout,info)
17    class(base_type), intent(inout) :: map
18    class(base_type), intent(inout) :: mapout
19    integer     :: info
20  end subroutine
21end module
22
23module r_mod
24  use base_mod
25  implicit none
26  type, extends(base_type) :: r_type
27    real  :: dat
28  contains
29    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Rank mismatch in argument" }
30  end type
31contains
32  subroutine  r_clone(map,mapout,info)
33    class(r_type), intent(inout) :: map
34    class(base_type), intent(inout) :: mapout(..)
35    integer     :: info
36  end subroutine
37end module
38
39! { dg-final { cleanup-modules "base_mod r_mod" } }
40