1 /* Helper functions in C for IEEE modules
2 Copyright (C) 2013-2023 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 "libgfortran.h"
27
28
29 /* Prototypes. */
30
31 extern int ieee_class_helper_4 (GFC_REAL_4 *);
32 internal_proto(ieee_class_helper_4);
33
34 extern int ieee_class_helper_8 (GFC_REAL_8 *);
35 internal_proto(ieee_class_helper_8);
36
37 #ifdef HAVE_GFC_REAL_10
38 extern int ieee_class_helper_10 (GFC_REAL_10 *);
39 internal_proto(ieee_class_helper_10);
40 #endif
41
42 #ifdef HAVE_GFC_REAL_16
43 extern int ieee_class_helper_16 (GFC_REAL_16 *);
44 internal_proto(ieee_class_helper_16);
45 #endif
46
47
48 #define CLASSMACRO(TYPE) \
49 int ieee_class_helper_ ## TYPE (GFC_REAL_ ## TYPE *value) \
50 { \
51 int res = __builtin_fpclassify (IEEE_QUIET_NAN, IEEE_POSITIVE_INF, \
52 IEEE_POSITIVE_NORMAL, \
53 IEEE_POSITIVE_DENORMAL, \
54 IEEE_POSITIVE_ZERO, *value); \
55 \
56 if (__builtin_signbit (*value)) \
57 { \
58 if (res == IEEE_POSITIVE_NORMAL) \
59 return IEEE_NEGATIVE_NORMAL; \
60 else if (res == IEEE_POSITIVE_DENORMAL) \
61 return IEEE_NEGATIVE_DENORMAL; \
62 else if (res == IEEE_POSITIVE_ZERO) \
63 return IEEE_NEGATIVE_ZERO; \
64 else if (res == IEEE_POSITIVE_INF) \
65 return IEEE_NEGATIVE_INF; \
66 } \
67 \
68 if (res == IEEE_QUIET_NAN) \
69 { \
70 if (__builtin_issignaling (*value)) \
71 return IEEE_SIGNALING_NAN; \
72 else \
73 return IEEE_QUIET_NAN; \
74 } \
75 \
76 return res; \
77 }
78
79 CLASSMACRO(4)
80 CLASSMACRO(8)
81
82 #ifdef HAVE_GFC_REAL_10
83 CLASSMACRO(10)
84 #endif
85
86 #ifdef HAVE_GFC_REAL_16
87 CLASSMACRO(16)
88 #endif
89
90
91 extern GFC_REAL_4 ieee_value_helper_4 (int);
92 internal_proto(ieee_value_helper_4);
93
94 extern GFC_REAL_8 ieee_value_helper_8 (int);
95 internal_proto(ieee_value_helper_8);
96
97 #ifdef HAVE_GFC_REAL_10
98 extern GFC_REAL_10 ieee_value_helper_10 (int);
99 internal_proto(ieee_value_helper_10);
100 #endif
101
102 #ifdef HAVE_GFC_REAL_16
103 extern GFC_REAL_16 ieee_value_helper_16 (int);
104 internal_proto(ieee_value_helper_16);
105 #endif
106
107
108 #define VALUEMACRO(TYPE, SUFFIX) \
109 GFC_REAL_ ## TYPE ieee_value_helper_ ## TYPE (int type) \
110 { \
111 switch (type) \
112 { \
113 case IEEE_SIGNALING_NAN: \
114 return __builtin_nans ## SUFFIX (""); \
115 \
116 case IEEE_QUIET_NAN: \
117 return __builtin_nan ## SUFFIX (""); \
118 \
119 case IEEE_NEGATIVE_INF: \
120 return - __builtin_inf ## SUFFIX (); \
121 \
122 case IEEE_NEGATIVE_NORMAL: \
123 return -42; \
124 \
125 case IEEE_NEGATIVE_DENORMAL: \
126 return -(GFC_REAL_ ## TYPE ## _TINY) / 2; \
127 \
128 case IEEE_NEGATIVE_ZERO: \
129 return -(GFC_REAL_ ## TYPE) 0; \
130 \
131 case IEEE_POSITIVE_ZERO: \
132 return 0; \
133 \
134 case IEEE_POSITIVE_DENORMAL: \
135 return (GFC_REAL_ ## TYPE ## _TINY) / 2; \
136 \
137 case IEEE_POSITIVE_NORMAL: \
138 return 42; \
139 \
140 case IEEE_POSITIVE_INF: \
141 return __builtin_inf ## SUFFIX (); \
142 \
143 default: \
144 return 0; \
145 } \
146 }
147
148
149 VALUEMACRO(4, f)
150 VALUEMACRO(8, )
151
152 #ifdef HAVE_GFC_REAL_10
153 VALUEMACRO(10, l)
154 #endif
155
156 #ifdef HAVE_GFC_REAL_16
157 # ifdef GFC_REAL_16_IS_FLOAT128
158 VALUEMACRO(16, f128)
159 # else
160 VALUEMACRO(16, l)
161 # endif
162 #endif
163
164
165 #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
166 GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
167 GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
168
169 /* Functions to save and restore floating-point state, clear and restore
170 exceptions on procedure entry/exit. The rules we follow are set
171 in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4,
172 14.5 paragraph 2, and 14.6 paragraph 1. */
173
174 void ieee_procedure_entry (void *);
175 export_proto(ieee_procedure_entry);
176
177 void
178 ieee_procedure_entry (void *state)
179 {
180 /* Save the floating-point state in the space provided by the caller. */
181 get_fpu_state (state);
182
183 /* Clear the floating-point exceptions. */
184 set_fpu_except_flags (0, GFC_FPE_ALL);
185 }
186
187
188 void ieee_procedure_exit (void *);
189 export_proto(ieee_procedure_exit);
190
191 void
192 ieee_procedure_exit (void *state)
193 {
194 /* Get the flags currently signaling. */
195 int flags = get_fpu_except_flags ();
196
197 /* Restore the floating-point state we had on entry. */
198 set_fpu_state (state);
199
200 /* And re-raised the flags that were raised since entry. */
201 set_fpu_except_flags (flags, 0);
202 }
203