1! { dg-do run } 2! Tests dynamic dispatch of class subroutines. 3! 4! Contributed by Paul Thomas <pault@gcc.gnu.org> 5! 6module m 7 type :: t1 8 integer :: i = 42 9 procedure(make_real), pointer :: ptr 10 contains 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 15 end type t1 16 17 type, extends(t1) :: t2 18 integer :: j = 99 19 contains 20 procedure, pass :: real => make_real2 21 procedure, pass :: make_integer => make_integer_2 22 procedure, pass :: prod => i_m_j_2 23 end type t2 24contains 25 subroutine make_real (arg, arg2) 26 class(t1), intent(in) :: arg 27 real :: arg2 28 arg2 = real (arg%i) 29 end subroutine make_real 30 31 subroutine make_real2 (arg, arg2) 32 class(t2), intent(in) :: arg 33 real :: arg2 34 arg2 = real (arg%j) 35 end subroutine make_real2 36 37 subroutine make_integer (arg, arg2, arg3) 38 class(t1), intent(in) :: arg 39 integer :: arg2, arg3 40 arg3 = arg%i * arg2 41 end subroutine make_integer 42 43 subroutine make_integer_2 (arg, arg2, arg3) 44 class(t2), intent(in) :: arg 45 integer :: arg2, arg3 46 arg3 = arg%j * arg2 47 end subroutine make_integer_2 48 49 subroutine i_m_j (arg, arg2) 50 class(t1), intent(in) :: arg 51 integer :: arg2 52 arg2 = arg%i 53 end subroutine i_m_j 54 55 subroutine i_m_j_2 (arg, arg2) 56 class(t2), intent(in) :: arg 57 integer :: arg2 58 arg2 = arg%j 59 end subroutine i_m_j_2 60end module m 61 62 use m 63 type, extends(t1) :: l1 64 character(16) :: chr 65 end type l1 66 class(t1), pointer :: a !=> NULL() 67 type(t1), target :: b 68 type(t2), target :: c 69 type(l1), target :: d 70 real :: r 71 integer :: i 72 73 a => b ! declared type 74 call a%real(r) 75 if (r .ne. real (42)) call abort 76 call a%prod(i) 77 if (i .ne. 42) call abort 78 call a%extract (2, i) 79 if (i .ne. 84) call abort 80 81 a => c ! extension in module 82 call a%real(r) 83 if (r .ne. real (99)) call abort 84 call a%prod(i) 85 if (i .ne. 99) call abort 86 call a%extract (3, i) 87 if (i .ne. 297) call abort 88 89 a => d ! extension in main 90 call a%real(r) 91 if (r .ne. real (42)) call abort 92 call a%prod(i) 93 if (i .ne. 42) call abort 94 call a%extract (4, i) 95 if (i .ne. 168) call abort 96end 97