1/* Helper functions in C for IEEE modules 2 Copyright (C) 2013-2020 Free Software Foundation, Inc. 3 Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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 30extern int ieee_class_helper_4 (GFC_REAL_4 *); 31internal_proto(ieee_class_helper_4); 32 33extern int ieee_class_helper_8 (GFC_REAL_8 *); 34internal_proto(ieee_class_helper_8); 35 36#ifdef HAVE_GFC_REAL_10 37extern int ieee_class_helper_10 (GFC_REAL_10 *); 38internal_proto(ieee_class_helper_10); 39#endif 40 41#ifdef HAVE_GFC_REAL_16 42extern int ieee_class_helper_16 (GFC_REAL_16 *); 43internal_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 50enum { 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 85CLASSMACRO(4) 86CLASSMACRO(8) 87 88#ifdef HAVE_GFC_REAL_10 89CLASSMACRO(10) 90#endif 91 92#ifdef HAVE_GFC_REAL_16 93CLASSMACRO(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 106void ieee_procedure_entry (void *); 107export_proto(ieee_procedure_entry); 108 109void 110ieee_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 120void ieee_procedure_exit (void *); 121export_proto(ieee_procedure_exit); 122 123void 124ieee_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