summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90')
-rw-r--r--gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90133
1 files changed, 133 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90
new file mode 100644
index 00000000000..d9f3ff0c7b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90
@@ -0,0 +1,133 @@
+! Program to test intrinsic functions as actual arguments
+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)
+ if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
+end subroutine
+
+program specifics
+ intrinsic abs
+ intrinsic aint
+ intrinsic anint
+ intrinsic acos
+ intrinsic asin
+ intrinsic atan
+ intrinsic cos
+ intrinsic sin
+ intrinsic tan
+ intrinsic cosh
+ intrinsic sinh
+ intrinsic tanh
+ intrinsic alog
+ intrinsic exp
+ intrinsic sign
+ intrinsic amod
+
+ intrinsic dabs
+ intrinsic dint
+ intrinsic dnint
+ intrinsic dacos
+ intrinsic dasin
+ intrinsic datan
+ intrinsic dcos
+ intrinsic dsin
+ intrinsic dtan
+ intrinsic dcosh
+ intrinsic dsinh
+ intrinsic dtanh
+ intrinsic dlog
+ intrinsic dexp
+ intrinsic dsign
+ intrinsic dmod
+
+ intrinsic dprod
+
+ !TODO: Also test complex variants
+
+ call test_r (abs, -1.0, abs(-1.0))
+ call test_r (aint, 1.7, 1.0)
+ call test_r (anint, 1.7, 2.0)
+ call test_r (acos, 0.5, acos(0.5))
+ call test_r (asin, 0.5, asin(0.5))
+ call test_r (atan, 0.5, atan(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 (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 (dasin, 0.5d0, dasin(0.5d0))
+ call test_d (datan, 0.5d0, datan(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 (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)
+end program
+