gcc/testsuite/gfortran.dg/constructor_6.f90

   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 !
  10 module test_cnt
  11   integer, public, save :: my_test_cnt = 0
  12 end module test_cnt
  13
  14 module 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
  29 contains
  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) STOP 1
  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) STOP 2
  48     else if (my_test_cnt == 2) then
  49       if (this_% n /= 10 .or. this_% id /= 0) STOP 3
  50     else
  51       STOP 4
  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
  64 end module Rational
  65
  66 module 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
  86 contains
  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) STOP 5
  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) STOP 6
 105     else if (my_test_cnt == 5) then
 106       if (this_% temperature /= 10 .or. this_% id /= 0) STOP 7
 107     else
 108       STOP 8
 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
 121 end module Temp_node
 122
 123 program 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) STOP 9
 139   call sample_rational_t % print
 140
 141   if (my_test_cnt /= 1) STOP 10
 142
 143   sample_rational_t = sample_rational_t % rational_t ("using override")
 144   if (my_test_cnt /= 2) STOP 11
 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) STOP 12
 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) STOP 13
 160
 161   sample_temp_node_t = temp_node_t ("using override")
 162   if (my_test_cnt /= 5) STOP 14
 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) STOP 15
 168
 169 end program Struct_over