1 /* Implementation of various C99 functions
2 Copyright (C) 2004 Free Software Foundation, Inc.
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public
8 License as published by the Free Software Foundation; either
9 version 2 of the License, or (at your option) any later version.
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public
26 License along with libgfortran; see the file COPYING. If not,
27 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
31 #include <sys/types.h>
35 #define C99_PROTOS_H WE_DONT_WANT_PROTOS_NOW
36 #include "libgfortran.h"
38 /* IRIX's <math.h> declares a non-C99 compliant implementation of cabs,
39 which takes two floating point arguments instead of a single complex.
40 If <complex.h> is missing this prevents building of c99_functions.c.
41 To work around this we redirect cabs{,f,l} calls to __gfc_cabs{,f,l}. */
43 #if defined(__sgi__) && !defined(HAVE_COMPLEX_H)
47 #define cabs __gfc_cabs
48 #define cabsf __gfc_cabsf
49 #define cabsl __gfc_cabsl
52 /* Tru64's <math.h> declares a non-C99 compliant implementation of cabs,
53 which takes two floating point arguments instead of a single complex.
54 To work around this we redirect cabs{,f,l} calls to __gfc_cabs{,f,l}. */
60 #define cabs __gfc_cabs
61 #define cabsf __gfc_cabsf
62 #define cabsl __gfc_cabsl
65 /* Prototypes to silence -Wstrict-prototypes -Wmissing-prototypes. */
67 float cabsf(float complex);
68 double cabs(double complex);
69 long double cabsl(long double complex);
71 float cargf(float complex);
72 double carg(double complex);
73 long double cargl(long double complex);
75 float complex clog10f(float complex);
76 double complex clog10(double complex);
77 long double complex clog10l(long double complex);
80 /* Wrappers for systems without the various C99 single precision Bessel
83 #if defined(HAVE_J0) && ! defined(HAVE_J0F)
85 extern float j0f (float);
90 return (float) j0 ((double) x
);
94 #if defined(HAVE_J1) && !defined(HAVE_J1F)
96 extern float j1f (float);
100 return (float) j1 ((double) x
);
104 #if defined(HAVE_JN) && !defined(HAVE_JNF)
106 extern float jnf (int, float);
111 return (float) jn (n
, (double) x
);
115 #if defined(HAVE_Y0) && !defined(HAVE_Y0F)
117 extern float y0f (float);
122 return (float) y0 ((double) x
);
126 #if defined(HAVE_Y1) && !defined(HAVE_Y1F)
128 extern float y1f (float);
133 return (float) y1 ((double) x
);
137 #if defined(HAVE_YN) && !defined(HAVE_YNF)
139 extern float ynf (int, float);
144 return (float) yn (n
, (double) x
);
149 /* Wrappers for systems without the C99 erff() and erfcf() functions. */
151 #if defined(HAVE_ERF) && !defined(HAVE_ERFF)
153 extern float erff (float);
158 return (float) erf ((double) x
);
162 #if defined(HAVE_ERFC) && !defined(HAVE_ERFCF)
164 extern float erfcf (float);
169 return (float) erfc ((double) x
);
179 return (float) acos(x
);
183 #if HAVE_ACOSH && !HAVE_ACOSHF
187 return (float) acosh ((double) x
);
196 return (float) asin(x
);
200 #if HAVE_ASINH && !HAVE_ASINHF
204 return (float) asinh ((double) x
);
209 #define HAVE_ATAN2F 1
211 atan2f(float y
, float x
)
213 return (float) atan2(y
, x
);
222 return (float) atan(x
);
226 #if HAVE_ATANH && !HAVE_ATANHF
230 return (float) atanh ((double) x
);
239 return (float) ceil(x
);
243 #ifndef HAVE_COPYSIGNF
244 #define HAVE_COPYSIGNF 1
246 copysignf(float x
, float y
)
248 return (float) copysign(x
, y
);
257 return (float) cos(x
);
266 return (float) cosh(x
);
275 return (float) exp(x
);
284 return (float) fabs(x
);
289 #define HAVE_FLOORF 1
293 return (float) floor(x
);
300 fmodf (float x
, float y
)
302 return (float) fmod (x
, y
);
307 #define HAVE_FREXPF 1
309 frexpf(float x
, int *exp
)
311 return (float) frexp(x
, exp
);
316 #define HAVE_HYPOTF 1
318 hypotf(float x
, float y
)
320 return (float) hypot(x
, y
);
329 return (float) log(x
);
334 #define HAVE_LOG10F 1
338 return (float) log10(x
);
343 #define HAVE_SCALBN 1
345 scalbn(double x
, int y
)
347 return x
* pow(FLT_RADIX
, y
);
352 #define HAVE_SCALBNF 1
354 scalbnf(float x
, int y
)
356 return (float) scalbn(x
, y
);
365 return (float) sin(x
);
374 return (float) sinh(x
);
383 return (float) sqrt(x
);
392 return (float) tan(x
);
401 return (float) tanh(x
);
421 #define HAVE_TRUNCF 1
425 return (float) trunc (x
);
429 #ifndef HAVE_NEXTAFTERF
430 #define HAVE_NEXTAFTERF 1
431 /* This is a portable implementation of nextafterf that is intended to be
432 independent of the floating point format or its in memory representation.
433 This implementation works correctly with denormalized values. */
435 nextafterf(float x
, float y
)
437 /* This variable is marked volatile to avoid excess precision problems
438 on some platforms, including IA-32. */
439 volatile float delta
;
440 float absx
, denorm_min
;
442 if (isnan(x
) || isnan(y
))
447 return x
> 0 ? __FLT_MAX__
: - __FLT_MAX__
;
449 /* absx = fabsf (x); */
450 absx
= (x
< 0.0) ? -x
: x
;
452 /* __FLT_DENORM_MIN__ is non-zero iff the target supports denormals. */
453 if (__FLT_DENORM_MIN__
== 0.0f
)
454 denorm_min
= __FLT_MIN__
;
456 denorm_min
= __FLT_DENORM_MIN__
;
458 if (absx
< __FLT_MIN__
)
465 /* Discard the fraction from x. */
466 frac
= frexpf (absx
, &exp
);
467 delta
= scalbnf (0.5f
, exp
);
469 /* Scale x by the epsilon of the representation. By rights we should
470 have been able to combine this with scalbnf, but some targets don't
471 get that correct with denormals. */
472 delta
*= __FLT_EPSILON__
;
474 /* If we're going to be reducing the absolute value of X, and doing so
475 would reduce the exponent of X, then the delta to be applied is
476 one exponent smaller. */
477 if (frac
== 0.5f
&& (y
< x
) == (x
> 0))
480 /* If that underflows to zero, then we're back to the minimum. */
496 powf(float x
, float y
)
498 return (float) pow(x
, y
);
502 /* Note that if fpclassify is not defined, then NaN is not handled */
504 /* Algorithm by Steven G. Kargl. */
508 /* Round to nearest integral value. If the argument is halfway between two
509 integral values then round away from zero. */
536 #define HAVE_ROUNDF 1
537 /* Round to nearest integral value. If the argument is halfway between two
538 integral values then round away from zero. */
565 #define HAVE_LOG10L 1
566 /* log10 function for long double variables. The version provided here
567 reduces the argument until it fits into a double, then use log10. */
569 log10l(long double x
)
571 #if LDBL_MAX_EXP > DBL_MAX_EXP
576 if (x
> 0x1p
16383L) { p2_result
+= 16383; x
/= 0x1p
16383L; }
577 if (x
> 0x1p
8191L) { p2_result
+= 8191; x
/= 0x1p
8191L; }
578 if (x
> 0x1p
4095L) { p2_result
+= 4095; x
/= 0x1p
4095L; }
579 if (x
> 0x1p
2047L) { p2_result
+= 2047; x
/= 0x1p
2047L; }
580 if (x
> 0x1p
1023L) { p2_result
+= 1023; x
/= 0x1p
1023L; }
581 val
= log10 ((double) x
);
582 return (val
+ p2_result
* .30102999566398119521373889472449302L);
585 #if LDBL_MIN_EXP < DBL_MIN_EXP
590 if (x
< 0x1p
-16380L) { p2_result
+= 16380; x
/= 0x1p
-16380L; }
591 if (x
< 0x1p
-8189L) { p2_result
+= 8189; x
/= 0x1p
-8189L; }
592 if (x
< 0x1p
-4093L) { p2_result
+= 4093; x
/= 0x1p
-4093L; }
593 if (x
< 0x1p
-2045L) { p2_result
+= 2045; x
/= 0x1p
-2045L; }
594 if (x
< 0x1p
-1021L) { p2_result
+= 1021; x
/= 0x1p
-1021L; }
595 val
= fabs(log10 ((double) x
));
596 return (- val
- p2_result
* .30102999566398119521373889472449302L);
605 #define HAVE_FLOORL 1
607 floorl (long double x
)
609 /* Zero, possibly signed. */
613 /* Large magnitude. */
614 if (x
> DBL_MAX
|| x
< (-DBL_MAX
))
617 /* Small positive values. */
618 if (x
>= 0 && x
< DBL_MIN
)
621 /* Small negative values. */
622 if (x
< 0 && x
> (-DBL_MIN
))
633 fmodl (long double x
, long double y
)
638 /* Need to check that the result has the same sign as x and magnitude
639 less than the magnitude of y. */
640 return x
- floorl (x
/ y
) * y
;
645 #if !defined(HAVE_CABSF)
648 cabsf (float complex z
)
650 return hypotf (REALPART (z
), IMAGPART (z
));
654 #if !defined(HAVE_CABS)
657 cabs (double complex z
)
659 return hypot (REALPART (z
), IMAGPART (z
));
663 #if !defined(HAVE_CABSL) && defined(HAVE_HYPOTL)
666 cabsl (long double complex z
)
668 return hypotl (REALPART (z
), IMAGPART (z
));
673 #if !defined(HAVE_CARGF)
676 cargf (float complex z
)
678 return atan2f (IMAGPART (z
), REALPART (z
));
682 #if !defined(HAVE_CARG)
685 carg (double complex z
)
687 return atan2 (IMAGPART (z
), REALPART (z
));
691 #if !defined(HAVE_CARGL) && defined(HAVE_ATAN2L)
694 cargl (long double complex z
)
696 return atan2l (IMAGPART (z
), REALPART (z
));
701 /* exp(z) = exp(a)*(cos(b) + i sin(b)) */
702 #if !defined(HAVE_CEXPF)
705 cexpf (float complex z
)
712 COMPLEX_ASSIGN (v
, cosf (b
), sinf (b
));
717 #if !defined(HAVE_CEXP)
720 cexp (double complex z
)
727 COMPLEX_ASSIGN (v
, cos (b
), sin (b
));
732 #if !defined(HAVE_CEXPL) && defined(HAVE_COSL) && defined(HAVE_SINL) && defined(EXPL)
735 cexpl (long double complex z
)
738 long double complex v
;
742 COMPLEX_ASSIGN (v
, cosl (b
), sinl (b
));
748 /* log(z) = log (cabs(z)) + i*carg(z) */
749 #if !defined(HAVE_CLOGF)
752 clogf (float complex z
)
756 COMPLEX_ASSIGN (v
, logf (cabsf (z
)), cargf (z
));
761 #if !defined(HAVE_CLOG)
764 clog (double complex z
)
768 COMPLEX_ASSIGN (v
, log (cabs (z
)), carg (z
));
773 #if !defined(HAVE_CLOGL) && defined(HAVE_LOGL) && defined(HAVE_CABSL) && defined(HAVE_CARGL)
776 clogl (long double complex z
)
778 long double complex v
;
780 COMPLEX_ASSIGN (v
, logl (cabsl (z
)), cargl (z
));
786 /* log10(z) = log10 (cabs(z)) + i*carg(z) */
787 #if !defined(HAVE_CLOG10F)
788 #define HAVE_CLOG10F 1
790 clog10f (float complex z
)
794 COMPLEX_ASSIGN (v
, log10f (cabsf (z
)), cargf (z
));
799 #if !defined(HAVE_CLOG10)
800 #define HAVE_CLOG10 1
802 clog10 (double complex z
)
806 COMPLEX_ASSIGN (v
, log10 (cabs (z
)), carg (z
));
811 #if !defined(HAVE_CLOG10L) && defined(HAVE_LOG10L) && defined(HAVE_CABSL) && defined(HAVE_CARGL)
812 #define HAVE_CLOG10L 1
814 clog10l (long double complex z
)
816 long double complex v
;
818 COMPLEX_ASSIGN (v
, log10l (cabsl (z
)), cargl (z
));
824 /* pow(base, power) = cexp (power * clog (base)) */
825 #if !defined(HAVE_CPOWF)
828 cpowf (float complex base
, float complex power
)
830 return cexpf (power
* clogf (base
));
834 #if !defined(HAVE_CPOW)
837 cpow (double complex base
, double complex power
)
839 return cexp (power
* clog (base
));
843 #if !defined(HAVE_CPOWL) && defined(HAVE_CEXPL) && defined(HAVE_CLOGL)
846 cpowl (long double complex base
, long double complex power
)
848 return cexpl (power
* clogl (base
));
853 /* sqrt(z). Algorithm pulled from glibc. */
854 #if !defined(HAVE_CSQRTF)
855 #define HAVE_CSQRTF 1
857 csqrtf (float complex z
)
868 COMPLEX_ASSIGN (v
, 0, copysignf (sqrtf (-re
), im
));
872 COMPLEX_ASSIGN (v
, fabsf (sqrtf (re
)), copysignf (0, im
));
879 r
= sqrtf (0.5 * fabsf (im
));
881 COMPLEX_ASSIGN (v
, r
, copysignf (r
, im
));
888 /* Use the identity 2 Re res Im res = Im x
889 to avoid cancellation error in d +/- Re x. */
892 r
= sqrtf (0.5 * d
+ 0.5 * re
);
897 s
= sqrtf (0.5 * d
- 0.5 * re
);
898 r
= fabsf ((0.5 * im
) / s
);
901 COMPLEX_ASSIGN (v
, r
, copysignf (s
, im
));
907 #if !defined(HAVE_CSQRT)
910 csqrt (double complex z
)
921 COMPLEX_ASSIGN (v
, 0, copysign (sqrt (-re
), im
));
925 COMPLEX_ASSIGN (v
, fabs (sqrt (re
)), copysign (0, im
));
932 r
= sqrt (0.5 * fabs (im
));
934 COMPLEX_ASSIGN (v
, r
, copysign (r
, im
));
941 /* Use the identity 2 Re res Im res = Im x
942 to avoid cancellation error in d +/- Re x. */
945 r
= sqrt (0.5 * d
+ 0.5 * re
);
950 s
= sqrt (0.5 * d
- 0.5 * re
);
951 r
= fabs ((0.5 * im
) / s
);
954 COMPLEX_ASSIGN (v
, r
, copysign (s
, im
));
960 #if !defined(HAVE_CSQRTL) && defined(HAVE_COPYSIGNL) && defined(HAVE_SQRTL) && defined(HAVE_FABSL) && defined(HAVE_HYPOTL)
961 #define HAVE_CSQRTL 1
963 csqrtl (long double complex z
)
966 long double complex v
;
974 COMPLEX_ASSIGN (v
, 0, copysignl (sqrtl (-re
), im
));
978 COMPLEX_ASSIGN (v
, fabsl (sqrtl (re
)), copysignl (0, im
));
985 r
= sqrtl (0.5 * fabsl (im
));
987 COMPLEX_ASSIGN (v
, copysignl (r
, im
), r
);
994 /* Use the identity 2 Re res Im res = Im x
995 to avoid cancellation error in d +/- Re x. */
998 r
= sqrtl (0.5 * d
+ 0.5 * re
);
1003 s
= sqrtl (0.5 * d
- 0.5 * re
);
1004 r
= fabsl ((0.5 * im
) / s
);
1007 COMPLEX_ASSIGN (v
, r
, copysignl (s
, im
));
1014 /* sinh(a + i b) = sinh(a) cos(b) + i cosh(a) sin(b) */
1015 #if !defined(HAVE_CSINHF)
1016 #define HAVE_CSINHF 1
1018 csinhf (float complex a
)
1025 COMPLEX_ASSIGN (v
, sinhf (r
) * cosf (i
), coshf (r
) * sinf (i
));
1030 #if !defined(HAVE_CSINH)
1031 #define HAVE_CSINH 1
1033 csinh (double complex a
)
1040 COMPLEX_ASSIGN (v
, sinh (r
) * cos (i
), cosh (r
) * sin (i
));
1045 #if !defined(HAVE_CSINHL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL)
1046 #define HAVE_CSINHL 1
1048 csinhl (long double complex a
)
1051 long double complex v
;
1055 COMPLEX_ASSIGN (v
, sinhl (r
) * cosl (i
), coshl (r
) * sinl (i
));
1061 /* cosh(a + i b) = cosh(a) cos(b) - i sinh(a) sin(b) */
1062 #if !defined(HAVE_CCOSHF)
1063 #define HAVE_CCOSHF 1
1065 ccoshf (float complex a
)
1072 COMPLEX_ASSIGN (v
, coshf (r
) * cosf (i
), - (sinhf (r
) * sinf (i
)));
1077 #if !defined(HAVE_CCOSH)
1078 #define HAVE_CCOSH 1
1080 ccosh (double complex a
)
1087 COMPLEX_ASSIGN (v
, cosh (r
) * cos (i
), - (sinh (r
) * sin (i
)));
1092 #if !defined(HAVE_CCOSHL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL)
1093 #define HAVE_CCOSHL 1
1095 ccoshl (long double complex a
)
1098 long double complex v
;
1102 COMPLEX_ASSIGN (v
, coshl (r
) * cosl (i
), - (sinhl (r
) * sinl (i
)));
1108 /* tanh(a + i b) = (tanh(a) + i tan(b)) / (1 - i tanh(a) tan(b)) */
1109 #if !defined(HAVE_CTANHF)
1110 #define HAVE_CTANHF 1
1112 ctanhf (float complex a
)
1117 rt
= tanhf (REALPART (a
));
1118 it
= tanf (IMAGPART (a
));
1119 COMPLEX_ASSIGN (n
, rt
, it
);
1120 COMPLEX_ASSIGN (d
, 1, - (rt
* it
));
1126 #if !defined(HAVE_CTANH)
1127 #define HAVE_CTANH 1
1129 ctanh (double complex a
)
1132 double complex n
, d
;
1134 rt
= tanh (REALPART (a
));
1135 it
= tan (IMAGPART (a
));
1136 COMPLEX_ASSIGN (n
, rt
, it
);
1137 COMPLEX_ASSIGN (d
, 1, - (rt
* it
));
1143 #if !defined(HAVE_CTANHL) && defined(HAVE_TANL) && defined(HAVE_TANHL)
1144 #define HAVE_CTANHL 1
1146 ctanhl (long double complex a
)
1149 long double complex n
, d
;
1151 rt
= tanhl (REALPART (a
));
1152 it
= tanl (IMAGPART (a
));
1153 COMPLEX_ASSIGN (n
, rt
, it
);
1154 COMPLEX_ASSIGN (d
, 1, - (rt
* it
));
1161 /* sin(a + i b) = sin(a) cosh(b) + i cos(a) sinh(b) */
1162 #if !defined(HAVE_CSINF)
1163 #define HAVE_CSINF 1
1165 csinf (float complex a
)
1172 COMPLEX_ASSIGN (v
, sinf (r
) * coshf (i
), cosf (r
) * sinhf (i
));
1177 #if !defined(HAVE_CSIN)
1180 csin (double complex a
)
1187 COMPLEX_ASSIGN (v
, sin (r
) * cosh (i
), cos (r
) * sinh (i
));
1192 #if !defined(HAVE_CSINL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL)
1193 #define HAVE_CSINL 1
1195 csinl (long double complex a
)
1198 long double complex v
;
1202 COMPLEX_ASSIGN (v
, sinl (r
) * coshl (i
), cosl (r
) * sinhl (i
));
1208 /* cos(a + i b) = cos(a) cosh(b) - i sin(a) sinh(b) */
1209 #if !defined(HAVE_CCOSF)
1210 #define HAVE_CCOSF 1
1212 ccosf (float complex a
)
1219 COMPLEX_ASSIGN (v
, cosf (r
) * coshf (i
), - (sinf (r
) * sinhf (i
)));
1224 #if !defined(HAVE_CCOS)
1227 ccos (double complex a
)
1234 COMPLEX_ASSIGN (v
, cos (r
) * cosh (i
), - (sin (r
) * sinh (i
)));
1239 #if !defined(HAVE_CCOSL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL)
1240 #define HAVE_CCOSL 1
1242 ccosl (long double complex a
)
1245 long double complex v
;
1249 COMPLEX_ASSIGN (v
, cosl (r
) * coshl (i
), - (sinl (r
) * sinhl (i
)));
1255 /* tan(a + i b) = (tan(a) + i tanh(b)) / (1 - i tan(a) tanh(b)) */
1256 #if !defined(HAVE_CTANF)
1257 #define HAVE_CTANF 1
1259 ctanf (float complex a
)
1264 rt
= tanf (REALPART (a
));
1265 it
= tanhf (IMAGPART (a
));
1266 COMPLEX_ASSIGN (n
, rt
, it
);
1267 COMPLEX_ASSIGN (d
, 1, - (rt
* it
));
1273 #if !defined(HAVE_CTAN)
1276 ctan (double complex a
)
1279 double complex n
, d
;
1281 rt
= tan (REALPART (a
));
1282 it
= tanh (IMAGPART (a
));
1283 COMPLEX_ASSIGN (n
, rt
, it
);
1284 COMPLEX_ASSIGN (d
, 1, - (rt
* it
));
1290 #if !defined(HAVE_CTANL) && defined(HAVE_TANL) && defined(HAVE_TANHL)
1291 #define HAVE_CTANL 1
1293 ctanl (long double complex a
)
1296 long double complex n
, d
;
1298 rt
= tanl (REALPART (a
));
1299 it
= tanhl (IMAGPART (a
));
1300 COMPLEX_ASSIGN (n
, rt
, it
);
1301 COMPLEX_ASSIGN (d
, 1, - (rt
* it
));