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

gcc/testsuite/ChangeLog

@@ -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,

gcc/testsuite/gfortran.dg/specifics_1.f90

@@ -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
+

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

@@ -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
 

libgfortran/generated/_abs_c10.F90

@@ -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

libgfortran/generated/_abs_c16.F90

@@ -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

libgfortran/generated/_abs_c4.F90

@@ -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

libgfortran/generated/_abs_c8.F90

@@ -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

libgfortran/generated/_conjg_c10.F90

@@ -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
 
 

libgfortran/generated/_conjg_c16.F90

@@ -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
 
 

libgfortran/generated/_conjg_c4.F90

@@ -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
 
 

libgfortran/generated/_conjg_c8.F90

@@ -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
 
 

libgfortran/m4/specific.m4

@@ -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