OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR libfortran/18791 (CABS specifics declared of wrong type) 

PR fortran/18791

        * gfortran.dg/specifics_1.f90: New test.
        * gfortran.fortran-torture/execute/specifics.f90: Add tests for
        complex specifics.

        * m4/specific.m4: Special-case cabs so that its return type is
        real. Special-case conjg so that their suffices are _4, _8, _10 and
        _16 instead of _c4, _c8, _c10 and _c16.
        * intrinsics/f2c_specifics.F90: Special-case conjg functions so
        that their suffices are _4 and _8 instead of _c4 and _c8.
        * generated/_conjg_c4.F90: Regenerate.
        * generated/_conjg_c8.F90: Regenerate.
        * generated/_conjg_c10.F90: Regenerate.
        * generated/_conjg_c16.F90: Regenerate.
        * generated/_abs_c4.F90: Regenerate.
        * generated/_abs_c8.F90: Regenerate.
        * generated/_abs_c10.F90: Regenerate.
        * generated/_abs_c16.F90: Regenerate.

From-SVN: r117317
This commit is contained in:
Francois-Xavier Coudert 2006-09-29 22:41:11 +02:00 committed by François-Xavier Coudert
parent 57270ac1c8
commit 4a44c1a228
12 changed files with 338 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2006-09-29 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/18791
* gfortran.dg/specifics_1.f90: New test.
* gfortran.fortran-torture/execute/specifics.f90: Add tests for
complex specifics.
2006-09-29 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gcc.dg/pthread-init-1.c, pthread-init-2.c,

224
gcc/testsuite/gfortran.dg/specifics_1.f90 Normal file
View File

@ -0,0 +1,224 @@
! Program to test intrinsic functions as actual arguments
! Copied from gfortran.fortran-torture/execute/specifics.f90
! It is run here with -ff2c option
!
! { dg-do run }
! { dg-options "-ff2c" }
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
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 conjg
intrinsic ccos
intrinsic cexp
intrinsic clog
intrinsic csin
intrinsic csqrt
intrinsic dconjg
intrinsic cdcos
intrinsic cdexp
intrinsic cdlog
intrinsic cdsin
intrinsic cdsqrt
intrinsic cabs
intrinsic cdabs
intrinsic dprod
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)
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 (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((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)))
end program

91
gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90
View File

@ -1,4 +1,56 @@
! Program to test intrinsic functions as actual arguments
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
@ -91,9 +143,24 @@ program specifics
intrinsic dsign
intrinsic dmod
intrinsic dprod
intrinsic conjg
intrinsic ccos
intrinsic cexp
intrinsic clog
intrinsic csin
intrinsic csqrt
!TODO: Also test complex variants
intrinsic dconjg
intrinsic cdcos
intrinsic cdexp
intrinsic cdlog
intrinsic cdsin
intrinsic cdsqrt
intrinsic cabs
intrinsic cdabs
intrinsic dprod
call test_r (abs, -1.0, abs(-1.0))
call test_r (aint, 1.7, 1.0)
@ -129,6 +196,24 @@ program specifics
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_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 (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((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)))
end program

2
libgfortran/generated/_abs_c10.F90
View File

@ -42,7 +42,7 @@
elemental function specific__abs_c10 (parm)
complex (kind=10), intent (in) :: parm
complex (kind=10) :: specific__abs_c10
real (kind=10) :: specific__abs_c10
specific__abs_c10 = abs (parm)
end function

2
libgfortran/generated/_abs_c16.F90
View File

@ -42,7 +42,7 @@
elemental function specific__abs_c16 (parm)
complex (kind=16), intent (in) :: parm
complex (kind=16) :: specific__abs_c16
real (kind=16) :: specific__abs_c16
specific__abs_c16 = abs (parm)
end function

2
libgfortran/generated/_abs_c4.F90
View File

@ -42,7 +42,7 @@
elemental function specific__abs_c4 (parm)
complex (kind=4), intent (in) :: parm
complex (kind=4) :: specific__abs_c4
real (kind=4) :: specific__abs_c4
specific__abs_c4 = abs (parm)
end function

2
libgfortran/generated/_abs_c8.F90
View File

@ -42,7 +42,7 @@
elemental function specific__abs_c8 (parm)
complex (kind=8), intent (in) :: parm
complex (kind=8) :: specific__abs_c8
real (kind=8) :: specific__abs_c8
specific__abs_c8 = abs (parm)
end function

6
libgfortran/generated/_conjg_c10.F90
View File

@ -40,11 +40,11 @@
#if defined (HAVE_GFC_COMPLEX_10)
elemental function specific__conjg_c10 (parm)
elemental function specific__conjg_10 (parm)
complex (kind=10), intent (in) :: parm
complex (kind=10) :: specific__conjg_c10
complex (kind=10) :: specific__conjg_10
specific__conjg_c10 = conjg (parm)
specific__conjg_10 = conjg (parm)
end function

6
libgfortran/generated/_conjg_c16.F90
View File

@ -40,11 +40,11 @@
#if defined (HAVE_GFC_COMPLEX_16)
elemental function specific__conjg_c16 (parm)
elemental function specific__conjg_16 (parm)
complex (kind=16), intent (in) :: parm
complex (kind=16) :: specific__conjg_c16
complex (kind=16) :: specific__conjg_16
specific__conjg_c16 = conjg (parm)
specific__conjg_16 = conjg (parm)
end function

6
libgfortran/generated/_conjg_c4.F90
View File

@ -40,11 +40,11 @@
#if defined (HAVE_GFC_COMPLEX_4)
elemental function specific__conjg_c4 (parm)
elemental function specific__conjg_4 (parm)
complex (kind=4), intent (in) :: parm
complex (kind=4) :: specific__conjg_c4
complex (kind=4) :: specific__conjg_4
specific__conjg_c4 = conjg (parm)
specific__conjg_4 = conjg (parm)
end function

6
libgfortran/generated/_conjg_c8.F90
View File

@ -40,11 +40,11 @@
#if defined (HAVE_GFC_COMPLEX_8)
elemental function specific__conjg_c8 (parm)
elemental function specific__conjg_8 (parm)
complex (kind=8), intent (in) :: parm
complex (kind=8) :: specific__conjg_c8
complex (kind=8) :: specific__conjg_8
specific__conjg_c8 = conjg (parm)
specific__conjg_8 = conjg (parm)
end function

5
libgfortran/m4/specific.m4
View File

@ -6,7 +6,8 @@ define(get_typename2, `$1 (kind=$2)')dnl
define(get_typename, `get_typename2(ifelse($1,i,integer,ifelse($1,r,real,ifelse($1,l,logical,ifelse($1,c,complex,unknown)))),`$2')')dnl
define(atype_name, get_typename(atype_letter,atype_kind))dnl
define(name, regexp(regexp(file, `[^/]*$', `\&'), `^_\([^_]*\)_', `\1'))dnl
define(function_name,`specific__'name`_'atype_code)dnl
define(rtype_name,get_typename(ifelse(name,abs,ifelse(atype_letter,c,r,atype_letter),atype_letter),atype_kind))dnl
define(function_name,ifelse(name,conjg,`specific__conjg_'atype_kind,`specific__'name`_'atype_code))dnl
define(type,ifelse(atype_letter,l,LOGICAL,ifelse(atype_letter,i,INTEGER,ifelse(atype_letter,r,REAL,ifelse(atype_letter,c,COMPLEX,UNKNOW)))))dnl
define(Q,ifelse(atype_kind,4,F,ifelse(atype_kind,8,`',ifelse(atype_kind,10,L,ifelse(atype_kind,16,L,`_'atype_kind)))))dnl
@ -33,7 +34,7 @@ ifelse(NEEDED,NONE,`',`#ifdef HAVE_'prefix`'NEEDED`'Q)
elemental function function_name (parm)
atype_name, intent (in) :: parm
atype_name :: function_name
rtype_name :: function_name
function_name = name (parm)
end function