blob: 2522ea11afd35641ae52436037e2c03c74965e5a [file] [log] [blame]
! { dg-do run }
!
! PR fortran/39427
!
! Contributed by Norman S. Clerman (in PR fortran/45155)
!
! Constructor test case
!
!
module test_cnt
integer, public, save :: my_test_cnt = 0
end module test_cnt
module Rational
use test_cnt
implicit none
private
type, public :: rational_t
integer :: n = 0, id = 1
contains
procedure, nopass :: Construct_rational_t
procedure :: Print_rational_t
procedure, private :: Rational_t_init
generic :: Rational_t => Construct_rational_t
generic :: print => Print_rational_t
end type rational_t
contains
function Construct_rational_t (message_) result (return_type)
character (*), intent (in) :: message_
type (rational_t) :: return_type
! print *, trim (message_)
if (my_test_cnt /= 1) STOP 1
my_test_cnt = my_test_cnt + 1
call return_type % Rational_t_init
end function Construct_rational_t
subroutine Print_rational_t (this_)
class (rational_t), intent (in) :: this_
! print *, "n, id", this_% n, this_% id
if (my_test_cnt == 0) then
if (this_% n /= 0 .or. this_% id /= 1) STOP 2
else if (my_test_cnt == 2) then
if (this_% n /= 10 .or. this_% id /= 0) STOP 3
else
STOP 4
end if
my_test_cnt = my_test_cnt + 1
end subroutine Print_rational_t
subroutine Rational_t_init (this_)
class (rational_t), intent (in out) :: this_
this_% n = 10
this_% id = 0
end subroutine Rational_t_init
end module Rational
module Temp_node
use test_cnt
implicit none
private
real, parameter :: NOMINAL_TEMP = 20.0
type, public :: temp_node_t
real :: temperature = NOMINAL_TEMP
integer :: id = 1
contains
procedure :: Print_temp_node_t
procedure, private :: Temp_node_t_init
generic :: Print => Print_temp_node_t
end type temp_node_t
interface temp_node_t
module procedure Construct_temp_node_t
end interface
contains
function Construct_temp_node_t (message_) result (return_type)
character (*), intent (in) :: message_
type (temp_node_t) :: return_type
!print *, trim (message_)
if (my_test_cnt /= 4) STOP 5
my_test_cnt = my_test_cnt + 1
call return_type % Temp_node_t_init
end function Construct_temp_node_t
subroutine Print_temp_node_t (this_)
class (temp_node_t), intent (in) :: this_
! print *, "temp, id", this_% temperature, this_% id
if (my_test_cnt == 3) then
if (this_% temperature /= 20 .or. this_% id /= 1) STOP 6
else if (my_test_cnt == 5) then
if (this_% temperature /= 10 .or. this_% id /= 0) STOP 7
else
STOP 8
end if
my_test_cnt = my_test_cnt + 1
end subroutine Print_temp_node_t
subroutine Temp_node_t_init (this_)
class (temp_node_t), intent (in out) :: this_
this_% temperature = 10.0
this_% id = 0
end subroutine Temp_node_t_init
end module Temp_node
program Struct_over
use test_cnt
use Rational, only : rational_t
use Temp_node, only : temp_node_t
implicit none
type (rational_t) :: sample_rational_t
type (temp_node_t) :: sample_temp_node_t
! print *, "rational_t"
! print *, "----------"
! print *, ""
!
! print *, "after declaration"
if (my_test_cnt /= 0) STOP 9
call sample_rational_t % print
if (my_test_cnt /= 1) STOP 10
sample_rational_t = sample_rational_t % rational_t ("using override")
if (my_test_cnt /= 2) STOP 11
! print *, "after override"
! call print (sample_rational_t)
! call sample_rational_t % print ()
call sample_rational_t % print
if (my_test_cnt /= 3) STOP 12
! print *, "sample_t"
! print *, "--------"
! print *, ""
!
! print *, "after declaration"
call sample_temp_node_t % print
if (my_test_cnt /= 4) STOP 13
sample_temp_node_t = temp_node_t ("using override")
if (my_test_cnt /= 5) STOP 14
! print *, "after override"
! call print (sample_rational_t)
! call sample_rational_t % print ()
call sample_temp_node_t % print
if (my_test_cnt /= 6) STOP 15
end program Struct_over