https://gcc.gnu.org/bugzilla/show_bug.cgi?id=95644
--- Comment #9 from kargl at gcc dot gnu.org ---
(In reply to kargl from comment #8)
>
> Short of someone diving in, there is always the kludge of ...
>
This is a better kludge, but is far from the correct approach
as gfortran should use the __builtin_fma() family of functions.
But, this works for at least static linking. I did not update
the symbol map for dynamic linking. I also did not test the
libquadmath portion. ENOTIME.
diff --git a/libgfortran/ieee/ieee_arithmetic.F90
b/libgfortran/ieee/ieee_arithmetic.F90
index 35a16938f8e..3d686863e90 100644
--- a/libgfortran/ieee/ieee_arithmetic.F90
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -39,7 +39,7 @@ module IEEE_ARITHMETIC
IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, IEEE_INEXACT, IEEE_USUAL, &
IEEE_ALL, IEEE_STATUS_TYPE, IEEE_GET_FLAG, IEEE_GET_HALTING_MODE, &
IEEE_GET_STATUS, IEEE_SET_FLAG, IEEE_SET_HALTING_MODE, &
- IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
+ IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING, IEEE_FMA
! Derived types and named constants
@@ -88,6 +88,17 @@ module IEEE_ARITHMETIC
end interface
public :: operator (.ne.)
+ ! IEEE_FMA
+ interface ieee_fma
+ module procedure fma04
+ module procedure fma08
+#ifdef HAVE_GFC_REAL_10
+ module procedure fma10
+#endif
+#ifdef HAVE_GFC_REAL_16
+ module procedure fma16
+#endif
+ end interface ieee_fma
! IEEE_IS_FINITE
@@ -808,6 +819,65 @@ SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
contains
+ impure elemental function fma04(x, y, z)
+ use iso_c_binding, only : knd => c_float
+ real(4) fma04
+ real(4), intent(in) :: x, y, z
+ interface
+ function fmaf(x, y, z) bind(c, name='fmaf')
+ import knd
+ real(knd) fmaf
+ real(knd), intent(in), value :: x, y, z
+ end function fmaf
+ end interface
+ fma04 = fmaf(real(x, knd), real(y, knd), real(z, knd))
+ end function fma04
+
+ impure elemental function fma08(x, y, z)
+ use iso_c_binding, only : knd => c_double
+ real(8) fma08
+ real(8), intent(in) :: x, y, z
+ interface
+ function fma(x, y, z) bind(c, name='fma')
+ import knd
+ real(knd) fma
+ real(knd), intent(in), value :: x, y, z
+ end function fma
+ end interface
+ fma08 = fma(real(x, knd), real(y, knd), real(z, knd))
+ end function fma08
+#ifdef HAVE_GFC_REAL_10
+ impure elemental function fma10(x, y, z)
+ use iso_c_binding, only : knd => c_long_double
+ real(10) fma10
+ real(10), intent(in) :: x, y, z
+ interface
+ function fmal(x, y, z) bind(c, name='fmal')
+ import knd
+ real(knd) fmal
+ real(knd), intent(in), value :: x, y, z
+ end function fmal
+ end interface
+ fma10 = fmal(real(x, knd), real(y, knd), real(z, knd))
+ end function fma10
+#endif
+#ifdef HAVE_GFC_REAL_16
+ impure elemental function fma16(x, y, z)
+ integer, parameter :: knd = 16
+ real(16) fma16
+ real(16), intent(in) :: x, y, z
+ interface
+ function fmaq(x, y, z) bind(c, name='fmaq')
+ import knd
+ real(knd) fmaq
+ real(knd), intent(in) :: x, y, z
+ end function fmaq
+ end interface
+ fma16 = fmaq(real(x, knd), real(y, knd), real(z, knd))
+ end function fma16
+#endif
+
+
! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
implicit none
