170 lines
3.9 KiB
Fortran
170 lines
3.9 KiB
Fortran
! { 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
|