libgfortran/ieee/ieee_helper.c

   1 /* Helper functions in C for IEEE modules
   2    Copyright (C) 2013-2023 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 /* 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
  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
  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     { \
  70       if (__builtin_issignaling (*value)) \
  71         return IEEE_SIGNALING_NAN; \
  72       else \
  73         return IEEE_QUIET_NAN; \
  74     } \
  75  \
  76     return res; \
  77   }
  78
  79 CLASSMACRO(4)
  80 CLASSMACRO(8)
  81
  82 #ifdef HAVE_GFC_REAL_10
  83 CLASSMACRO(10)
  84 #endif
  85
  86 #ifdef HAVE_GFC_REAL_16
  87 CLASSMACRO(16)
  88 #endif
  89
  90
  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
 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