1 /* Helper functions in C for IEEE modules 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 "libgfortran.h" 27 28 /* Prototypes. */ 29 30 extern int ieee_class_helper_4 (GFC_REAL_4 *); 31 internal_proto(ieee_class_helper_4); 32 33 extern int ieee_class_helper_8 (GFC_REAL_8 *); 34 internal_proto(ieee_class_helper_8); 35 36 #ifdef HAVE_GFC_REAL_10 37 extern int ieee_class_helper_10 (GFC_REAL_10 *); 38 internal_proto(ieee_class_helper_10); 39 #endif 40 41 #ifdef HAVE_GFC_REAL_16 42 extern int ieee_class_helper_16 (GFC_REAL_16 *); 43 internal_proto(ieee_class_helper_16); 44 #endif 45 46 /* Enumeration of the possible floating-point types. These values 47 correspond to the hidden arguments of the IEEE_CLASS_TYPE 48 derived-type of IEEE_ARITHMETIC. */ 49 50 enum { IEEE_OTHER_VALUE = 0, IEEE_SIGNALING_NAN, IEEE_QUIET_NAN, 51 IEEE_NEGATIVE_INF, IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL, 52 IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, IEEE_POSITIVE_DENORMAL, 53 IEEE_POSITIVE_NORMAL, IEEE_POSITIVE_INF, IEEE_SUBNORMAL, 54 IEEE_NEGATIVE_SUBNORMAL, IEEE_POSITIVE_SUBNORMAL }; 55 56 #define CLASSMACRO(TYPE) \ 57 int ieee_class_helper_ ## TYPE (GFC_REAL_ ## TYPE *value) \ 58 { \ 59 int res = __builtin_fpclassify (IEEE_QUIET_NAN, IEEE_POSITIVE_INF, \ 60 IEEE_POSITIVE_NORMAL, \ 61 IEEE_POSITIVE_DENORMAL, \ 62 IEEE_POSITIVE_ZERO, *value); \ 63 \ 64 if (__builtin_signbit (*value)) \ 65 { \ 66 if (res == IEEE_POSITIVE_NORMAL) \ 67 return IEEE_NEGATIVE_NORMAL; \ 68 else if (res == IEEE_POSITIVE_DENORMAL) \ 69 return IEEE_NEGATIVE_DENORMAL; \ 70 else if (res == IEEE_POSITIVE_ZERO) \ 71 return IEEE_NEGATIVE_ZERO; \ 72 else if (res == IEEE_POSITIVE_INF) \ 73 return IEEE_NEGATIVE_INF; \ 74 } \ 75 \ 76 if (res == IEEE_QUIET_NAN) \ 77 { \ 78 /* TODO: Handle signaling NaNs */ \ 79 return res; \ 80 } \ 81 \ 82 return res; \ 83 } 84 85 CLASSMACRO(4) 86 CLASSMACRO(8) 87 88 #ifdef HAVE_GFC_REAL_10 89 CLASSMACRO(10) 90 #endif 91 92 #ifdef HAVE_GFC_REAL_16 93 CLASSMACRO(16) 94 #endif 95 96 97 #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \ 98 GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \ 99 GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT) 100 101 /* Functions to save and restore floating-point state, clear and restore 102 exceptions on procedure entry/exit. The rules we follow are set 103 in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4, 104 14.5 paragraph 2, and 14.6 paragraph 1. */ 105 106 void ieee_procedure_entry (void *); 107 export_proto(ieee_procedure_entry); 108 109 void 110 ieee_procedure_entry (void *state) 111 { 112 /* Save the floating-point state in the space provided by the caller. */ 113 get_fpu_state (state); 114 115 /* Clear the floating-point exceptions. */ 116 set_fpu_except_flags (0, GFC_FPE_ALL); 117 } 118 119 120 void ieee_procedure_exit (void *); 121 export_proto(ieee_procedure_exit); 122 123 void 124 ieee_procedure_exit (void *state) 125 { 126 /* Get the flags currently signaling. */ 127 int flags = get_fpu_except_flags (); 128 129 /* Restore the floating-point state we had on entry. */ 130 set_fpu_state (state); 131 132 /* And re-raised the flags that were raised since entry. */ 133 set_fpu_except_flags (flags, 0); 134 } 135 136