gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90

   1 ! Program to test intrinsic functions as actual arguments
   2 subroutine test_r(fn, val, res)
   3   real fn
   4   real val, res
   5
   6   if (diff(fn(val), res)) call abort
   7 contains
   8 function diff(a, b)
   9   real a, b
  10   logical diff
  11   diff = (abs(a - b) .gt. 0.00001)
  12 end function
  13 end subroutine
  14
  15 subroutine test_d(fn, val, res)
  16   double precision fn
  17   double precision val, res
  18
  19   if (diff(fn(val), res)) call abort
  20 contains
  21 function diff(a, b)
  22   double precision a, b
  23   logical diff
  24   diff = (abs(a - b) .gt. 0.00001d0)
  25 end function
  26 end subroutine
  27
  28 subroutine test_r2(fn, val1, val2, res)
  29   real fn
  30   real val1, val2, res
  31
  32   if (diff(fn(val1, val2), res)) call abort
  33 contains
  34 function diff(a, b)
  35   real a, b
  36   logical diff
  37   diff = (abs(a - b) .gt. 0.00001)
  38 end function
  39 end subroutine
  40
  41 subroutine test_d2(fn, val1, val2, res)
  42   double precision fn
  43   double precision val1, val2, res
  44
  45   if (diff(fn(val1, val2), res)) call abort
  46 contains
  47 function diff(a, b)
  48   double precision a, b
  49   logical diff
  50   diff = (abs(a - b) .gt. 0.00001d0)
  51 end function
  52 end subroutine
  53
  54 subroutine test_dprod(fn)
  55   double precision fn
  56   if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
  57 end subroutine
  58
  59 program specifics
  60   intrinsic abs
  61   intrinsic aint
  62   intrinsic anint
  63   intrinsic acos
  64   intrinsic asin
  65   intrinsic atan
  66   intrinsic cos
  67   intrinsic sin
  68   intrinsic tan
  69   intrinsic cosh
  70   intrinsic sinh
  71   intrinsic tanh
  72   intrinsic alog
  73   intrinsic exp
  74   intrinsic sign
  75   intrinsic amod
  76
  77   intrinsic dabs
  78   intrinsic dint
  79   intrinsic dnint
  80   intrinsic dacos
  81   intrinsic dasin
  82   intrinsic datan
  83   intrinsic dcos
  84   intrinsic dsin
  85   intrinsic dtan
  86   intrinsic dcosh
  87   intrinsic dsinh
  88   intrinsic dtanh
  89   intrinsic dlog
  90   intrinsic dexp
  91   intrinsic dsign
  92   intrinsic dmod
  93
  94   intrinsic dprod
  95
  96   !TODO: Also test complex variants
  97
  98   call test_r (abs, -1.0, abs(-1.0))
  99   call test_r (aint, 1.7, 1.0)
 100   call test_r (anint, 1.7, 2.0)
 101   call test_r (acos, 0.5, acos(0.5))
 102   call test_r (asin, 0.5, asin(0.5))
 103   call test_r (atan, 0.5, atan(0.5))
 104   call test_r (cos, 1.0, cos(1.0))
 105   call test_r (sin, 1.0, sin(1.0))
 106   call test_r (tan, 1.0, tan(1.0))
 107   call test_r (cosh, 1.0, cosh(1.0))
 108   call test_r (sinh, 1.0, sinh(1.0))
 109   call test_r (tanh, 1.0, tanh(1.0))
 110   call test_r (alog, 2.0, alog(2.0))
 111   call test_r (exp, 1.0, exp(1.0))
 112   call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
 113   call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
 114
 115   call test_d (dabs, -1d0, abs(-1d0))
 116   call test_d (dint, 1.7d0, 1d0)
 117   call test_d (dnint, 1.7d0, 2d0)
 118   call test_d (dacos, 0.5d0, dacos(0.5d0))
 119   call test_d (dasin, 0.5d0, dasin(0.5d0))
 120   call test_d (datan, 0.5d0, datan(0.5d0))
 121   call test_d (dcos, 1d0, dcos(1d0))
 122   call test_d (dsin, 1d0, dsin(1d0))
 123   call test_d (dtan, 1d0, dtan(1d0))
 124   call test_d (dcosh, 1d0, dcosh(1d0))
 125   call test_d (dsinh, 1d0, dsinh(1d0))
 126   call test_d (dtanh, 1d0, dtanh(1d0))
 127   call test_d (dlog, 2d0, dlog(2d0))
 128   call test_d (dexp, 1d0, dexp(1d0))
 129   call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
 130   call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))
 131
 132   call test_dprod(dprod)
 133 end program
 134