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 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 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