libgfortran/ieee/ieee_helper.c

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