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