1!    Implementation of the IEEE_EXCEPTIONS standard intrinsic module
2!    Copyright (C) 2013-2019 Free Software Foundation, Inc.
3!    Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
4!
5! This file is part of the GNU Fortran runtime library (libgfortran).
6!
7! Libgfortran is free software; you can redistribute it and/or
8! modify it under the terms of the GNU General Public
9! License as published by the Free Software Foundation; either
10! version 3 of the License, or (at your option) any later version.
11!
12! Libgfortran is distributed in the hope that it will be useful,
13! but WITHOUT ANY WARRANTY; without even the implied warranty of
14! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15! GNU General Public License for more details.
16!
17! Under Section 7 of GPL version 3, you are granted additional
18! permissions described in the GCC Runtime Library Exception, version
19! 3.1, as published by the Free Software Foundation.
20!
21! You should have received a copy of the GNU General Public License and
22! a copy of the GCC Runtime Library Exception along with this program;
23! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24! <http://www.gnu.org/licenses/>.  */
25
26#include "config.h"
27#include "kinds.inc"
28#include "c99_protos.inc"
29#include "fpu-target.inc"
30
31module IEEE_EXCEPTIONS
32
33  implicit none
34  private
35
36! Derived types and named constants
37
38  type, public :: IEEE_FLAG_TYPE
39    private
40    integer :: hidden
41  end type
42
43  type(IEEE_FLAG_TYPE), parameter, public :: &
44    IEEE_INVALID        = IEEE_FLAG_TYPE(GFC_FPE_INVALID), &
45    IEEE_OVERFLOW       = IEEE_FLAG_TYPE(GFC_FPE_OVERFLOW), &
46    IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(GFC_FPE_ZERO), &
47    IEEE_UNDERFLOW      = IEEE_FLAG_TYPE(GFC_FPE_UNDERFLOW), &
48    IEEE_INEXACT        = IEEE_FLAG_TYPE(GFC_FPE_INEXACT)
49
50  type(IEEE_FLAG_TYPE), parameter, public :: &
51    IEEE_USUAL(3) = [ IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID ], &
52    IEEE_ALL(5)   = [ IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT ]
53
54  type, public :: IEEE_STATUS_TYPE
55    private
56    character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden
57  end type
58
59  interface IEEE_SUPPORT_FLAG
60    module procedure IEEE_SUPPORT_FLAG_4, &
61                     IEEE_SUPPORT_FLAG_8, &
62#ifdef HAVE_GFC_REAL_10
63                     IEEE_SUPPORT_FLAG_10, &
64#endif
65#ifdef HAVE_GFC_REAL_16
66                     IEEE_SUPPORT_FLAG_16, &
67#endif
68                     IEEE_SUPPORT_FLAG_NOARG
69  end interface IEEE_SUPPORT_FLAG
70
71  public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
72  public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
73  public :: IEEE_SET_FLAG, IEEE_GET_FLAG
74  public :: IEEE_SET_STATUS, IEEE_GET_STATUS
75
76contains
77
78! Saving and restoring floating-point status
79
80  subroutine IEEE_GET_STATUS (STATUS_VALUE)
81    implicit none
82    type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
83
84    interface
85      subroutine helper(ptr) &
86          bind(c, name="_gfortrani_get_fpu_state")
87        use, intrinsic :: iso_c_binding, only : c_char
88        character(kind=c_char) :: ptr(*)
89      end subroutine
90    end interface
91
92    call helper(STATUS_VALUE%hidden)
93  end subroutine
94
95  subroutine IEEE_SET_STATUS (STATUS_VALUE)
96    implicit none
97    type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
98
99    interface
100      subroutine helper(ptr) &
101          bind(c, name="_gfortrani_set_fpu_state")
102        use, intrinsic :: iso_c_binding, only : c_char
103        character(kind=c_char) :: ptr(*)
104      end subroutine
105    end interface
106
107    call helper(STATUS_VALUE%hidden)
108  end subroutine
109
110! Getting and setting flags
111
112  elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
113    implicit none
114    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
115    logical, intent(out) :: FLAG_VALUE
116
117    interface
118      pure integer function helper() &
119        bind(c, name="_gfortrani_get_fpu_except_flags")
120      end function
121    end interface
122
123    FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
124  end subroutine
125
126  elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
127    implicit none
128    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
129    logical, intent(in) :: FLAG_VALUE
130
131    interface
132      pure subroutine helper(set, clear) &
133          bind(c, name="_gfortrani_set_fpu_except_flags")
134        integer, intent(in), value :: set, clear
135      end subroutine
136    end interface
137
138    if (FLAG_VALUE) then
139      call helper(FLAG%hidden, 0)
140    else
141      call helper(0, FLAG%hidden)
142    end if
143  end subroutine
144
145! Querying and changing the halting mode
146
147  elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
148    implicit none
149    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
150    logical, intent(out) :: HALTING
151
152    interface
153      pure integer function helper() &
154          bind(c, name="_gfortrani_get_fpu_trap_exceptions")
155      end function
156    end interface
157
158    HALTING = (IAND(helper(), FLAG%hidden) /= 0)
159  end subroutine
160
161  elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
162    implicit none
163    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
164    logical, intent(in) :: HALTING
165
166    interface
167      pure subroutine helper(trap, notrap) &
168          bind(c, name="_gfortrani_set_fpu_trap_exceptions")
169        integer, intent(in), value :: trap, notrap
170      end subroutine
171    end interface
172
173    if (HALTING) then
174      call helper(FLAG%hidden, 0)
175    else
176      call helper(0, FLAG%hidden)
177    end if
178  end subroutine
179
180! Querying support
181
182  pure logical function IEEE_SUPPORT_HALTING (FLAG)
183    implicit none
184    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
185
186    interface
187      pure integer function helper(flag) &
188          bind(c, name="_gfortrani_support_fpu_trap")
189        integer, intent(in), value :: flag
190      end function
191    end interface
192
193    IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
194  end function
195
196  pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
197    implicit none
198    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
199
200    interface
201      pure integer function helper(flag) &
202          bind(c, name="_gfortrani_support_fpu_flag")
203        integer, intent(in), value :: flag
204      end function
205    end interface
206
207    IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
208  end function
209
210  pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
211    implicit none
212    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
213    real(kind=4), intent(in) :: X
214    res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
215  end function
216
217  pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
218    implicit none
219    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
220    real(kind=8), intent(in) :: X
221    res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
222  end function
223
224#ifdef HAVE_GFC_REAL_10
225  pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res)
226    implicit none
227    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
228    real(kind=10), intent(in) :: X
229    res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
230  end function
231#endif
232
233#ifdef HAVE_GFC_REAL_16
234  pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res)
235    implicit none
236    type(IEEE_FLAG_TYPE), intent(in) :: FLAG
237    real(kind=16), intent(in) :: X
238    res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
239  end function
240#endif
241
242end module IEEE_EXCEPTIONS
243