libgfortran/ieee/ieee_helper.c

   1 /* Helper functions in C for IEEE modules
   2    Copyright (C) 2013 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 extern int ieee_is_finite_4_ (GFC_REAL_4 *);
  37 export_proto(ieee_is_finite_4_);
  38
  39 extern int ieee_is_finite_8_ (GFC_REAL_8 *);
  40 export_proto(ieee_is_finite_8_);
  41
  42 extern int ieee_is_nan_4_ (GFC_REAL_4 *);
  43 export_proto(ieee_is_nan_4_);
  44
  45 extern int ieee_is_nan_8_ (GFC_REAL_8 *);
  46 export_proto(ieee_is_nan_8_);
  47
  48 extern int ieee_is_negative_4_ (GFC_REAL_4 *);
  49 export_proto(ieee_is_negative_4_);
  50
  51 extern int ieee_is_negative_8_ (GFC_REAL_8 *);
  52 export_proto(ieee_is_negative_8_);
  53
  54 extern int ieee_is_normal_4_ (GFC_REAL_4 *);
  55 export_proto(ieee_is_normal_4_);
  56
  57 extern int ieee_is_normal_8_ (GFC_REAL_8 *);
  58 export_proto(ieee_is_normal_8_);
  59
  60
  61 /* Enumeration of the possible floating-point types. These values
  62    correspond to the hidden arguments of the IEEE_CLASS_TYPE
  63    derived-type of IEEE_ARITHMETIC.  */
  64
  65 enum { IEEE_OTHER_VALUE = 0, IEEE_SIGNALING_NAN, IEEE_QUIET_NAN,
  66   IEEE_NEGATIVE_INF, IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL,
  67   IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, IEEE_POSITIVE_DENORMAL,
  68   IEEE_POSITIVE_NORMAL, IEEE_POSITIVE_INF };
  69
  70 #define CLASSMACRO(TYPE) \
  71   int ieee_class_helper_ ## TYPE (GFC_REAL_ ## TYPE *value) \
  72   { \
  73     int res = __builtin_fpclassify (IEEE_QUIET_NAN, IEEE_POSITIVE_INF, \
  74                                     IEEE_POSITIVE_NORMAL, \
  75                                     IEEE_POSITIVE_DENORMAL, \
  76                                     IEEE_POSITIVE_ZERO, *value); \
  77  \
  78     if (__builtin_signbit (*value)) \
  79     { \
  80       if (res == IEEE_POSITIVE_NORMAL) \
  81         return IEEE_NEGATIVE_NORMAL; \
  82       else if (res == IEEE_POSITIVE_DENORMAL) \
  83         return IEEE_NEGATIVE_DENORMAL; \
  84       else if (res == IEEE_POSITIVE_ZERO) \
  85         return IEEE_NEGATIVE_ZERO; \
  86       else if (res == IEEE_POSITIVE_INF) \
  87         return IEEE_NEGATIVE_INF; \
  88     } \
  89  \
  90     if (res == IEEE_QUIET_NAN) \
  91     { \
  92       /* TODO: Handle signaling NaNs  */ \
  93       return res; \
  94     } \
  95  \
  96     return res; \
  97   }
  98
  99 CLASSMACRO(4)
 100 CLASSMACRO(8)
 101
 102
 103 /* Testing functions.  */
 104
 105 int ieee_is_finite_4_ (GFC_REAL_4 *val)
 106 {
 107   return __builtin_isfinite(*val) ? 1 : 0;
 108 }
 109
 110 int ieee_is_finite_8_ (GFC_REAL_8 *val)
 111 {
 112   return __builtin_isfinite(*val) ? 1 : 0;
 113 }
 114
 115 int ieee_is_nan_4_ (GFC_REAL_4 *val)
 116 {
 117   return __builtin_isnan(*val) ? 1 : 0;
 118 }
 119
 120 int ieee_is_nan_8_ (GFC_REAL_8 *val)
 121 {
 122   return __builtin_isnan(*val) ? 1 : 0;
 123 }
 124
 125 int ieee_is_negative_4_ (GFC_REAL_4 *val)
 126 {
 127   return (__builtin_signbit(*val) && !__builtin_isnan(*val)) ? 1 : 0;
 128 }
 129
 130 int ieee_is_negative_8_ (GFC_REAL_8 *val)
 131 {
 132   return (__builtin_signbit(*val) && !__builtin_isnan(*val)) ? 1 : 0;
 133 }
 134
 135 int ieee_is_normal_4_ (GFC_REAL_4 *val)
 136 {
 137   return (__builtin_isnormal(*val) || *val == 0) ? 1 : 0;
 138 }
 139
 140 int ieee_is_normal_8_ (GFC_REAL_8 *val)
 141 {
 142   return (__builtin_isnormal(*val) || *val == 0) ? 1 : 0;
 143 }
 144
 145 GFC_REAL_4 ieee_copy_sign_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
 146 export_proto(ieee_copy_sign_4_4_);
 147 GFC_REAL_4 ieee_copy_sign_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
 148 {
 149   GFC_REAL_4 s = __builtin_signbit(*y) ? -1 : 1;
 150   return __builtin_copysign(*x, s);
 151 }
 152
 153 GFC_REAL_4 ieee_copy_sign_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
 154 export_proto(ieee_copy_sign_4_8_);
 155 GFC_REAL_4 ieee_copy_sign_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
 156 {
 157   GFC_REAL_4 s = __builtin_signbit(*y) ? -1 : 1;
 158   return __builtin_copysign(*x, s);
 159 }
 160
 161 GFC_REAL_8 ieee_copy_sign_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
 162 export_proto(ieee_copy_sign_8_4_);
 163 GFC_REAL_8 ieee_copy_sign_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
 164 {
 165   GFC_REAL_8 s = __builtin_signbit(*y) ? -1 : 1;
 166   return __builtin_copysign(*x, s);
 167 }
 168
 169 GFC_REAL_8 ieee_copy_sign_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
 170 export_proto(ieee_copy_sign_8_8_);
 171 GFC_REAL_8 ieee_copy_sign_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
 172 {
 173   GFC_REAL_8 s = __builtin_signbit(*y) ? -1 : 1;
 174   return __builtin_copysign(*x, s);
 175 }
 176
 177 int ieee_unordered_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
 178 export_proto(ieee_unordered_4_4_);
 179 int ieee_unordered_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
 180 {
 181   return __builtin_isunordered(*x, *y);
 182 }
 183
 184 int ieee_unordered_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
 185 export_proto(ieee_unordered_4_8_);
 186 int ieee_unordered_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
 187 {
 188   return __builtin_isunordered(*x, *y);
 189 }
 190
 191 int ieee_unordered_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
 192 export_proto(ieee_unordered_8_4_);
 193 int ieee_unordered_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
 194 {
 195   return __builtin_isunordered(*x, *y);
 196 }
 197
 198 int ieee_unordered_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
 199 export_proto(ieee_unordered_8_8_);
 200 int ieee_unordered_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
 201 {
 202   return __builtin_isunordered(*x, *y);
 203 }
 204
 205
 206 /* Arithmetic functions (LOGB, NEXT_AFTER, REM, RINT, SCALB).  */
 207
 208 GFC_REAL_4 ieee_logb_4_ (GFC_REAL_4 *);
 209 export_proto(ieee_logb_4_);
 210
 211 GFC_REAL_4 ieee_logb_4_ (GFC_REAL_4 *x)
 212 {
 213   GFC_REAL_4 res;
 214   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 215
 216   get_fpu_state (buffer);
 217   res = __builtin_logb (*x);
 218   set_fpu_state (buffer);
 219   return res;
 220 }
 221
 222 GFC_REAL_8 ieee_logb_8_ (GFC_REAL_8 *);
 223 export_proto(ieee_logb_8_);
 224
 225 GFC_REAL_8 ieee_logb_8_ (GFC_REAL_8 *x)
 226 {
 227   GFC_REAL_8 res;
 228   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 229
 230   get_fpu_state (buffer);
 231   res = __builtin_logb (*x);
 232   set_fpu_state (buffer);
 233   return res;
 234 }
 235
 236 GFC_REAL_4 ieee_next_after_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
 237 export_proto(ieee_next_after_4_4_);
 238
 239 GFC_REAL_4 ieee_next_after_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
 240 {
 241   return __builtin_nextafterf (*x, *y);
 242 }
 243
 244 GFC_REAL_4 ieee_next_after_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
 245 export_proto(ieee_next_after_4_8_);
 246
 247 GFC_REAL_4 ieee_next_after_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
 248 {
 249   return __builtin_nextafterf (*x, *y);
 250 }
 251
 252 GFC_REAL_8 ieee_next_after_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
 253 export_proto(ieee_next_after_8_4_);
 254
 255 GFC_REAL_8 ieee_next_after_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
 256 {
 257   return __builtin_nextafter (*x, *y);
 258 }
 259
 260 GFC_REAL_8 ieee_next_after_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
 261 export_proto(ieee_next_after_8_8_);
 262
 263 GFC_REAL_8 ieee_next_after_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
 264 {
 265   return __builtin_nextafter (*x, *y);
 266 }
 267
 268 GFC_REAL_4 ieee_rem_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
 269 export_proto(ieee_rem_4_4_);
 270
 271 GFC_REAL_4 ieee_rem_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
 272 {
 273   GFC_REAL_4 res;
 274   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 275
 276   get_fpu_state (buffer);
 277   res = __builtin_remainderf (*x, *y);
 278   set_fpu_state (buffer);
 279   return res;
 280 }
 281
 282 GFC_REAL_8 ieee_rem_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
 283 export_proto(ieee_rem_4_8_);
 284
 285 GFC_REAL_8 ieee_rem_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
 286 {
 287   GFC_REAL_8 res;
 288   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 289
 290   get_fpu_state (buffer);
 291   res = __builtin_remainder (*x, *y);
 292   set_fpu_state (buffer);
 293   return res;
 294 }
 295
 296 GFC_REAL_8 ieee_rem_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
 297 export_proto(ieee_rem_8_4_);
 298
 299 GFC_REAL_8 ieee_rem_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
 300 {
 301   GFC_REAL_8 res;
 302   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 303
 304   get_fpu_state (buffer);
 305   res = __builtin_remainder (*x, *y);
 306   set_fpu_state (buffer);
 307   return res;
 308 }
 309
 310 GFC_REAL_8 ieee_rem_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
 311 export_proto(ieee_rem_8_8_);
 312
 313 GFC_REAL_8 ieee_rem_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
 314 {
 315   GFC_REAL_8 res;
 316   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 317
 318   get_fpu_state (buffer);
 319   res = __builtin_remainder (*x, *y);
 320   set_fpu_state (buffer);
 321   return res;
 322 }
 323
 324 GFC_REAL_4 ieee_rint_4_ (GFC_REAL_4 *);
 325 export_proto(ieee_rint_4_);
 326
 327 GFC_REAL_4 ieee_rint_4_ (GFC_REAL_4 *x)
 328 {
 329   GFC_REAL_4 res;
 330   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 331
 332   get_fpu_state (buffer);
 333   res = __builtin_rint (*x);
 334   set_fpu_state (buffer);
 335   return res;
 336 }
 337
 338 GFC_REAL_8 ieee_rint_8_ (GFC_REAL_8 *);
 339 export_proto(ieee_rint_8_);
 340
 341 GFC_REAL_8 ieee_rint_8_ (GFC_REAL_8 *x)
 342 {
 343   GFC_REAL_8 res;
 344   char buffer[GFC_FPE_STATE_BUFFER_SIZE];
 345
 346   get_fpu_state (buffer);
 347   res = __builtin_rint (*x);
 348   set_fpu_state (buffer);
 349   return res;
 350 }
 351
 352 GFC_REAL_4 ieee_scalb_4_ (GFC_REAL_4 *, int *);
 353 export_proto(ieee_scalb_4_);
 354
 355 GFC_REAL_4 ieee_scalb_4_ (GFC_REAL_4 *x, int *i)
 356 {
 357   return __builtin_scalbnf (*x, *i);
 358 }
 359
 360 GFC_REAL_8 ieee_scalb_8_ (GFC_REAL_8 *, int *);
 361 export_proto(ieee_scalb_8_);
 362
 363 GFC_REAL_8 ieee_scalb_8_ (GFC_REAL_8 *x, int *i)
 364 {
 365   return __builtin_scalbn (*x, *i);
 366 }
 367
 368
 369 #define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
 370                      GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
 371                      GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
 372
 373 /* Functions to save and restore floating-point state, clear and restore
 374    exceptions on procedure entry/exit.  The rules we follow are set
 375    in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4,
 376    14.5 paragraph 2, and 14.6 paragraph 1.  */
 377
 378 void ieee_procedure_entry (void *);
 379 export_proto(ieee_procedure_entry);
 380
 381 void
 382 ieee_procedure_entry (void *state)
 383 {
 384   /* Save the floating-point state in the space provided by the caller.  */
 385   get_fpu_state (state);
 386
 387   /* Clear the floating-point exceptions.  */
 388   set_fpu_except_flags (0, GFC_FPE_ALL);
 389 }
 390
 391
 392 void ieee_procedure_exit (void *);
 393 export_proto(ieee_procedure_exit);
 394
 395 void
 396 ieee_procedure_exit (void *state)
 397 {
 398   /* Get the flags currently signaling.  */
 399   int flags = get_fpu_except_flags ();
 400
 401   /* Restore the floating-point state we had on entry.  */
 402   set_fpu_state (state);
 403
 404   /* And re-raised the flags that were raised since entry.  */
 405   set_fpu_except_flags (flags, 0);
 406 }
 407