2 ! Tests dynamic dispatch of class subroutines.
4 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
9 procedure(make_real), pointer :: ptr
11 procedure, pass :: real => make_real
12 procedure, pass :: make_integer
13 procedure, pass :: prod => i_m_j
14 generic, public :: extract => real, make_integer
17 type, extends(t1) :: t2
20 procedure, pass :: real => make_real2
21 procedure, pass :: make_integer => make_integer_2
22 procedure, pass :: prod => i_m_j_2
25 subroutine make_real (arg, arg2)
26 class(t1), intent(in) :: arg
29 end subroutine make_real
31 subroutine make_real2 (arg, arg2)
32 class(t2), intent(in) :: arg
35 end subroutine make_real2
37 subroutine make_integer (arg, arg2, arg3)
38 class(t1), intent(in) :: arg
41 end subroutine make_integer
43 subroutine make_integer_2 (arg, arg2, arg3)
44 class(t2), intent(in) :: arg
47 end subroutine make_integer_2
49 subroutine i_m_j (arg, arg2)
50 class(t1), intent(in) :: arg
55 subroutine i_m_j_2 (arg, arg2)
56 class(t2), intent(in) :: arg
59 end subroutine i_m_j_2
63 type, extends(t1) :: l1
66 class(t1), pointer :: a !=> NULL()
73 a => b ! declared type
75 if (r .ne. real (42)) STOP 1
81 a => c ! extension in module
83 if (r .ne. real (99)) STOP 4
87 if (i .ne. 297) STOP 6
89 a => d ! extension in main
91 if (r .ne. real (42)) STOP 7
95 if (i .ne. 168) STOP 9