libgfortran/ieee/ieee_helper.c

   1 /* Helper functions in C for IEEE modules
   2    Copyright (C) 2013-2018 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 };
  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       /* TODO: Handle signaling NaNs  */ \
  78       return res; \
  79     } \
  80  \
  81     return res; \
  82   }
  83
  84 CLASSMACRO(4)
  85 CLASSMACRO(8)
  86
  87 #ifdef HAVE_GFC_REAL_10
  88 CLASSMACRO(10)
  89 #endif
  90
  91 #ifdef HAVE_GFC_REAL_16
  92 CLASSMACRO(16)
  93 #endif
  94
  95
  96 #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
  97                      GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
  98                      GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
  99
 100 /* Functions to save and restore floating-point state, clear and restore
 101    exceptions on procedure entry/exit.  The rules we follow are set
 102    in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4,
 103    14.5 paragraph 2, and 14.6 paragraph 1.  */
 104
 105 void ieee_procedure_entry (void *);
 106 export_proto(ieee_procedure_entry);
 107
 108 void
 109 ieee_procedure_entry (void *state)
 110 {
 111   /* Save the floating-point state in the space provided by the caller.  */
 112   get_fpu_state (state);
 113
 114   /* Clear the floating-point exceptions.  */
 115   set_fpu_except_flags (0, GFC_FPE_ALL);
 116 }
 117
 118
 119 void ieee_procedure_exit (void *);
 120 export_proto(ieee_procedure_exit);
 121
 122 void
 123 ieee_procedure_exit (void *state)
 124 {
 125   /* Get the flags currently signaling.  */
 126   int flags = get_fpu_except_flags ();
 127
 128   /* Restore the floating-point state we had on entry.  */
 129   set_fpu_state (state);
 130
 131   /* And re-raised the flags that were raised since entry.  */
 132   set_fpu_except_flags (flags, 0);
 133 }
 134