gcc/testsuite/gfortran.dg/specifics_1.f90

   1 ! Program to test intrinsic functions as actual arguments
   2 !
   3 ! Copied from gfortran.fortran-torture/execute/specifics.f90
   4 ! Please keep them in sync
   5 !
   6 ! It is run here with -ff2c option
   7 !
   8 ! { dg-do run }
   9 ! { dg-options "-ff2c" }
  10 ! Program to test intrinsic functions as actual arguments
  11 subroutine test_c(fn, val, res)
  12   complex fn
  13   complex val, res
  14
  15   if (diff(fn(val),res)) call abort
  16 contains
  17 function diff(a,b)
  18   complex a,b
  19   logical diff
  20   diff = (abs(a - b) .gt. 0.00001)
  21 end function
  22 end subroutine
  23
  24 subroutine test_z(fn, val, res)
  25   double complex fn
  26   double complex val, res
  27
  28   if (diff(fn(val),res)) call abort
  29 contains
  30 function diff(a,b)
  31   double complex a,b
  32   logical diff
  33   diff = (abs(a - b) .gt. 0.00001)
  34 end function
  35 end subroutine
  36
  37 subroutine test_cabs(fn, val, res)
  38   real fn, res
  39   complex val
  40
  41   if (diff(fn(val),res)) call abort
  42 contains
  43 function diff(a,b)
  44   real a,b
  45   logical diff
  46   diff = (abs(a - b) .gt. 0.00001)
  47 end function
  48 end subroutine
  49
  50 subroutine test_cdabs(fn, val, res)
  51   double precision fn, res
  52   double complex val
  53
  54   if (diff(fn(val),res)) call abort
  55 contains
  56 function diff(a,b)
  57   double precision a,b
  58   logical diff
  59   diff = (abs(a - b) .gt. 0.00001)
  60 end function
  61 end subroutine
  62
  63 subroutine test_r(fn, val, res)
  64   real fn
  65   real val, res
  66
  67   if (diff(fn(val), res)) call abort
  68 contains
  69 function diff(a, b)
  70   real a, b
  71   logical diff
  72   diff = (abs(a - b) .gt. 0.00001)
  73 end function
  74 end subroutine
  75
  76 subroutine test_d(fn, val, res)
  77   double precision fn
  78   double precision val, res
  79
  80   if (diff(fn(val), res)) call abort
  81 contains
  82 function diff(a, b)
  83   double precision a, b
  84   logical diff
  85   diff = (abs(a - b) .gt. 0.00001d0)
  86 end function
  87 end subroutine
  88
  89 subroutine test_r2(fn, val1, val2, res)
  90   real fn
  91   real val1, val2, res
  92
  93   if (diff(fn(val1, val2), res)) call abort
  94 contains
  95 function diff(a, b)
  96   real a, b
  97   logical diff
  98   diff = (abs(a - b) .gt. 0.00001)
  99 end function
 100 end subroutine
 101
 102 subroutine test_d2(fn, val1, val2, res)
 103   double precision fn
 104   double precision val1, val2, res
 105
 106   if (diff(fn(val1, val2), res)) call abort
 107 contains
 108 function diff(a, b)
 109   double precision a, b
 110   logical diff
 111   diff = (abs(a - b) .gt. 0.00001d0)
 112 end function
 113 end subroutine
 114
 115 subroutine test_dprod(fn)
 116   double precision fn
 117   if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
 118 end subroutine
 119
 120 subroutine test_nint(fn,val,res)
 121   integer fn, res
 122   real val
 123   if (res .ne. fn(val)) call abort
 124 end subroutine
 125
 126 subroutine test_idnint(fn,val,res)
 127   integer fn, res
 128   double precision val
 129   if (res .ne. fn(val)) call abort
 130 end subroutine
 131
 132 subroutine test_idim(fn,val1,val2,res)
 133   integer fn, res, val1, val2
 134   if (res .ne. fn(val1,val2)) call abort
 135 end subroutine
 136
 137 subroutine test_iabs(fn,val,res)
 138   integer fn, res, val
 139   if (res .ne. fn(val)) call abort
 140 end subroutine
 141
 142 subroutine test_len(fn,val,res)
 143   integer fn, res
 144   character(len=*) val
 145   if (res .ne. fn(val)) call abort
 146 end subroutine
 147
 148 subroutine test_index(fn,val1,val2,res)
 149   integer fn, res
 150   character(len=*) val1, val2
 151   if (fn(val1,val2) .ne. res) call abort
 152 end subroutine
 153
 154 program specifics
 155   intrinsic abs
 156   intrinsic aint
 157   intrinsic anint
 158   intrinsic acos
 159   intrinsic acosh
 160   intrinsic asin
 161   intrinsic asinh
 162   intrinsic atan
 163   intrinsic atanh
 164   intrinsic cos
 165   intrinsic sin
 166   intrinsic tan
 167   intrinsic cosh
 168   intrinsic sinh
 169   intrinsic tanh
 170   intrinsic alog
 171   intrinsic alog10
 172   intrinsic exp
 173   intrinsic sign
 174   intrinsic isign
 175   intrinsic amod
 176
 177   intrinsic dabs
 178   intrinsic dint
 179   intrinsic dnint
 180   intrinsic dacos
 181   intrinsic dacosh
 182   intrinsic dasin
 183   intrinsic dasinh
 184   intrinsic datan
 185   intrinsic datanh
 186   intrinsic dcos
 187   intrinsic dsin
 188   intrinsic dtan
 189   intrinsic dcosh
 190   intrinsic dsinh
 191   intrinsic dtanh
 192   intrinsic dlog
 193   intrinsic dlog10
 194   intrinsic dexp
 195   intrinsic dsign
 196   intrinsic dmod
 197
 198   intrinsic conjg
 199   intrinsic ccos
 200   intrinsic cexp
 201   intrinsic clog
 202   intrinsic csin
 203   intrinsic csqrt
 204
 205   intrinsic dconjg
 206   intrinsic cdcos
 207   intrinsic cdexp
 208   intrinsic cdlog
 209   intrinsic cdsin
 210   intrinsic cdsqrt
 211   intrinsic zcos
 212   intrinsic zexp
 213   intrinsic zlog
 214   intrinsic zsin
 215   intrinsic zsqrt
 216
 217   intrinsic cabs
 218   intrinsic cdabs
 219   intrinsic zabs
 220
 221   intrinsic dprod
 222
 223   intrinsic nint
 224   intrinsic idnint
 225   intrinsic dim
 226   intrinsic ddim
 227   intrinsic idim
 228   intrinsic iabs
 229   intrinsic mod
 230   intrinsic len
 231   intrinsic index
 232
 233   intrinsic aimag
 234   intrinsic dimag
 235
 236   call test_r (abs, -1.0, abs(-1.0))
 237   call test_r (aint, 1.7, aint(1.7))
 238   call test_r (anint, 1.7, anint(1.7))
 239   call test_r (acos, 0.5, acos(0.5))
 240   call test_r (acosh, 1.5, acosh(1.5))
 241   call test_r (asin, 0.5, asin(0.5))
 242   call test_r (asinh, 0.5, asinh(0.5))
 243   call test_r (atan, 0.5, atan(0.5))
 244   call test_r (atanh, 0.5, atanh(0.5))
 245   call test_r (cos, 1.0, cos(1.0))
 246   call test_r (sin, 1.0, sin(1.0))
 247   call test_r (tan, 1.0, tan(1.0))
 248   call test_r (cosh, 1.0, cosh(1.0))
 249   call test_r (sinh, 1.0, sinh(1.0))
 250   call test_r (tanh, 1.0, tanh(1.0))
 251   call test_r (alog, 2.0, alog(2.0))
 252   call test_r (alog10, 2.0, alog10(2.0))
 253   call test_r (exp, 1.0, exp(1.0))
 254   call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
 255   call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
 256
 257   call test_d (dabs, -1d0, abs(-1d0))
 258   call test_d (dint, 1.7d0, 1d0)
 259   call test_d (dnint, 1.7d0, 2d0)
 260   call test_d (dacos, 0.5d0, dacos(0.5d0))
 261   call test_d (dacosh, 1.5d0, dacosh(1.5d0))
 262   call test_d (dasin, 0.5d0, dasin(0.5d0))
 263   call test_d (dasinh, 0.5d0, dasinh(0.5d0))
 264   call test_d (datan, 0.5d0, datan(0.5d0))
 265   call test_d (datanh, 0.5d0, datanh(0.5d0))
 266   call test_d (dcos, 1d0, dcos(1d0))
 267   call test_d (dsin, 1d0, dsin(1d0))
 268   call test_d (dtan, 1d0, dtan(1d0))
 269   call test_d (dcosh, 1d0, dcosh(1d0))
 270   call test_d (dsinh, 1d0, dsinh(1d0))
 271   call test_d (dtanh, 1d0, dtanh(1d0))
 272   call test_d (dlog, 2d0, dlog(2d0))
 273   call test_d (dlog10, 2d0, dlog10(2d0))
 274   call test_d (dexp, 1d0, dexp(1d0))
 275   call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
 276   call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))
 277
 278   call test_dprod (dprod)
 279
 280   call test_c (conjg, (1.2,-4.), conjg((1.2,-4.)))
 281   call test_c (ccos, (1.2,-4.), ccos((1.2,-4.)))
 282   call test_c (cexp, (1.2,-4.), cexp((1.2,-4.)))
 283   call test_c (clog, (1.2,-4.), clog((1.2,-4.)))
 284   call test_c (csin, (1.2,-4.), csin((1.2,-4.)))
 285   call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.)))
 286
 287   call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0)))
 288   call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0)))
 289   call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0)))
 290   call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
 291   call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0)))
 292   call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
 293   call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0)))
 294   call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
 295   call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0)))
 296   call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0)))
 297   call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0)))
 298
 299   call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.)))
 300   call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0)))
 301   call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0)))
 302   call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.)))
 303   call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0)))
 304
 305   call test_nint (nint, -1.2, nint(-1.2))
 306   call test_idnint (idnint, -1.2d0, idnint(-1.2d0))
 307   call test_idim (isign, -42, 17, isign(-42, 17))
 308   call test_idim (idim, -42, 17, idim(-42,17))
 309   call test_idim (idim, 42, 17, idim(42,17))
 310   call test_r2 (dim, 1.2, -4., dim(1.2, -4.))
 311   call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0))
 312   call test_iabs (iabs, -7, iabs(-7))
 313   call test_idim (mod, 5, 2, mod(5,2))
 314   call test_len (len, "foobar", len("foobar"))
 315   call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))
 316
 317 end program
 318