module/__fortran_ieee_exceptions.f90

!===-- module/__fortran_ieee_exceptions.f90 --------------------------------===!
!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!===------------------------------------------------------------------------===!

! See Fortran 2018, clause 17
! The content of the standard intrinsic IEEE_EXCEPTIONS module is packaged
! here under another name so that IEEE_ARITHMETIC can USE it and export its
! declarations without clashing with a non-intrinsic module in a program.

include '../include/flang/Runtime/magic-numbers.h'

module __fortran_ieee_exceptions
  implicit none

  ! Set PRIVATE by default to explicitly only export what is meant
  ! to be exported by this MODULE.
  private

  type, public :: ieee_flag_type ! Fortran 2018, 17.2 & 17.3
    private
    integer(kind=1) :: flag = 0
  end type ieee_flag_type

  type(ieee_flag_type), parameter, public :: &
    ieee_invalid = ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INVALID), &
    ieee_overflow = ieee_flag_type(_FORTRAN_RUNTIME_IEEE_OVERFLOW), &
    ieee_divide_by_zero = &
        ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO), &
    ieee_underflow = ieee_flag_type(_FORTRAN_RUNTIME_IEEE_UNDERFLOW), &
    ieee_inexact = ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INEXACT), &
    ieee_denorm = ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DENORM) ! extension

  type(ieee_flag_type), parameter, public :: &
    ieee_usual(*) = [ ieee_overflow, ieee_divide_by_zero, ieee_invalid ], &
    ieee_all(*) = [ ieee_usual, ieee_underflow, ieee_inexact ]

  type, public :: ieee_modes_type ! Fortran 2018, 17.7
    private ! opaque fenv.h femode_t data
    integer(kind=4) :: __data(_FORTRAN_RUNTIME_IEEE_FEMODE_T_EXTENT)
  end type ieee_modes_type

  type, public :: ieee_status_type ! Fortran 2018, 17.7
    private ! opaque fenv.h fenv_t data
    integer(kind=4) :: __data(_FORTRAN_RUNTIME_IEEE_FENV_T_EXTENT)
  end type ieee_status_type

! Define specifics with 1 LOGICAL or REAL argument for generic G.
#define SPECIFICS_L(G) \
  G(1) G(2) G(4) G(8)
#if __x86_64__
#define SPECIFICS_R(G) \
  G(2) G(3) G(4) G(8) G(10) G(16)
#else
#define SPECIFICS_R(G) \
  G(2) G(3) G(4) G(8) G(16)
#endif

#define IEEE_GET_FLAG_L(FVKIND) \
  elemental subroutine ieee_get_flag_l##FVKIND(flag, flag_value); \
    import ieee_flag_type; \
    type(ieee_flag_type), intent(in) :: flag; \
    logical(FVKIND), intent(out) :: flag_value; \
  end subroutine ieee_get_flag_l##FVKIND;
  interface ieee_get_flag
    SPECIFICS_L(IEEE_GET_FLAG_L)
  end interface ieee_get_flag
  public :: ieee_get_flag
#undef IEEE_GET_FLAG_L

#define IEEE_GET_HALTING_MODE_L(HKIND) \
  elemental subroutine ieee_get_halting_mode_l##HKIND(flag, halting); \
    import ieee_flag_type; \
    type(ieee_flag_type), intent(in) :: flag; \
    logical(HKIND), intent(out) :: halting; \
  end subroutine ieee_get_halting_mode_l##HKIND;
  interface ieee_get_halting_mode
    SPECIFICS_L(IEEE_GET_HALTING_MODE_L)
  end interface ieee_get_halting_mode
  public :: ieee_get_halting_mode
#undef IEEE_GET_HALTING_MODE_L

  interface ieee_get_modes
    pure subroutine ieee_get_modes_0(modes)
      import ieee_modes_type
      type(ieee_modes_type), intent(out) :: modes
    end subroutine ieee_get_modes_0
  end interface
  public :: ieee_get_modes

  interface ieee_get_status
    pure subroutine ieee_get_status_0(status)
      import ieee_status_type
      type(ieee_status_type), intent(out) :: status
    end subroutine ieee_get_status_0
  end interface
  public :: ieee_get_status

#define IEEE_SET_FLAG_L(FVKIND) \
  elemental subroutine ieee_set_flag_l##FVKIND(flag, flag_value); \
    import ieee_flag_type; \
    type(ieee_flag_type), intent(in) :: flag; \
    logical(FVKIND), intent(in) :: flag_value; \
  end subroutine ieee_set_flag_l##FVKIND;
  interface ieee_set_flag
    SPECIFICS_L(IEEE_SET_FLAG_L)
  end interface ieee_set_flag
  public :: ieee_set_flag
#undef IEEE_SET_FLAG_L

#define IEEE_SET_HALTING_MODE_L(HKIND) \
  elemental subroutine ieee_set_halting_mode_l##HKIND(flag, halting); \
    import ieee_flag_type; \
    type(ieee_flag_type), intent(in) :: flag; \
    logical(HKIND), intent(in) :: halting; \
  end subroutine ieee_set_halting_mode_l##HKIND;
  interface ieee_set_halting_mode
    SPECIFICS_L(IEEE_SET_HALTING_MODE_L)
  end interface ieee_set_halting_mode
  public :: ieee_set_halting_mode
#undef IEEE_SET_HALTING_MODE_L

  interface ieee_set_modes
    subroutine ieee_set_modes_0(modes)
      import ieee_modes_type
      type(ieee_modes_type), intent(in) :: modes
    end subroutine ieee_set_modes_0
  end interface
  public :: ieee_set_modes

  interface ieee_set_status
    subroutine ieee_set_status_0(status)
      import ieee_status_type
      type(ieee_status_type), intent(in) :: status
    end subroutine ieee_set_status_0
  end interface
  public :: ieee_set_status

#define IEEE_SUPPORT_FLAG_R(XKIND) \
  pure logical function ieee_support_flag_a##XKIND(flag, x); \
    import ieee_flag_type; \
    type(ieee_flag_type), intent(in) :: flag; \
    real(XKIND), intent(in) :: x(..); \
  end function ieee_support_flag_a##XKIND;
  interface ieee_support_flag
    pure logical function ieee_support_flag_0(flag)
      import ieee_flag_type
      type(ieee_flag_type), intent(in) :: flag
    end function ieee_support_flag_0
    SPECIFICS_R(IEEE_SUPPORT_FLAG_R)
  end interface ieee_support_flag
  public :: ieee_support_flag
#undef IEEE_SUPPORT_FLAG_R

  interface ieee_support_halting
    pure logical function ieee_support_halting_0(flag)
      import ieee_flag_type
      type(ieee_flag_type), intent(in) :: flag
    end function ieee_support_halting_0
  end interface
  public :: ieee_support_halting

end module __fortran_ieee_exceptions