summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90
blob: 96977fd11aec5ba1bec0228fec5003dcc40ca27f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
! Program to test intrinsic functions as actual arguments
!
! Please keep the content of this file in sync with gfortran.dg/specifics_1.f90
subroutine test_c(fn, val, res)
  complex fn
  complex val, res

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  complex a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine 

subroutine test_z(fn, val, res)
  double complex fn
  double complex val, res

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  double complex a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine 

subroutine test_cabs(fn, val, res)
  real fn, res
  complex val

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  real a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine 

subroutine test_cdabs(fn, val, res)
  double precision fn, res
  double complex val

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  double precision a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine 

subroutine test_r(fn, val, res)
  real fn
  real val, res

  if (diff(fn(val), res)) call abort
contains
function diff(a, b)
  real a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_d(fn, val, res)
  double precision fn
  double precision val, res

  if (diff(fn(val), res)) call abort
contains
function diff(a, b)
  double precision a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001d0)
end function
end subroutine

subroutine test_r2(fn, val1, val2, res)
  real fn
  real val1, val2, res

  if (diff(fn(val1, val2), res)) call abort
contains
function diff(a, b)
  real a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_d2(fn, val1, val2, res)
  double precision fn
  double precision val1, val2, res

  if (diff(fn(val1, val2), res)) call abort
contains
function diff(a, b)
  double precision a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001d0)
end function
end subroutine

subroutine test_dprod(fn)
  double precision fn
  if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
end subroutine

subroutine test_nint(fn,val,res)
  integer fn, res
  real val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_idnint(fn,val,res)
  integer fn, res
  double precision val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_idim(fn,val1,val2,res)
  integer fn, res, val1, val2
  if (res .ne. fn(val1,val2)) call abort
end subroutine

subroutine test_iabs(fn,val,res)
  integer fn, res, val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_len(fn,val,res)
  integer fn, res
  character(len=*) val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_index(fn,val1,val2,res)
  integer fn, res
  character(len=*) val1, val2
  if (fn(val1,val2) .ne. res) call abort
end subroutine

program specifics
  intrinsic abs
  intrinsic aint
  intrinsic anint
  intrinsic acos
  intrinsic acosh
  intrinsic asin
  intrinsic asinh
  intrinsic atan
  intrinsic atanh
  intrinsic cos
  intrinsic sin
  intrinsic tan
  intrinsic cosh
  intrinsic sinh
  intrinsic tanh
  intrinsic alog
  intrinsic alog10
  intrinsic exp
  intrinsic sign
  intrinsic isign
  intrinsic amod

  intrinsic dabs
  intrinsic dint
  intrinsic dnint
  intrinsic dacos
  intrinsic dacosh
  intrinsic dasin
  intrinsic dasinh
  intrinsic datan
  intrinsic datanh
  intrinsic dcos
  intrinsic dsin
  intrinsic dtan
  intrinsic dcosh
  intrinsic dsinh
  intrinsic dtanh
  intrinsic dlog
  intrinsic dlog10
  intrinsic dexp
  intrinsic dsign
  intrinsic dmod

  intrinsic conjg
  intrinsic ccos
  intrinsic cexp
  intrinsic clog
  intrinsic csin
  intrinsic csqrt

  intrinsic dconjg
  intrinsic cdcos
  intrinsic cdexp
  intrinsic cdlog
  intrinsic cdsin
  intrinsic cdsqrt
  intrinsic zcos
  intrinsic zexp
  intrinsic zlog
  intrinsic zsin
  intrinsic zsqrt

  intrinsic cabs
  intrinsic cdabs
  intrinsic zabs

  intrinsic dprod

  intrinsic nint
  intrinsic idnint
  intrinsic dim
  intrinsic ddim
  intrinsic idim
  intrinsic iabs
  intrinsic mod
  intrinsic len
  intrinsic index

  intrinsic aimag
  intrinsic dimag

  call test_r (abs, -1.0, abs(-1.0))
  call test_r (aint, 1.7, aint(1.7))
  call test_r (anint, 1.7, anint(1.7))
  call test_r (acos, 0.5, acos(0.5))
  call test_r (acosh, 1.5, acosh(1.5))
  call test_r (asin, 0.5, asin(0.5))
  call test_r (asinh, 0.5, asinh(0.5))
  call test_r (atan, 0.5, atan(0.5))
  call test_r (atanh, 0.5, atanh(0.5))
  call test_r (cos, 1.0, cos(1.0))
  call test_r (sin, 1.0, sin(1.0))
  call test_r (tan, 1.0, tan(1.0))
  call test_r (cosh, 1.0, cosh(1.0))
  call test_r (sinh, 1.0, sinh(1.0))
  call test_r (tanh, 1.0, tanh(1.0))
  call test_r (alog, 2.0, alog(2.0))
  call test_r (alog10, 2.0, alog10(2.0))
  call test_r (exp, 1.0, exp(1.0))
  call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
  call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
  
  call test_d (dabs, -1d0, abs(-1d0))
  call test_d (dint, 1.7d0, 1d0)
  call test_d (dnint, 1.7d0, 2d0)
  call test_d (dacos, 0.5d0, dacos(0.5d0))
  call test_d (dacosh, 1.5d0, dacosh(1.5d0))
  call test_d (dasin, 0.5d0, dasin(0.5d0))
  call test_d (dasinh, 0.5d0, dasinh(0.5d0))
  call test_d (datan, 0.5d0, datan(0.5d0))
  call test_d (datanh, 0.5d0, datanh(0.5d0))
  call test_d (dcos, 1d0, dcos(1d0))
  call test_d (dsin, 1d0, dsin(1d0))
  call test_d (dtan, 1d0, dtan(1d0))
  call test_d (dcosh, 1d0, dcosh(1d0))
  call test_d (dsinh, 1d0, dsinh(1d0))
  call test_d (dtanh, 1d0, dtanh(1d0))
  call test_d (dlog, 2d0, dlog(2d0))
  call test_d (dlog10, 2d0, dlog10(2d0))
  call test_d (dexp, 1d0, dexp(1d0))
  call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
  call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))

  call test_dprod (dprod)

  call test_c (conjg, (1.2,-4.), conjg((1.2,-4.)))
  call test_c (ccos, (1.2,-4.), ccos((1.2,-4.)))
  call test_c (cexp, (1.2,-4.), cexp((1.2,-4.)))
  call test_c (clog, (1.2,-4.), clog((1.2,-4.)))
  call test_c (csin, (1.2,-4.), csin((1.2,-4.)))
  call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.)))

  call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0)))
  call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0)))
  call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0)))
  call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
  call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0)))
  call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
  call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0)))
  call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
  call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0)))
  call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0)))
  call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0)))

  call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.)))
  call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0)))
  call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0)))
  call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.)))
  call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0)))

  call test_nint (nint, -1.2, nint(-1.2))
  call test_idnint (idnint, -1.2d0, idnint(-1.2d0))
  call test_idim (isign, -42, 17, isign(-42, 17))
  call test_idim (idim, -42, 17, idim(-42,17))
  call test_idim (idim, 42, 17, idim(42,17))
  call test_r2 (dim, 1.2, -4., dim(1.2, -4.))
  call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0))
  call test_iabs (iabs, -7, iabs(-7))
  call test_idim (mod, 5, 2, mod(5,2))
  call test_len (len, "foobar", len("foobar"))
  call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))

end program