1! { dg-do run } 2! Tests dynamic dispatch of class functions. 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 real function make_real (arg) 26 class(t1), intent(in) :: arg 27 make_real = real (arg%i) 28 end function make_real 29 30 real function make_real2 (arg) 31 class(t2), intent(in) :: arg 32 make_real2 = real (arg%j) 33 end function make_real2 34 35 integer function make_integer (arg, arg2) 36 class(t1), intent(in) :: arg 37 integer :: arg2 38 make_integer = arg%i * arg2 39 end function make_integer 40 41 integer function make_integer_2 (arg, arg2) 42 class(t2), intent(in) :: arg 43 integer :: arg2 44 make_integer_2 = arg%j * arg2 45 end function make_integer_2 46 47 integer function i_m_j (arg) 48 class(t1), intent(in) :: arg 49 i_m_j = arg%i 50 end function i_m_j 51 52 integer function i_m_j_2 (arg) 53 class(t2), intent(in) :: arg 54 i_m_j_2 = arg%j 55 end function i_m_j_2 56end module m 57 58 use m 59 type, extends(t1) :: l1 60 character(16) :: chr 61 end type l1 62 class(t1), pointer :: a !=> NULL() 63 type(t1), target :: b 64 type(t2), target :: c 65 type(l1), target :: d 66 a => b ! declared type 67 if (a%real() .ne. real (42)) STOP 1 68 if (a%prod() .ne. 42) STOP 2 69 if (a%extract (2) .ne. 84) STOP 3 70 a => c ! extension in module 71 if (a%real() .ne. real (99)) STOP 4 72 if (a%prod() .ne. 99) STOP 5 73 if (a%extract (3) .ne. 297) STOP 6 74 a => d ! extension in main 75 if (a%real() .ne. real (42)) STOP 7 76 if (a%prod() .ne. 42) STOP 8 77 if (a%extract (4) .ne. 168) STOP 9 78end 79