5 ! Contributed by Norman S. Clerman (in PR fortran/45155)
7 ! Constructor test case
11 integer, public
, save :: my_test_cnt
= 0
19 type, public
:: rational_t
20 integer :: n
= 0, id
= 1
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
31 function Construct_rational_t (message_
) result (return_type
)
32 character (*), intent (in
) :: message_
33 type (rational_t
) :: return_type
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
40 end function Construct_rational_t
42 subroutine Print_rational_t (this_
)
43 class (rational_t
), intent (in
) :: this_
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 ()
53 my_test_cnt
= my_test_cnt
+ 1
54 end subroutine Print_rational_t
56 subroutine Rational_t_init (this_
)
57 class (rational_t
), intent (in out
) :: this_
62 end subroutine Rational_t_init
71 real, parameter :: NOMINAL_TEMP
= 20.0
73 type, public
:: temp_node_t
74 real :: temperature
= NOMINAL_TEMP
77 procedure
:: Print_temp_node_t
78 procedure
, private
:: Temp_node_t_init
79 generic
:: Print => Print_temp_node_t
83 module procedure Construct_temp_node_t
88 function Construct_temp_node_t (message_
) result (return_type
)
89 character (*), intent (in
) :: message_
90 type (temp_node_t
) :: return_type
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
97 end function Construct_temp_node_t
99 subroutine Print_temp_node_t (this_
)
100 class (temp_node_t
), intent (in
) :: this_
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 ()
110 my_test_cnt
= my_test_cnt
+ 1
111 end subroutine Print_temp_node_t
113 subroutine Temp_node_t_init (this_
)
114 class (temp_node_t
), intent (in out
) :: this_
116 this_
% temperature
= 10.0
119 end subroutine Temp_node_t_init
125 use Rational
, only
: rational_t
126 use Temp_node
, only
: temp_node_t
130 type (rational_t
) :: sample_rational_t
131 type (temp_node_t
) :: sample_temp_node_t
133 ! print *, "rational_t"
134 ! print *, "----------"
137 ! print *, "after declaration"
138 if (my_test_cnt
/= 0) call abort()
139 call sample_rational_t
% print
141 if (my_test_cnt
/= 1) call abort()
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
150 if (my_test_cnt
/= 3) call abort()
152 ! print *, "sample_t"
153 ! print *, "--------"
156 ! print *, "after declaration"
157 call sample_temp_node_t
% print
159 if (my_test_cnt
/= 4) call abort()
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()
169 end program Struct_over