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