1! { dg-do run } 2! 3! PR fortran/39427 4! 5! Contributed by Norman S. Clerman (in PR fortran/45155) 6! 7! Constructor test case 8! 9! 10module test_cnt 11 integer, public, save :: my_test_cnt = 0 12end module test_cnt 13 14module Rational 15 use test_cnt 16 implicit none 17 private 18 19 type, public :: rational_t 20 integer :: n = 0, id = 1 21 contains 22 procedure, nopass :: Construct_rational_t 23 procedure :: Print_rational_t 24 procedure, private :: Rational_t_init 25 generic :: Rational_t => Construct_rational_t 26 generic :: print => Print_rational_t 27 end type rational_t 28 29contains 30 31 function Construct_rational_t (message_) result (return_type) 32 character (*), intent (in) :: message_ 33 type (rational_t) :: return_type 34 35! print *, trim (message_) 36 if (my_test_cnt /= 1) call abort() 37 my_test_cnt = my_test_cnt + 1 38 call return_type % Rational_t_init 39 40 end function Construct_rational_t 41 42 subroutine Print_rational_t (this_) 43 class (rational_t), intent (in) :: this_ 44 45! print *, "n, id", this_% n, this_% id 46 if (my_test_cnt == 0) then 47 if (this_% n /= 0 .or. this_% id /= 1) call abort () 48 else if (my_test_cnt == 2) then 49 if (this_% n /= 10 .or. this_% id /= 0) call abort () 50 else 51 call abort () 52 end if 53 my_test_cnt = my_test_cnt + 1 54 end subroutine Print_rational_t 55 56 subroutine Rational_t_init (this_) 57 class (rational_t), intent (in out) :: this_ 58 59 this_% n = 10 60 this_% id = 0 61 62 end subroutine Rational_t_init 63 64end module Rational 65 66module Temp_node 67 use test_cnt 68 implicit none 69 private 70 71 real, parameter :: NOMINAL_TEMP = 20.0 72 73 type, public :: temp_node_t 74 real :: temperature = NOMINAL_TEMP 75 integer :: id = 1 76 contains 77 procedure :: Print_temp_node_t 78 procedure, private :: Temp_node_t_init 79 generic :: Print => Print_temp_node_t 80 end type temp_node_t 81 82 interface temp_node_t 83 module procedure Construct_temp_node_t 84 end interface 85 86contains 87 88 function Construct_temp_node_t (message_) result (return_type) 89 character (*), intent (in) :: message_ 90 type (temp_node_t) :: return_type 91 92 !print *, trim (message_) 93 if (my_test_cnt /= 4) call abort() 94 my_test_cnt = my_test_cnt + 1 95 call return_type % Temp_node_t_init 96 97 end function Construct_temp_node_t 98 99 subroutine Print_temp_node_t (this_) 100 class (temp_node_t), intent (in) :: this_ 101 102! print *, "temp, id", this_% temperature, this_% id 103 if (my_test_cnt == 3) then 104 if (this_% temperature /= 20 .or. this_% id /= 1) call abort () 105 else if (my_test_cnt == 5) then 106 if (this_% temperature /= 10 .or. this_% id /= 0) call abort () 107 else 108 call abort () 109 end if 110 my_test_cnt = my_test_cnt + 1 111 end subroutine Print_temp_node_t 112 113 subroutine Temp_node_t_init (this_) 114 class (temp_node_t), intent (in out) :: this_ 115 116 this_% temperature = 10.0 117 this_% id = 0 118 119 end subroutine Temp_node_t_init 120 121end module Temp_node 122 123program Struct_over 124 use test_cnt 125 use Rational, only : rational_t 126 use Temp_node, only : temp_node_t 127 128 implicit none 129 130 type (rational_t) :: sample_rational_t 131 type (temp_node_t) :: sample_temp_node_t 132 133! print *, "rational_t" 134! print *, "----------" 135! print *, "" 136! 137! print *, "after declaration" 138 if (my_test_cnt /= 0) call abort() 139 call sample_rational_t % print 140 141 if (my_test_cnt /= 1) call abort() 142 143 sample_rational_t = sample_rational_t % rational_t ("using override") 144 if (my_test_cnt /= 2) call abort() 145! print *, "after override" 146 ! call print (sample_rational_t) 147 ! call sample_rational_t % print () 148 call sample_rational_t % print 149 150 if (my_test_cnt /= 3) call abort() 151 152! print *, "sample_t" 153! print *, "--------" 154! print *, "" 155! 156! print *, "after declaration" 157 call sample_temp_node_t % print 158 159 if (my_test_cnt /= 4) call abort() 160 161 sample_temp_node_t = temp_node_t ("using override") 162 if (my_test_cnt /= 5) call abort() 163! print *, "after override" 164 ! call print (sample_rational_t) 165 ! call sample_rational_t % print () 166 call sample_temp_node_t % print 167 if (my_test_cnt /= 6) call abort() 168 169end program Struct_over 170