OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [constructor_6.f90] - Blame information for rev 749

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn 
! { 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) 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 
 
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) 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 
 
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) 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 
 
169 
end program Struct_over
170 
 
171 
! { dg-final { cleanup-modules "test_cnt rational temp_node" } }

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.