1! { dg-do run { xfail spu-*-* } }
2! FAILs on SPU because of wrong compile-time rounding mode
3! { dg-options "" }
4! { dg-options "-ffloat-store" { target { { i?86-*-* x86_64-*-* } && ilp32 } } }
5!
6!
7module mod_check
8  implicit none
9
10  interface check
11    module procedure check_i8
12    module procedure check_i4
13    module procedure check_r8
14    module procedure check_r4
15    module procedure check_c8
16    module procedure check_c4
17  end interface check
18
19  interface acheck
20    module procedure acheck_c8
21    module procedure acheck_c4
22  end interface acheck
23
24contains
25
26  subroutine check_i8 (a, b)
27    integer(kind=8), intent(in) :: a, b
28    if (a /= b) STOP 1
29  end subroutine check_i8
30
31  subroutine check_i4 (a, b)
32    integer(kind=4), intent(in) :: a, b
33    if (a /= b) STOP 2
34  end subroutine check_i4
35
36  subroutine check_r8 (a, b)
37    real(kind=8), intent(in) :: a, b
38    if (a /= b) STOP 3
39  end subroutine check_r8
40
41  subroutine check_r4 (a, b)
42    real(kind=4), intent(in) :: a, b
43    if (a /= b) STOP 4
44  end subroutine check_r4
45
46  subroutine check_c8 (a, b)
47    complex(kind=8), intent(in) :: a, b
48    if (a /= b) STOP 5
49  end subroutine check_c8
50
51  subroutine check_c4 (a, b)
52    complex(kind=4), intent(in) :: a, b
53    if (a /= b) STOP 6
54  end subroutine check_c4
55
56  subroutine acheck_c8 (a, b)
57    complex(kind=8), intent(in) :: a, b
58    if (abs(a-b) > 1.d-9 * min(abs(a),abs(b))) STOP 7
59  end subroutine acheck_c8
60
61  subroutine acheck_c4 (a, b)
62    complex(kind=4), intent(in) :: a, b
63    if (abs(a-b) > 1.e-5 * min(abs(a),abs(b))) STOP 8
64  end subroutine acheck_c4
65
66end module mod_check
67
68program test
69  use mod_check
70  implicit none
71
72  integer(kind=4) :: i4
73  integer(kind=8) :: i8
74  real(kind=4) :: r4
75  real(kind=8) :: r8
76  complex(kind=4) :: c4
77  complex(kind=8) :: c8
78
79#define TEST(base,exp,var) var = base; call check((var)**(exp),(base)**(exp))
80#define ATEST(base,exp,var) var = base; call acheck((var)**(exp),(base)**(exp))
81
82!!!!! INTEGER BASE !!!!!
83  TEST(0,0,i4)
84  TEST(0_8,0_8,i8)
85  TEST(1,0,i4)
86  TEST(1_8,0_8,i8)
87  TEST(-1,0,i4)
88  TEST(-1_8,0_8,i8)
89  TEST(huge(0_4),0,i4)
90  TEST(huge(0_8),0_8,i8)
91  TEST(-huge(0_4)-1,0,i4)
92  TEST(-huge(0_8)-1_8,0_8,i8)
93
94  TEST(1,1,i4)
95  TEST(1_8,1_8,i8)
96  TEST(1,2,i4)
97  TEST(1_8,2_8,i8)
98  TEST(1,-1,i4)
99  TEST(1_8,-1_8,i8)
100  TEST(1,-2,i4)
101  TEST(1_8,-2_8,i8)
102  TEST(1,huge(0),i4)
103  TEST(1_8,huge(0_8),i8)
104  TEST(1,-huge(0)-1,i4)
105  TEST(1_8,-huge(0_8)-1_8,i8)
106
107  TEST(-1,1,i4)
108  TEST(-1_8,1_8,i8)
109  TEST(-1,2,i4)
110  TEST(-1_8,2_8,i8)
111  TEST(-1,-1,i4)
112  TEST(-1_8,-1_8,i8)
113  TEST(-1,-2,i4)
114  TEST(-1_8,-2_8,i8)
115  TEST(-1,huge(0),i4)
116  TEST(-1_8,huge(0_8),i8)
117  TEST(-1,-huge(0)-1,i4)
118  TEST(-1_8,-huge(0_8)-1_8,i8)
119
120  TEST(2,9,i4)
121  TEST(2_8,9_8,i8)
122  TEST(-2,9,i4)
123  TEST(-2_8,9_8,i8)
124  TEST(2,-9,i4)
125  TEST(2_8,-9_8,i8)
126  TEST(-2,-9,i4)
127  TEST(-2_8,-9_8,i8)
128
129!!!!! REAL BASE !!!!!
130  TEST(0.0,0,r4)
131  TEST(0.0,1,r4)
132  TEST(0.0,huge(0),r4)
133  TEST(0.0,0_8,r4)
134  TEST(0.0,1_8,r4)
135  TEST(0.0,huge(0_8),r4)
136
137  TEST(1.0,0,r4)
138  TEST(1.0,1,r4)
139  TEST(1.0,-1,r4)
140  TEST(1.0,huge(0),r4)
141  TEST(1.0,-huge(0)-1,r4)
142  TEST(1.0,0_8,r4)
143  TEST(1.0,1_8,r4)
144  TEST(1.0,-1_8,r4)
145  TEST(1.0,huge(0_8),r4)
146  TEST(1.0,-huge(0_8)-1_8,r4)
147
148  TEST(-1.0,0,r4)
149  TEST(-1.0,1,r4)
150  TEST(-1.0,-1,r4)
151  TEST(-1.0,huge(0),r4)
152  TEST(-1.0,-huge(0)-1,r4)
153  TEST(-1.0,0_8,r4)
154  TEST(-1.0,1_8,r4)
155  TEST(-1.0,-1_8,r4)
156  TEST(-1.0,huge(0_8),r4)
157  TEST(-1.0,-huge(0_8)-1_8,r4)
158
159  TEST(2.0,0,r4)
160  TEST(2.0,1,r4)
161  TEST(2.0,-1,r4)
162  TEST(2.0,3,r4)
163  TEST(2.0,-3,r4)
164  TEST(2.0,0_8,r4)
165  TEST(2.0,1_8,r4)
166  TEST(2.0,-1_8,r4)
167  TEST(2.0,3_8,r4)
168  TEST(2.0,-3_8,r4)
169
170  TEST(nearest(1.0,-1.0),0,r4)
171  TEST(nearest(1.0,-1.0),huge(0_4),r4) ! { dg-warning "Arithmetic underflow" }
172  TEST(nearest(1.0,-1.0),0_8,r4)
173  TEST(nearest(1.0_8,-1.0),huge(0_8),r8) ! { dg-warning "Arithmetic underflow" }
174
175  TEST(nearest(1.0,-1.0),107,r4)
176  TEST(nearest(1.0,1.0),107,r4)
177
178!!!!! COMPLEX BASE !!!!!
179  TEST((1.0,0.2),0,c4)
180  TEST((1.0,0.2),1,c4)
181  TEST((1.0,0.2),2,c4)
182  ATEST((1.0,0.2),9,c4)
183  ATEST((1.0,0.2),-1,c4)
184  ATEST((1.0,0.2),-2,c4)
185  ATEST((1.0,0.2),-9,c4)
186
187  TEST((0.0,0.2),0,c4)
188  TEST((0.0,0.2),1,c4)
189  TEST((0.0,0.2),2,c4)
190  ATEST((0.0,0.2),9,c4)
191  ATEST((0.0,0.2),-1,c4)
192  ATEST((0.0,0.2),-2,c4)
193  ATEST((0.0,0.2),-9,c4)
194
195  TEST((1.0,0.),0,c4)
196  TEST((1.0,0.),1,c4)
197  TEST((1.0,0.),2,c4)
198  TEST((1.0,0.),9,c4)
199  ATEST((1.0,0.),-1,c4)
200  ATEST((1.0,0.),-2,c4)
201  ATEST((1.0,0.),-9,c4)
202
203end program test
204