libgfortran/ieee/ieee_helper.c

   1 /* Helper functions in C for IEEE modules
   2    Copyright (C) 2013-2015 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 /* Enumeration of the possible floating-point types. These values
  37    correspond to the hidden arguments of the IEEE_CLASS_TYPE
  38    derived-type of IEEE_ARITHMETIC.  */
  39
  40 enum { IEEE_OTHER_VALUE = 0, IEEE_SIGNALING_NAN, IEEE_QUIET_NAN,
  41   IEEE_NEGATIVE_INF, IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL,
  42   IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, IEEE_POSITIVE_DENORMAL,
  43   IEEE_POSITIVE_NORMAL, IEEE_POSITIVE_INF };
  44
  45 #define CLASSMACRO(TYPE) \
  46   int ieee_class_helper_ ## TYPE (GFC_REAL_ ## TYPE *value) \
  47   { \
  48     int res = __builtin_fpclassify (IEEE_QUIET_NAN, IEEE_POSITIVE_INF, \
  49                                     IEEE_POSITIVE_NORMAL, \
  50                                     IEEE_POSITIVE_DENORMAL, \
  51                                     IEEE_POSITIVE_ZERO, *value); \
  52  \
  53     if (__builtin_signbit (*value)) \
  54     { \
  55       if (res == IEEE_POSITIVE_NORMAL) \
  56         return IEEE_NEGATIVE_NORMAL; \
  57       else if (res == IEEE_POSITIVE_DENORMAL) \
  58         return IEEE_NEGATIVE_DENORMAL; \
  59       else if (res == IEEE_POSITIVE_ZERO) \
  60         return IEEE_NEGATIVE_ZERO; \
  61       else if (res == IEEE_POSITIVE_INF) \
  62         return IEEE_NEGATIVE_INF; \
  63     } \
  64  \
  65     if (res == IEEE_QUIET_NAN) \
  66     { \
  67       /* TODO: Handle signaling NaNs  */ \
  68       return res; \
  69     } \
  70  \
  71     return res; \
  72   }
  73
  74 CLASSMACRO(4)
  75 CLASSMACRO(8)
  76
  77
  78 #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
  79                      GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
  80                      GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
  81
  82 /* Functions to save and restore floating-point state, clear and restore
  83    exceptions on procedure entry/exit.  The rules we follow are set
  84    in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4,
  85    14.5 paragraph 2, and 14.6 paragraph 1.  */
  86
  87 void ieee_procedure_entry (void *);
  88 export_proto(ieee_procedure_entry);
  89
  90 void
  91 ieee_procedure_entry (void *state)
  92 {
  93   /* Save the floating-point state in the space provided by the caller.  */
  94   get_fpu_state (state);
  95
  96   /* Clear the floating-point exceptions.  */
  97   set_fpu_except_flags (0, GFC_FPE_ALL);
  98 }
  99
 100
 101 void ieee_procedure_exit (void *);
 102 export_proto(ieee_procedure_exit);
 103
 104 void
 105 ieee_procedure_exit (void *state)
 106 {
 107   /* Get the flags currently signaling.  */
 108   int flags = get_fpu_except_flags ();
 109
 110   /* Restore the floating-point state we had on entry.  */
 111   set_fpu_state (state);
 112
 113   /* And re-raised the flags that were raised since entry.  */
 114   set_fpu_except_flags (flags, 0);
 115 }
 116