+2014-06-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/29383
+ * gfortran.h (gfc_simplify_ieee_selected_real_kind): New prototype.
+ * libgfortran.h (GFC_FPE_*): Use simple integer values, valid in
+ both C and Fortran.
+ * expr.c (gfc_check_init_expr): Simplify IEEE_SELECTED_REAL_KIND.
+ * simplify.c (gfc_simplify_ieee_selected_real_kind): New function.
+ * module.c (mio_symbol): Keep track of symbols which came from
+ intrinsic modules.
+ (gfc_use_module): Keep track of the IEEE modules.
+ * trans-decl.c (gfc_get_symbol_decl): Adjust code since
+ we have new intrinsic modules.
+ (gfc_build_builtin_function_decls): Build decls for
+ ieee_procedure_entry and ieee_procedure_exit.
+ (is_from_ieee_module, is_ieee_module_used, save_fp_state,
+ restore_fp_state): New functions.
+ (gfc_generate_function_code): Save and restore floating-point
+ state on procedure entry/exit, when IEEE modules are used.
+ * intrinsic.texi: Document the IEEE modules.
+
2014-06-25 Tobias Burnus <burnus@net-b.de>
* interface.c (check_intents): Fix diagnostic with
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
+
+ /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic
+ module IEEE_ARITHMETIC, which is allowed in initialization
+ expressions. */
+ if (!strcmp(sym->name, "ieee_selected_real_kind")
+ && sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
+ {
+ gfc_expr *new_expr = gfc_simplify_ieee_selected_real_kind (e);
+ if (new_expr)
+ {
+ gfc_replace_expr (e, new_expr);
+ t = true;
+ break;
+ }
+ }
- sym = e->symtree->n.sym;
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
typedef enum
{
- INTMOD_NONE = 0, INTMOD_ISO_FORTRAN_ENV, INTMOD_ISO_C_BINDING
+ INTMOD_NONE = 0, INTMOD_ISO_FORTRAN_ENV, INTMOD_ISO_C_BINDING,
+ INTMOD_IEEE_FEATURES, INTMOD_IEEE_EXCEPTIONS, INTMOD_IEEE_ARITHMETIC
}
intmod_id;
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag;
+gfc_expr *gfc_simplify_ieee_selected_real_kind (gfc_expr *);
+
/* Given a symbol that we have decided is intrinsic, mark it as such
by placing it into a special module that is otherwise impossible to
read or write. */
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
Both are equivalent to the value @code{NULL} in C.
+
+
+@node IEEE modules
+@section IEEE modules: @code{IEEE_EXCEPTIONS}, @code{IEEE_ARITHMETIC}, and @code{IEEE_FEATURES}
+@table @asis
+@item @emph{Standard}:
+Fortran 2003 and later
+@end table
+
+The @code{IEEE_EXCEPTIONS}, @code{IEEE_ARITHMETIC}, and @code{IEEE_FEATURES}
+intrinsic modules provide support for exceptions and IEEE arithmetic, as
+defined in Fortran 2003 and later standards, and the IEC 60559:1989 standard
+(@emph{Binary floating-point arithmetic for microprocessor systems}). These
+modules are only provided on the following supported platforms:
+
+@itemize @bullet
+@item i386 and x86_64 processors
+@item platforms which use the GNU C Library (glibc)
+@item platforms with support for SysV/386 routines for floating point
+interface (including Solaris and BSDs)
+@item platforms with the AIX OS
+@end itemize
+
+For full compliance with the Fortran standards, code using the
+@code{IEEE_EXCEPTIONS} or @code{IEEE_ARITHMETIC} modules should be compiled
+with the following options: @code{-fno-unsafe-math-optimizations
+-frounding-math -fsignaling-nans}.
+
+
@node OpenMP Modules OMP_LIB and OMP_LIB_KINDS
@section OpenMP Modules @code{OMP_LIB} and @code{OMP_LIB_KINDS}
@table @asis
obsolescent in later standards. */
-/* Bitmasks for the various FPE that can be enabled. */
-#define GFC_FPE_INVALID (1<<0)
-#define GFC_FPE_DENORMAL (1<<1)
-#define GFC_FPE_ZERO (1<<2)
-#define GFC_FPE_OVERFLOW (1<<3)
-#define GFC_FPE_UNDERFLOW (1<<4)
-#define GFC_FPE_INEXACT (1<<5)
+/* Bitmasks for the various FPE that can be enabled. These need to be straight integers
+ e.g., 8 instead of (1<<3), because they will be included in Fortran source. */
+#define GFC_FPE_INVALID 1
+#define GFC_FPE_DENORMAL 2
+#define GFC_FPE_ZERO 4
+#define GFC_FPE_OVERFLOW 8
+#define GFC_FPE_UNDERFLOW 16
+#define GFC_FPE_INEXACT 32
/* Defines for floating-point rounding modes. */
#define GFC_FPE_DOWNWARD 1
#define GFC_FPE_TOWARDZERO 3
#define GFC_FPE_UPWARD 4
+/* Size of the buffer required to store FPU state for any target.
+ In particular, this has to be larger than fenv_t on all glibc targets.
+ Currently, the winner is x86_64 with 32 bytes. */
+#define GFC_FPE_STATE_BUFFER_SIZE 32
/* Bitmasks for the various runtime checks that can be enabled. */
#define GFC_RTCHECK_BOUNDS (1<<0)
static const char *module_name;
static gfc_use_list *module_list;
+/* If we're reading an intrinsic module, this is its ID. */
+static intmod_id current_intmod;
+
/* Content of module. */
static char* module_content;
else
{
mio_integer (&intmod);
- sym->from_intmod = (intmod_id) intmod;
+ if (current_intmod)
+ sym->from_intmod = current_intmod;
+ else
+ sym->from_intmod = (intmod_id) intmod;
}
mio_integer (&(sym->intmod_sym_id));
module_name = module->module_name;
gfc_rename_list = module->rename;
only_flag = module->only_flag;
+ current_intmod = INTMOD_NONE;
filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
+ 1);
if (module_fp == NULL && module->intrinsic)
gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
module_name);
+
+ /* Check for the IEEE modules, so we can mark their symbols
+ accordingly when we read them. */
+ if (strcmp (module_name, "ieee_features") == 0
+ && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
+ {
+ current_intmod = INTMOD_IEEE_FEATURES;
+ }
+ else if (strcmp (module_name, "ieee_exceptions") == 0
+ && gfc_notify_std (GFC_STD_F2003,
+ "IEEE_EXCEPTIONS module at %C"))
+ {
+ current_intmod = INTMOD_IEEE_EXCEPTIONS;
+ }
+ else if (strcmp (module_name, "ieee_arithmetic") == 0
+ && gfc_notify_std (GFC_STD_F2003,
+ "IEEE_ARITHMETIC module at %C"))
+ {
+ current_intmod = INTMOD_IEEE_ARITHMETIC;
+ }
}
if (module_fp == NULL)
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
}
+gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
tree gfc_static_ctors;
+/* Whether we've seen a symbol from an IEEE module in the namespace. */
+static int seen_ieee_symbol;
+
/* Function declarations for builtin library functions. */
tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_associated;
tree gfor_fndecl_system_clock4;
tree gfor_fndecl_system_clock8;
+tree gfor_fndecl_ieee_procedure_entry;
+tree gfor_fndecl_ieee_procedure_exit;
/* Coarray run-time library function decls. */
/* Special case for array-valued named constants from intrinsic
procedures; those are inlined. */
- if (sym->attr.use_assoc && sym->from_intmod
- && sym->attr.flavor == FL_PARAMETER)
+ if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER
+ && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ || sym->from_intmod == INTMOD_ISO_C_BINDING))
intrinsic_array_parameter = true;
/* If use associated compilation, use the module
get_identifier (PREFIX("set_fpe")),
void_type_node, 1, integer_type_node);
+ gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
+ get_identifier (PREFIX("ieee_procedure_entry")),
+ void_type_node, 1, pvoid_type_node);
+
+ gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
+ get_identifier (PREFIX("ieee_procedure_exit")),
+ void_type_node, 1, pvoid_type_node);
+
/* Keep the array dimension in sync with the call, later in this file. */
gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("set_options")), "..R",
}
+static void
+is_from_ieee_module (gfc_symbol *sym)
+{
+ if (sym->from_intmod == INTMOD_IEEE_FEATURES
+ || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
+ || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
+ seen_ieee_symbol = 1;
+}
+
+
+static int
+is_ieee_module_used (gfc_namespace *ns)
+{
+ seen_ieee_symbol = 0;
+ gfc_traverse_ns (ns, is_from_ieee_module);
+ return seen_ieee_symbol;
+}
+
+
+static tree
+save_fp_state (stmtblock_t *block)
+{
+ tree type, fpstate, tmp;
+
+ type = build_array_type (char_type_node,
+ build_range_type (size_type_node, size_zero_node,
+ size_int (32)));
+ fpstate = gfc_create_var (type, "fpstate");
+ fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
+ 1, fpstate);
+ gfc_add_expr_to_block (block, tmp);
+
+ return fpstate;
+}
+
+
+static void
+restore_fp_state (stmtblock_t *block, tree fpstate)
+{
+ tree tmp;
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
+ 1, fpstate);
+ gfc_add_expr_to_block (block, tmp);
+}
+
+
/* Generate code for a function. */
void
tree old_context;
tree decl;
tree tmp;
+ tree fpstate = NULL_TREE;
stmtblock_t init, cleanup;
stmtblock_t body;
gfc_wrapped_block try_block;
tree recurcheckvar = NULL_TREE;
gfc_symbol *sym;
gfc_symbol *previous_procedure_symbol;
- int rank;
+ int rank, ieee;
bool is_recursive;
sym = ns->proc_name;
free (msg);
}
+ /* Check if an IEEE module is used in the procedure. If so, save
+ the floating point state. */
+ ieee = is_ieee_module_used (ns);
+ if (ieee)
+ fpstate = save_fp_state (&init);
+
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
recurcheckvar = NULL;
}
+ /* If IEEE modules are loaded, restore the floating-point state. */
+ if (ieee)
+ restore_fp_state (&cleanup, fpstate);
+
/* Finish the function body and add init and cleanup code. */
tmp = gfc_finish_block (&body);
gfc_start_wrapped_block (&try_block, tmp);
+2014-06-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/29383
+ * lib/target-supports.exp (check_effective_target_fortran_ieee):
+ New function.
+ * gfortran.dg/ieee/ieee.exp: New file.
+ * gfortran.dg/ieee/ieee_1.F90: New file.
+ * gfortran.dg/ieee/ieee_2.f90: New file.
+ * gfortran.dg/ieee/ieee_3.f90: New file.
+ * gfortran.dg/ieee/ieee_4.f90: New file.
+ * gfortran.dg/ieee/ieee_5.f90: New file.
+ * gfortran.dg/ieee/ieee_6.f90: New file.
+ * gfortran.dg/ieee/ieee_7.f90: New file.
+ * gfortran.dg/ieee/ieee_rounding_1.f90: New file.
+
2014-06-28 Jonathan Wakely <jwakely@redhat.com>
* g++.dg/cpp0x/elision_conv.C: New.
--- /dev/null
+# Copyright (C) 2013 Free Software Foundation, Inc.
+#
+# This file is part of GCC.
+#
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+#
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# GCC testsuite that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gfortran-dg.exp
+load_lib target-supports.exp
+
+# Initialize `dg'.
+dg-init
+
+# Flags specified in each test
+global DEFAULT_FFLAGS
+if ![info exists DEFAULT_FFLAGS] then {
+ set DEFAULT_FFLAGS ""
+}
+
+# Flags for finding the IEEE modules
+if [info exists TOOL_OPTIONS] {
+ set specpath [get_multilibs ${TOOL_OPTIONS}]
+} else {
+ set specpath [get_multilibs]
+}
+set options "-fintrinsic-modules-path $specpath/libgfortran/"
+
+# Bail out if IEEE tests are not supported at all
+if ![check_effective_target_fortran_ieee $options ] {
+ return
+}
+
+# Add target-independent options to require IEEE compatibility
+set options "$DEFAULT_FFLAGS $options -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans"
+
+# Add target-specific options to require IEEE compatibility
+set target_options [add_options_for_ieee ""]
+set options "$options $target_options"
+
+# Main loop.
+gfortran-dg-runtest [lsort \
+ [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] $options
+
+# All done.
+dg-finish
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-ffree-line-length-none -O0" }
+!
+! Use dg-additional-options rather than dg-options to avoid overwriting the
+! default IEEE options which are passed by ieee.exp and necessary.
+
+ use ieee_features, only : ieee_datatype, ieee_denormal, ieee_divide, &
+ ieee_halting, ieee_inexact_flag, ieee_inf, ieee_invalid_flag, &
+ ieee_nan, ieee_rounding, ieee_sqrt, ieee_underflow_flag
+ use ieee_exceptions
+
+ implicit none
+
+ interface use_real
+ procedure use_real_4, use_real_8
+ end interface use_real
+
+ type(ieee_flag_type), parameter :: x(5) = &
+ [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
+ IEEE_UNDERFLOW, IEEE_INEXACT ]
+ logical :: l(5) = .false.
+ character(len=5) :: s
+
+#define FLAGS_STRING(S) \
+ call ieee_get_flag(x, l) ; \
+ write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l)
+
+#define CHECK_FLAGS(expected) \
+ FLAGS_STRING(s) ; \
+ if (s /= expected) then ; \
+ write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \
+ call abort ; \
+ end if ; \
+ call check_flag_sub
+
+ real :: sx
+ double precision :: dx
+
+ ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG
+
+ !!!! IEEE float
+
+ ! Initial flags are all off
+ CHECK_FLAGS(" ")
+
+ ! Check we can clear them
+ call ieee_set_flag(ieee_all, .false.)
+ CHECK_FLAGS(" ")
+
+ ! Raise invalid, then clear
+ sx = -1
+ call use_real(sx)
+ sx = sqrt(sx)
+ call use_real(sx)
+ CHECK_FLAGS("I ")
+ call ieee_set_flag(ieee_all, .false.)
+ CHECK_FLAGS(" ")
+
+ ! Raise overflow and precision
+ sx = huge(sx)
+ CHECK_FLAGS(" ")
+ sx = sx*sx
+ CHECK_FLAGS(" O P")
+ call use_real(sx)
+
+ ! Also raise divide-by-zero
+ sx = 0
+ sx = 1 / sx
+ CHECK_FLAGS(" OZ P")
+ call use_real(sx)
+
+ ! Clear them
+ call ieee_set_flag([ieee_overflow,ieee_inexact,&
+ ieee_divide_by_zero],[.false.,.false.,.true.])
+ CHECK_FLAGS(" Z ")
+ call ieee_set_flag(ieee_divide_by_zero, .false.)
+ CHECK_FLAGS(" ")
+
+ ! Raise underflow
+ sx = tiny(sx)
+ CHECK_FLAGS(" ")
+ sx = sx / 10
+ call use_real(sx)
+ CHECK_FLAGS(" UP")
+
+ ! Raise everything
+ call ieee_set_flag(ieee_all, .true.)
+ CHECK_FLAGS("IOZUP")
+
+ ! And clear
+ call ieee_set_flag(ieee_all, .false.)
+ CHECK_FLAGS(" ")
+
+ !!!! IEEE double
+
+ ! Initial flags are all off
+ CHECK_FLAGS(" ")
+
+ ! Check we can clear them
+ call ieee_set_flag(ieee_all, .false.)
+ CHECK_FLAGS(" ")
+
+ ! Raise invalid, then clear
+ dx = -1
+ call use_real(dx)
+ dx = sqrt(dx)
+ call use_real(dx)
+ CHECK_FLAGS("I ")
+ call ieee_set_flag(ieee_all, .false.)
+ CHECK_FLAGS(" ")
+
+ ! Raise overflow and precision
+ dx = huge(dx)
+ CHECK_FLAGS(" ")
+ dx = dx*dx
+ CHECK_FLAGS(" O P")
+ call use_real(dx)
+
+ ! Also raise divide-by-zero
+ dx = 0
+ dx = 1 / dx
+ CHECK_FLAGS(" OZ P")
+ call use_real(dx)
+
+ ! Clear them
+ call ieee_set_flag([ieee_overflow,ieee_inexact,&
+ ieee_divide_by_zero],[.false.,.false.,.true.])
+ CHECK_FLAGS(" Z ")
+ call ieee_set_flag(ieee_divide_by_zero, .false.)
+ CHECK_FLAGS(" ")
+
+ ! Raise underflow
+ dx = tiny(dx)
+ CHECK_FLAGS(" ")
+ dx = dx / 10
+ CHECK_FLAGS(" UP")
+ call use_real(dx)
+
+ ! Raise everything
+ call ieee_set_flag(ieee_all, .true.)
+ CHECK_FLAGS("IOZUP")
+
+ ! And clear
+ call ieee_set_flag(ieee_all, .false.)
+ CHECK_FLAGS(" ")
+
+contains
+
+ subroutine check_flag_sub
+ use ieee_exceptions
+ logical :: l(5) = .false.
+ type(ieee_flag_type), parameter :: x(5) = &
+ [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
+ IEEE_UNDERFLOW, IEEE_INEXACT ]
+ call ieee_get_flag(x, l)
+
+ if (any(l)) then
+ print *, "Flags not cleared in subroutine"
+ call abort
+ end if
+ end subroutine
+
+ ! Interface to a routine that avoids calculations to be optimized out,
+ ! making it appear that we use the result
+ subroutine use_real_4(x)
+ real :: x
+ if (x == 123456.789) print *, "toto"
+ end subroutine
+ subroutine use_real_8(x)
+ double precision :: x
+ if (x == 123456.789) print *, "toto"
+ end subroutine
+
+end
--- /dev/null
+! { dg-do run }
+
+ use, intrinsic :: ieee_features
+ use, intrinsic :: ieee_exceptions
+ use, intrinsic :: ieee_arithmetic
+ implicit none
+
+ interface check_equal
+ procedure check_equal_float, check_equal_double
+ end interface
+
+ interface check_not_equal
+ procedure check_not_equal_float, check_not_equal_double
+ end interface
+
+ real :: sx1, sx2, sx3
+ double precision :: dx1, dx2, dx3
+ type(ieee_round_type) :: mode
+
+ ! Test IEEE_COPY_SIGN
+ sx1 = 1.3
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort
+ sx1 = huge(sx1)
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort
+ sx1 = ieee_value(sx1, ieee_positive_inf)
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort
+ sx1 = tiny(sx1)
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort
+ sx1 = tiny(sx1)
+ sx1 = sx1 / 101
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -sx1) call abort
+
+ sx1 = -1.3
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort
+ sx1 = -huge(sx1)
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort
+ sx1 = ieee_value(sx1, ieee_negative_inf)
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort
+ sx1 = -tiny(sx1)
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort
+ sx1 = -tiny(sx1)
+ sx1 = sx1 / 101
+ if (ieee_copy_sign(sx1, sx1) /= sx1) call abort
+ if (ieee_copy_sign(sx1, -sx1) /= -sx1) call abort
+ if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) call abort
+ if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) call abort
+
+ if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero) call abort
+ if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero) call abort
+ if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero) call abort
+ if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero) call abort
+
+ sx1 = ieee_value(0., ieee_quiet_nan)
+ if (ieee_class(ieee_copy_sign(sx1, 1.)) /= ieee_quiet_nan) call abort
+ if (ieee_class(ieee_copy_sign(sx1, -1.)) /= ieee_quiet_nan) call abort
+
+ dx1 = 1.3
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -1.d0) /= -dx1) call abort
+ dx1 = huge(dx1)
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.d0) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -1.) /= -dx1) call abort
+ dx1 = ieee_value(dx1, ieee_positive_inf)
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -1.d0) /= -dx1) call abort
+ dx1 = tiny(dx1)
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.d0) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -1.) /= -dx1) call abort
+ dx1 = tiny(dx1)
+ dx1 = dx1 / 101
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -1.d0) /= -dx1) call abort
+
+ dx1 = -1.3d0
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) call abort
+ if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) call abort
+ dx1 = -huge(dx1)
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) call abort
+ if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) call abort
+ dx1 = ieee_value(dx1, ieee_negative_inf)
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) call abort
+ if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) call abort
+ dx1 = -tiny(dx1)
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) call abort
+ if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) call abort
+ dx1 = -tiny(dx1)
+ dx1 = dx1 / 101
+ if (ieee_copy_sign(dx1, dx1) /= dx1) call abort
+ if (ieee_copy_sign(dx1, -dx1) /= -dx1) call abort
+ if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) call abort
+ if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) call abort
+
+ if (ieee_class(ieee_copy_sign(0.d0, -1.)) /= ieee_negative_zero) call abort
+ if (ieee_class(ieee_copy_sign(-0.d0, -1.)) /= ieee_negative_zero) call abort
+ if (ieee_class(ieee_copy_sign(0.d0, 1.)) /= ieee_positive_zero) call abort
+ if (ieee_class(ieee_copy_sign(-0.d0, 1.)) /= ieee_positive_zero) call abort
+
+ dx1 = ieee_value(0.d0, ieee_quiet_nan)
+ if (ieee_class(ieee_copy_sign(dx1, 1.d0)) /= ieee_quiet_nan) call abort
+ if (ieee_class(ieee_copy_sign(dx1, -1.)) /= ieee_quiet_nan) call abort
+
+ ! Test IEEE_LOGB
+
+ if (ieee_logb(1.17) /= exponent(1.17) - 1) call abort
+ if (ieee_logb(-1.17) /= exponent(-1.17) - 1) call abort
+ if (ieee_logb(huge(sx1)) /= exponent(huge(sx1)) - 1) call abort
+ if (ieee_logb(-huge(sx1)) /= exponent(-huge(sx1)) - 1) call abort
+ if (ieee_logb(tiny(sx1)) /= exponent(tiny(sx1)) - 1) call abort
+ if (ieee_logb(-tiny(sx1)) /= exponent(-tiny(sx1)) - 1) call abort
+
+ if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf) call abort
+ if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf) call abort
+
+ sx1 = ieee_value(sx1, ieee_positive_inf)
+ if (ieee_class(ieee_logb(sx1)) /= ieee_positive_inf) call abort
+ if (ieee_class(ieee_logb(-sx1)) /= ieee_positive_inf) call abort
+
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (ieee_class(ieee_logb(sx1)) /= ieee_quiet_nan) call abort
+
+ if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) call abort
+ if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) call abort
+ if (ieee_logb(huge(dx1)) /= exponent(huge(dx1)) - 1) call abort
+ if (ieee_logb(-huge(dx1)) /= exponent(-huge(dx1)) - 1) call abort
+ if (ieee_logb(tiny(dx1)) /= exponent(tiny(dx1)) - 1) call abort
+ if (ieee_logb(-tiny(dx1)) /= exponent(-tiny(dx1)) - 1) call abort
+
+ if (ieee_class(ieee_logb(0.d0)) /= ieee_negative_inf) call abort
+ if (ieee_class(ieee_logb(-0.d0)) /= ieee_negative_inf) call abort
+
+ dx1 = ieee_value(dx1, ieee_positive_inf)
+ if (ieee_class(ieee_logb(dx1)) /= ieee_positive_inf) call abort
+ if (ieee_class(ieee_logb(-dx1)) /= ieee_positive_inf) call abort
+
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (ieee_class(ieee_logb(dx1)) /= ieee_quiet_nan) call abort
+
+ ! Test IEEE_NEXT_AFTER
+
+ if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) call abort
+ if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) call abort
+
+ sx1 = 0.12
+ if (ieee_next_after(sx1, sx1) /= sx1) call abort
+ sx1 = -0.12
+ if (ieee_next_after(sx1, sx1) /= sx1) call abort
+ sx1 = huge(sx1)
+ if (ieee_next_after(sx1, sx1) /= sx1) call abort
+ sx1 = tiny(sx1)
+ if (ieee_next_after(sx1, sx1) /= sx1) call abort
+ sx1 = 0
+ if (ieee_next_after(sx1, sx1) /= sx1) call abort
+ sx1 = ieee_value(sx1, ieee_negative_inf)
+ if (ieee_next_after(sx1, sx1) /= sx1) call abort
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (ieee_class(ieee_next_after(sx1, sx1)) /= ieee_quiet_nan) call abort
+
+ if (ieee_next_after(0., 1.0) <= 0) call abort
+ if (ieee_next_after(0., -1.0) >= 0) call abort
+ sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_negative_inf))
+ if (.not. sx1 < huge(sx1)) call abort
+ sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_positive_inf))
+ if (ieee_class(sx1) /= ieee_positive_inf) call abort
+ sx1 = ieee_next_after(-tiny(sx1), 1.0)
+ if (ieee_class(sx1) /= ieee_negative_denormal) call abort
+
+ if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) call abort
+ if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) call abort
+
+ dx1 = 0.12
+ if (ieee_next_after(dx1, dx1) /= dx1) call abort
+ dx1 = -0.12
+ if (ieee_next_after(dx1, dx1) /= dx1) call abort
+ dx1 = huge(dx1)
+ if (ieee_next_after(dx1, dx1) /= dx1) call abort
+ dx1 = tiny(dx1)
+ if (ieee_next_after(dx1, dx1) /= dx1) call abort
+ dx1 = 0
+ if (ieee_next_after(dx1, dx1) /= dx1) call abort
+ dx1 = ieee_value(dx1, ieee_negative_inf)
+ if (ieee_next_after(dx1, dx1) /= dx1) call abort
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (ieee_class(ieee_next_after(dx1, dx1)) /= ieee_quiet_nan) call abort
+
+ if (ieee_next_after(0.d0, 1.0) <= 0) call abort
+ if (ieee_next_after(0.d0, -1.0d0) >= 0) call abort
+ dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_negative_inf))
+ if (.not. dx1 < huge(dx1)) call abort
+ dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_positive_inf))
+ if (ieee_class(dx1) /= ieee_positive_inf) call abort
+ dx1 = ieee_next_after(-tiny(dx1), 1.0d0)
+ if (ieee_class(dx1) /= ieee_negative_denormal) call abort
+
+ ! Test IEEE_REM
+
+ if (ieee_rem(4.0, 3.0) /= 1.0) call abort
+ if (ieee_rem(-4.0, 3.0) /= -1.0) call abort
+ if (ieee_rem(2.0, 3.0d0) /= -1.0d0) call abort
+ if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) call abort
+ if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) call abort
+ if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) call abort
+
+ if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan), 1.0)) &
+ /= ieee_quiet_nan) call abort
+ if (ieee_class(ieee_rem(1.0, ieee_value(0.d0, ieee_quiet_nan))) &
+ /= ieee_quiet_nan) call abort
+
+ if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf), 1.0)) &
+ /= ieee_quiet_nan) call abort
+ if (ieee_class(ieee_rem(ieee_value(0.d0, ieee_negative_inf), 1.0)) &
+ /= ieee_quiet_nan) call abort
+ if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf)) &
+ /= -1.0) call abort
+ if (ieee_rem(1.0, ieee_value(0.d0, ieee_negative_inf)) &
+ /= 1.0) call abort
+
+
+ ! Test IEEE_RINT
+
+ if (ieee_support_rounding (ieee_nearest, sx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_nearest)
+ sx1 = 7 / 3.
+ sx1 = ieee_rint (sx1)
+ call ieee_set_rounding_mode (mode)
+ if (sx1 /= 2) call abort
+ end if
+
+ if (ieee_support_rounding (ieee_up, sx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_up)
+ sx1 = 7 / 3.
+ sx1 = ieee_rint (sx1)
+ call ieee_set_rounding_mode (mode)
+ if (sx1 /= 3) call abort
+ end if
+
+ if (ieee_support_rounding (ieee_down, sx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_down)
+ sx1 = 7 / 3.
+ sx1 = ieee_rint (sx1)
+ call ieee_set_rounding_mode (mode)
+ if (sx1 /= 2) call abort
+ end if
+
+ if (ieee_support_rounding (ieee_to_zero, sx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_to_zero)
+ sx1 = 7 / 3.
+ sx1 = ieee_rint (sx1)
+ call ieee_set_rounding_mode (mode)
+ if (sx1 /= 2) call abort
+ end if
+
+ if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero) call abort
+ if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero) call abort
+
+ if (ieee_support_rounding (ieee_nearest, dx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_nearest)
+ dx1 = 7 / 3.d0
+ dx1 = ieee_rint (dx1)
+ call ieee_set_rounding_mode (mode)
+ if (dx1 /= 2) call abort
+ end if
+
+ if (ieee_support_rounding (ieee_up, dx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_up)
+ dx1 = 7 / 3.d0
+ dx1 = ieee_rint (dx1)
+ call ieee_set_rounding_mode (mode)
+ if (dx1 /= 3) call abort
+ end if
+
+ if (ieee_support_rounding (ieee_down, dx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_down)
+ dx1 = 7 / 3.d0
+ dx1 = ieee_rint (dx1)
+ call ieee_set_rounding_mode (mode)
+ if (dx1 /= 2) call abort
+ end if
+
+ if (ieee_support_rounding (ieee_to_zero, dx1)) then
+ call ieee_get_rounding_mode (mode)
+ call ieee_set_rounding_mode (ieee_to_zero)
+ dx1 = 7 / 3.d0
+ dx1 = ieee_rint (dx1)
+ call ieee_set_rounding_mode (mode)
+ if (dx1 /= 2) call abort
+ end if
+
+ if (ieee_class(ieee_rint(0.d0)) /= ieee_positive_zero) call abort
+ if (ieee_class(ieee_rint(-0.d0)) /= ieee_negative_zero) call abort
+
+ ! Test IEEE_SCALB
+
+ sx1 = 1
+ if (ieee_scalb(sx1, 2) /= 4.) call abort
+ if (ieee_scalb(-sx1, 2) /= -4.) call abort
+ if (ieee_scalb(sx1, -2) /= 1/4.) call abort
+ if (ieee_scalb(-sx1, -2) /= -1/4.) call abort
+ if (ieee_class(ieee_scalb(sx1, huge(0))) /= ieee_positive_inf) call abort
+ if (ieee_class(ieee_scalb(-sx1, huge(0))) /= ieee_negative_inf) call abort
+ if (ieee_class(ieee_scalb(sx1, -huge(0))) /= ieee_positive_zero) call abort
+ if (ieee_class(ieee_scalb(-sx1, -huge(0))) /= ieee_negative_zero) call abort
+
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (ieee_class(ieee_scalb(sx1, 1)) /= ieee_quiet_nan) call abort
+ sx1 = ieee_value(sx1, ieee_positive_inf)
+ if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_positive_inf) call abort
+ sx1 = ieee_value(sx1, ieee_negative_inf)
+ if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_negative_inf) call abort
+
+ dx1 = 1
+ if (ieee_scalb(dx1, 2) /= 4.d0) call abort
+ if (ieee_scalb(-dx1, 2) /= -4.d0) call abort
+ if (ieee_scalb(dx1, -2) /= 1/4.d0) call abort
+ if (ieee_scalb(-dx1, -2) /= -1/4.d0) call abort
+ if (ieee_class(ieee_scalb(dx1, huge(0))) /= ieee_positive_inf) call abort
+ if (ieee_class(ieee_scalb(-dx1, huge(0))) /= ieee_negative_inf) call abort
+ if (ieee_class(ieee_scalb(dx1, -huge(0))) /= ieee_positive_zero) call abort
+ if (ieee_class(ieee_scalb(-dx1, -huge(0))) /= ieee_negative_zero) call abort
+
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (ieee_class(ieee_scalb(dx1, 1)) /= ieee_quiet_nan) call abort
+ dx1 = ieee_value(dx1, ieee_positive_inf)
+ if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_positive_inf) call abort
+ dx1 = ieee_value(dx1, ieee_negative_inf)
+ if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_negative_inf) call abort
+
+contains
+
+ subroutine check_equal_float (x, y)
+ real, intent(in) :: x, y
+ if (x /= y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+ subroutine check_equal_double (x, y)
+ double precision, intent(in) :: x, y
+ if (x /= y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+ subroutine check_not_equal_float (x, y)
+ real, intent(in) :: x, y
+ if (x == y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+ subroutine check_not_equal_double (x, y)
+ double precision, intent(in) :: x, y
+ if (x == y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+end
--- /dev/null
+! { dg-do run }
+
+ use :: ieee_arithmetic
+ implicit none
+
+ real :: sx1, sx2, sx3
+ double precision :: dx1, dx2, dx3
+ integer, parameter :: s = kind(sx1), d = kind(dx1)
+ type(ieee_round_type) :: mode
+
+ ! Test IEEE_IS_FINITE
+
+ if (ieee_support_datatype(0._s)) then
+ if (.not. ieee_is_finite(0.2_s)) call abort
+ if (.not. ieee_is_finite(-0.2_s)) call abort
+ if (.not. ieee_is_finite(0._s)) call abort
+ if (.not. ieee_is_finite(-0._s)) call abort
+ if (.not. ieee_is_finite(tiny(0._s))) call abort
+ if (.not. ieee_is_finite(tiny(0._s)/100)) call abort
+ if (.not. ieee_is_finite(huge(0._s))) call abort
+ if (.not. ieee_is_finite(-huge(0._s))) call abort
+ sx1 = huge(sx1)
+ if (ieee_is_finite(2*sx1)) call abort
+ if (ieee_is_finite(2*(-sx1))) call abort
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (ieee_is_finite(sx1)) call abort
+ end if
+
+ if (ieee_support_datatype(0._d)) then
+ if (.not. ieee_is_finite(0.2_d)) call abort
+ if (.not. ieee_is_finite(-0.2_d)) call abort
+ if (.not. ieee_is_finite(0._d)) call abort
+ if (.not. ieee_is_finite(-0._d)) call abort
+ if (.not. ieee_is_finite(tiny(0._d))) call abort
+ if (.not. ieee_is_finite(tiny(0._d)/100)) call abort
+ if (.not. ieee_is_finite(huge(0._d))) call abort
+ if (.not. ieee_is_finite(-huge(0._d))) call abort
+ dx1 = huge(dx1)
+ if (ieee_is_finite(2*dx1)) call abort
+ if (ieee_is_finite(2*(-dx1))) call abort
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (ieee_is_finite(dx1)) call abort
+ end if
+
+ ! Test IEEE_IS_NAN
+
+ if (ieee_support_datatype(0._s)) then
+ if (ieee_is_nan(0.2_s)) call abort
+ if (ieee_is_nan(-0.2_s)) call abort
+ if (ieee_is_nan(0._s)) call abort
+ if (ieee_is_nan(-0._s)) call abort
+ if (ieee_is_nan(tiny(0._s))) call abort
+ if (ieee_is_nan(tiny(0._s)/100)) call abort
+ if (ieee_is_nan(huge(0._s))) call abort
+ if (ieee_is_nan(-huge(0._s))) call abort
+ sx1 = huge(sx1)
+ if (ieee_is_nan(2*sx1)) call abort
+ if (ieee_is_nan(2*(-sx1))) call abort
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (.not. ieee_is_nan(sx1)) call abort
+ sx1 = -1
+ if (.not. ieee_is_nan(sqrt(sx1))) call abort
+ end if
+
+ if (ieee_support_datatype(0._d)) then
+ if (ieee_is_nan(0.2_d)) call abort
+ if (ieee_is_nan(-0.2_d)) call abort
+ if (ieee_is_nan(0._d)) call abort
+ if (ieee_is_nan(-0._d)) call abort
+ if (ieee_is_nan(tiny(0._d))) call abort
+ if (ieee_is_nan(tiny(0._d)/100)) call abort
+ if (ieee_is_nan(huge(0._d))) call abort
+ if (ieee_is_nan(-huge(0._d))) call abort
+ dx1 = huge(dx1)
+ if (ieee_is_nan(2*dx1)) call abort
+ if (ieee_is_nan(2*(-dx1))) call abort
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (.not. ieee_is_nan(dx1)) call abort
+ dx1 = -1
+ if (.not. ieee_is_nan(sqrt(dx1))) call abort
+ end if
+
+ ! IEEE_IS_NEGATIVE
+
+ if (ieee_support_datatype(0._s)) then
+ if (ieee_is_negative(0.2_s)) call abort
+ if (.not. ieee_is_negative(-0.2_s)) call abort
+ if (ieee_is_negative(0._s)) call abort
+ if (.not. ieee_is_negative(-0._s)) call abort
+ if (ieee_is_negative(tiny(0._s))) call abort
+ if (ieee_is_negative(tiny(0._s)/100)) call abort
+ if (.not. ieee_is_negative(-tiny(0._s))) call abort
+ if (.not. ieee_is_negative(-tiny(0._s)/100)) call abort
+ if (ieee_is_negative(huge(0._s))) call abort
+ if (.not. ieee_is_negative(-huge(0._s))) call abort
+ sx1 = huge(sx1)
+ if (ieee_is_negative(2*sx1)) call abort
+ if (.not. ieee_is_negative(2*(-sx1))) call abort
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (ieee_is_negative(sx1)) call abort
+ sx1 = -1
+ if (ieee_is_negative(sqrt(sx1))) call abort
+ end if
+
+ if (ieee_support_datatype(0._d)) then
+ if (ieee_is_negative(0.2_d)) call abort
+ if (.not. ieee_is_negative(-0.2_d)) call abort
+ if (ieee_is_negative(0._d)) call abort
+ if (.not. ieee_is_negative(-0._d)) call abort
+ if (ieee_is_negative(tiny(0._d))) call abort
+ if (ieee_is_negative(tiny(0._d)/100)) call abort
+ if (.not. ieee_is_negative(-tiny(0._d))) call abort
+ if (.not. ieee_is_negative(-tiny(0._d)/100)) call abort
+ if (ieee_is_negative(huge(0._d))) call abort
+ if (.not. ieee_is_negative(-huge(0._d))) call abort
+ dx1 = huge(dx1)
+ if (ieee_is_negative(2*dx1)) call abort
+ if (.not. ieee_is_negative(2*(-dx1))) call abort
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (ieee_is_negative(dx1)) call abort
+ dx1 = -1
+ if (ieee_is_negative(sqrt(dx1))) call abort
+ end if
+
+ ! Test IEEE_IS_NORMAL
+
+ if (ieee_support_datatype(0._s)) then
+ if (.not. ieee_is_normal(0.2_s)) call abort
+ if (.not. ieee_is_normal(-0.2_s)) call abort
+ if (.not. ieee_is_normal(0._s)) call abort
+ if (.not. ieee_is_normal(-0._s)) call abort
+ if (.not. ieee_is_normal(tiny(0._s))) call abort
+ if (ieee_is_normal(tiny(0._s)/100)) call abort
+ if (.not. ieee_is_normal(-tiny(0._s))) call abort
+ if (ieee_is_normal(-tiny(0._s)/100)) call abort
+ if (.not. ieee_is_normal(huge(0._s))) call abort
+ if (.not. ieee_is_normal(-huge(0._s))) call abort
+ sx1 = huge(sx1)
+ if (ieee_is_normal(2*sx1)) call abort
+ if (ieee_is_normal(2*(-sx1))) call abort
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (ieee_is_normal(sx1)) call abort
+ sx1 = -1
+ if (ieee_is_normal(sqrt(sx1))) call abort
+ end if
+
+ if (ieee_support_datatype(0._d)) then
+ if (.not. ieee_is_normal(0.2_d)) call abort
+ if (.not. ieee_is_normal(-0.2_d)) call abort
+ if (.not. ieee_is_normal(0._d)) call abort
+ if (.not. ieee_is_normal(-0._d)) call abort
+ if (.not. ieee_is_normal(tiny(0._d))) call abort
+ if (ieee_is_normal(tiny(0._d)/100)) call abort
+ if (.not. ieee_is_normal(-tiny(0._d))) call abort
+ if (ieee_is_normal(-tiny(0._d)/100)) call abort
+ if (.not. ieee_is_normal(huge(0._d))) call abort
+ if (.not. ieee_is_normal(-huge(0._d))) call abort
+ dx1 = huge(dx1)
+ if (ieee_is_normal(2*dx1)) call abort
+ if (ieee_is_normal(2*(-dx1))) call abort
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (ieee_is_normal(dx1)) call abort
+ dx1 = -1
+ if (ieee_is_normal(sqrt(dx1))) call abort
+ end if
+
+end
--- /dev/null
+! { dg-do run }
+
+ use :: ieee_arithmetic
+ implicit none
+
+ real :: sx1, sx2, sx3
+ double precision :: dx1, dx2, dx3
+ integer, parameter :: s = kind(sx1), d = kind(dx1)
+ type(ieee_round_type) :: mode
+
+ ! Test IEEE_CLASS
+
+ if (ieee_support_datatype(0._s)) then
+ sx1 = 0.1_s
+ if (ieee_class(sx1) /= ieee_positive_normal) call abort
+ if (ieee_class(-sx1) /= ieee_negative_normal) call abort
+ sx1 = huge(sx1)
+ if (ieee_class(sx1) /= ieee_positive_normal) call abort
+ if (ieee_class(-sx1) /= ieee_negative_normal) call abort
+ if (ieee_class(2*sx1) /= ieee_positive_inf) call abort
+ if (ieee_class(2*(-sx1)) /= ieee_negative_inf) call abort
+ sx1 = tiny(sx1)
+ if (ieee_class(sx1) /= ieee_positive_normal) call abort
+ if (ieee_class(-sx1) /= ieee_negative_normal) call abort
+ if (ieee_class(sx1 / 2) /= ieee_positive_denormal) call abort
+ if (ieee_class((-sx1) / 2) /= ieee_negative_denormal) call abort
+ sx1 = -1
+ if (ieee_class(sqrt(sx1)) /= ieee_quiet_nan) call abort
+ sx1 = 0
+ if (ieee_class(sx1) /= ieee_positive_zero) call abort
+ if (ieee_class(-sx1) /= ieee_negative_zero) call abort
+ end if
+
+ if (ieee_support_datatype(0._d)) then
+ dx1 = 0.1_d
+ if (ieee_class(dx1) /= ieee_positive_normal) call abort
+ if (ieee_class(-dx1) /= ieee_negative_normal) call abort
+ dx1 = huge(dx1)
+ if (ieee_class(dx1) /= ieee_positive_normal) call abort
+ if (ieee_class(-dx1) /= ieee_negative_normal) call abort
+ if (ieee_class(2*dx1) /= ieee_positive_inf) call abort
+ if (ieee_class(2*(-dx1)) /= ieee_negative_inf) call abort
+ dx1 = tiny(dx1)
+ if (ieee_class(dx1) /= ieee_positive_normal) call abort
+ if (ieee_class(-dx1) /= ieee_negative_normal) call abort
+ if (ieee_class(dx1 / 2) /= ieee_positive_denormal) call abort
+ if (ieee_class((-dx1) / 2) /= ieee_negative_denormal) call abort
+ dx1 = -1
+ if (ieee_class(sqrt(dx1)) /= ieee_quiet_nan) call abort
+ dx1 = 0
+ if (ieee_class(dx1) /= ieee_positive_zero) call abort
+ if (ieee_class(-dx1) /= ieee_negative_zero) call abort
+ end if
+
+ ! Test IEEE_VALUE and IEEE_UNORDERED
+
+ if (ieee_support_datatype(0._s)) then
+ sx1 = ieee_value(sx1, ieee_quiet_nan)
+ if (.not. ieee_is_nan(sx1)) call abort
+ if (.not. ieee_unordered(sx1, sx1)) call abort
+ if (.not. ieee_unordered(sx1, 0._s)) call abort
+ if (.not. ieee_unordered(sx1, 0._d)) call abort
+ if (.not. ieee_unordered(0._s, sx1)) call abort
+ if (.not. ieee_unordered(0._d, sx1)) call abort
+ if (ieee_unordered(0._s, 0._s)) call abort
+
+ sx1 = ieee_value(sx1, ieee_positive_inf)
+ if (ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (ieee_is_negative(sx1)) call abort
+ if (ieee_is_normal(sx1)) call abort
+
+ sx1 = ieee_value(sx1, ieee_negative_inf)
+ if (ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (.not. ieee_is_negative(sx1)) call abort
+ if (ieee_is_normal(sx1)) call abort
+
+ sx1 = ieee_value(sx1, ieee_positive_normal)
+ if (.not. ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (ieee_is_negative(sx1)) call abort
+ if (.not. ieee_is_normal(sx1)) call abort
+
+ sx1 = ieee_value(sx1, ieee_negative_normal)
+ if (.not. ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (.not. ieee_is_negative(sx1)) call abort
+ if (.not. ieee_is_normal(sx1)) call abort
+
+ sx1 = ieee_value(sx1, ieee_positive_denormal)
+ if (.not. ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (ieee_is_negative(sx1)) call abort
+ if (ieee_is_normal(sx1)) call abort
+ if (sx1 <= 0) call abort
+ if (sx1 >= tiny(sx1)) call abort
+
+ sx1 = ieee_value(sx1, ieee_negative_denormal)
+ if (.not. ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (.not. ieee_is_negative(sx1)) call abort
+ if (ieee_is_normal(sx1)) call abort
+ if (sx1 >= 0) call abort
+ if (sx1 <= -tiny(sx1)) call abort
+
+ sx1 = ieee_value(sx1, ieee_positive_zero)
+ if (.not. ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (ieee_is_negative(sx1)) call abort
+ if (.not. ieee_is_normal(sx1)) call abort
+ if (sx1 /= 0) call abort
+
+ sx1 = ieee_value(sx1, ieee_negative_zero)
+ if (.not. ieee_is_finite(sx1)) call abort
+ if (ieee_is_nan(sx1)) call abort
+ if (.not. ieee_is_negative(sx1)) call abort
+ if (.not. ieee_is_normal(sx1)) call abort
+ if (sx1 /= 0) call abort
+
+ end if
+
+ if (ieee_support_datatype(0._d)) then
+ dx1 = ieee_value(dx1, ieee_quiet_nan)
+ if (.not. ieee_is_nan(dx1)) call abort
+ if (.not. ieee_unordered(dx1, dx1)) call abort
+ if (.not. ieee_unordered(dx1, 0._s)) call abort
+ if (.not. ieee_unordered(dx1, 0._d)) call abort
+ if (.not. ieee_unordered(0._s, dx1)) call abort
+ if (.not. ieee_unordered(0._d, dx1)) call abort
+ if (ieee_unordered(0._d, 0._d)) call abort
+
+ dx1 = ieee_value(dx1, ieee_positive_inf)
+ if (ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (ieee_is_negative(dx1)) call abort
+ if (ieee_is_normal(dx1)) call abort
+
+ dx1 = ieee_value(dx1, ieee_negative_inf)
+ if (ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (.not. ieee_is_negative(dx1)) call abort
+ if (ieee_is_normal(dx1)) call abort
+
+ dx1 = ieee_value(dx1, ieee_positive_normal)
+ if (.not. ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (ieee_is_negative(dx1)) call abort
+ if (.not. ieee_is_normal(dx1)) call abort
+
+ dx1 = ieee_value(dx1, ieee_negative_normal)
+ if (.not. ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (.not. ieee_is_negative(dx1)) call abort
+ if (.not. ieee_is_normal(dx1)) call abort
+
+ dx1 = ieee_value(dx1, ieee_positive_denormal)
+ if (.not. ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (ieee_is_negative(dx1)) call abort
+ if (ieee_is_normal(dx1)) call abort
+ if (dx1 <= 0) call abort
+ if (dx1 >= tiny(dx1)) call abort
+
+ dx1 = ieee_value(dx1, ieee_negative_denormal)
+ if (.not. ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (.not. ieee_is_negative(dx1)) call abort
+ if (ieee_is_normal(dx1)) call abort
+ if (dx1 >= 0) call abort
+ if (dx1 <= -tiny(dx1)) call abort
+
+ dx1 = ieee_value(dx1, ieee_positive_zero)
+ if (.not. ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (ieee_is_negative(dx1)) call abort
+ if (.not. ieee_is_normal(dx1)) call abort
+ if (dx1 /= 0) call abort
+
+ dx1 = ieee_value(dx1, ieee_negative_zero)
+ if (.not. ieee_is_finite(dx1)) call abort
+ if (ieee_is_nan(dx1)) call abort
+ if (.not. ieee_is_negative(dx1)) call abort
+ if (.not. ieee_is_normal(dx1)) call abort
+ if (dx1 /= 0) call abort
+
+ end if
+
+end
--- /dev/null
+! { dg-do run }
+
+ use :: ieee_arithmetic
+ implicit none
+
+ logical mode
+
+ ! Test IEEE_SET_UNDERFLOW_MODE, IEEE_GET_UNDERFLOW_MODE,
+ ! and IEEE_SUPPORT_UNDERFLOW_CONTROL
+ !
+ ! We don't have any targets where this is supported yet, so
+ ! we just check these subroutines are present.
+
+ if (ieee_support_underflow_control() &
+ .or. ieee_support_underflow_control(0.)) then
+
+ call ieee_get_underflow_mode(mode)
+ call ieee_set_underflow_mode(.false.)
+ call ieee_set_underflow_mode(.true.)
+ call ieee_set_underflow_mode(mode)
+
+ end if
+
+ if (ieee_support_underflow_control() &
+ .or. ieee_support_underflow_control(0.d0)) then
+
+ call ieee_get_underflow_mode(mode)
+ call ieee_set_underflow_mode(.false.)
+ call ieee_set_underflow_mode(.true.)
+ call ieee_set_underflow_mode(mode)
+
+ end if
+
+end
--- /dev/null
+! { dg-do run }
+!
+! This test will fail on older x86_64 glibc (< 2.20), due to this bug:
+! https://sourceware.org/bugzilla/show_bug.cgi?id=16198
+! We usually won't see it anyway, because on such systems x86_64 assembly
+! (libgfortran/config/fpu-387.h) is used.
+!
+ use :: ieee_arithmetic
+ implicit none
+
+ type(ieee_status_type) :: s1, s2
+ logical :: flags(5), halt(5)
+ type(ieee_round_type) :: mode
+ real :: x
+
+ ! Test IEEE_GET_STATUS and IEEE_SET_STATUS
+
+ call ieee_set_flag(ieee_all, .false.)
+ call ieee_set_rounding_mode(ieee_down)
+ call ieee_set_halting_mode(ieee_all, .false.)
+
+ call ieee_get_status(s1)
+ call ieee_set_status(s1)
+
+ call ieee_get_flag(ieee_all, flags)
+ if (any(flags)) call abort
+ call ieee_get_rounding_mode(mode)
+ if (mode /= ieee_down) call abort
+ call ieee_get_halting_mode(ieee_all, halt)
+ if (any(halt)) call abort
+
+ call ieee_set_rounding_mode(ieee_to_zero)
+ call ieee_set_flag(ieee_underflow, .true.)
+ call ieee_set_halting_mode(ieee_overflow, .true.)
+ x = -1
+ x = sqrt(x)
+ if (.not. ieee_is_nan(x)) call abort
+
+ call ieee_get_status(s2)
+
+ call ieee_get_flag(ieee_all, flags)
+ if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]))) call abort
+ call ieee_get_rounding_mode(mode)
+ if (mode /= ieee_to_zero) call abort
+ call ieee_get_halting_mode(ieee_all, halt)
+ if ((.not. halt(1)) .or. any(halt(2:))) call abort
+
+ call ieee_set_status(s2)
+
+ call ieee_get_flag(ieee_all, flags)
+ if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]))) call abort
+ call ieee_get_rounding_mode(mode)
+ if (mode /= ieee_to_zero) call abort
+ call ieee_get_halting_mode(ieee_all, halt)
+ if ((.not. halt(1)) .or. any(halt(2:))) call abort
+
+ call ieee_set_status(s1)
+
+ call ieee_get_flag(ieee_all, flags)
+ if (any(flags)) call abort
+ call ieee_get_rounding_mode(mode)
+ if (mode /= ieee_down) call abort
+ call ieee_get_halting_mode(ieee_all, halt)
+ if (any(halt)) call abort
+
+ call ieee_set_status(s2)
+
+ call ieee_get_flag(ieee_all, flags)
+ if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]))) call abort
+ call ieee_get_rounding_mode(mode)
+ if (mode /= ieee_to_zero) call abort
+ call ieee_get_halting_mode(ieee_all, halt)
+ if ((.not. halt(1)) .or. any(halt(2:))) call abort
+
+end
--- /dev/null
+! { dg-do run }
+
+ use :: ieee_arithmetic
+ implicit none
+
+ ! Test IEEE_SELECTED_REAL_KIND in specification expressions
+
+ integer(kind=ieee_selected_real_kind()) :: i1
+ integer(kind=ieee_selected_real_kind(10)) :: i2
+ integer(kind=ieee_selected_real_kind(10,10)) :: i3
+ integer(kind=ieee_selected_real_kind(10,10,2)) :: i4
+
+ ! Test IEEE_SELECTED_REAL_KIND
+
+ if (ieee_support_datatype(0.)) then
+ if (ieee_selected_real_kind() /= kind(0.)) call abort
+ if (ieee_selected_real_kind(0) /= kind(0.)) call abort
+ if (ieee_selected_real_kind(0,0) /= kind(0.)) call abort
+ if (ieee_selected_real_kind(0,0,2) /= kind(0.)) call abort
+ end if
+
+ if (ieee_support_datatype(0.d0)) then
+ if (ieee_selected_real_kind(precision(0.)+1) /= kind(0.d0)) call abort
+ if (ieee_selected_real_kind(precision(0.),range(0.)+1) /= kind(0.d0)) call abort
+ if (ieee_selected_real_kind(precision(0.)+1,range(0.)+1) /= kind(0.d0)) call abort
+ if (ieee_selected_real_kind(precision(0.)+1,range(0.)+1,2) /= kind(0.d0)) call abort
+ end if
+
+ if (ieee_selected_real_kind(0,0,3) /= -5) call abort
+ if (ieee_selected_real_kind(precision(0.d0)+1) /= -1) call abort
+ if (ieee_selected_real_kind(0,range(0.d0)+1) /= -2) call abort
+ if (ieee_selected_real_kind(precision(0.d0)+1,range(0.d0)+1) /= -3) call abort
+
+end
--- /dev/null
+! { dg-do run }
+
+ use, intrinsic :: ieee_features, only : ieee_rounding
+ use, intrinsic :: ieee_arithmetic
+ implicit none
+
+ interface check_equal
+ procedure check_equal_float, check_equal_double
+ end interface
+
+ interface check_not_equal
+ procedure check_not_equal_float, check_not_equal_double
+ end interface
+
+ interface divide
+ procedure divide_float, divide_double
+ end interface
+
+ real :: sx1, sx2, sx3
+ double precision :: dx1, dx2, dx3
+ type(ieee_round_type) :: mode
+
+ ! We should support at least C float and C double types
+ if (ieee_support_rounding(ieee_nearest)) then
+ if (.not. ieee_support_rounding(ieee_nearest, 0.)) call abort
+ if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) call abort
+ end if
+
+ ! The initial rounding mode should probably be NEAREST
+ ! (at least on the platforms we currently support)
+ if (ieee_support_rounding(ieee_nearest, 0.)) then
+ call ieee_get_rounding_mode (mode)
+ if (mode /= ieee_nearest) call abort
+ end if
+
+
+ if (ieee_support_rounding(ieee_up, sx1) .and. &
+ ieee_support_rounding(ieee_down, sx1) .and. &
+ ieee_support_rounding(ieee_nearest, sx1) .and. &
+ ieee_support_rounding(ieee_to_zero, sx1)) then
+
+ sx1 = 1
+ sx2 = 3
+ sx1 = divide(sx1, sx2, ieee_up)
+
+ sx3 = 1
+ sx2 = 3
+ sx3 = divide(sx3, sx2, ieee_down)
+ call check_not_equal(sx1, sx3)
+ call check_equal(sx3, nearest(sx1, -1.))
+ call check_equal(sx1, nearest(sx3, 1.))
+
+ call check_equal(1./3., divide(1., 3., ieee_nearest))
+ call check_equal(-1./3., divide(-1., 3., ieee_nearest))
+
+ call check_equal(divide(3., 7., ieee_to_zero), &
+ divide(3., 7., ieee_down))
+ call check_equal(divide(-3., 7., ieee_to_zero), &
+ divide(-3., 7., ieee_up))
+
+ end if
+
+ if (ieee_support_rounding(ieee_up, dx1) .and. &
+ ieee_support_rounding(ieee_down, dx1) .and. &
+ ieee_support_rounding(ieee_nearest, dx1) .and. &
+ ieee_support_rounding(ieee_to_zero, dx1)) then
+
+ dx1 = 1
+ dx2 = 3
+ dx1 = divide(dx1, dx2, ieee_up)
+
+ dx3 = 1
+ dx2 = 3
+ dx3 = divide(dx3, dx2, ieee_down)
+ call check_not_equal(dx1, dx3)
+ call check_equal(dx3, nearest(dx1, -1.d0))
+ call check_equal(dx1, nearest(dx3, 1.d0))
+
+ call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest))
+ call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest))
+
+ call check_equal(divide(3.d0, 7.d0, ieee_to_zero), &
+ divide(3.d0, 7.d0, ieee_down))
+ call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), &
+ divide(-3.d0, 7.d0, ieee_up))
+
+ end if
+
+contains
+
+ real function divide_float (x, y, rounding) result(res)
+ use, intrinsic :: ieee_arithmetic
+ real, intent(in) :: x, y
+ type(ieee_round_type), intent(in) :: rounding
+ type(ieee_round_type) :: old
+
+ call ieee_get_rounding_mode (old)
+ call ieee_set_rounding_mode (rounding)
+
+ res = x / y
+
+ call ieee_set_rounding_mode (old)
+ end function
+
+ double precision function divide_double (x, y, rounding) result(res)
+ use, intrinsic :: ieee_arithmetic
+ double precision, intent(in) :: x, y
+ type(ieee_round_type), intent(in) :: rounding
+ type(ieee_round_type) :: old
+
+ call ieee_get_rounding_mode (old)
+ call ieee_set_rounding_mode (rounding)
+
+ res = x / y
+
+ call ieee_set_rounding_mode (old)
+ end function
+
+ subroutine check_equal_float (x, y)
+ real, intent(in) :: x, y
+ if (x /= y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+ subroutine check_equal_double (x, y)
+ double precision, intent(in) :: x, y
+ if (x /= y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+ subroutine check_not_equal_float (x, y)
+ real, intent(in) :: x, y
+ if (x == y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+ subroutine check_not_equal_double (x, y)
+ double precision, intent(in) :: x, y
+ if (x == y) then
+ print *, x, y
+ call abort
+ end if
+ end subroutine
+
+end
}
+# Return 1 if the target supports Fortran's IEEE modules,
+# 0 otherwise.
+#
+# When the target name changes, replace the cached result.
+
+proc check_effective_target_fortran_ieee { flags } {
+ return [check_no_compiler_messages fortran_ieee executable {
+ ! Fortran
+ use, intrinsic :: ieee_features
+ end
+ } $flags ]
+}
+
+
# Return 1 if the target supports SQRT for the largest floating-point
# type. (Some targets lack the libm support for this FP type.)
# On most targets, this check effectively checks either whether sqrtl is
+2014-06-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/29383
+ * configure.host: Add checks for IEEE support, rework priorities.
+ * configure.ac: Define IEEE_SUPPORT, check for fpsetsticky and
+ fpresetsticky.
+ * configure: Regenerate.
+ * Makefile.am: Build new ieee files, install IEEE_* modules.
+ * Makefile.in: Regenerate.
+ * gfortran.map (GFORTRAN_1.6): Add new symbols.
+ * libgfortran.h (get_fpu_trap_exceptions, set_fpu_trap_exceptions,
+ support_fpu_trap, set_fpu_except_flags, support_fpu_flag,
+ support_fpu_rounding_mode, get_fpu_state, set_fpu_state): New
+ prototypes.
+ * config/fpu-*.h (get_fpu_trap_exceptions,
+ set_fpu_trap_exceptions, support_fpu_trap, set_fpu_except_flags,
+ support_fpu_flag, support_fpu_rounding_mode, get_fpu_state,
+ set_fpu_state): New functions.
+ * ieee/ieee_features.F90: New file.
+ * ieee/ieee_exceptions.F90: New file.
+ * ieee/ieee_arithmetic.F90: New file.
+ * ieee/ieee_helper.c: New file.
+
2014-06-26 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/61499
libcaf_single_la_DEPENDENCIES = caf/libcaf.h
libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
+if IEEE_SUPPORT
+fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
+nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod
+endif
+
## io.h conflicts with a system header on some platforms, so
## use -iquote
AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
# Some targets require additional compiler options for IEEE compatibility.
AM_CFLAGS += $(IEEE_FLAGS)
+AM_FCFLAGS += $(IEEE_FLAGS)
gfor_io_src= \
io/close.c \
runtime/in_pack_generic.c \
runtime/in_unpack_generic.c
+if IEEE_SUPPORT
+
+gfor_helper_src+=ieee/ieee_helper.c
+
+gfor_ieee_src= \
+ieee/ieee_arithmetic.F90 \
+ieee/ieee_exceptions.F90 \
+ieee/ieee_features.F90
+
+else
+
+gfor_ieee_src=
+
+endif
+
gfor_src= \
runtime/backtrace.c \
runtime/bounds.c \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
$(i_pow_c) $(i_rrspacing_c) $(i_spacing_c) $(i_pack_c) $(i_unpack_c) \
$(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \
- $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h
+ $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc
# Machine generated specifics
gfor_built_specific_src= \
$(patsubst %.F90,%.lo,$(patsubst %.f90,%.lo,$(notdir $(gfor_specific_src)))): AM_FCFLAGS += -fallow-leading-underscore
selected_real_kind.lo selected_int_kind.lo: AM_FCFLAGS += -fallow-leading-underscore
+if IEEE_SUPPORT
+# Add flags for IEEE modules
+$(patsubst %.F90,%.lo,$(notdir $(gfor_ieee_src))): AM_FCFLAGS += -Wno-unused-dummy-argument -Wno-c-binding-type -ffree-line-length-0 -fallow-leading-underscore
+endif
+
+# Dependencies between IEEE_ARITHMETIC and IEEE_EXCEPTIONS
+ieee_arithmetic.lo: ieee/ieee_arithmetic.F90 ieee_exceptions.lo
+ $(LTPPFCCOMPILE) -c -o $@ $<
+
+ieee_features.mod: ieee_features.lo
+ :
+ieee_exceptions.mod: ieee_exceptions.lo
+ :
+ieee_arithmetic.mod: ieee_arithmetic.lo
+ :
+
BUILT_SOURCES=$(gfor_built_src) $(gfor_built_specific_src) \
$(gfor_built_specific2_src) $(gfor_misc_specifics)
prereq_SRC = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \
- $(gfor_helper_src) $(gfor_io_headers) $(gfor_specific_src)
+ $(gfor_helper_src) $(gfor_ieee_src) $(gfor_io_headers) $(gfor_specific_src)
if onestep
# dummy sources for libtool
fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER)
cp $(srcdir)/$(FPU_HOST_HEADER) $@
+fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h
+ grep '^#define GFC_FPE_' < $(top_srcdir)/../gcc/fortran/libgfortran.h > $@ || true
+ grep '^#define GFC_FPE_' < $(srcdir)/libgfortran.h >> $@ || true
+
## A 'normal' build shouldn't need to regenerate these
## so we only include them in maintainer mode
@SET_MAKE@
+
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
build_triplet = @build@
host_triplet = @host@
target_triplet = @target@
+@IEEE_SUPPORT_TRUE@am__append_1 = ieee/ieee_helper.c
# dummy sources for libtool
-@onestep_TRUE@am__append_1 = libgfortran_c.c libgfortran_f.f90
+@onestep_TRUE@am__append_2 = libgfortran_c.c libgfortran_f.f90
subdir = .
DIST_COMMON = ChangeLog $(srcdir)/Makefile.in $(srcdir)/Makefile.am \
$(top_srcdir)/configure $(am__configure_deps) \
}
am__installdirs = "$(DESTDIR)$(cafexeclibdir)" \
"$(DESTDIR)$(myexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \
- "$(DESTDIR)$(toolexeclibdir)"
+ "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(fincludedir)"
LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(myexeclib_LTLIBRARIES) \
$(toolexeclib_LTLIBRARIES)
libcaf_single_la_LIBADD =
intrinsics.lo list_read.lo lock.lo open.lo read.lo \
size_from_kind.lo transfer.lo transfer128.lo unit.lo unix.lo \
write.lo fbuf.lo
-am__objects_42 = associated.lo abort.lo access.lo args.lo \
+@IEEE_SUPPORT_TRUE@am__objects_42 = ieee_helper.lo
+am__objects_43 = associated.lo abort.lo access.lo args.lo \
bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo \
selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
system_clock.lo time.lo transpose_generic.lo umask.lo \
unlink.lo unpack_generic.lo in_pack_generic.lo \
- in_unpack_generic.lo
-am__objects_43 =
-am__objects_44 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
+ in_unpack_generic.lo $(am__objects_42)
+@IEEE_SUPPORT_TRUE@am__objects_44 = ieee_arithmetic.lo \
+@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
+am__objects_45 =
+am__objects_46 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \
_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \
_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \
_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \
_anint_r8.lo _anint_r10.lo _anint_r16.lo
-am__objects_45 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
+am__objects_47 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \
_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \
_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \
_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
_mod_r10.lo _mod_r16.lo
-am__objects_46 = misc_specifics.lo
-am__objects_47 = $(am__objects_44) $(am__objects_45) $(am__objects_46) \
+am__objects_48 = misc_specifics.lo
+am__objects_49 = $(am__objects_46) $(am__objects_47) $(am__objects_48) \
dprod_r8.lo f2c_specifics.lo
-am__objects_48 = $(am__objects_1) $(am__objects_40) $(am__objects_41) \
- $(am__objects_42) $(am__objects_43) $(am__objects_47)
-@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_48)
+am__objects_50 = $(am__objects_1) $(am__objects_40) $(am__objects_41) \
+ $(am__objects_43) $(am__objects_44) $(am__objects_45) \
+ $(am__objects_49)
+@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_50)
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
libgfortranbegin_la_LIBADD =
MULTIDO = true
MULTICLEAN = true
DATA = $(toolexeclib_DATA)
+HEADERS = $(nodist_finclude_HEADERS)
ETAGS = etags
CTAGS = ctags
ACLOCAL = @ACLOCAL@
# Some targets require additional compiler options for IEEE compatibility.
AM_CFLAGS = @AM_CFLAGS@ -fcx-fortran-rules $(SECTION_FLAGS) \
$(IEEE_FLAGS)
-AM_FCFLAGS = @AM_FCFLAGS@
+AM_FCFLAGS = @AM_FCFLAGS@ $(IEEE_FLAGS)
AR = @AR@
AS = @AS@
AUTOCONF = @AUTOCONF@
FPU_HOST_HEADER = @FPU_HOST_HEADER@
GREP = @GREP@
IEEE_FLAGS = @IEEE_FLAGS@
+IEEE_SUPPORT = @IEEE_SUPPORT@
INSTALL = @INSTALL@
INSTALL_DATA = @INSTALL_DATA@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
libcaf_single_la_LDFLAGS = -static
libcaf_single_la_DEPENDENCIES = caf/libcaf.h
libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
+@IEEE_SUPPORT_TRUE@fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
+@IEEE_SUPPORT_TRUE@nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod
AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
-I$(srcdir)/$(MULTISRCTOP)../gcc/config $(LIBQUADINCLUDE) \
-I$(MULTIBUILDTOP)../../$(host_subdir)/gcc \
io/format.h \
io/unix.h
-gfor_helper_src = \
-intrinsics/associated.c \
-intrinsics/abort.c \
-intrinsics/access.c \
-intrinsics/args.c \
-intrinsics/bit_intrinsics.c \
-intrinsics/c99_functions.c \
-intrinsics/chdir.c \
-intrinsics/chmod.c \
-intrinsics/clock.c \
-intrinsics/cpu_time.c \
-intrinsics/cshift0.c \
-intrinsics/ctime.c \
-intrinsics/date_and_time.c \
-intrinsics/dtime.c \
-intrinsics/env.c \
-intrinsics/eoshift0.c \
-intrinsics/eoshift2.c \
-intrinsics/erfc_scaled.c \
-intrinsics/etime.c \
-intrinsics/execute_command_line.c \
-intrinsics/exit.c \
-intrinsics/extends_type_of.c \
-intrinsics/fnum.c \
-intrinsics/gerror.c \
-intrinsics/getcwd.c \
-intrinsics/getlog.c \
-intrinsics/getXid.c \
-intrinsics/hostnm.c \
-intrinsics/ierrno.c \
-intrinsics/ishftc.c \
-intrinsics/iso_c_generated_procs.c \
-intrinsics/iso_c_binding.c \
-intrinsics/kill.c \
-intrinsics/link.c \
-intrinsics/malloc.c \
-intrinsics/mvbits.c \
-intrinsics/move_alloc.c \
-intrinsics/pack_generic.c \
-intrinsics/perror.c \
-intrinsics/selected_char_kind.c \
-intrinsics/signal.c \
-intrinsics/size.c \
-intrinsics/sleep.c \
-intrinsics/spread_generic.c \
-intrinsics/string_intrinsics.c \
-intrinsics/system.c \
-intrinsics/rand.c \
-intrinsics/random.c \
-intrinsics/rename.c \
-intrinsics/reshape_generic.c \
-intrinsics/reshape_packed.c \
-intrinsics/selected_int_kind.f90 \
-intrinsics/selected_real_kind.f90 \
-intrinsics/stat.c \
-intrinsics/symlnk.c \
-intrinsics/system_clock.c \
-intrinsics/time.c \
-intrinsics/transpose_generic.c \
-intrinsics/umask.c \
-intrinsics/unlink.c \
-intrinsics/unpack_generic.c \
-runtime/in_pack_generic.c \
-runtime/in_unpack_generic.c
+gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
+ intrinsics/access.c intrinsics/args.c \
+ intrinsics/bit_intrinsics.c intrinsics/c99_functions.c \
+ intrinsics/chdir.c intrinsics/chmod.c intrinsics/clock.c \
+ intrinsics/cpu_time.c intrinsics/cshift0.c intrinsics/ctime.c \
+ intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \
+ intrinsics/eoshift0.c intrinsics/eoshift2.c \
+ intrinsics/erfc_scaled.c intrinsics/etime.c \
+ intrinsics/execute_command_line.c intrinsics/exit.c \
+ intrinsics/extends_type_of.c intrinsics/fnum.c \
+ intrinsics/gerror.c intrinsics/getcwd.c intrinsics/getlog.c \
+ intrinsics/getXid.c intrinsics/hostnm.c intrinsics/ierrno.c \
+ intrinsics/ishftc.c intrinsics/iso_c_generated_procs.c \
+ intrinsics/iso_c_binding.c intrinsics/kill.c intrinsics/link.c \
+ intrinsics/malloc.c intrinsics/mvbits.c \
+ intrinsics/move_alloc.c intrinsics/pack_generic.c \
+ intrinsics/perror.c intrinsics/selected_char_kind.c \
+ intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
+ intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
+ intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
+ intrinsics/rename.c intrinsics/reshape_generic.c \
+ intrinsics/reshape_packed.c intrinsics/selected_int_kind.f90 \
+ intrinsics/selected_real_kind.f90 intrinsics/stat.c \
+ intrinsics/symlnk.c intrinsics/system_clock.c \
+ intrinsics/time.c intrinsics/transpose_generic.c \
+ intrinsics/umask.c intrinsics/unlink.c \
+ intrinsics/unpack_generic.c runtime/in_pack_generic.c \
+ runtime/in_unpack_generic.c $(am__append_1)
+@IEEE_SUPPORT_FALSE@gfor_ieee_src =
+@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
+@IEEE_SUPPORT_TRUE@ieee/ieee_arithmetic.F90 \
+@IEEE_SUPPORT_TRUE@ieee/ieee_exceptions.F90 \
+@IEEE_SUPPORT_TRUE@ieee/ieee_features.F90
gfor_src = \
runtime/backtrace.c \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
$(i_pow_c) $(i_rrspacing_c) $(i_spacing_c) $(i_pack_c) $(i_unpack_c) \
$(i_spread_c) selected_int_kind.inc selected_real_kind.inc kinds.h \
- $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h
+ $(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc
# Machine generated specifics
BUILT_SOURCES = $(gfor_built_src) $(gfor_built_specific_src) \
$(gfor_built_specific2_src) $(gfor_misc_specifics) \
- $(am__append_1)
+ $(am__append_2)
prereq_SRC = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \
- $(gfor_helper_src) $(gfor_io_headers) $(gfor_specific_src)
+ $(gfor_helper_src) $(gfor_ieee_src) $(gfor_io_headers) $(gfor_specific_src)
@onestep_FALSE@libgfortran_la_SOURCES = $(prereq_SRC)
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i2.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i8.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ieee_helper.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ierrno.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/in_pack_c10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/in_pack_c16.Plo@am__quote@
.F90.lo:
$(LTPPFCCOMPILE) -c -o $@ $<
+ieee_exceptions.lo: ieee/ieee_exceptions.F90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o ieee_exceptions.lo `test -f 'ieee/ieee_exceptions.F90' || echo '$(srcdir)/'`ieee/ieee_exceptions.F90
+
+ieee_features.lo: ieee/ieee_features.F90
+ $(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o ieee_features.lo `test -f 'ieee/ieee_features.F90' || echo '$(srcdir)/'`ieee/ieee_features.F90
+
_abs_c4.lo: $(srcdir)/generated/_abs_c4.F90
$(LIBTOOL) --tag=FC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o _abs_c4.lo `test -f '$(srcdir)/generated/_abs_c4.F90' || echo '$(srcdir)/'`$(srcdir)/generated/_abs_c4.F90
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_unpack_generic.lo `test -f 'runtime/in_unpack_generic.c' || echo '$(srcdir)/'`runtime/in_unpack_generic.c
+ieee_helper.lo: ieee/ieee_helper.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT ieee_helper.lo -MD -MP -MF $(DEPDIR)/ieee_helper.Tpo -c -o ieee_helper.lo `test -f 'ieee/ieee_helper.c' || echo '$(srcdir)/'`ieee/ieee_helper.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/ieee_helper.Tpo $(DEPDIR)/ieee_helper.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='ieee/ieee_helper.c' object='ieee_helper.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ieee_helper.lo `test -f 'ieee/ieee_helper.c' || echo '$(srcdir)/'`ieee/ieee_helper.c
+
.f90.o:
$(FCCOMPILE) -c -o $@ $<
@list='$(toolexeclib_DATA)'; test -n "$(toolexeclibdir)" || list=; \
files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
dir='$(DESTDIR)$(toolexeclibdir)'; $(am__uninstall_files_from_dir)
+install-nodist_fincludeHEADERS: $(nodist_finclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ test -z "$(fincludedir)" || $(MKDIR_P) "$(DESTDIR)$(fincludedir)"
+ @list='$(nodist_finclude_HEADERS)'; test -n "$(fincludedir)" || list=; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(fincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(fincludedir)" || exit $$?; \
+ done
+
+uninstall-nodist_fincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(nodist_finclude_HEADERS)'; test -n "$(fincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ dir='$(DESTDIR)$(fincludedir)'; $(am__uninstall_files_from_dir)
ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
check-am: all-am
check: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) check-am
-all-am: Makefile $(LTLIBRARIES) all-multi $(DATA) config.h
+all-am: Makefile $(LTLIBRARIES) all-multi $(DATA) $(HEADERS) config.h
installdirs:
- for dir in "$(DESTDIR)$(cafexeclibdir)" "$(DESTDIR)$(myexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)"; do \
+ for dir in "$(DESTDIR)$(cafexeclibdir)" "$(DESTDIR)$(myexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(fincludedir)"; do \
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
done
install: $(BUILT_SOURCES)
info-am:
-install-data-am:
+install-data-am: install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
ps-am:
uninstall-am: uninstall-cafexeclibLTLIBRARIES \
- uninstall-myexeclibLTLIBRARIES uninstall-toolexeclibDATA \
+ uninstall-myexeclibLTLIBRARIES \
+ uninstall-nodist_fincludeHEADERS uninstall-toolexeclibDATA \
uninstall-toolexeclibLTLIBRARIES
.MAKE: all all-multi check clean-multi distclean-multi install \
install-data install-data-am install-dvi install-dvi-am \
install-exec install-exec-am install-html install-html-am \
install-info install-info-am install-man install-multi \
- install-myexeclibLTLIBRARIES install-pdf install-pdf-am \
- install-ps install-ps-am install-strip install-toolexeclibDATA \
+ install-myexeclibLTLIBRARIES install-nodist_fincludeHEADERS \
+ install-pdf install-pdf-am install-ps install-ps-am \
+ install-strip install-toolexeclibDATA \
install-toolexeclibLTLIBRARIES installcheck installcheck-am \
installdirs maintainer-clean maintainer-clean-generic \
maintainer-clean-multi mostlyclean mostlyclean-compile \
mostlyclean-generic mostlyclean-libtool mostlyclean-multi pdf \
pdf-am ps ps-am tags uninstall uninstall-am \
uninstall-cafexeclibLTLIBRARIES uninstall-myexeclibLTLIBRARIES \
- uninstall-toolexeclibDATA uninstall-toolexeclibLTLIBRARIES
+ uninstall-nodist_fincludeHEADERS uninstall-toolexeclibDATA \
+ uninstall-toolexeclibLTLIBRARIES
@LIBGFOR_USE_SYMVER_SUN_TRUE@@LIBGFOR_USE_SYMVER_TRUE@gfortran.map-sun : $(srcdir)/gfortran.map \
@LIBGFOR_USE_SYMVER_SUN_TRUE@@LIBGFOR_USE_SYMVER_TRUE@ $(top_srcdir)/../contrib/make_sunver.pl \
# Add the -fallow-leading-underscore option when needed
$(patsubst %.F90,%.lo,$(patsubst %.f90,%.lo,$(notdir $(gfor_specific_src)))): AM_FCFLAGS += -fallow-leading-underscore
selected_real_kind.lo selected_int_kind.lo: AM_FCFLAGS += -fallow-leading-underscore
+
+# Add flags for IEEE modules
+@IEEE_SUPPORT_TRUE@$(patsubst %.F90,%.lo,$(notdir $(gfor_ieee_src))): AM_FCFLAGS += -Wno-unused-dummy-argument -Wno-c-binding-type -ffree-line-length-0 -fallow-leading-underscore
+
+# Dependencies between IEEE_ARITHMETIC and IEEE_EXCEPTIONS
+ieee_arithmetic.lo: ieee/ieee_arithmetic.F90 ieee_exceptions.lo
+ $(LTPPFCCOMPILE) -c -o $@ $<
+
+ieee_features.mod: ieee_features.lo
+ :
+ieee_exceptions.mod: ieee_exceptions.lo
+ :
+ieee_arithmetic.mod: ieee_arithmetic.lo
+ :
@onestep_TRUE@libgfortran_c.c libgfortran_f.f90 libgfortran_F.F90:
@onestep_TRUE@ echo > $@
# overrides for libtool perusing the dummy sources
fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER)
cp $(srcdir)/$(FPU_HOST_HEADER) $@
+fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h
+ grep '^#define GFC_FPE_' < $(top_srcdir)/../gcc/fortran/libgfortran.h > $@ || true
+ grep '^#define GFC_FPE_' < $(srcdir)/libgfortran.h >> $@ || true
+
@MAINTAINER_MODE_TRUE@$(i_all_c): m4/all.m4 $(I_M4_DEPS2)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 all.m4 > $@
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
+#include <assert.h>
+
#ifndef __SSE_MATH__
#include "cpuid.h"
#endif
#define _FPU_RC_MASK 0x3
+/* This structure corresponds to the layout of the block
+ written by FSTENV. */
+typedef struct
+{
+ unsigned short int __control_word;
+ unsigned short int __unused1;
+ unsigned short int __status_word;
+ unsigned short int __unused2;
+ unsigned short int __tags;
+ unsigned short int __unused3;
+ unsigned int __eip;
+ unsigned short int __cs_selector;
+ unsigned int __opcode:11;
+ unsigned int __unused4:5;
+ unsigned int __data_offset;
+ unsigned short int __data_selector;
+ unsigned short int __unused5;
+ unsigned int __mxcsr;
+}
+my_fenv_t;
+
+
+/* Raise the supported floating-point exceptions from EXCEPTS. Other
+ bits in EXCEPTS are ignored. Code originally borrowed from
+ libatomic/config/x86/fenv.c. */
+
+static void
+local_feraiseexcept (int excepts)
+{
+ if (excepts & _FPU_MASK_IM)
+ {
+ float f = 0.0f;
+#ifdef __SSE_MATH__
+ volatile float r __attribute__ ((unused));
+ __asm__ __volatile__ ("%vdivss\t{%0, %d0|%d0, %0}" : "+x" (f));
+ r = f; /* Needed to trigger exception. */
+#else
+ __asm__ __volatile__ ("fdiv\t{%y0, %0|%0, %y0}" : "+t" (f));
+ /* No need for fwait, exception is triggered by emitted fstp. */
+#endif
+ }
+ if (excepts & _FPU_MASK_DM)
+ {
+ my_fenv_t temp;
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word |= _FPU_MASK_DM;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+ __asm__ __volatile__ ("fwait");
+ }
+ if (excepts & _FPU_MASK_ZM)
+ {
+ float f = 1.0f, g = 0.0f;
+#ifdef __SSE_MATH__
+ volatile float r __attribute__ ((unused));
+ __asm__ __volatile__ ("%vdivss\t{%1, %d0|%d0, %1}" : "+x" (f) : "xm" (g));
+ r = f; /* Needed to trigger exception. */
+#else
+ __asm__ __volatile__ ("fdivs\t%1" : "+t" (f) : "m" (g));
+ /* No need for fwait, exception is triggered by emitted fstp. */
+#endif
+ }
+ if (excepts & _FPU_MASK_OM)
+ {
+ my_fenv_t temp;
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word |= _FPU_MASK_OM;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+ __asm__ __volatile__ ("fwait");
+ }
+ if (excepts & _FPU_MASK_UM)
+ {
+ my_fenv_t temp;
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word |= _FPU_MASK_UM;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+ __asm__ __volatile__ ("fwait");
+ }
+ if (excepts & _FPU_MASK_PM)
+ {
+ float f = 1.0f, g = 3.0f;
+#ifdef __SSE_MATH__
+ volatile float r __attribute__ ((unused));
+ __asm__ __volatile__ ("%vdivss\t{%1, %d0|%d0, %1}" : "+x" (f) : "xm" (g));
+ r = f; /* Needed to trigger exception. */
+#else
+ __asm__ __volatile__ ("fdivs\t%1" : "+t" (f) : "m" (g));
+ /* No need for fwait, exception is triggered by emitted fstp. */
+#endif
+ }
+}
+
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int excepts = 0;
+ int exc_set = 0, exc_clr = 0;
unsigned short cw;
- __asm__ __volatile__ ("fstcw\t%0" : "=m" (cw));
+ if (trap & GFC_FPE_INVALID) exc_set |= _FPU_MASK_IM;
+ if (trap & GFC_FPE_DENORMAL) exc_set |= _FPU_MASK_DM;
+ if (trap & GFC_FPE_ZERO) exc_set |= _FPU_MASK_ZM;
+ if (trap & GFC_FPE_OVERFLOW) exc_set |= _FPU_MASK_OM;
+ if (trap & GFC_FPE_UNDERFLOW) exc_set |= _FPU_MASK_UM;
+ if (trap & GFC_FPE_INEXACT) exc_set |= _FPU_MASK_PM;
+
+ if (notrap & GFC_FPE_INVALID) exc_clr |= _FPU_MASK_IM;
+ if (notrap & GFC_FPE_DENORMAL) exc_clr |= _FPU_MASK_DM;
+ if (notrap & GFC_FPE_ZERO) exc_clr |= _FPU_MASK_ZM;
+ if (notrap & GFC_FPE_OVERFLOW) exc_clr |= _FPU_MASK_OM;
+ if (notrap & GFC_FPE_UNDERFLOW) exc_clr |= _FPU_MASK_UM;
+ if (notrap & GFC_FPE_INEXACT) exc_clr |= _FPU_MASK_PM;
- if (options.fpe & GFC_FPE_INVALID) excepts |= _FPU_MASK_IM;
- if (options.fpe & GFC_FPE_DENORMAL) excepts |= _FPU_MASK_DM;
- if (options.fpe & GFC_FPE_ZERO) excepts |= _FPU_MASK_ZM;
- if (options.fpe & GFC_FPE_OVERFLOW) excepts |= _FPU_MASK_OM;
- if (options.fpe & GFC_FPE_UNDERFLOW) excepts |= _FPU_MASK_UM;
- if (options.fpe & GFC_FPE_INEXACT) excepts |= _FPU_MASK_PM;
+ __asm__ __volatile__ ("fstcw\t%0" : "=m" (cw));
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
+ cw |= exc_clr;
+ cw &= ~exc_set;
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
__asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
/* The SSE exception masks are shifted by 7 bits. */
- cw_sse |= _FPU_MASK_ALL << 7;
- cw_sse &= ~(excepts << 7);
+ cw_sse |= (exc_clr << 7);
+ cw_sse &= ~(exc_set << 7);
/* Clear stalled exception flags. */
cw_sse &= ~_FPU_EX_ALL;
}
}
+void
+set_fpu (void)
+{
+ set_fpu_trap_exceptions (options.fpe, 0);
+}
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ unsigned short cw;
+
+ __asm__ __volatile__ ("fstcw\t%0" : "=m" (cw));
+ cw &= _FPU_MASK_ALL;
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+
+ /* The SSE exception masks are shifted by 7 bits. */
+ cw = cw | ((cw_sse >> 7) & _FPU_MASK_ALL);
+ }
+
+ if (~cw & _FPU_MASK_IM) res |= GFC_FPE_INVALID;
+ if (~cw & _FPU_MASK_DM) res |= GFC_FPE_DENORMAL;
+ if (~cw & _FPU_MASK_ZM) res |= GFC_FPE_ZERO;
+ if (~cw & _FPU_MASK_OM) res |= GFC_FPE_OVERFLOW;
+ if (~cw & _FPU_MASK_UM) res |= GFC_FPE_UNDERFLOW;
+ if (~cw & _FPU_MASK_PM) res |= GFC_FPE_INEXACT;
+
+ return res;
+}
+
+int
+support_fpu_trap (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
int
get_fpu_except_flags (void)
{
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
return result;
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
void
set_fpu_rounding_mode (int round)
{
return GFC_FPE_INVALID; /* Should be unreachable. */
}
}
+
+int
+support_fpu_rounding_mode (int mode __attribute__((unused)))
+{
+ return 1;
+}
+
+void
+get_fpu_state (void *state)
+{
+ my_fenv_t *envp = state;
+
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(my_fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE);
+
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (*envp));
+
+ /* fnstenv has the side effect of masking all exceptions, so we need
+ to restore the control word after that. */
+ __asm__ __volatile__ ("fldcw\t%0" : : "m" (envp->__control_word));
+
+ if (has_sse())
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (envp->__mxcsr));
+}
+
+void
+set_fpu_state (void *state)
+{
+ my_fenv_t *envp = state;
+
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(my_fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE);
+
+ /* glibc sources (sysdeps/x86_64/fpu/fesetenv.c) do something more
+ complex than this, but I think it suffices in our case. */
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (*envp));
+
+ if (has_sse())
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (envp->__mxcsr));
+}
+
#include <fpxcp.h>
#endif
+#ifdef HAVE_FENV_H
+#include <fenv.h>
+#endif
+
+
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- fptrap_t mode = 0;
+ fptrap_t mode_set = 0, mode_clr = 0;
- if (options.fpe & GFC_FPE_INVALID)
#ifdef TRP_INVALID
- mode |= TRP_INVALID;
-#else
+ if (trap & GFC_FPE_INVALID)
+ mode_set |= TRP_INVALID;
+ if (notrap & GFC_FPE_INVALID)
+ mode_clr |= TRP_INVALID;
+#endif
+
+#ifdef TRP_DIV_BY_ZERO
+ if (trap & GFC_FPE_ZERO)
+ mode_set |= TRP_DIV_BY_ZERO;
+ if (notrap & GFC_FPE_ZERO)
+ mode_clr |= TRP_DIV_BY_ZERO;
+#endif
+
+#ifdef TRP_OVERFLOW
+ if (trap & GFC_FPE_OVERFLOW)
+ mode_set |= TRP_OVERFLOW;
+ if (notrap & GFC_FPE_OVERFLOW)
+ mode_clr |= TRP_OVERFLOW;
+#endif
+
+#ifdef TRP_UNDERFLOW
+ if (trap & GFC_FPE_UNDERFLOW)
+ mode_set |= TRP_UNDERFLOW;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ mode_clr |= TRP_UNDERFLOW;
+#endif
+
+#ifdef TRP_INEXACT
+ if (trap & GFC_FPE_INEXACT)
+ mode_set |= TRP_INEXACT;
+ if (notrap & GFC_FPE_INEXACT)
+ mode_clr |= TRP_INEXACT;
+#endif
+
+ fp_trap (FP_TRAP_SYNC);
+ fp_enable (mode_set);
+ fp_disable (mode_clr);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+
+#ifdef TRP_INVALID
+ if (fp_is_enabled (TRP_INVALID))
+ res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef TRP_DIV_BY_ZERO
+ if (fp_is_enabled (TRP_DIV_BY_ZERO))
+ res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef TRP_OVERFLOW
+ if (fp_is_enabled (TRP_OVERFLOW))
+ res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef TRP_UNDERFLOW
+ if (fp_is_enabled (TRP_UNDERFLOW))
+ res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef TRP_INEXACT
+ if (fp_is_enabled (TRP_INEXACT))
+ res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef TRP_INVALID
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
+#ifndef TRP_DIV_BY_ZERO
if (options.fpe & GFC_FPE_ZERO)
-#ifdef TRP_DIV_BY_ZERO
- mode |= TRP_DIV_BY_ZERO;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef TRP_OVERFLOW
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef TRP_OVERFLOW
- mode |= TRP_OVERFLOW;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef TRP_UNDERFLOW
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef TRP_UNDERFLOW
- mode |= TRP_UNDERFLOW;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef TRP_INEXACT
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef TRP_INEXACT
- mode |= TRP_INEXACT;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fp_trap(FP_TRAP_SYNC);
- fp_enable(mode);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
-
int
get_fpu_except_flags (void)
{
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+ int exc_set = 0, exc_clr = 0;
+
+#ifdef FP_INVALID
+ if (set & GFC_FPE_INVALID)
+ exc_set |= FP_INVALID;
+ else if (clear & GFC_FPE_INVALID)
+ exc_clr |= FP_INVALID;
+#endif
+
+#ifdef FP_DIV_BY_ZERO
+ if (set & GFC_FPE_ZERO)
+ exc_set |= FP_DIV_BY_ZERO;
+ else if (clear & GFC_FPE_ZERO)
+ exc_clr |= FP_DIV_BY_ZERO;
+#endif
+
+#ifdef FP_OVERFLOW
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= FP_OVERFLOW;
+ else if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= FP_OVERFLOW;
+#endif
+
+#ifdef FP_UNDERFLOW
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= FP_UNDERFLOW;
+ else if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= FP_UNDERFLOW;
+#endif
+
+/* AIX does not have FP_DENORMAL. */
+
+#ifdef FP_INEXACT
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= FP_INEXACT;
+ else if (clear & GFC_FPE_INEXACT)
+ exc_clr |= FP_INEXACT;
+#endif
+
+ fp_clr_flag (exc_clr);
+ fp_set_flag (exc_set);
+}
+
+
+int
+support_fpu_flag (int flag)
+{
+ if (flag & GFC_FPE_INVALID)
+ {
+#ifndef FP_INVALID
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_ZERO)
+ {
+#ifndef FP_DIV_BY_ZERO
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_OVERFLOW)
+ {
+#ifndef FP_OVERFLOW
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_UNDERFLOW)
+ {
+#ifndef FP_UNDERFLOW
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_DENORMAL)
+ {
+ /* AIX does not support denormal flag. */
+ return 0;
+ }
+ else if (flag & GFC_FPE_INEXACT)
+ {
+#ifndef FP_INEXACT
+ return 0;
+#endif
+ }
+
+ return 1;
+}
+
+
+
+
int
get_fpu_rounding_mode (void)
{
fesetround (rnd_mode);
}
+
+
+int
+support_fpu_rounding_mode (int mode)
+{
+ switch (mode)
+ {
+ case GFC_FPE_TONEAREST:
+#ifdef FE_TONEAREST
+ return 1;
+#else
+ return 0;
+#endif
+
+#ifdef FE_UPWARD
+ return 1;
+#else
+ return 0;
+#endif
+
+#ifdef FE_DOWNWARD
+ return 1;
+#else
+ return 0;
+#endif
+
+#ifdef FE_TOWARDZERO
+ return 1;
+#else
+ return 0;
+#endif
+
+ default:
+ return 0;
+ }
+}
+
+
+
+void
+get_fpu_state (void *state)
+{
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(fenv_t) <= GFC_FPE_STATE_BUFFER_SIZE);
+
+ fegetenv (state);
+}
+
+void
+set_fpu_state (void *state)
+{
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(fenv_t) <= GFC_FPE_STATE_BUFFER_SIZE);
+
+ fesetenv (state);
+}
+
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
feenableexcept function in fenv.h to set individual exceptions
(there's nothing to do that in C99). */
+#include <assert.h>
+
#ifdef HAVE_FENV_H
#include <fenv.h>
#endif
-void set_fpu (void)
-{
- if (FE_ALL_EXCEPT != 0)
- fedisableexcept (FE_ALL_EXCEPT);
- if (options.fpe & GFC_FPE_INVALID)
+void set_fpu_trap_exceptions (int trap, int notrap)
+{
#ifdef FE_INVALID
+ if (trap & GFC_FPE_INVALID)
feenableexcept (FE_INVALID);
-#else
+ if (notrap & GFC_FPE_INVALID)
+ fedisableexcept (FE_INVALID);
+#endif
+
+/* glibc does never have a FE_DENORMAL. */
+#ifdef FE_DENORMAL
+ if (trap & GFC_FPE_DENORMAL)
+ feenableexcept (FE_DENORMAL);
+ if (notrap & GFC_FPE_DENORMAL)
+ fedisableexcept (FE_DENORMAL);
+#endif
+
+#ifdef FE_DIVBYZERO
+ if (trap & GFC_FPE_ZERO)
+ feenableexcept (FE_DIVBYZERO);
+ if (notrap & GFC_FPE_ZERO)
+ fedisableexcept (FE_DIVBYZERO);
+#endif
+
+#ifdef FE_OVERFLOW
+ if (trap & GFC_FPE_OVERFLOW)
+ feenableexcept (FE_OVERFLOW);
+ if (notrap & GFC_FPE_OVERFLOW)
+ fedisableexcept (FE_OVERFLOW);
+#endif
+
+#ifdef FE_UNDERFLOW
+ if (trap & GFC_FPE_UNDERFLOW)
+ feenableexcept (FE_UNDERFLOW);
+ if (notrap & GFC_FPE_UNDERFLOW)
+ fedisableexcept (FE_UNDERFLOW);
+#endif
+
+#ifdef FE_INEXACT
+ if (trap & GFC_FPE_INEXACT)
+ feenableexcept (FE_INEXACT);
+ if (notrap & GFC_FPE_INEXACT)
+ fedisableexcept (FE_INEXACT);
+#endif
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int exceptions = fegetexcept ();
+ int res = 0;
+
+#ifdef FE_INVALID
+ if (exceptions & FE_INVALID) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FE_DENORMAL
+ if (exceptions & FE_DENORMAL) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FE_DIVBYZERO
+ if (exceptions & FE_DIVBYZERO) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FE_OVERFLOW
+ if (exceptions & FE_OVERFLOW) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FE_UNDERFLOW
+ if (exceptions & FE_UNDERFLOW) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FE_INEXACT
+ if (exceptions & FE_INEXACT) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void set_fpu (void)
+{
+#ifndef FE_INVALID
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
/* glibc does never have a FE_DENORMAL. */
+#ifndef FE_DENORMAL
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FE_DENORMAL
- feenableexcept (FE_DENORMAL);
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FE_DIVBYZERO
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FE_DIVBYZERO
- feenableexcept (FE_DIVBYZERO);
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FE_OVERFLOW
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FE_OVERFLOW
- feenableexcept (FE_OVERFLOW);
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FE_UNDERFLOW
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FE_UNDERFLOW
- feenableexcept (FE_UNDERFLOW);
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FE_INEXACT
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FE_INEXACT
- feenableexcept (FE_INEXACT);
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
+
+ set_fpu_trap_exceptions (options.fpe, 0);
}
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+ int exc_set = 0, exc_clr = 0;
+
+#ifdef FE_INVALID
+ if (set & GFC_FPE_INVALID)
+ exc_set |= FE_INVALID;
+ else if (clear & GFC_FPE_INVALID)
+ exc_clr |= FE_INVALID;
+#endif
+
+#ifdef FE_DIVBYZERO
+ if (set & GFC_FPE_ZERO)
+ exc_set |= FE_DIVBYZERO;
+ else if (clear & GFC_FPE_ZERO)
+ exc_clr |= FE_DIVBYZERO;
+#endif
+
+#ifdef FE_OVERFLOW
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= FE_OVERFLOW;
+ else if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= FE_OVERFLOW;
+#endif
+
+#ifdef FE_UNDERFLOW
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= FE_UNDERFLOW;
+ else if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= FE_UNDERFLOW;
+#endif
+
+#ifdef FE_DENORMAL
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= FE_DENORMAL;
+ else if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= FE_DENORMAL;
+#endif
+
+#ifdef FE_INEXACT
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= FE_INEXACT;
+ else if (clear & GFC_FPE_INEXACT)
+ exc_clr |= FE_INEXACT;
+#endif
+
+ feclearexcept (exc_clr);
+ feraiseexcept (exc_set);
+}
+
+
+int
+support_fpu_flag (int flag)
+{
+ if (flag & GFC_FPE_INVALID)
+ {
+#ifndef FE_INVALID
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_ZERO)
+ {
+#ifndef FE_DIVBYZERO
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_OVERFLOW)
+ {
+#ifndef FE_OVERFLOW
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_UNDERFLOW)
+ {
+#ifndef FE_UNDERFLOW
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_DENORMAL)
+ {
+#ifndef FE_DENORMAL
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_INEXACT)
+ {
+#ifndef FE_INEXACT
+ return 0;
+#endif
+ }
+
+ return 1;
+}
+
+
int
get_fpu_rounding_mode (void)
{
fesetround (rnd_mode);
}
+
+
+int
+support_fpu_rounding_mode (int mode)
+{
+ switch (mode)
+ {
+ case GFC_FPE_TONEAREST:
+#ifdef FE_TONEAREST
+ return 1;
+#else
+ return 0;
+#endif
+
+#ifdef FE_UPWARD
+ return 1;
+#else
+ return 0;
+#endif
+
+#ifdef FE_DOWNWARD
+ return 1;
+#else
+ return 0;
+#endif
+
+#ifdef FE_TOWARDZERO
+ return 1;
+#else
+ return 0;
+#endif
+
+ default:
+ return 0;
+ }
+}
+
+
+void
+get_fpu_state (void *state)
+{
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(fenv_t) <= GFC_FPE_STATE_BUFFER_SIZE);
+
+ fegetenv (state);
+}
+
+
+void
+set_fpu_state (void *state)
+{
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(fenv_t) <= GFC_FPE_STATE_BUFFER_SIZE);
+
+ fesetenv (state);
+}
+
/* FPU-related code for SysV platforms with fpsetmask(). */
+/* BSD and Solaris systems have slightly different types and functions
+ naming. We deal with these here, to simplify the code below. */
+
+#if HAVE_FP_EXCEPT
+# define FP_EXCEPT_TYPE fp_except
+#elif HAVE_FP_EXCEPT_T
+# define FP_EXCEPT_TYPE fp_except_t
+#else
+ choke me
+#endif
+
+#if HAVE_FP_RND
+# define FP_RND_TYPE fp_rnd
+#elif HAVE_FP_RND_T
+# define FP_RND_TYPE fp_rnd_t
+#else
+ choke me
+#endif
+
+#if HAVE_FPSETSTICKY
+# define FPSETSTICKY fpsetsticky
+#elif HAVE_FPRESETSTICKY
+# define FPSETSTICKY fpresetsticky
+#else
+ choke me
+#endif
+
+
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ FP_EXCEPT_TYPE cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ FP_EXCEPT_TYPE cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (cw & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (cw & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (cw & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (cw & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (cw & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (cw & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
int result;
-#if HAVE_FP_EXCEPT
- fp_except set_excepts;
-#elif HAVE_FP_EXCEPT_T
- fp_except_t set_excepts;
-#else
- choke me
-#endif
+ FP_EXCEPT_TYPE set_excepts;
result = 0;
set_excepts = fpgetsticky ();
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+ FP_EXCEPT_TYPE flags;
+
+ flags = fpgetsticky ();
+
+#ifdef FP_X_INV
+ if (set & GFC_FPE_INVALID)
+ flags |= FP_X_INV;
+ if (clear & GFC_FPE_INVALID)
+ flags &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DZ
+ if (set & GFC_FPE_ZERO)
+ flags |= FP_X_DZ;
+ if (clear & GFC_FPE_ZERO)
+ flags &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (set & GFC_FPE_OVERFLOW)
+ flags |= FP_X_OFL;
+ if (clear & GFC_FPE_OVERFLOW)
+ flags &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (set & GFC_FPE_UNDERFLOW)
+ flags |= FP_X_UFL;
+ if (clear & GFC_FPE_UNDERFLOW)
+ flags &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_DNML
+ if (set & GFC_FPE_DENORMAL)
+ flags |= FP_X_DNML;
+ if (clear & GFC_FPE_DENORMAL)
+ flags &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_IMP
+ if (set & GFC_FPE_INEXACT)
+ flags |= FP_X_IMP;
+ if (clear & GFC_FPE_INEXACT)
+ flags &= ~FP_X_IMP;
+#endif
+
+ FPSETSTICKY (flags);
+}
+
+
+int
+support_fpu_flag (int flag)
+{
+ if (flag & GFC_FPE_INVALID)
+ {
+#ifndef FP_X_INV
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_ZERO)
+ {
+#ifndef FP_X_DZ
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_OVERFLOW)
+ {
+#ifndef FP_X_OFL
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_UNDERFLOW)
+ {
+#ifndef FP_X_UFL
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_DENORMAL)
+ {
+#ifndef FP_X_DNML
+ return 0;
+#endif
+ }
+ else if (flag & GFC_FPE_INEXACT)
+ {
+#ifndef FP_X_IMP
+ return 0;
+#endif
+ }
+
+ return 1;
+}
+
+
int
get_fpu_rounding_mode (void)
{
void
set_fpu_rounding_mode (int mode)
{
-#if HAVE_FP_RND
- fp_rnd rnd_mode;
-#elif HAVE_FP_RND_T
- fp_rnd_t rnd_mode;
-#else
- choke me
-#endif
+ FP_RND_TYPE rnd_mode;
switch (mode)
{
}
fpsetround (rnd_mode);
}
+
+
+int
+support_fpu_rounding_mode (int mode)
+{
+ switch (mode)
+ {
+ case GFC_FPE_TONEAREST:
+#ifdef FP_RN
+ return 1;
+#else
+ return 0;
+#endif
+
+ case GFC_FPE_UPWARD:
+#ifdef FP_RP
+ return 1;
+#else
+ return 0;
+#endif
+
+ case GFC_FPE_DOWNWARD:
+#ifdef FP_RM
+ return 1;
+#else
+ return 0;
+#endif
+
+ case GFC_FPE_TOWARDZERO:
+#ifdef FP_RZ
+ return 1;
+#else
+ return 0;
+#endif
+
+ default:
+ return 0;
+ }
+}
+
+
+typedef struct
+{
+ FP_EXCEPT_TYPE mask;
+ FP_EXCEPT_TYPE sticky;
+ FP_RND_TYPE round;
+} fpu_state_t;
+
+
+void
+get_fpu_state (void *s)
+{
+ fpu_state_t *state = s;
+
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(fpu_state_t) <= GFC_FPE_STATE_BUFFER_SIZE);
+
+ state->mask = fpgetmask ();
+ state->sticky = fpgetsticky ();
+ state->round = fpgetround ();
+}
+
+void
+set_fpu_state (void *s)
+{
+ fpu_state_t *state = s;
+
+ /* Check we can actually store the FPU state in the allocated size. */
+ assert (sizeof(fpu_state_t) <= GFC_FPE_STATE_BUFFER_SIZE);
+
+ fpsetmask (state->mask);
+ FPSETSTICKY (state->sticky);
+ fpsetround (state->round);
+}
+
LTLIBOBJS
LIBOBJS
IEEE_FLAGS
+IEEE_SUPPORT
+IEEE_SUPPORT_FALSE
+IEEE_SUPPORT_TRUE
FPU_HOST_HEADER
LIBGFOR_BUILD_QUAD_FALSE
LIBGFOR_BUILD_QUAD_TRUE
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
-#line 12349 "configure"
+#line 12352 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
-#line 12455 "configure"
+#line 12458 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
. ${srcdir}/configure.host
{ $as_echo "$as_me:${as_lineno-$LINENO}: FPU dependent file will be ${fpu_host}.h" >&5
$as_echo "$as_me: FPU dependent file will be ${fpu_host}.h" >&6;}
+{ $as_echo "$as_me:${as_lineno-$LINENO}: Support for IEEE modules: ${ieee_support}" >&5
+$as_echo "$as_me: Support for IEEE modules: ${ieee_support}" >&6;}
FPU_HOST_HEADER=config/${fpu_host}.h
+# Whether we will build the IEEE modules
+ if test x${ieee_support} = xyes; then
+ IEEE_SUPPORT_TRUE=
+ IEEE_SUPPORT_FALSE='#'
+else
+ IEEE_SUPPORT_TRUE='#'
+ IEEE_SUPPORT_FALSE=
+fi
+
+
+
# Some targets require additional compiler options for IEEE compatibility.
IEEE_FLAGS="${ieee_flags}"
as_fn_error "conditional \"LIBGFOR_BUILD_QUAD\" was never defined.
Usually this means the macro was only invoked conditionally." "$LINENO" 5
fi
+if test -z "${IEEE_SUPPORT_TRUE}" && test -z "${IEEE_SUPPORT_FALSE}"; then
+ as_fn_error "conditional \"IEEE_SUPPORT\" was never defined.
+Usually this means the macro was only invoked conditionally." "$LINENO" 5
+fi
: ${CONFIG_STATUS=./config.status}
ac_write_fail=0
#include <math.h>
]])
+# Check whether we have fpsetsticky or fpresetsticky
+AC_CHECK_FUNC([fpsetsticky],[have_fpsetsticky=yes AC_DEFINE([HAVE_FPSETSTICKY],[1],[fpsetsticky is present])])
+AC_CHECK_FUNC([fpresetsticky],[have_fpresetsticky=yes AC_DEFINE([HAVE_FPRESETSTICKY],[1],[fpresetsticky is present])])
+
# Check for AIX fp_trap and fp_enable
AC_CHECK_FUNC([fp_trap],[have_fp_trap=yes AC_DEFINE([HAVE_FP_TRAP],[1],[fp_trap is present])])
AC_CHECK_FUNC([fp_enable],[have_fp_enable=yes AC_DEFINE([HAVE_FP_ENABLE],[1],[fp_enable is present])])
# build chain.
. ${srcdir}/configure.host
AC_MSG_NOTICE([FPU dependent file will be ${fpu_host}.h])
+AC_MSG_NOTICE([Support for IEEE modules: ${ieee_support}])
FPU_HOST_HEADER=config/${fpu_host}.h
AC_SUBST(FPU_HOST_HEADER)
+# Whether we will build the IEEE modules
+AM_CONDITIONAL(IEEE_SUPPORT,[test x${ieee_support} = xyes])
+AC_SUBST(IEEE_SUPPORT)
+
# Some targets require additional compiler options for IEEE compatibility.
IEEE_FLAGS="${ieee_flags}"
AC_SUBST(IEEE_FLAGS)
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
+
+if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes"; then
+ fpu_host='fpu-aix'
+ ieee_support='yes'
+fi
+
+if test "x${have_fpsetmask}" = "xyes"; then
+ fpu_host='fpu-sysv'
+ ieee_support='yes'
+fi
if test "x${have_feenableexcept}" = "xyes"; then
fpu_host='fpu-glibc'
+ ieee_support='yes'
fi
# x86 asm should be used instead of glibc, since glibc doesn't support
# the x86 denormal exception.
case "${host_cpu}" in
i?86 | x86_64)
- fpu_host='fpu-387' ;;
+ fpu_host='fpu-387'
+ ieee_support='yes'
+ ;;
esac
-if test "x${have_fpsetmask}" = "xyes"; then
- fpu_host='fpu-sysv'
-fi
-
-if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes"; then
- fpu_host='fpu-aix'
-fi
-
# Some targets require additional compiler options for NaN/Inf.
ieee_flags=
case "${host_cpu}" in
_gfortran_backtrace;
} GFORTRAN_1.4;
+GFORTRAN_1.6 {
+ global:
+ _gfortran_ieee_copy_sign_4_4_;
+ _gfortran_ieee_copy_sign_4_8_;
+ _gfortran_ieee_copy_sign_8_4_;
+ _gfortran_ieee_copy_sign_8_8_;
+ _gfortran_ieee_is_finite_4_;
+ _gfortran_ieee_is_finite_8_;
+ _gfortran_ieee_is_nan_4_;
+ _gfortran_ieee_is_nan_8_;
+ _gfortran_ieee_is_negative_4_;
+ _gfortran_ieee_is_negative_8_;
+ _gfortran_ieee_is_normal_4_;
+ _gfortran_ieee_is_normal_8_;
+ _gfortran_ieee_logb_4_;
+ _gfortran_ieee_logb_8_;
+ _gfortran_ieee_next_after_4_4_;
+ _gfortran_ieee_next_after_4_8_;
+ _gfortran_ieee_next_after_8_4_;
+ _gfortran_ieee_next_after_8_8_;
+ _gfortran_ieee_procedure_entry;
+ _gfortran_ieee_procedure_exit;
+ _gfortran_ieee_rem_4_4_;
+ _gfortran_ieee_rem_4_8_;
+ _gfortran_ieee_rem_8_4_;
+ _gfortran_ieee_rem_8_8_;
+ _gfortran_ieee_rint_4_;
+ _gfortran_ieee_rint_8_;
+ _gfortran_ieee_scalb_4_;
+ _gfortran_ieee_scalb_8_;
+ _gfortran_ieee_unordered_4_4_;
+ _gfortran_ieee_unordered_4_8_;
+ _gfortran_ieee_unordered_8_4_;
+ _gfortran_ieee_unordered_8_8_;
+ __ieee_arithmetic_MOD_ieee_class_4;
+ __ieee_arithmetic_MOD_ieee_class_8;
+ __ieee_arithmetic_MOD_ieee_class_type_eq;
+ __ieee_arithmetic_MOD_ieee_class_type_ne;
+ __ieee_arithmetic_MOD_ieee_get_rounding_mode;
+ __ieee_arithmetic_MOD_ieee_get_underflow_mode;
+ __ieee_arithmetic_MOD_ieee_round_type_eq;
+ __ieee_arithmetic_MOD_ieee_round_type_ne;
+ __ieee_arithmetic_MOD_ieee_selected_real_kind;
+ __ieee_arithmetic_MOD_ieee_set_rounding_mode;
+ __ieee_arithmetic_MOD_ieee_set_underflow_mode;
+ __ieee_arithmetic_MOD_ieee_support_datatype_4;
+ __ieee_arithmetic_MOD_ieee_support_datatype_8;
+ __ieee_arithmetic_MOD_ieee_support_datatype_10;
+ __ieee_arithmetic_MOD_ieee_support_datatype_16;
+ __ieee_arithmetic_MOD_ieee_support_datatype_noarg;
+ __ieee_arithmetic_MOD_ieee_support_denormal_4;
+ __ieee_arithmetic_MOD_ieee_support_denormal_8;
+ __ieee_arithmetic_MOD_ieee_support_denormal_10;
+ __ieee_arithmetic_MOD_ieee_support_denormal_16;
+ __ieee_arithmetic_MOD_ieee_support_denormal_noarg;
+ __ieee_arithmetic_MOD_ieee_support_divide_4;
+ __ieee_arithmetic_MOD_ieee_support_divide_8;
+ __ieee_arithmetic_MOD_ieee_support_divide_10;
+ __ieee_arithmetic_MOD_ieee_support_divide_16;
+ __ieee_arithmetic_MOD_ieee_support_divide_noarg;
+ __ieee_arithmetic_MOD_ieee_support_inf_4;
+ __ieee_arithmetic_MOD_ieee_support_inf_8;
+ __ieee_arithmetic_MOD_ieee_support_inf_10;
+ __ieee_arithmetic_MOD_ieee_support_inf_16;
+ __ieee_arithmetic_MOD_ieee_support_inf_noarg;
+ __ieee_arithmetic_MOD_ieee_support_io_4;
+ __ieee_arithmetic_MOD_ieee_support_io_8;
+ __ieee_arithmetic_MOD_ieee_support_io_10;
+ __ieee_arithmetic_MOD_ieee_support_io_16;
+ __ieee_arithmetic_MOD_ieee_support_io_noarg;
+ __ieee_arithmetic_MOD_ieee_support_nan_4;
+ __ieee_arithmetic_MOD_ieee_support_nan_8;
+ __ieee_arithmetic_MOD_ieee_support_nan_10;
+ __ieee_arithmetic_MOD_ieee_support_nan_16;
+ __ieee_arithmetic_MOD_ieee_support_nan_noarg;
+ __ieee_arithmetic_MOD_ieee_support_rounding_4;
+ __ieee_arithmetic_MOD_ieee_support_rounding_8;
+ __ieee_arithmetic_MOD_ieee_support_rounding_10;
+ __ieee_arithmetic_MOD_ieee_support_rounding_16;
+ __ieee_arithmetic_MOD_ieee_support_rounding_noarg;
+ __ieee_arithmetic_MOD_ieee_support_sqrt_4;
+ __ieee_arithmetic_MOD_ieee_support_sqrt_8;
+ __ieee_arithmetic_MOD_ieee_support_sqrt_10;
+ __ieee_arithmetic_MOD_ieee_support_sqrt_16;
+ __ieee_arithmetic_MOD_ieee_support_sqrt_noarg;
+ __ieee_arithmetic_MOD_ieee_support_standard_4;
+ __ieee_arithmetic_MOD_ieee_support_standard_8;
+ __ieee_arithmetic_MOD_ieee_support_standard_10;
+ __ieee_arithmetic_MOD_ieee_support_standard_16;
+ __ieee_arithmetic_MOD_ieee_support_standard_noarg;
+ __ieee_arithmetic_MOD_ieee_support_underflow_control_4;
+ __ieee_arithmetic_MOD_ieee_support_underflow_control_8;
+ __ieee_arithmetic_MOD_ieee_support_underflow_control_10;
+ __ieee_arithmetic_MOD_ieee_support_underflow_control_16;
+ __ieee_arithmetic_MOD_ieee_support_underflow_control_noarg;
+ __ieee_arithmetic_MOD_ieee_value_4;
+ __ieee_arithmetic_MOD_ieee_value_8;
+ __ieee_exceptions_MOD_ieee_all;
+ __ieee_exceptions_MOD_ieee_get_flag;
+ __ieee_exceptions_MOD_ieee_get_halting_mode;
+ __ieee_exceptions_MOD_ieee_get_status;
+ __ieee_exceptions_MOD_ieee_set_flag;
+ __ieee_exceptions_MOD_ieee_set_halting_mode;
+ __ieee_exceptions_MOD_ieee_set_status;
+ __ieee_exceptions_MOD_ieee_support_flag_4;
+ __ieee_exceptions_MOD_ieee_support_flag_8;
+ __ieee_exceptions_MOD_ieee_support_flag_noarg;
+ __ieee_exceptions_MOD_ieee_support_halting;
+ __ieee_exceptions_MOD_ieee_usual;
+} GFORTRAN_1.5;
+
F2C_1.0 {
global:
_gfortran_f2c_specific__abs_c4;
--- /dev/null
+! Implementation of the IEEE_ARITHMETIC standard intrinsic module
+! Copyright (C) 2013 Free Software Foundation, Inc.
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+!
+! This file is part of the GNU Fortran runtime library (libgfortran).
+!
+! Libgfortran is free software; you can redistribute it and/or
+! modify it under the terms of the GNU General Public
+! License as published by the Free Software Foundation; either
+! version 3 of the License, or (at your option) any later version.
+!
+! Libgfortran is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! Under Section 7 of GPL version 3, you are granted additional
+! permissions described in the GCC Runtime Library Exception, version
+! 3.1, as published by the Free Software Foundation.
+!
+! You should have received a copy of the GNU General Public License and
+! a copy of the GCC Runtime Library Exception along with this program;
+! see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+! <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "kinds.inc"
+#include "c99_protos.inc"
+#include "fpu-target.inc"
+
+module IEEE_ARITHMETIC
+
+ use IEEE_EXCEPTIONS
+ implicit none
+ private
+
+ ! Every public symbol from IEEE_EXCEPTIONS must be made public here
+ public :: IEEE_FLAG_TYPE, IEEE_INVALID, IEEE_OVERFLOW, &
+ IEEE_DIVIDE_BY_ZERO, IEEE_UNDERFLOW, IEEE_INEXACT, IEEE_USUAL, &
+ IEEE_ALL, IEEE_STATUS_TYPE, IEEE_GET_FLAG, IEEE_GET_HALTING_MODE, &
+ IEEE_GET_STATUS, IEEE_SET_FLAG, IEEE_SET_HALTING_MODE, &
+ IEEE_SET_STATUS, IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
+
+ ! Derived types and named constants
+
+ type, public :: IEEE_CLASS_TYPE
+ private
+ integer :: hidden
+ end type
+
+ type(IEEE_CLASS_TYPE), parameter, public :: &
+ IEEE_OTHER_VALUE = IEEE_CLASS_TYPE(0), &
+ IEEE_SIGNALING_NAN = IEEE_CLASS_TYPE(1), &
+ IEEE_QUIET_NAN = IEEE_CLASS_TYPE(2), &
+ IEEE_NEGATIVE_INF = IEEE_CLASS_TYPE(3), &
+ IEEE_NEGATIVE_NORMAL = IEEE_CLASS_TYPE(4), &
+ IEEE_NEGATIVE_DENORMAL = IEEE_CLASS_TYPE(5), &
+ IEEE_NEGATIVE_ZERO = IEEE_CLASS_TYPE(6), &
+ IEEE_POSITIVE_ZERO = IEEE_CLASS_TYPE(7), &
+ IEEE_POSITIVE_DENORMAL = IEEE_CLASS_TYPE(8), &
+ IEEE_POSITIVE_NORMAL = IEEE_CLASS_TYPE(9), &
+ IEEE_POSITIVE_INF = IEEE_CLASS_TYPE(10)
+
+ type, public :: IEEE_ROUND_TYPE
+ private
+ integer :: hidden
+ end type
+
+ type(IEEE_ROUND_TYPE), parameter, public :: &
+ IEEE_NEAREST = IEEE_ROUND_TYPE(GFC_FPE_TONEAREST), &
+ IEEE_TO_ZERO = IEEE_ROUND_TYPE(GFC_FPE_TOWARDZERO), &
+ IEEE_UP = IEEE_ROUND_TYPE(GFC_FPE_UPWARD), &
+ IEEE_DOWN = IEEE_ROUND_TYPE(GFC_FPE_DOWNWARD), &
+ IEEE_OTHER = IEEE_ROUND_TYPE(0)
+
+
+ ! Equality operators on the derived types
+ interface operator (==)
+ module procedure IEEE_CLASS_TYPE_EQ, IEEE_ROUND_TYPE_EQ
+ end interface
+ public :: operator(==)
+
+ interface operator (/=)
+ module procedure IEEE_CLASS_TYPE_NE, IEEE_ROUND_TYPE_NE
+ end interface
+ public :: operator (/=)
+
+
+ ! IEEE_IS_FINITE
+
+ interface
+ elemental logical function _gfortran_ieee_is_finite_4(X)
+ real(kind=4), intent(in) :: X
+ end function
+ elemental logical function _gfortran_ieee_is_finite_8(X)
+ real(kind=8), intent(in) :: X
+ end function
+ end interface
+
+ interface IEEE_IS_FINITE
+ procedure _gfortran_ieee_is_finite_4, _gfortran_ieee_is_finite_8
+ end interface
+ public :: IEEE_IS_FINITE
+
+ ! IEEE_IS_NAN
+
+ interface
+ elemental logical function _gfortran_ieee_is_nan_4(X)
+ real(kind=4), intent(in) :: X
+ end function
+ elemental logical function _gfortran_ieee_is_nan_8(X)
+ real(kind=8), intent(in) :: X
+ end function
+ end interface
+
+ interface IEEE_IS_NAN
+ procedure _gfortran_ieee_is_nan_4, _gfortran_ieee_is_nan_8
+ end interface
+ public :: IEEE_IS_NAN
+
+ ! IEEE_IS_NEGATIVE
+
+ interface
+ elemental logical function _gfortran_ieee_is_negative_4(X)
+ real(kind=4), intent(in) :: X
+ end function
+ elemental logical function _gfortran_ieee_is_negative_8(X)
+ real(kind=8), intent(in) :: X
+ end function
+ end interface
+
+ interface IEEE_IS_NEGATIVE
+ procedure _gfortran_ieee_is_negative_4, _gfortran_ieee_is_negative_8
+ end interface
+ public :: IEEE_IS_NEGATIVE
+
+ ! IEEE_IS_NORMAL
+
+ interface
+ elemental logical function _gfortran_ieee_is_normal_4(X)
+ real(kind=4), intent(in) :: X
+ end function
+ elemental logical function _gfortran_ieee_is_normal_8(X)
+ real(kind=8), intent(in) :: X
+ end function
+ end interface
+
+ interface IEEE_IS_NORMAL
+ procedure _gfortran_ieee_is_normal_4, _gfortran_ieee_is_normal_8
+ end interface
+ public :: IEEE_IS_NORMAL
+
+ ! IEEE_COPY_SIGN
+
+ interface
+ elemental real(kind=4) function _gfortran_ieee_copy_sign_4_4 (X,Y)
+ real(kind=4), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental real(kind=4) function _gfortran_ieee_copy_sign_4_8 (X,Y)
+ real(kind=4), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_copy_sign_8_4 (X,Y)
+ real(kind=8), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_copy_sign_8_8 (X,Y)
+ real(kind=8), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ end interface
+
+ interface IEEE_COPY_SIGN
+ procedure _gfortran_ieee_copy_sign_4_4, _gfortran_ieee_copy_sign_4_8, &
+ _gfortran_ieee_copy_sign_8_4, _gfortran_ieee_copy_sign_8_8
+ end interface
+ public :: IEEE_COPY_SIGN
+
+ ! IEEE_UNORDERED
+
+ interface
+ elemental logical function _gfortran_ieee_unordered_4_4 (X,Y)
+ real(kind=4), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental logical function _gfortran_ieee_unordered_4_8 (X,Y)
+ real(kind=4), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ elemental logical function _gfortran_ieee_unordered_8_4 (X,Y)
+ real(kind=8), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental logical function _gfortran_ieee_unordered_8_8 (X,Y)
+ real(kind=8), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ end interface
+
+ interface IEEE_UNORDERED
+ procedure _gfortran_ieee_unordered_4_4, _gfortran_ieee_unordered_4_8, &
+ _gfortran_ieee_unordered_8_4, _gfortran_ieee_unordered_8_8
+ end interface
+ public :: IEEE_UNORDERED
+
+ ! IEEE_LOGB
+
+ interface
+ elemental real(kind=4) function _gfortran_ieee_logb_4 (X)
+ real(kind=4), intent(in) :: X
+ end function
+ elemental real(kind=8) function _gfortran_ieee_logb_8 (X)
+ real(kind=8), intent(in) :: X
+ end function
+ end interface
+
+ interface IEEE_LOGB
+ procedure _gfortran_ieee_logb_4, _gfortran_ieee_logb_8
+ end interface
+ public :: IEEE_LOGB
+
+ ! IEEE_NEXT_AFTER
+
+ interface
+ elemental real(kind=4) function _gfortran_ieee_next_after_4_4 (X, Y)
+ real(kind=4), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental real(kind=4) function _gfortran_ieee_next_after_4_8 (X, Y)
+ real(kind=4), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_next_after_8_4 (X, Y)
+ real(kind=8), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_next_after_8_8 (X, Y)
+ real(kind=8), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ end interface
+
+ interface IEEE_NEXT_AFTER
+ procedure _gfortran_ieee_next_after_4_4, _gfortran_ieee_next_after_4_8, &
+ _gfortran_ieee_next_after_8_4, _gfortran_ieee_next_after_8_8
+ end interface
+ public :: IEEE_NEXT_AFTER
+
+ ! IEEE_REM
+
+ interface
+ elemental real(kind=4) function _gfortran_ieee_rem_4_4 (X, Y)
+ real(kind=4), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_rem_4_8 (X, Y)
+ real(kind=4), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_rem_8_4 (X, Y)
+ real(kind=8), intent(in) :: X
+ real(kind=4), intent(in) :: Y
+ end function
+ elemental real(kind=8) function _gfortran_ieee_rem_8_8 (X, Y)
+ real(kind=8), intent(in) :: X
+ real(kind=8), intent(in) :: Y
+ end function
+ end interface
+
+ interface IEEE_REM
+ procedure _gfortran_ieee_rem_4_4, _gfortran_ieee_rem_4_8, &
+ _gfortran_ieee_rem_8_4, _gfortran_ieee_rem_8_8
+ end interface
+ public :: IEEE_REM
+
+ ! IEEE_RINT
+
+ interface
+ elemental real(kind=4) function _gfortran_ieee_rint_4 (X)
+ real(kind=4), intent(in) :: X
+ end function
+ elemental real(kind=8) function _gfortran_ieee_rint_8 (X)
+ real(kind=8), intent(in) :: X
+ end function
+ end interface
+
+ interface IEEE_RINT
+ procedure _gfortran_ieee_rint_4, _gfortran_ieee_rint_8
+ end interface
+ public :: IEEE_RINT
+
+ ! IEEE_SCALB
+
+ interface
+ elemental real(kind=4) function _gfortran_ieee_scalb_4 (X, I)
+ real(kind=4), intent(in) :: X
+ integer, intent(in) :: I
+ end function
+ elemental real(kind=8) function _gfortran_ieee_scalb_8 (X, I)
+ real(kind=8), intent(in) :: X
+ integer, intent(in) :: I
+ end function
+ end interface
+
+ interface IEEE_SCALB
+ procedure _gfortran_ieee_scalb_4, _gfortran_ieee_scalb_8
+ end interface
+ public :: IEEE_SCALB
+
+ ! IEEE_VALUE
+
+ interface IEEE_VALUE
+ module procedure IEEE_VALUE_4, IEEE_VALUE_8
+ end interface
+ public :: IEEE_VALUE
+
+ ! IEEE_CLASS
+
+ interface IEEE_CLASS
+ module procedure IEEE_CLASS_4, IEEE_CLASS_8
+ end interface
+ public :: IEEE_CLASS
+
+ ! Public declarations for contained procedures
+ public :: IEEE_GET_ROUNDING_MODE, IEEE_SET_ROUNDING_MODE
+ public :: IEEE_GET_UNDERFLOW_MODE, IEEE_SET_UNDERFLOW_MODE
+ public :: IEEE_SELECTED_REAL_KIND
+
+ ! IEEE_SUPPORT_ROUNDING
+
+ interface IEEE_SUPPORT_ROUNDING
+ module procedure IEEE_SUPPORT_ROUNDING_4, IEEE_SUPPORT_ROUNDING_8, &
+#ifdef HAVE_GFC_REAL_10
+ IEEE_SUPPORT_ROUNDING_10, &
+#endif
+#ifdef HAVE_GFC_REAL_16
+ IEEE_SUPPORT_ROUNDING_16, &
+#endif
+ IEEE_SUPPORT_ROUNDING_NOARG
+ end interface
+ public :: IEEE_SUPPORT_ROUNDING
+
+ ! Interface to the FPU-specific function
+ interface
+ pure integer function support_rounding_helper(flag) &
+ bind(c, name="_gfortrani_support_fpu_rounding_mode")
+ integer, intent(in), value :: flag
+ end function
+ end interface
+
+! IEEE_SUPPORT_* generic functions
+
+#if defined(HAVE_GFC_REAL_10) && defined(HAVE_GFC_REAL_16)
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_16, NAME/**/_NOARG
+#elif defined(HAVE_GFC_REAL_10)
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_10, NAME/**/_NOARG
+#elif defined(HAVE_GFC_REAL_16)
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_16, NAME/**/_NOARG
+#else
+# define MACRO1(NAME) NAME/**/_4, NAME/**/_8, NAME/**/_NOARG
+#endif
+
+#define SUPPORTGENERIC(NAME) \
+ interface NAME ; module procedure MACRO1(NAME) ; end interface ; \
+ public :: NAME
+
+SUPPORTGENERIC(IEEE_SUPPORT_DATATYPE)
+SUPPORTGENERIC(IEEE_SUPPORT_DENORMAL)
+SUPPORTGENERIC(IEEE_SUPPORT_DIVIDE)
+SUPPORTGENERIC(IEEE_SUPPORT_INF)
+SUPPORTGENERIC(IEEE_SUPPORT_IO)
+SUPPORTGENERIC(IEEE_SUPPORT_NAN)
+SUPPORTGENERIC(IEEE_SUPPORT_SQRT)
+SUPPORTGENERIC(IEEE_SUPPORT_STANDARD)
+SUPPORTGENERIC(IEEE_SUPPORT_UNDERFLOW_CONTROL)
+
+contains
+
+ ! Equality operators for IEEE_CLASS_TYPE and IEEE_ROUNDING_MODE
+ elemental logical function IEEE_CLASS_TYPE_EQ (X, Y) result(res)
+ implicit none
+ type(IEEE_CLASS_TYPE), intent(in) :: X, Y
+ res = (X%hidden == Y%hidden)
+ end function
+
+ elemental logical function IEEE_CLASS_TYPE_NE (X, Y) result(res)
+ implicit none
+ type(IEEE_CLASS_TYPE), intent(in) :: X, Y
+ res = (X%hidden /= Y%hidden)
+ end function
+
+ elemental logical function IEEE_ROUND_TYPE_EQ (X, Y) result(res)
+ implicit none
+ type(IEEE_ROUND_TYPE), intent(in) :: X, Y
+ res = (X%hidden == Y%hidden)
+ end function
+
+ elemental logical function IEEE_ROUND_TYPE_NE (X, Y) result(res)
+ implicit none
+ type(IEEE_ROUND_TYPE), intent(in) :: X, Y
+ res = (X%hidden /= Y%hidden)
+ end function
+
+ ! IEEE_SELECTED_REAL_KIND
+ integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res)
+ implicit none
+ integer, intent(in), optional :: P, R, RADIX
+ integer :: p2, r2
+
+ p2 = 0 ; r2 = 0
+ if (present(p)) p2 = p
+ if (present(r)) r2 = r
+
+ ! The only IEEE types we support right now are binary
+ if (present(radix)) then
+ if (radix /= 2) then
+ res = -5
+ return
+ endif
+ endif
+
+ ! Does IEEE float fit?
+ if (precision(0.) >= p2 .and. range(0.) >= r2) then
+ res = kind(0.)
+ return
+ endif
+
+ ! Does IEEE double fit?
+ if (precision(0.d0) >= p2 .and. range(0.d0) >= r2) then
+ res = kind(0.d0)
+ return
+ endif
+
+ if (precision(0.d0) < p2 .and. range(0.d0) < r2) then
+ res = -3
+ return
+ endif
+
+ if (precision(0.d0) < p2) then
+ res = -1
+ return
+ endif
+
+ res = -2
+ end function
+
+
+ ! IEEE_CLASS
+
+ elemental function IEEE_CLASS_4 (X) result(res)
+ implicit none
+ real(kind=4), intent(in) :: X
+ type(IEEE_CLASS_TYPE) :: res
+
+ interface
+ pure integer function _gfortrani_ieee_class_helper_4(val)
+ real(kind=4), intent(in) :: val
+ end function
+ end interface
+
+ res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_4(X))
+ end function
+
+ elemental function IEEE_CLASS_8 (X) result(res)
+ implicit none
+ real(kind=8), intent(in) :: X
+ type(IEEE_CLASS_TYPE) :: res
+
+ interface
+ pure integer function _gfortrani_ieee_class_helper_8(val)
+ real(kind=8), intent(in) :: val
+ end function
+ end interface
+
+ res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X))
+ end function
+
+ ! IEEE_VALUE
+
+ elemental real(kind=4) function IEEE_VALUE_4(X, C) result(res)
+ implicit none
+ real(kind=4), intent(in) :: X
+ type(IEEE_CLASS_TYPE), intent(in) :: C
+
+ select case (C%hidden)
+ case (1) ! IEEE_SIGNALING_NAN
+ res = -1
+ res = sqrt(res)
+ case (2) ! IEEE_QUIET_NAN
+ res = -1
+ res = sqrt(res)
+ case (3) ! IEEE_NEGATIVE_INF
+ res = huge(res)
+ res = (-res) * res
+ case (4) ! IEEE_NEGATIVE_NORMAL
+ res = -42
+ case (5) ! IEEE_NEGATIVE_DENORMAL
+ res = -tiny(res)
+ res = res / 2
+ case (6) ! IEEE_NEGATIVE_ZERO
+ res = 0
+ res = -res
+ case (7) ! IEEE_POSITIVE_ZERO
+ res = 0
+ case (8) ! IEEE_POSITIVE_DENORMAL
+ res = tiny(res)
+ res = res / 2
+ case (9) ! IEEE_POSITIVE_NORMAL
+ res = 42
+ case (10) ! IEEE_POSITIVE_INF
+ res = huge(res)
+ res = res * res
+ case default ! IEEE_OTHER_VALUE, should not happen
+ res = 0
+ end select
+ end function
+
+ elemental real(kind=8) function IEEE_VALUE_8(X, C) result(res)
+ implicit none
+ real(kind=8), intent(in) :: X
+ type(IEEE_CLASS_TYPE), intent(in) :: C
+
+ select case (C%hidden)
+ case (1) ! IEEE_SIGNALING_NAN
+ res = -1
+ res = sqrt(res)
+ case (2) ! IEEE_QUIET_NAN
+ res = -1
+ res = sqrt(res)
+ case (3) ! IEEE_NEGATIVE_INF
+ res = huge(res)
+ res = (-res) * res
+ case (4) ! IEEE_NEGATIVE_NORMAL
+ res = -42
+ case (5) ! IEEE_NEGATIVE_DENORMAL
+ res = -tiny(res)
+ res = res / 2
+ case (6) ! IEEE_NEGATIVE_ZERO
+ res = 0
+ res = -res
+ case (7) ! IEEE_POSITIVE_ZERO
+ res = 0
+ case (8) ! IEEE_POSITIVE_DENORMAL
+ res = tiny(res)
+ res = res / 2
+ case (9) ! IEEE_POSITIVE_NORMAL
+ res = 42
+ case (10) ! IEEE_POSITIVE_INF
+ res = huge(res)
+ res = res * res
+ case default ! IEEE_OTHER_VALUE, should not happen
+ res = 0
+ end select
+ end function
+
+
+ ! IEEE_GET_ROUNDING_MODE
+
+ subroutine IEEE_GET_ROUNDING_MODE (ROUND_VALUE)
+ implicit none
+ type(IEEE_ROUND_TYPE), intent(out) :: ROUND_VALUE
+ integer :: i
+
+ interface
+ integer function helper() &
+ bind(c, name="_gfortrani_get_fpu_rounding_mode")
+ end function
+ end interface
+
+ ! FIXME: Use intermediate variable i to avoid triggering PR59023
+ i = helper()
+ ROUND_VALUE = IEEE_ROUND_TYPE(i)
+ end subroutine
+
+
+ ! IEEE_SET_ROUNDING_MODE
+
+ subroutine IEEE_SET_ROUNDING_MODE (ROUND_VALUE)
+ implicit none
+ type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+
+ interface
+ subroutine helper(val) &
+ bind(c, name="_gfortrani_set_fpu_rounding_mode")
+ integer, value :: val
+ end subroutine
+ end interface
+
+ call helper(ROUND_VALUE%hidden)
+ end subroutine
+
+
+ ! IEEE_GET_UNDERFLOW_MODE
+
+ subroutine IEEE_GET_UNDERFLOW_MODE (GRADUAL)
+ implicit none
+ logical, intent(out) :: GRADUAL
+ ! We do not support getting/setting underflow mode yet. We still
+ ! provide the procedures to avoid link-time error if a user program
+ ! uses it protected by a call to IEEE_SUPPORT_UNDERFLOW_CONTROL
+ call abort
+ end subroutine
+
+
+ ! IEEE_SET_UNDERFLOW_MODE
+
+ subroutine IEEE_SET_UNDERFLOW_MODE (GRADUAL)
+ implicit none
+ logical, intent(in) :: GRADUAL
+ ! We do not support getting/setting underflow mode yet. We still
+ ! provide the procedures to avoid link-time error if a user program
+ ! uses it protected by a call to IEEE_SUPPORT_UNDERFLOW_CONTROL
+ call abort
+ end subroutine
+
+! IEEE_SUPPORT_ROUNDING
+
+ pure logical function IEEE_SUPPORT_ROUNDING_4 (ROUND_VALUE, X) result(res)
+ implicit none
+ real(kind=4), intent(in) :: X
+ type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+ res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
+ end function
+
+ pure logical function IEEE_SUPPORT_ROUNDING_8 (ROUND_VALUE, X) result(res)
+ implicit none
+ real(kind=8), intent(in) :: X
+ type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+ res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
+ end function
+
+#ifdef HAVE_GFC_REAL_10
+ pure logical function IEEE_SUPPORT_ROUNDING_10 (ROUND_VALUE, X) result(res)
+ implicit none
+ real(kind=10), intent(in) :: X
+ type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+ res = .false.
+ end function
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+ pure logical function IEEE_SUPPORT_ROUNDING_16 (ROUND_VALUE, X) result(res)
+ implicit none
+ real(kind=16), intent(in) :: X
+ type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+ res = .false.
+ end function
+#endif
+
+ pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res)
+ implicit none
+ type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+ res = .false.
+#else
+ res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0)
+#endif
+ end function
+
+! IEEE_SUPPORT_* functions
+
+#define SUPPORTMACRO(NAME, INTKIND, VALUE) \
+ pure logical function NAME/**/_/**/INTKIND (X) result(res) ; \
+ implicit none ; \
+ real(INTKIND), intent(in) :: X(..) ; \
+ res = VALUE ; \
+ end function
+
+#define SUPPORTMACRO_NOARG(NAME, VALUE) \
+ pure logical function NAME/**/_NOARG () result(res) ; \
+ implicit none ; \
+ res = VALUE ; \
+ end function
+
+! IEEE_SUPPORT_DATATYPE
+
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.)
+#endif
+
+! IEEE_SUPPORT_DENORMAL
+
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.)
+#endif
+
+! IEEE_SUPPORT_DIVIDE
+
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.)
+#endif
+
+! IEEE_SUPPORT_INF
+
+SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_INF,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_INF,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.)
+#endif
+
+! IEEE_SUPPORT_IO
+
+SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_IO,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_IO,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.)
+#endif
+
+! IEEE_SUPPORT_NAN
+
+SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.)
+#endif
+
+! IEEE_SUPPORT_SQRT
+
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.)
+#endif
+
+! IEEE_SUPPORT_STANDARD
+
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.)
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.false.)
+#endif
+#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.false.)
+#else
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.)
+#endif
+
+! IEEE_SUPPORT_UNDERFLOW_CONTROL
+
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,4,.false.)
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,8,.false.)
+#ifdef HAVE_GFC_REAL_10
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,10,.false.)
+#endif
+#ifdef HAVE_GFC_REAL_16
+SUPPORTMACRO(IEEE_SUPPORT_UNDERFLOW_CONTROL,16,.false.)
+#endif
+SUPPORTMACRO_NOARG(IEEE_SUPPORT_UNDERFLOW_CONTROL,.false.)
+
+
+end module IEEE_ARITHMETIC
--- /dev/null
+! Implementation of the IEEE_EXCEPTIONS standard intrinsic module
+! Copyright (C) 2013 Free Software Foundation, Inc.
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+!
+! This file is part of the GNU Fortran runtime library (libgfortran).
+!
+! Libgfortran is free software; you can redistribute it and/or
+! modify it under the terms of the GNU General Public
+! License as published by the Free Software Foundation; either
+! version 3 of the License, or (at your option) any later version.
+!
+! Libgfortran is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! Under Section 7 of GPL version 3, you are granted additional
+! permissions described in the GCC Runtime Library Exception, version
+! 3.1, as published by the Free Software Foundation.
+!
+! You should have received a copy of the GNU General Public License and
+! a copy of the GCC Runtime Library Exception along with this program;
+! see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+! <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "kinds.inc"
+#include "c99_protos.inc"
+#include "fpu-target.inc"
+
+module IEEE_EXCEPTIONS
+
+ implicit none
+ private
+
+! Derived types and named constants
+
+ type, public :: IEEE_FLAG_TYPE
+ private
+ integer :: hidden
+ end type
+
+ type(IEEE_FLAG_TYPE), parameter, public :: &
+ IEEE_INVALID = IEEE_FLAG_TYPE(GFC_FPE_INVALID), &
+ IEEE_OVERFLOW = IEEE_FLAG_TYPE(GFC_FPE_OVERFLOW), &
+ IEEE_DIVIDE_BY_ZERO = IEEE_FLAG_TYPE(GFC_FPE_ZERO), &
+ IEEE_UNDERFLOW = IEEE_FLAG_TYPE(GFC_FPE_UNDERFLOW), &
+ IEEE_INEXACT = IEEE_FLAG_TYPE(GFC_FPE_INEXACT)
+
+ type(IEEE_FLAG_TYPE), parameter, public :: &
+ IEEE_USUAL(3) = [ IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, IEEE_INVALID ], &
+ IEEE_ALL(5) = [ IEEE_USUAL, IEEE_UNDERFLOW, IEEE_INEXACT ]
+
+ type, public :: IEEE_STATUS_TYPE
+ private
+ character(len=GFC_FPE_STATE_BUFFER_SIZE) :: hidden
+ end type
+
+ interface IEEE_SUPPORT_FLAG
+ module procedure IEEE_SUPPORT_FLAG_NOARG, &
+ IEEE_SUPPORT_FLAG_4, &
+ IEEE_SUPPORT_FLAG_8
+ end interface IEEE_SUPPORT_FLAG
+
+ public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
+ public :: IEEE_SET_HALTING_MODE, IEEE_GET_HALTING_MODE
+ public :: IEEE_SET_FLAG, IEEE_GET_FLAG
+ public :: IEEE_SET_STATUS, IEEE_GET_STATUS
+
+contains
+
+! Saving and restoring floating-point status
+
+ subroutine IEEE_GET_STATUS (STATUS_VALUE)
+ implicit none
+ type(IEEE_STATUS_TYPE), intent(out) :: STATUS_VALUE
+
+ interface
+ subroutine helper(ptr) &
+ bind(c, name="_gfortrani_get_fpu_state")
+ use, intrinsic :: iso_c_binding, only : c_char
+ character(kind=c_char) :: ptr(*)
+ end subroutine
+ end interface
+
+ call helper(STATUS_VALUE%hidden)
+ end subroutine
+
+ subroutine IEEE_SET_STATUS (STATUS_VALUE)
+ implicit none
+ type(IEEE_STATUS_TYPE), intent(in) :: STATUS_VALUE
+
+ interface
+ subroutine helper(ptr) &
+ bind(c, name="_gfortrani_set_fpu_state")
+ use, intrinsic :: iso_c_binding, only : c_char
+ character(kind=c_char) :: ptr(*)
+ end subroutine
+ end interface
+
+ call helper(STATUS_VALUE%hidden)
+ end subroutine
+
+! Getting and setting flags
+
+ elemental subroutine IEEE_GET_FLAG (FLAG, FLAG_VALUE)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+ logical, intent(out) :: FLAG_VALUE
+
+ interface
+ pure integer function helper() &
+ bind(c, name="_gfortrani_get_fpu_except_flags")
+ end function
+ end interface
+
+ FLAG_VALUE = (IAND(helper(), FLAG%hidden) /= 0)
+ end subroutine
+
+ elemental subroutine IEEE_SET_FLAG (FLAG, FLAG_VALUE)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+ logical, intent(in) :: FLAG_VALUE
+
+ interface
+ pure subroutine helper(set, clear) &
+ bind(c, name="_gfortrani_set_fpu_except_flags")
+ integer, intent(in), value :: set, clear
+ end subroutine
+ end interface
+
+ if (FLAG_VALUE) then
+ call helper(FLAG%hidden, 0)
+ else
+ call helper(0, FLAG%hidden)
+ end if
+ end subroutine
+
+! Querying and changing the halting mode
+
+ elemental subroutine IEEE_GET_HALTING_MODE (FLAG, HALTING)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+ logical, intent(out) :: HALTING
+
+ interface
+ pure integer function helper() &
+ bind(c, name="_gfortrani_get_fpu_trap_exceptions")
+ end function
+ end interface
+
+ HALTING = (IAND(helper(), FLAG%hidden) /= 0)
+ end subroutine
+
+ elemental subroutine IEEE_SET_HALTING_MODE (FLAG, HALTING)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+ logical, intent(in) :: HALTING
+
+ interface
+ pure subroutine helper(trap, notrap) &
+ bind(c, name="_gfortrani_set_fpu_trap_exceptions")
+ integer, intent(in), value :: trap, notrap
+ end subroutine
+ end interface
+
+ if (HALTING) then
+ call helper(FLAG%hidden, 0)
+ else
+ call helper(0, FLAG%hidden)
+ end if
+ end subroutine
+
+! Querying support
+
+ pure logical function IEEE_SUPPORT_HALTING (FLAG)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+
+ interface
+ pure integer function helper(flag) &
+ bind(c, name="_gfortrani_support_fpu_trap")
+ integer, intent(in), value :: flag
+ end function
+ end interface
+
+ IEEE_SUPPORT_HALTING = (helper(FLAG%hidden) /= 0)
+ end function
+
+ pure logical function IEEE_SUPPORT_FLAG_NOARG (FLAG)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+
+ interface
+ pure integer function helper(flag) &
+ bind(c, name="_gfortrani_support_fpu_flag")
+ integer, intent(in), value :: flag
+ end function
+ end interface
+
+ IEEE_SUPPORT_FLAG_NOARG = (helper(FLAG%hidden) /= 0)
+ end function
+
+ pure logical function IEEE_SUPPORT_FLAG_4 (FLAG, X) result(res)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+ real(kind=4), intent(in) :: X
+ res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
+ end function
+
+ pure logical function IEEE_SUPPORT_FLAG_8 (FLAG, X) result(res)
+ implicit none
+ type(IEEE_FLAG_TYPE), intent(in) :: FLAG
+ real(kind=8), intent(in) :: X
+ res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
+ end function
+
+end module IEEE_EXCEPTIONS
--- /dev/null
+! Implementation of the IEEE_FEATURES standard intrinsic module
+! Copyright (C) 2013 Free Software Foundation, Inc.
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+!
+! This file is part of the GNU Fortran runtime library (libgfortran).
+!
+! Libgfortran is free software; you can redistribute it and/or
+! modify it under the terms of the GNU General Public
+! License as published by the Free Software Foundation; either
+! version 3 of the License, or (at your option) any later version.
+!
+! Libgfortran is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! Under Section 7 of GPL version 3, you are granted additional
+! permissions described in the GCC Runtime Library Exception, version
+! 3.1, as published by the Free Software Foundation.
+!
+! You should have received a copy of the GNU General Public License and
+! a copy of the GCC Runtime Library Exception along with this program;
+! see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+! <http://www.gnu.org/licenses/>. */
+
+module IEEE_FEATURES
+
+ implicit none
+ private
+
+ type, public :: IEEE_FEATURES_TYPE
+ private
+ integer :: hidden
+ end type
+
+ type(IEEE_FEATURES_TYPE), parameter, public :: &
+ IEEE_DATATYPE = IEEE_FEATURES_TYPE(0), &
+ IEEE_DENORMAL = IEEE_FEATURES_TYPE(1), &
+ IEEE_DIVIDE = IEEE_FEATURES_TYPE(2), &
+ IEEE_HALTING = IEEE_FEATURES_TYPE(3), &
+ IEEE_INEXACT_FLAG = IEEE_FEATURES_TYPE(4), &
+ IEEE_INF = IEEE_FEATURES_TYPE(5), &
+ IEEE_INVALID_FLAG = IEEE_FEATURES_TYPE(6), &
+ IEEE_NAN = IEEE_FEATURES_TYPE(7), &
+ IEEE_ROUNDING = IEEE_FEATURES_TYPE(8), &
+ IEEE_SQRT = IEEE_FEATURES_TYPE(9), &
+ IEEE_UNDERFLOW_FLAG = IEEE_FEATURES_TYPE(10)
+
+end module IEEE_FEATURES
--- /dev/null
+/* Helper functions in C for IEEE modules
+ Copyright (C) 2013 Free Software Foundation, Inc.
+ Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+/* Prototypes. */
+
+extern int ieee_class_helper_4 (GFC_REAL_4 *);
+internal_proto(ieee_class_helper_4);
+
+extern int ieee_class_helper_8 (GFC_REAL_8 *);
+internal_proto(ieee_class_helper_8);
+
+extern int ieee_is_finite_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_finite_4_);
+
+extern int ieee_is_finite_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_finite_8_);
+
+extern int ieee_is_nan_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_nan_4_);
+
+extern int ieee_is_nan_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_nan_8_);
+
+extern int ieee_is_negative_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_negative_4_);
+
+extern int ieee_is_negative_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_negative_8_);
+
+extern int ieee_is_normal_4_ (GFC_REAL_4 *);
+export_proto(ieee_is_normal_4_);
+
+extern int ieee_is_normal_8_ (GFC_REAL_8 *);
+export_proto(ieee_is_normal_8_);
+
+
+/* Enumeration of the possible floating-point types. These values
+ correspond to the hidden arguments of the IEEE_CLASS_TYPE
+ derived-type of IEEE_ARITHMETIC. */
+
+enum { IEEE_OTHER_VALUE = 0, IEEE_SIGNALING_NAN, IEEE_QUIET_NAN,
+ IEEE_NEGATIVE_INF, IEEE_NEGATIVE_NORMAL, IEEE_NEGATIVE_DENORMAL,
+ IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, IEEE_POSITIVE_DENORMAL,
+ IEEE_POSITIVE_NORMAL, IEEE_POSITIVE_INF };
+
+#define CLASSMACRO(TYPE) \
+ int ieee_class_helper_ ## TYPE (GFC_REAL_ ## TYPE *value) \
+ { \
+ int res = __builtin_fpclassify (IEEE_QUIET_NAN, IEEE_POSITIVE_INF, \
+ IEEE_POSITIVE_NORMAL, \
+ IEEE_POSITIVE_DENORMAL, \
+ IEEE_POSITIVE_ZERO, *value); \
+ \
+ if (__builtin_signbit (*value)) \
+ { \
+ if (res == IEEE_POSITIVE_NORMAL) \
+ return IEEE_NEGATIVE_NORMAL; \
+ else if (res == IEEE_POSITIVE_DENORMAL) \
+ return IEEE_NEGATIVE_DENORMAL; \
+ else if (res == IEEE_POSITIVE_ZERO) \
+ return IEEE_NEGATIVE_ZERO; \
+ else if (res == IEEE_POSITIVE_INF) \
+ return IEEE_NEGATIVE_INF; \
+ } \
+ \
+ if (res == IEEE_QUIET_NAN) \
+ { \
+ /* TODO: Handle signaling NaNs */ \
+ return res; \
+ } \
+ \
+ return res; \
+ }
+
+CLASSMACRO(4)
+CLASSMACRO(8)
+
+
+/* Testing functions. */
+
+int ieee_is_finite_4_ (GFC_REAL_4 *val)
+{
+ return __builtin_isfinite(*val) ? 1 : 0;
+}
+
+int ieee_is_finite_8_ (GFC_REAL_8 *val)
+{
+ return __builtin_isfinite(*val) ? 1 : 0;
+}
+
+int ieee_is_nan_4_ (GFC_REAL_4 *val)
+{
+ return __builtin_isnan(*val) ? 1 : 0;
+}
+
+int ieee_is_nan_8_ (GFC_REAL_8 *val)
+{
+ return __builtin_isnan(*val) ? 1 : 0;
+}
+
+int ieee_is_negative_4_ (GFC_REAL_4 *val)
+{
+ return (__builtin_signbit(*val) && !__builtin_isnan(*val)) ? 1 : 0;
+}
+
+int ieee_is_negative_8_ (GFC_REAL_8 *val)
+{
+ return (__builtin_signbit(*val) && !__builtin_isnan(*val)) ? 1 : 0;
+}
+
+int ieee_is_normal_4_ (GFC_REAL_4 *val)
+{
+ return (__builtin_isnormal(*val) || *val == 0) ? 1 : 0;
+}
+
+int ieee_is_normal_8_ (GFC_REAL_8 *val)
+{
+ return (__builtin_isnormal(*val) || *val == 0) ? 1 : 0;
+}
+
+GFC_REAL_4 ieee_copy_sign_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_copy_sign_4_4_);
+GFC_REAL_4 ieee_copy_sign_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+ GFC_REAL_4 s = __builtin_signbit(*y) ? -1 : 1;
+ return __builtin_copysign(*x, s);
+}
+
+GFC_REAL_4 ieee_copy_sign_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_copy_sign_4_8_);
+GFC_REAL_4 ieee_copy_sign_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+ GFC_REAL_4 s = __builtin_signbit(*y) ? -1 : 1;
+ return __builtin_copysign(*x, s);
+}
+
+GFC_REAL_8 ieee_copy_sign_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_copy_sign_8_4_);
+GFC_REAL_8 ieee_copy_sign_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+ GFC_REAL_8 s = __builtin_signbit(*y) ? -1 : 1;
+ return __builtin_copysign(*x, s);
+}
+
+GFC_REAL_8 ieee_copy_sign_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_copy_sign_8_8_);
+GFC_REAL_8 ieee_copy_sign_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+ GFC_REAL_8 s = __builtin_signbit(*y) ? -1 : 1;
+ return __builtin_copysign(*x, s);
+}
+
+int ieee_unordered_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_unordered_4_4_);
+int ieee_unordered_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+ return __builtin_isunordered(*x, *y);
+}
+
+int ieee_unordered_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_unordered_4_8_);
+int ieee_unordered_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+ return __builtin_isunordered(*x, *y);
+}
+
+int ieee_unordered_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_unordered_8_4_);
+int ieee_unordered_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+ return __builtin_isunordered(*x, *y);
+}
+
+int ieee_unordered_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_unordered_8_8_);
+int ieee_unordered_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+ return __builtin_isunordered(*x, *y);
+}
+
+
+/* Arithmetic functions (LOGB, NEXT_AFTER, REM, RINT, SCALB). */
+
+GFC_REAL_4 ieee_logb_4_ (GFC_REAL_4 *);
+export_proto(ieee_logb_4_);
+
+GFC_REAL_4 ieee_logb_4_ (GFC_REAL_4 *x)
+{
+ GFC_REAL_4 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_logb (*x);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_8 ieee_logb_8_ (GFC_REAL_8 *);
+export_proto(ieee_logb_8_);
+
+GFC_REAL_8 ieee_logb_8_ (GFC_REAL_8 *x)
+{
+ GFC_REAL_8 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_logb (*x);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_4 ieee_next_after_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_next_after_4_4_);
+
+GFC_REAL_4 ieee_next_after_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+ return __builtin_nextafterf (*x, *y);
+}
+
+GFC_REAL_4 ieee_next_after_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_next_after_4_8_);
+
+GFC_REAL_4 ieee_next_after_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+ return __builtin_nextafterf (*x, *y);
+}
+
+GFC_REAL_8 ieee_next_after_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_next_after_8_4_);
+
+GFC_REAL_8 ieee_next_after_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+ return __builtin_nextafter (*x, *y);
+}
+
+GFC_REAL_8 ieee_next_after_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_next_after_8_8_);
+
+GFC_REAL_8 ieee_next_after_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+ return __builtin_nextafter (*x, *y);
+}
+
+GFC_REAL_4 ieee_rem_4_4_ (GFC_REAL_4 *, GFC_REAL_4 *);
+export_proto(ieee_rem_4_4_);
+
+GFC_REAL_4 ieee_rem_4_4_ (GFC_REAL_4 *x, GFC_REAL_4 *y)
+{
+ GFC_REAL_4 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_remainderf (*x, *y);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_8 ieee_rem_4_8_ (GFC_REAL_4 *, GFC_REAL_8 *);
+export_proto(ieee_rem_4_8_);
+
+GFC_REAL_8 ieee_rem_4_8_ (GFC_REAL_4 *x, GFC_REAL_8 *y)
+{
+ GFC_REAL_8 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_remainder (*x, *y);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_8 ieee_rem_8_4_ (GFC_REAL_8 *, GFC_REAL_4 *);
+export_proto(ieee_rem_8_4_);
+
+GFC_REAL_8 ieee_rem_8_4_ (GFC_REAL_8 *x, GFC_REAL_4 *y)
+{
+ GFC_REAL_8 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_remainder (*x, *y);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_8 ieee_rem_8_8_ (GFC_REAL_8 *, GFC_REAL_8 *);
+export_proto(ieee_rem_8_8_);
+
+GFC_REAL_8 ieee_rem_8_8_ (GFC_REAL_8 *x, GFC_REAL_8 *y)
+{
+ GFC_REAL_8 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_remainder (*x, *y);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_4 ieee_rint_4_ (GFC_REAL_4 *);
+export_proto(ieee_rint_4_);
+
+GFC_REAL_4 ieee_rint_4_ (GFC_REAL_4 *x)
+{
+ GFC_REAL_4 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_rint (*x);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_8 ieee_rint_8_ (GFC_REAL_8 *);
+export_proto(ieee_rint_8_);
+
+GFC_REAL_8 ieee_rint_8_ (GFC_REAL_8 *x)
+{
+ GFC_REAL_8 res;
+ char buffer[GFC_FPE_STATE_BUFFER_SIZE];
+
+ get_fpu_state (buffer);
+ res = __builtin_rint (*x);
+ set_fpu_state (buffer);
+ return res;
+}
+
+GFC_REAL_4 ieee_scalb_4_ (GFC_REAL_4 *, int *);
+export_proto(ieee_scalb_4_);
+
+GFC_REAL_4 ieee_scalb_4_ (GFC_REAL_4 *x, int *i)
+{
+ return __builtin_scalbnf (*x, *i);
+}
+
+GFC_REAL_8 ieee_scalb_8_ (GFC_REAL_8 *, int *);
+export_proto(ieee_scalb_8_);
+
+GFC_REAL_8 ieee_scalb_8_ (GFC_REAL_8 *x, int *i)
+{
+ return __builtin_scalbn (*x, *i);
+}
+
+
+#define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
+ GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
+ GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT)
+
+/* Functions to save and restore floating-point state, clear and restore
+ exceptions on procedure entry/exit. The rules we follow are set
+ in Fortran 2008's 14.3 paragraph 3, note 14.4, 14.4 paragraph 4,
+ 14.5 paragraph 2, and 14.6 paragraph 1. */
+
+void ieee_procedure_entry (void *);
+export_proto(ieee_procedure_entry);
+
+void
+ieee_procedure_entry (void *state)
+{
+ /* Save the floating-point state in the space provided by the caller. */
+ get_fpu_state (state);
+
+ /* Clear the floating-point exceptions. */
+ set_fpu_except_flags (0, GFC_FPE_ALL);
+}
+
+
+void ieee_procedure_exit (void *);
+export_proto(ieee_procedure_exit);
+
+void
+ieee_procedure_exit (void *state)
+{
+ /* Get the flags currently signaling. */
+ int flags = get_fpu_except_flags ();
+
+ /* Restore the floating-point state we had on entry. */
+ set_fpu_state (state);
+
+ /* And re-raised the flags that were raised since entry. */
+ set_fpu_except_flags (flags, 0);
+}
+
extern void set_fpu (void);
internal_proto(set_fpu);
+extern int get_fpu_trap_exceptions (void);
+internal_proto(get_fpu_trap_exceptions);
+
+extern void set_fpu_trap_exceptions (int, int);
+internal_proto(set_fpu_trap_exceptions);
+
+extern int support_fpu_trap (int);
+internal_proto(support_fpu_trap);
+
extern int get_fpu_except_flags (void);
internal_proto(get_fpu_except_flags);
-extern void set_fpu_rounding_mode (int round);
+extern void set_fpu_except_flags (int, int);
+internal_proto(set_fpu_except_flags);
+
+extern int support_fpu_flag (int);
+internal_proto(support_fpu_flag);
+
+extern void set_fpu_rounding_mode (int);
internal_proto(set_fpu_rounding_mode);
extern int get_fpu_rounding_mode (void);
internal_proto(get_fpu_rounding_mode);
+extern int support_fpu_rounding_mode (int);
+internal_proto(support_fpu_rounding_mode);
+
+extern void get_fpu_state (void *);
+internal_proto(get_fpu_state);
+
+extern void set_fpu_state (void *);
+internal_proto(set_fpu_state);
+
/* memory.c */
extern void *xmalloc (size_t) __attribute__ ((malloc));
projects / thirdparty / gcc.git / commitdiff
