PR fortran/29383

gcc/fortran/
	* gfortran.h (gfc_simplify_ieee_selected_real_kind): New prototype.
	* libgfortran.h (GFC_FPE_*): Use simple integer values, valid in
	both C and Fortran.
	* expr.c (gfc_check_init_expr): Simplify IEEE_SELECTED_REAL_KIND.
	* simplify.c (gfc_simplify_ieee_selected_real_kind): New function.
	* module.c (mio_symbol): Keep track of symbols which came from
	intrinsic modules.
	(gfc_use_module): Keep track of the IEEE modules.
	* trans-decl.c (gfc_get_symbol_decl): Adjust code since
	we have new intrinsic modules.
	(gfc_build_builtin_function_decls): Build decls for
	ieee_procedure_entry and ieee_procedure_exit.
	(is_from_ieee_module, is_ieee_module_used, save_fp_state,
	restore_fp_state): New functions.
	(gfc_generate_function_code): Save and restore floating-point
	state on procedure entry/exit, when IEEE modules are used.
	* intrinsic.texi: Document the IEEE modules.

libgfortran/
	* configure.host: Add checks for IEEE support, rework priorities.
	* configure.ac: Define IEEE_SUPPORT, check for fpsetsticky and
	fpresetsticky.
	* configure: Regenerate.
	* Makefile.am: Build new ieee files, install IEEE_* modules.
	* Makefile.in: Regenerate.
	* gfortran.map (GFORTRAN_1.6): Add new symbols.
	* libgfortran.h (get_fpu_trap_exceptions, set_fpu_trap_exceptions,
	support_fpu_trap, set_fpu_except_flags, support_fpu_flag,
	support_fpu_rounding_mode, get_fpu_state, set_fpu_state): New
	prototypes.
	* config/fpu-*.h (get_fpu_trap_exceptions,
	set_fpu_trap_exceptions, support_fpu_trap, set_fpu_except_flags,
	support_fpu_flag, support_fpu_rounding_mode, get_fpu_state,
	set_fpu_state): New functions.
	* ieee/ieee_features.F90: New file.
	* ieee/ieee_exceptions.F90: New file.
	* ieee/ieee_arithmetic.F90: New file.
	* ieee/ieee_helper.c: New file.

gcc/testsuite/
	* lib/target-supports.exp (check_effective_target_fortran_ieee): 
	New function.
	* gfortran.dg/ieee/ieee.exp: New file.
	* gfortran.dg/ieee/ieee_1.F90: New file.
	* gfortran.dg/ieee/ieee_2.f90: New file.
	* gfortran.dg/ieee/ieee_3.f90: New file.
	* gfortran.dg/ieee/ieee_4.f90: New file.
	* gfortran.dg/ieee/ieee_5.f90: New file.
	* gfortran.dg/ieee/ieee_6.f90: New file.
	* gfortran.dg/ieee/ieee_7.f90: New file.
	* gfortran.dg/ieee/ieee_rounding_1.f90: New file.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@212102 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 1491 insertions, 0 deletions

diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90
new file mode 100644
index 00000000000..1dce4f79ee4
--- /dev/null
+++ b/libgfortran/ieee/ieee_arithmetic.F90
@@ -0,0 +1,817 @@
+!    Implementation of the IEEE_ARITHMETIC standard intrinsic module
+!    Copyright (C) 2013 Free Software Foundation, Inc.
+!    Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+! 
+! This file is part of the GNU Fortran runtime library (libgfortran).
+! 
+! Libgfortran is free software; you can redistribute it and/or
+! modify it under the terms of the GNU General Public
+! License as published by the Free Software Foundation; either
+! version 3 of the License, or (at your option) any later version.
+! 
+! Libgfortran is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! GNU General Public License for more details.
+! 
+! Under Section 7 of GPL version 3, you are granted additional
+! permissions described in the GCC Runtime Library Exception, version
+! 3.1, as published by the Free Software Foundation.
+! 
+! You should have received a copy of the GNU General Public License and
+! a copy of the GCC Runtime Library Exception along with this program;
+! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+! <http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "kinds.inc"
+#include "c99_protos.inc"
+#include "fpu-target.inc"
+
+module IEEE_ARITHMETIC
+
+  use IEEE_EXCEPTIONS
+  implicit none
+  private
+
+  ! Every public symbol from IEEE_EXCEPTIONS must be made public here
+  public :: IEEE_FLAG_TYPE, IEEE_INVALID, IEEE_OVERFLOW, &
+    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
+
+  ! Derived types and named constants
+
+  type, public :: IEEE_CLASS_TYPE
+    private
+    integer :: hidden
+  end type
+
+  type(IEEE_CLASS_TYPE), parameter, public :: &
+    IEEE_OTHER_VALUE       = IEEE_CLASS_TYPE(0), &
+    IEEE_SIGNALING_NAN     = IEEE_CLASS_TYPE(1), &
+    IEEE_QUIET_NAN         = IEEE_CLASS_TYPE(2), &
+    IEEE_NEGATIVE_INF      = IEEE_CLASS_TYPE(3), &
+    IEEE_NEGATIVE_NORMAL   = IEEE_CLASS_TYPE(4), &
+    IEEE_NEGATIVE_DENORMAL = IEEE_CLASS_TYPE(5), &
+    IEEE_NEGATIVE_ZERO     = IEEE_CLASS_TYPE(6), &
+    IEEE_POSITIVE_ZERO     = IEEE_CLASS_TYPE(7), &
+    IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), &
+    IEEE_POSITIVE_NORMAL   = IEEE_CLASS_TYPE(9), &
+    IEEE_POSITIVE_INF      = IEEE_CLASS_TYPE(10)
+
+  type, public :: IEEE_ROUND_TYPE
+    private
+    integer :: hidden
+  end type
+
+  type(IEEE_ROUND_TYPE), parameter, public :: &
+    IEEE_NEAREST           = IEEE_ROUND_TYPE(GFC_FPE_TONEAREST), &
+    IEEE_TO_ZERO           = IEEE_ROUND_TYPE(GFC_FPE_TOWARDZERO), &
+    IEEE_UP                = IEEE_ROUND_TYPE(GFC_FPE_UPWARD), &
+    IEEE_DOWN              = IEEE_ROUND_TYPE(GFC_FPE_DOWNWARD), &
+    IEEE_OTHER             = IEEE_ROUND_TYPE(0)
+
+
+  ! Equality operators on the derived types
+  interface operator (==)
+    module procedure IEEE_CLASS_TYPE_EQ, IEEE_ROUND_TYPE_EQ
+  end interface
+  public :: operator(==)
+
+  interface operator (/=)
+    module procedure IEEE_CLASS_TYPE_NE, IEEE_ROUND_TYPE_NE
+  end interface
+  public :: operator (/=)
+
+
+  ! IEEE_IS_FINITE
+
+  interface
+    elemental logical function _gfortran_ieee_is_finite_4(X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental logical function _gfortran_ieee_is_finite_8(X)
+      real(kind=8), intent(in) :: X
+    end function
+  end interface
+
+  interface IEEE_IS_FINITE
+    procedure _gfortran_ieee_is_finite_4, _gfortran_ieee_is_finite_8
+  end interface
+  public :: IEEE_IS_FINITE
+
+  ! IEEE_IS_NAN
+
+  interface
+    elemental logical function _gfortran_ieee_is_nan_4(X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental logical function _gfortran_ieee_is_nan_8(X)
+      real(kind=8), intent(in) :: X
+    end function
+  end interface
+
+  interface IEEE_IS_NAN
+    procedure _gfortran_ieee_is_nan_4, _gfortran_ieee_is_nan_8
+  end interface
+  public :: IEEE_IS_NAN
+
+  ! IEEE_IS_NEGATIVE
+
+  interface
+    elemental logical function _gfortran_ieee_is_negative_4(X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental logical function _gfortran_ieee_is_negative_8(X)
+      real(kind=8), intent(in) :: X
+    end function
+  end interface
+
+  interface IEEE_IS_NEGATIVE
+    procedure _gfortran_ieee_is_negative_4, _gfortran_ieee_is_negative_8
+  end interface
+  public :: IEEE_IS_NEGATIVE
+
+  ! IEEE_IS_NORMAL
+
+  interface
+    elemental logical function _gfortran_ieee_is_normal_4(X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental logical function _gfortran_ieee_is_normal_8(X)
+      real(kind=8), intent(in) :: X
+    end function
+  end interface
+
+  interface IEEE_IS_NORMAL
+    procedure _gfortran_ieee_is_normal_4, _gfortran_ieee_is_normal_8
+  end interface
+  public :: IEEE_IS_NORMAL
+
+  ! IEEE_COPY_SIGN
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_copy_sign_4_4 (X,Y)
+      real(kind=4), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental real(kind=4) function _gfortran_ieee_copy_sign_4_8 (X,Y)
+      real(kind=4), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_copy_sign_8_4 (X,Y)
+      real(kind=8), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_copy_sign_8_8 (X,Y)
+      real(kind=8), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+  end interface
+
+  interface IEEE_COPY_SIGN
+    procedure _gfortran_ieee_copy_sign_4_4, _gfortran_ieee_copy_sign_4_8, &
+              _gfortran_ieee_copy_sign_8_4, _gfortran_ieee_copy_sign_8_8
+  end interface
+  public :: IEEE_COPY_SIGN
+
+  ! IEEE_UNORDERED
+
+  interface
+    elemental logical function _gfortran_ieee_unordered_4_4 (X,Y)
+      real(kind=4), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental logical function _gfortran_ieee_unordered_4_8 (X,Y)
+      real(kind=4), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+    elemental logical function _gfortran_ieee_unordered_8_4 (X,Y)
+      real(kind=8), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental logical function _gfortran_ieee_unordered_8_8 (X,Y)
+      real(kind=8), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+  end interface
+
+  interface IEEE_UNORDERED
+    procedure _gfortran_ieee_unordered_4_4, _gfortran_ieee_unordered_4_8, &
+              _gfortran_ieee_unordered_8_4, _gfortran_ieee_unordered_8_8
+  end interface
+  public :: IEEE_UNORDERED
+
+  ! IEEE_LOGB
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_logb_4 (X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental real(kind=8) function _gfortran_ieee_logb_8 (X)
+      real(kind=8), intent(in) :: X
+    end function
+  end interface
+
+  interface IEEE_LOGB
+    procedure _gfortran_ieee_logb_4, _gfortran_ieee_logb_8
+  end interface
+  public :: IEEE_LOGB
+
+  ! IEEE_NEXT_AFTER
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_next_after_4_4 (X, Y)
+      real(kind=4), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental real(kind=4) function _gfortran_ieee_next_after_4_8 (X, Y)
+      real(kind=4), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_next_after_8_4 (X, Y)
+      real(kind=8), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_next_after_8_8 (X, Y)
+      real(kind=8), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+  end interface
+
+  interface IEEE_NEXT_AFTER
+    procedure _gfortran_ieee_next_after_4_4, _gfortran_ieee_next_after_4_8, &
+              _gfortran_ieee_next_after_8_4, _gfortran_ieee_next_after_8_8
+  end interface
+  public :: IEEE_NEXT_AFTER
+
+  ! IEEE_REM
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_rem_4_4 (X, Y)
+      real(kind=4), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_rem_4_8 (X, Y)
+      real(kind=4), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_rem_8_4 (X, Y)
+      real(kind=8), intent(in) :: X
+      real(kind=4), intent(in) :: Y
+    end function
+    elemental real(kind=8) function _gfortran_ieee_rem_8_8 (X, Y)
+      real(kind=8), intent(in) :: X
+      real(kind=8), intent(in) :: Y
+    end function
+  end interface
+
+  interface IEEE_REM
+    procedure _gfortran_ieee_rem_4_4, _gfortran_ieee_rem_4_8, &
+              _gfortran_ieee_rem_8_4, _gfortran_ieee_rem_8_8
+  end interface
+  public :: IEEE_REM
+
+  ! IEEE_RINT
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_rint_4 (X)
+      real(kind=4), intent(in) :: X
+    end function
+    elemental real(kind=8) function _gfortran_ieee_rint_8 (X)
+      real(kind=8), intent(in) :: X
+    end function
+  end interface
+
+  interface IEEE_RINT
+    procedure _gfortran_ieee_rint_4, _gfortran_ieee_rint_8
+  end interface
+  public :: IEEE_RINT
+
+  ! IEEE_SCALB
+
+  interface
+    elemental real(kind=4) function _gfortran_ieee_scalb_4 (X, I)
+      real(kind=4), intent(in) :: X
+      integer, intent(in) :: I
+    end function
+    elemental real(kind=8) function _gfortran_ieee_scalb_8 (X, I)
+      real(kind=8), intent(in) :: X
+      integer, intent(in) :: I
+    end function
+  end interface
+
+  interface IEEE_SCALB
+    procedure _gfortran_ieee_scalb_4, _gfortran_ieee_scalb_8
+  end interface
+  public :: IEEE_SCALB
+
+  ! IEEE_VALUE
+
+  interface IEEE_VALUE
+    module procedure IEEE_VALUE_4, IEEE_VALUE_8
+  end interface
+  public :: IEEE_VALUE
+
+  ! IEEE_CLASS
+
+  interface IEEE_CLASS
+    module procedure IEEE_CLASS_4, IEEE_CLASS_8
+  end interface
+  public :: IEEE_CLASS
+
+  ! Public declarations for contained procedures
+  public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
+  public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
+  public :: IEEE_SELECTED_REAL_KIND
+
+  ! IEEE_SUPPORT_ROUNDING
+
+  interface IEEE_SUPPORT_ROUNDING
+    module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, &
+#ifdef HAVE_GFC_REAL_10
+                     IEEE_SUPPORT_ROUNDING_10, &
+#endif
+#ifdef HAVE_GFC_REAL_16
+                     IEEE_SUPPORT_ROUNDING_16, &
+#endif
+                     IEEE_SUPPORT_ROUNDING_NOARG
+  end interface
+  public :: IEEE_SUPPORT_ROUNDING
+  
+  ! Interface to the FPU-specific function
+  interface
+    pure integer function support_rounding_helper(flag) &
+        bind(c, name="_gfortrani_support_fpu_rounding_mode")
+      integer, intent(in), value :: flag
+    end function
+  end interface
+
+! IEEE_SUPPORT_* generic functions
+
+#if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG
+#elif defined(HAVE_GFC_REAL_10)
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG
+#elif defined(HAVE_GFC_REAL_16)
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG
+#else
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG
+#endif
+
+#define SUPPORTGENERIC(NAME) \
+  interface NAME ; module procedure MACRO1(NAME) ; end interface ; \
+  public :: NAME
+
+SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
+SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
+SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
+SUPPORTGENERIC(IEEE_SUPPORT_INF)
+SUPPORTGENERIC(IEEE_SUPPORT_IO)
+SUPPORTGENERIC(IEEE_SUPPORT_NAN)
+SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
+SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
+SUPPORTGENERIC(IEEE_SUPPORT_UNDERFLOW_CONTROL)
+
+contains
+
+  ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
+  elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
+    implicit none
+    type(IEEE_CLASS_TYPE), intent(in) :: X, Y
+    res = (X%hidden == Y%hidden)
+  end function
+
+  elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res)
+    implicit none
+    type(IEEE_CLASS_TYPE), intent(in) :: X, Y
+    res = (X%hidden /= Y%hidden)
+  end function
+
+  elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res)
+    implicit none
+    type(IEEE_ROUND_TYPE), intent(in) :: X, Y
+    res = (X%hidden == Y%hidden)
+  end function
+
+  elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res)
+    implicit none
+    type(IEEE_ROUND_TYPE), intent(in) :: X, Y
+    res = (X%hidden /= Y%hidden)
+  end function
+
+  ! IEEE_SELECTED_REAL_KIND
+  integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
+    implicit none
+    integer, intent(in), optional :: P, R, RADIX
+    integer :: p2, r2
+
+    p2 = 0 ; r2 = 0
+    if (present(p)) p2 = p
+    if (present(r)) r2 = r
+
+    ! The only IEEE types we support right now are binary
+    if (present(radix)) then
+      if (radix /= 2) then
+        res = -5
+        return
+      endif
+    endif
+
+    ! Does IEEE float fit?
+    if (precision(0.) >= p2 .and. range(0.) >= r2) then
+      res = kind(0.)
+      return
+    endif
+
+    ! Does IEEE double fit?
+    if (precision(0.d0) >= p2 .and. range(0.d0) >= r2) then
+      res = kind(0.d0)
+      return
+    endif
+
+    if (precision(0.d0) < p2 .and. range(0.d0) < r2) then
+      res = -3
+      return
+    endif
+
+    if (precision(0.d0) < p2) then
+      res = -1
+      return
+    endif
+
+   res = -2
+  end function
+
+
+  ! IEEE_CLASS
+
+  elemental function IEEE_CLASS_4 (X) result(res)
+    implicit none
+    real(kind=4), intent(in) :: X
+    type(IEEE_CLASS_TYPE) :: res
+
+    interface
+      pure integer function _gfortrani_ieee_class_helper_4(val)
+        real(kind=4), intent(in) :: val
+      end function
+    end interface
+
+    res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X))
+  end function
+
+  elemental function IEEE_CLASS_8 (X) result(res)
+    implicit none
+    real(kind=8), intent(in) :: X
+    type(IEEE_CLASS_TYPE) :: res
+
+    interface
+      pure integer function _gfortrani_ieee_class_helper_8(val)
+        real(kind=8), intent(in) :: val
+      end function
+    end interface
+
+    res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X))
+  end function
+
+  ! IEEE_VALUE
+
+  elemental real(kind=4) function IEEE_VALUE_4(X, C) result(res)
+    implicit none
+    real(kind=4), intent(in) :: X
+    type(IEEE_CLASS_TYPE), intent(in) :: C
+
+    select case (C%hidden)
+      case (1)     ! IEEE_SIGNALING_NAN
+        res = -1
+        res = sqrt(res)
+      case (2)     ! IEEE_QUIET_NAN
+        res = -1
+        res = sqrt(res)
+      case (3)     ! IEEE_NEGATIVE_INF
+        res = huge(res)
+        res = (-res) * res
+      case (4)     ! IEEE_NEGATIVE_NORMAL
+        res = -42
+      case (5)     ! IEEE_NEGATIVE_DENORMAL
+        res = -tiny(res)
+        res = res / 2
+      case (6)     ! IEEE_NEGATIVE_ZERO
+        res = 0
+        res = -res
+      case (7)     ! IEEE_POSITIVE_ZERO
+        res = 0
+      case (8)     ! IEEE_POSITIVE_DENORMAL
+        res = tiny(res)
+        res = res / 2
+      case (9)     ! IEEE_POSITIVE_NORMAL
+        res = 42
+      case (10)    ! IEEE_POSITIVE_INF
+        res = huge(res)
+        res = res * res
+      case default ! IEEE_OTHER_VALUE, should not happen
+        res = 0
+     end select
+  end function
+
+  elemental real(kind=8) function IEEE_VALUE_8(X, C) result(res)
+    implicit none
+    real(kind=8), intent(in) :: X
+    type(IEEE_CLASS_TYPE), intent(in) :: C
+
+    select case (C%hidden)
+      case (1)     ! IEEE_SIGNALING_NAN
+        res = -1
+        res = sqrt(res)
+      case (2)     ! IEEE_QUIET_NAN
+        res = -1
+        res = sqrt(res)
+      case (3)     ! IEEE_NEGATIVE_INF
+        res = huge(res)
+        res = (-res) * res
+      case (4)     ! IEEE_NEGATIVE_NORMAL
+        res = -42
+      case (5)     ! IEEE_NEGATIVE_DENORMAL
+        res = -tiny(res)
+        res = res / 2
+      case (6)     ! IEEE_NEGATIVE_ZERO
+        res = 0
+        res = -res
+      case (7)     ! IEEE_POSITIVE_ZERO
+        res = 0
+      case (8)     ! IEEE_POSITIVE_DENORMAL
+        res = tiny(res)
+        res = res / 2
+      case (9)     ! IEEE_POSITIVE_NORMAL
+        res = 42
+      case (10)    ! IEEE_POSITIVE_INF
+        res = huge(res)
+        res = res * res
+      case default ! IEEE_OTHER_VALUE, should not happen
+        res = 0
+     end select
+  end function
+
+
+  ! IEEE_GET_ROUNDING_MODE
+
+  subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE)
+    implicit none
+    type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
+    integer :: i
+
+    interface
+      integer function helper() &
+        bind(c, name="_gfortrani_get_fpu_rounding_mode")
+      end function
+    end interface
+
+    ! FIXME: Use intermediate variable i to avoid triggering PR59023
+    i = helper()
+    ROUND_VALUE = IEEE_ROUND_TYPE(i)
+  end subroutine
+
+
+  ! IEEE_SET_ROUNDING_MODE
+
+  subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE)
+    implicit none
+    type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+
+    interface
+      subroutine helper(val) &
+          bind(c, name="_gfortrani_set_fpu_rounding_mode")
+        integer, value :: val
+      end subroutine
+    end interface
+    
+    call helper(ROUND_VALUE%hidden)
+  end subroutine
+
+
+  ! IEEE_GET_UNDERFLOW_MODE
+
+  subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
+    implicit none
+    logical, intent(out) :: GRADUAL
+    ! We do not support getting/setting underflow mode yet. We still
+    ! provide the procedures to avoid link-time error if a user program
+    ! uses it protected by a call to IEEE_SUPPORT_UNDERFLOW_CONTROL
+    call abort
+  end subroutine
+
+
+  ! IEEE_SET_UNDERFLOW_MODE
+
+  subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
+    implicit none
+    logical, intent(in) :: GRADUAL
+    ! We do not support getting/setting underflow mode yet. We still
+    ! provide the procedures to avoid link-time error if a user program
+    ! uses it protected by a call to IEEE_SUPPORT_UNDERFLOW_CONTROL
+    call abort
+  end subroutine
+
+! IEEE_SUPPORT_ROUNDING
+
+  pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res)
+    implicit none
+    real(kind=4), intent(in) :: X
+    type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+    res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
+  end function
+
+  pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res)
+    implicit none
+    real(kind=8), intent(in) :: X
+    type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+    res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
+  end function
+
+#ifdef HAVE_GFC_REAL_10
+  pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res)
+    implicit none
+    real(kind=10), intent(in) :: X
+    type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+    res = .false.
+  end function
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+  pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res)
+    implicit none
+    real(kind=16), intent(in) :: X
+    type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+    res = .false.
+  end function
+#endif
+
+  pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res)
+    implicit none
+    type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+    res = .false.
+#else
+    res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
+#endif
+  end function
+
+! IEEE_SUPPORT_* functions
+
+#define SUPPORTMACRO(NAME, INTKIND, VALUE) \
+  pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \
+    implicit none                                            ; \
+    real(INTKIND), intent(in) :: X(..)                       ; \
+    res = VALUE                                              ; \
+  end function
+
+#define SUPPORTMACRO_NOARG(NAME, VALUE) \
+  pure logical function NAME/**/_NOARG () result(res) ; \
+    implicit none                                     ; \
+    res = VALUE                                       ; \
+  end function
+
+! IEEE_SUPPORT_DATATYPE
+
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
+#endif
+
+! IEEE_SUPPORT_DENORMAL
+
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
+#endif
+
+! IEEE_SUPPORT_DIVIDE
+
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
+#endif
+
+! IEEE_SUPPORT_INF
+
+SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_INF,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_INF,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
+#endif
+
+! IEEE_SUPPORT_IO
+
+SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_IO,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_IO,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
+#endif
+
+! IEEE_SUPPORT_NAN
+
+SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
+#endif
+
+! IEEE_SUPPORT_SQRT
+
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
+#endif
+
+! IEEE_SUPPORT_STANDARD
+
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
+#endif
+
+! IEEE_SUPPORT_UNDERFLOW_CONTROL
+
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,4,.false.)
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,8,.false.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,16,.false.)
+#endif
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_UNDERFLOW_CONTROL,.false.)
+
+
+end module IEEE_ARITHMETIC
diff --git a/libgfortran/ieee/ieee_exceptions.F90 b/libgfortran/ieee/ieee_exceptions.F90
new file mode 100644
index 00000000000..e77bcf0f8dd
--- /dev/null
+++ b/libgfortran/ieee/ieee_exceptions.F90
@@ -0,0 +1,218 @@
+!    Implementation of the IEEE_EXCEPTIONS standard intrinsic module
+!    Copyright (C) 2013 Free Software Foundation, Inc.
+!    Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+! 
+! This file is part of the GNU Fortran runtime library (libgfortran).
+! 
+! Libgfortran is free software; you can redistribute it and/or
+! modify it under the terms of the GNU General Public
+! License as published by the Free Software Foundation; either
+! version 3 of the License, or (at your option) any later version.
+! 
+! Libgfortran is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! GNU General Public License for more details.
+! 
+! Under Section 7 of GPL version 3, you are granted additional
+! permissions described in the GCC Runtime Library Exception, version
+! 3.1, as published by the Free Software Foundation.
+! 
+! You should have received a copy of the GNU General Public License and
+! a copy of the GCC Runtime Library Exception along with this program;
+! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+! <http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "kinds.inc"
+#include "c99_protos.inc"
+#include "fpu-target.inc"
+
+module IEEE_EXCEPTIONS
+
+  implicit none
+  private
+
+! Derived types and named constants
+
+  type, public :: IEEE_FLAG_TYPE
+    private
+    integer :: hidden
+  end type
+
+  type(IEEE_FLAG_TYPE), parameter, public :: &
+    IEEE_INVALID        = IEEE_FLAG_TYPE(GFC_FPE_INVALID), &
+    IEEE_OVERFLOW       = IEEE_FLAG_TYPE(GFC_FPE_OVERFLOW), &
+    IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(GFC_FPE_ZERO), &
+    IEEE_UNDERFLOW      = IEEE_FLAG_TYPE(GFC_FPE_UNDERFLOW), &
+    IEEE_INEXACT        = IEEE_FLAG_TYPE(GFC_FPE_INEXACT)
+
+  type(IEEE_FLAG_TYPE), parameter, public :: &
+    IEEE_USUAL(3) = [ IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID ], &
+    IEEE_ALL(5)   = [ IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT ]
+
+  type, public :: IEEE_STATUS_TYPE
+    private
+    character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden
+  end type
+
+  interface IEEE_SUPPORT_FLAG
+    module procedure IEEE_SUPPORT_FLAG_NOARG, &
+                     IEEE_SUPPORT_FLAG_4, &
+                     IEEE_SUPPORT_FLAG_8
+  end interface IEEE_SUPPORT_FLAG
+
+  public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
+  public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
+  public :: IEEE_SET_FLAG, IEEE_GET_FLAG
+  public :: IEEE_SET_STATUS, IEEE_GET_STATUS
+
+contains
+
+! Saving and restoring floating-point status
+
+  subroutine IEEE_GET_STATUS (STATUS_VALUE)
+    implicit none
+    type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
+
+    interface
+      subroutine helper(ptr) &
+          bind(c, name="_gfortrani_get_fpu_state")
+        use, intrinsic :: iso_c_binding, only : c_char
+        character(kind=c_char) :: ptr(*)
+      end subroutine
+    end interface
+
+    call helper(STATUS_VALUE%hidden)
+  end subroutine
+
+  subroutine IEEE_SET_STATUS (STATUS_VALUE)
+    implicit none
+    type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
+
+    interface
+      subroutine helper(ptr) &
+          bind(c, name="_gfortrani_set_fpu_state")
+        use, intrinsic :: iso_c_binding, only : c_char
+        character(kind=c_char) :: ptr(*)
+      end subroutine
+    end interface
+
+    call helper(STATUS_VALUE%hidden)
+  end subroutine
+
+! Getting and setting flags
+
+  elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+    logical, intent(out) :: FLAG_VALUE
+
+    interface
+      pure integer function helper() &
+        bind(c, name="_gfortrani_get_fpu_except_flags")
+      end function
+    end interface
+
+    FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
+  end subroutine
+
+  elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+    logical, intent(in) :: FLAG_VALUE
+
+    interface
+      pure subroutine helper(set, clear) &
+          bind(c, name="_gfortrani_set_fpu_except_flags")
+        integer, intent(in), value :: set, clear
+      end subroutine
+    end interface
+
+    if (FLAG_VALUE) then
+      call helper(FLAG%hidden, 0)
+    else
+      call helper(0, FLAG%hidden)
+    end if
+  end subroutine
+
+! Querying and changing the halting mode
+
+  elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+    logical, intent(out) :: HALTING
+
+    interface
+      pure integer function helper() &
+          bind(c, name="_gfortrani_get_fpu_trap_exceptions")
+      end function
+    end interface
+
+    HALTING = (IAND(helper(), FLAG%hidden) /= 0)
+  end subroutine
+
+  elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+    logical, intent(in) :: HALTING
+
+    interface
+      pure subroutine helper(trap, notrap) &
+          bind(c, name="_gfortrani_set_fpu_trap_exceptions")
+        integer, intent(in), value :: trap, notrap
+      end subroutine
+    end interface
+
+    if (HALTING) then
+      call helper(FLAG%hidden, 0)
+    else
+      call helper(0, FLAG%hidden)
+    end if
+  end subroutine
+
+! Querying support
+
+  pure logical function IEEE_SUPPORT_HALTING (FLAG)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+
+    interface
+      pure integer function helper(flag) &
+          bind(c, name="_gfortrani_support_fpu_trap")
+        integer, intent(in), value :: flag
+      end function
+    end interface
+
+    IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
+  end function
+
+  pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+
+    interface
+      pure integer function helper(flag) &
+          bind(c, name="_gfortrani_support_fpu_flag")
+        integer, intent(in), value :: flag
+      end function
+    end interface
+
+    IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
+  end function
+
+  pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+    real(kind=4), intent(in) :: X
+    res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
+  end function
+
+  pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
+    implicit none
+    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+    real(kind=8), intent(in) :: X
+    res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
+  end function
+
+end module IEEE_EXCEPTIONS
diff --git a/libgfortran/ieee/ieee_features.F90 b/libgfortran/ieee/ieee_features.F90
new file mode 100644
index 00000000000..b3a5c5404f6
--- /dev/null
+++ b/libgfortran/ieee/ieee_features.F90
@@ -0,0 +1,49 @@
+!    Implementation of the IEEE_FEATURES standard intrinsic module
+!    Copyright (C) 2013 Free Software Foundation, Inc.
+!    Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+! 
+! This file is part of the GNU Fortran runtime library (libgfortran).
+! 
+! Libgfortran is free software; you can redistribute it and/or
+! modify it under the terms of the GNU General Public
+! License as published by the Free Software Foundation; either
+! version 3 of the License, or (at your option) any later version.
+! 
+! Libgfortran is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+! GNU General Public License for more details.
+! 
+! Under Section 7 of GPL version 3, you are granted additional
+! permissions described in the GCC Runtime Library Exception, version
+! 3.1, as published by the Free Software Foundation.
+! 
+! You should have received a copy of the GNU General Public License and
+! a copy of the GCC Runtime Library Exception along with this program;
+! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+! <http://www.gnu.org/licenses/>.  */
+
+module IEEE_FEATURES
+
+  implicit none
+  private
+
+  type, public :: IEEE_FEATURES_TYPE
+    private
+    integer :: hidden
+  end type
+
+  type(IEEE_FEATURES_TYPE), parameter, public :: &
+    IEEE_DATATYPE       = IEEE_FEATURES_TYPE(0), &
+    IEEE_DENORMAL       = IEEE_FEATURES_TYPE(1), &
+    IEEE_DIVIDE         = IEEE_FEATURES_TYPE(2), &
+    IEEE_HALTING        = IEEE_FEATURES_TYPE(3), &
+    IEEE_INEXACT_FLAG   = IEEE_FEATURES_TYPE(4), &
+    IEEE_INF            = IEEE_FEATURES_TYPE(5), &
+    IEEE_INVALID_FLAG   = IEEE_FEATURES_TYPE(6), &
+    IEEE_NAN            = IEEE_FEATURES_TYPE(7), &
+    IEEE_ROUNDING       = IEEE_FEATURES_TYPE(8), &
+    IEEE_SQRT           = IEEE_FEATURES_TYPE(9), &
+    IEEE_UNDERFLOW_FLAG = IEEE_FEATURES_TYPE(10)
+
+end module IEEE_FEATURES
diff --git a/libgfortran/ieee/ieee_helper.c b/libgfortran/ieee/ieee_helper.c
new file mode 100644
index 00000000000..f628add6b2e
--- /dev/null
+++ b/libgfortran/ieee/ieee_helper.c
@@ -0,0 +1,407 @@
+/* Helper functions in C for IEEE modules
+   Copyright (C) 2013 Free Software Foundation, Inc.
+   Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+
+/* Prototypes.  */
+
+extern int ieee_class_helper_4 (GFC_REAL_4 *);
+internal_proto(ieee_class_helper_4);
+
+extern int ieee_class_helper_8 (GFC_REAL_8 *);
+internal_proto(ieee_class_helper_8);
+
+extern int ieee_is_finite_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_finite_4_);
+
+extern int ieee_is_finite_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_finite_8_);
+
+extern int ieee_is_nan_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_nan_4_);
+
+extern int ieee_is_nan_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_nan_8_);
+
+extern int ieee_is_negative_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_negative_4_);
+
+extern int ieee_is_negative_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_negative_8_);
+
+extern int ieee_is_normal_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_normal_4_);
+
+extern int ieee_is_normal_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_normal_8_);
+
+
+/* Enumeration of the possible floating-point types. These values
+   correspond to the hidden arguments of the IEEE_CLASS_TYPE
+   derived-type of IEEE_ARITHMETIC.  */
+
+enum { IEEE_OTHER_VALUE = 0, IEEE_SIGNALING_NAN, IEEE_QUIET_NAN,
+  IEEE_NEGATIVE_INF, IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL,
+  IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, IEEE_POSITIVE_DENORMAL,
+  IEEE_POSITIVE_NORMAL, IEEE_POSITIVE_INF };
+
+#define CLASSMACRO(TYPE) \
+  int ieee_class_helper_ ## TYPE (GFC_REAL_ ## TYPE *value) \
+  { \
+    int res = __builtin_fpclassify (IEEE_QUIET_NAN, IEEE_POSITIVE_INF, \
+				    IEEE_POSITIVE_NORMAL, \
+				    IEEE_POSITIVE_DENORMAL, \
+				    IEEE_POSITIVE_ZERO, *value); \
+ \
+    if (__builtin_signbit (*value)) \
+    { \
+      if (res == IEEE_POSITIVE_NORMAL) \
+	return IEEE_NEGATIVE_NORMAL; \
+      else if (res == IEEE_POSITIVE_DENORMAL) \
+	return IEEE_NEGATIVE_DENORMAL; \
+      else if (res == IEEE_POSITIVE_ZERO) \
+	return IEEE_NEGATIVE_ZERO; \
+      else if (res == IEEE_POSITIVE_INF) \
+	return IEEE_NEGATIVE_INF; \
+    } \
+ \
+    if (res == IEEE_QUIET_NAN) \
+    { \
+      /* TODO: Handle signaling NaNs  */ \
+      return res; \
+    } \
+ \
+    return res; \
+  }
+
+CLASSMACRO(4)
+CLASSMACRO(8)
+
+
+/* Testing functions.  */
+
+int ieee_is_finite_4_ (GFC_REAL_4 *val)
+{
+  return __builtin_isfinite(*val) ? 1 : 0;
+}
+
+int ieee_is_finite_8_ (GFC_REAL_8 *val)
+{
+  return __builtin_isfinite(*val) ? 1 : 0;
+}
+
+int ieee_is_nan_4_ (GFC_REAL_4 *val)
+{
+  return __builtin_isnan(*val) ? 1 : 0;
+}
+
+int ieee_is_nan_8_ (GFC_REAL_8 *val)
+{
+  return __builtin_isnan(*val) ? 1 : 0;
+}
+
+int ieee_is_negative_4_ (GFC_REAL_4 *val)
+{
+  return (__builtin_signbit(*val) && !__builtin_isnan(*val)) ? 1 : 0;
+}
+
+int ieee_is_negative_8_ (GFC_REAL_8 *val)
+{
+  return (__builtin_signbit(*val) && !__builtin_isnan(*val)) ? 1 : 0;
+}
+
+int ieee_is_normal_4_ (GFC_REAL_4 *val)
+{
+  return (__builtin_isnormal(*val) || *val == 0) ? 1 : 0;
+}
+
+int ieee_is_normal_8_ (GFC_REAL_8 *val)
+{
+  return (__builtin_isnormal(*val) || *val == 0) ? 1 : 0;
+}
+
+GFC_REAL_4 ieee_copy_sign_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_copy_sign_4_4_);
+GFC_REAL_4 ieee_copy_sign_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+  GFC_REAL_4 s = __builtin_signbit(*y) ? -1 : 1;
+  return __builtin_copysign(*x, s);
+}
+
+GFC_REAL_4 ieee_copy_sign_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_copy_sign_4_8_);
+GFC_REAL_4 ieee_copy_sign_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+  GFC_REAL_4 s = __builtin_signbit(*y) ? -1 : 1;
+  return __builtin_copysign(*x, s);
+}
+
+GFC_REAL_8 ieee_copy_sign_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_copy_sign_8_4_);
+GFC_REAL_8 ieee_copy_sign_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+  GFC_REAL_8 s = __builtin_signbit(*y) ? -1 : 1;
+  return __builtin_copysign(*x, s);
+}
+
+GFC_REAL_8 ieee_copy_sign_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_copy_sign_8_8_);
+GFC_REAL_8 ieee_copy_sign_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+  GFC_REAL_8 s = __builtin_signbit(*y) ? -1 : 1;
+  return __builtin_copysign(*x, s);
+}
+
+int ieee_unordered_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_unordered_4_4_);
+int ieee_unordered_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+  return __builtin_isunordered(*x, *y);
+}
+
+int ieee_unordered_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_unordered_4_8_);
+int ieee_unordered_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+  return __builtin_isunordered(*x, *y);
+}
+
+int ieee_unordered_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_unordered_8_4_);
+int ieee_unordered_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+  return __builtin_isunordered(*x, *y);
+}
+
+int ieee_unordered_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_unordered_8_8_);
+int ieee_unordered_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+  return __builtin_isunordered(*x, *y);
+}
+
+
+/* Arithmetic functions (LOGB, NEXT_AFTER, REM, RINT, SCALB).  */
+
+GFC_REAL_4 ieee_logb_4_ (GFC_REAL_4 *);
+export_proto(ieee_logb_4_);
+
+GFC_REAL_4 ieee_logb_4_ (GFC_REAL_4 *x)
+{
+  GFC_REAL_4 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_logb (*x);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_8 ieee_logb_8_ (GFC_REAL_8 *);
+export_proto(ieee_logb_8_);
+
+GFC_REAL_8 ieee_logb_8_ (GFC_REAL_8 *x)
+{
+  GFC_REAL_8 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_logb (*x);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_4 ieee_next_after_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_next_after_4_4_);
+
+GFC_REAL_4 ieee_next_after_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+  return __builtin_nextafterf (*x, *y);
+}
+
+GFC_REAL_4 ieee_next_after_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_next_after_4_8_);
+
+GFC_REAL_4 ieee_next_after_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+  return __builtin_nextafterf (*x, *y);
+}
+
+GFC_REAL_8 ieee_next_after_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_next_after_8_4_);
+
+GFC_REAL_8 ieee_next_after_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+  return __builtin_nextafter (*x, *y);
+}
+
+GFC_REAL_8 ieee_next_after_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_next_after_8_8_);
+
+GFC_REAL_8 ieee_next_after_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+  return __builtin_nextafter (*x, *y);
+}
+
+GFC_REAL_4 ieee_rem_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_rem_4_4_);
+
+GFC_REAL_4 ieee_rem_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+  GFC_REAL_4 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_remainderf (*x, *y);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_8 ieee_rem_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_rem_4_8_);
+
+GFC_REAL_8 ieee_rem_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+  GFC_REAL_8 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_remainder (*x, *y);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_8 ieee_rem_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_rem_8_4_);
+
+GFC_REAL_8 ieee_rem_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+  GFC_REAL_8 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_remainder (*x, *y);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_8 ieee_rem_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_rem_8_8_);
+
+GFC_REAL_8 ieee_rem_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+  GFC_REAL_8 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_remainder (*x, *y);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_4 ieee_rint_4_ (GFC_REAL_4 *);
+export_proto(ieee_rint_4_);
+
+GFC_REAL_4 ieee_rint_4_ (GFC_REAL_4 *x)
+{
+  GFC_REAL_4 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_rint (*x);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_8 ieee_rint_8_ (GFC_REAL_8 *);
+export_proto(ieee_rint_8_);
+
+GFC_REAL_8 ieee_rint_8_ (GFC_REAL_8 *x)
+{
+  GFC_REAL_8 res;
+  char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+  get_fpu_state (buffer);
+  res = __builtin_rint (*x);
+  set_fpu_state (buffer);
+  return res;
+}
+
+GFC_REAL_4 ieee_scalb_4_ (GFC_REAL_4 *, int *);
+export_proto(ieee_scalb_4_);
+
+GFC_REAL_4 ieee_scalb_4_ (GFC_REAL_4 *x, int *i)
+{
+  return __builtin_scalbnf (*x, *i);
+}
+
+GFC_REAL_8 ieee_scalb_8_ (GFC_REAL_8 *, int *);
+export_proto(ieee_scalb_8_);
+
+GFC_REAL_8 ieee_scalb_8_ (GFC_REAL_8 *x, int *i)
+{
+  return __builtin_scalbn (*x, *i);
+}
+
+
+#define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
+		     GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
+		     GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
+
+/* Functions to save and restore floating-point state, clear and restore
+   exceptions on procedure entry/exit.  The rules we follow are set
+   in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4,
+   14.5 paragraph 2, and 14.6 paragraph 1.  */
+
+void ieee_procedure_entry (void *);
+export_proto(ieee_procedure_entry);
+
+void
+ieee_procedure_entry (void *state)
+{
+  /* Save the floating-point state in the space provided by the caller.  */
+  get_fpu_state (state);
+
+  /* Clear the floating-point exceptions.  */
+  set_fpu_except_flags (0, GFC_FPE_ALL);
+}
+
+
+void ieee_procedure_exit (void *);
+export_proto(ieee_procedure_exit);
+
+void
+ieee_procedure_exit (void *state)
+{
+  /* Get the flags currently signaling.  */
+  int flags = get_fpu_except_flags ();
+
+  /* Restore the floating-point state we had on entry.  */
+  set_fpu_state (state);
+
+  /* And re-raised the flags that were raised since entry.  */
+  set_fpu_except_flags (flags, 0);
+}
+