1! { dg-do run }
2!
3! Verifying the runtime behavior of the intrinsic function SAME_TYPE_AS.
4!
5! Contributed by Janus Weil <janus@gcc.gnu.org>
6
7 type :: t1
8  integer :: i
9 end type 
10
11 type, extends(t1) :: t2
12  integer :: j
13 end type
14
15 CLASS(t1), pointer :: c1,c2
16 TYPE(t1), target :: x1
17 TYPE(t2) ,target :: x2
18
19 intrinsic :: SAME_TYPE_AS
20 logical :: l
21
22 c1 => NULL()
23
24 l = SAME_TYPE_AS (x1,x1)
25 print *,l
26 if (.not.l) call abort()
27 l = SAME_TYPE_AS (x1,x2)
28 print *,l
29 if (l) call abort()
30
31 c1 => x1
32 l = SAME_TYPE_AS (c1,x1)
33 print *,l
34 if (.not.l) call abort()
35 l = SAME_TYPE_AS (c1,x2)
36 print *,l
37 if (l) call abort()
38
39 c1 => x2
40 c2 => x2
41 l = SAME_TYPE_AS (c1,c2)
42 print *,l
43 if (.not.l) call abort()
44
45 c1 => x1
46 c2 => x2
47 l = SAME_TYPE_AS (c1,c2)
48 print *,l
49 if (l) call abort()
50
51end
52