]>
Commit | Line | Data |
---|---|---|
8b198102 | 1 | /* Helper functions in C for IEEE modules |
83ffe9cd | 2 | Copyright (C) 2013-2023 Free Software Foundation, Inc. |
8b198102 FXC |
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 | ||
49295426 | 28 | |
8b198102 FXC |
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 | ||
22a49988 FXC |
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 | ||
8b198102 FXC |
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 | { \ | |
387e6f15 | 70 | if (__builtin_issignaling (*value)) \ |
49295426 FXC |
71 | return IEEE_SIGNALING_NAN; \ |
72 | else \ | |
73 | return IEEE_QUIET_NAN; \ | |
8b198102 FXC |
74 | } \ |
75 | \ | |
76 | return res; \ | |
77 | } | |
78 | ||
79 | CLASSMACRO(4) | |
80 | CLASSMACRO(8) | |
81 | ||
22a49988 FXC |
82 | #ifdef HAVE_GFC_REAL_10 |
83 | CLASSMACRO(10) | |
84 | #endif | |
85 | ||
86 | #ifdef HAVE_GFC_REAL_16 | |
87 | CLASSMACRO(16) | |
88 | #endif | |
89 | ||
8b198102 | 90 | |
90045c5d FXC |
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 | ||
8b198102 FXC |
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 |