Skip to content

R
riscv-gcc-1
Commit 8b198102 by Francois-Xavier Coudert Committed by François-Xavier Coudert
Options

re PR fortran/29383 (Fortran 2003/F95[TR15580:1999]: Floating point exception (IEEE) support) 

	PR fortran/29383

gcc/fortran/
	* 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.

libgfortran/
	* 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.

gcc/testsuite/
	* 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.

From-SVN: r212102
parent a8647163
Showing with 2768 additions and 119 deletions
gcc/fortran/ChangeLog
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
......
gcc/fortran/expr.c
......@@ -2460,9 +2460,23 @@ gfc_check_init_expr (gfc_expr *e)
{
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)
{
......
gcc/fortran/gfortran.h
......@@ -678,7 +678,8 @@ iso_c_binding_symbol;
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;
......@@ -2870,6 +2871,8 @@ gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *);
/* 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. */
......
gcc/fortran/intrinsic.texi
......@@ -13155,6 +13155,7 @@ Fortran 95 elemental function: @ref{IEOR}
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
* IEEE modules::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
......@@ -13366,6 +13367,35 @@ Moreover, the following two named constants are defined:
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
......
gcc/fortran/libgfortran.h
......@@ -35,13 +35,14 @@ along with GCC; see the file COPYING3. If not see
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
......@@ -49,6 +50,10 @@ along with GCC; see the file COPYING3. If not see
#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)
......
gcc/fortran/module.c
......@@ -190,6 +190,9 @@ static gzFile module_fp;
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;
......@@ -4096,7 +4099,10 @@ mio_symbol (gfc_symbol *sym)
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));
......@@ -6733,6 +6739,7 @@ gfc_use_module (gfc_use_list *module)
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);
......@@ -6777,6 +6784,26 @@ gfc_use_module (gfc_use_list *module)
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)
......
gcc/fortran/simplify.c
......@@ -5460,12 +5460,13 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
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;
}
......@@ -5488,6 +5489,87 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
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)
{
gfc_expr *result;
......
gcc/fortran/trans-decl.c
......@@ -90,6 +90,9 @@ static stmtblock_t caf_init_block;
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;
......@@ -118,6 +121,8 @@ tree gfor_fndecl_in_unpack;
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. */
......@@ -1376,8 +1381,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* 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
......@@ -3269,6 +3275,14 @@ gfc_build_builtin_function_decls (void)
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",
......@@ -5530,6 +5544,55 @@ gfc_generate_return (void)
}
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
......@@ -5539,13 +5602,14 @@ gfc_generate_function_code (gfc_namespace * ns)
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;
......@@ -5636,6 +5700,12 @@ gfc_generate_function_code (gfc_namespace * ns)
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);
......@@ -5719,6 +5789,10 @@ gfc_generate_function_code (gfc_namespace * ns)
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);
......
gcc/testsuite/ChangeLog
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.
......
gcc/testsuite/gfortran.dg/ieee/ieee.exp 0 → 100644
# 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
gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 0 → 100644
! { 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
gcc/testsuite/lib/target-supports.exp
......@@ -1110,6 +1110,20 @@ proc check_effective_target_fortran_real_16 { } {
}
# 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
......
libgfortran/ChangeLog
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
......
libgfortran/Makefile.am
......@@ -54,6 +54,11 @@ libcaf_single_la_LDFLAGS = -static
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 \
......@@ -70,6 +75,7 @@ AM_CFLAGS += $(SECTION_FLAGS)
# Some targets require additional compiler options for IEEE compatibility.
AM_CFLAGS += $(IEEE_FLAGS)
AM_FCFLAGS += $(IEEE_FLAGS)
gfor_io_src= \
io/close.c \
......@@ -160,6 +166,21 @@ intrinsics/unpack_generic.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 \
......@@ -650,7 +671,7 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_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= \
......@@ -811,11 +832,27 @@ $(patsubst %.c,%.lo,$(notdir $(i_matmull_c))): AM_CFLAGS += -funroll-loops
$(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
......@@ -871,6 +908,10 @@ selected_real_kind.inc: $(srcdir)/mk-srk-inc.sh
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
......
libgfortran/config/fpu-387.h
......@@ -23,6 +23,8 @@ 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 <assert.h>
#ifndef __SSE_MATH__
#include "cpuid.h"
#endif
......@@ -62,24 +64,122 @@ has_sse (void)
#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));
......@@ -90,8 +190,8 @@ set_fpu (void)
__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;
......@@ -100,6 +200,47 @@ set_fpu (void)
}
}
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)
{
......@@ -107,7 +248,7 @@ 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())
......@@ -131,6 +272,70 @@ get_fpu_except_flags (void)
}
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)
{
int round_mode;
......@@ -213,3 +418,44 @@ get_fpu_rounding_mode (void)
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));
}
libgfortran/config/fpu-aix.h
......@@ -33,15 +33,103 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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
......@@ -50,43 +138,33 @@ set_fpu (void)
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)
{
......@@ -118,6 +196,98 @@ 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)
{
......@@ -188,3 +358,60 @@ set_fpu_rounding_mode (int mode)
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);
}
libgfortran/config/fpu-generic.h
......@@ -51,6 +51,12 @@ set_fpu (void)
"exception not supported.\n");
}
void
set_fpu_trap_exceptions (int trap __attribute__((unused)),
int notrap __attribute__((unused)))
{
}
int
get_fpu_except_flags (void)
{
......
libgfortran/config/fpu-glibc.h
......@@ -27,63 +27,141 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
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);
}
......@@ -129,6 +207,102 @@ get_fpu_except_flags (void)
}
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)
{
......@@ -199,3 +373,60 @@ set_fpu_rounding_mode (int mode)
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);
}
libgfortran/config/fpu-sysv.h
......@@ -25,73 +25,174 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
/* 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 ();
......@@ -130,6 +231,103 @@ get_fpu_except_flags (void)
}
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)
{
......@@ -163,13 +361,7 @@ 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)
{
......@@ -201,3 +393,78 @@ set_fpu_rounding_mode (int 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);
}
libgfortran/configure
......@@ -606,6 +606,9 @@ am__EXEEXT_TRUE
LTLIBOBJS
LIBOBJS
IEEE_FLAGS
IEEE_SUPPORT
IEEE_SUPPORT_FALSE
IEEE_SUPPORT_TRUE
FPU_HOST_HEADER
LIBGFOR_BUILD_QUAD_FALSE
LIBGFOR_BUILD_QUAD_TRUE
......@@ -12346,7 +12349,7 @@ else
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
......@@ -12452,7 +12455,7 @@ else
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
......@@ -26119,9 +26122,22 @@ fi
. ${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}"
......@@ -26765,6 +26781,10 @@ if test -z "${LIBGFOR_BUILD_QUAD_TRUE}" && test -z "${LIBGFOR_BUILD_QUAD_FALSE}"
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
......
libgfortran/configure.ac
......@@ -530,6 +530,10 @@ AC_CHECK_TYPES([fp_rnd,fp_rnd_t], [], [], [[
#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])])
......@@ -539,9 +543,14 @@ AC_CHECK_FUNC([fp_enable],[have_fp_enable=yes AC_DEFINE([HAVE_FP_ENABLE],[1],[fp
# 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)
......
libgfortran/configure.host
......@@ -19,26 +19,32 @@
# 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
......
libgfortran/gfortran.map
......@@ -1195,6 +1195,117 @@ GFORTRAN_1.5 {
_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;
......
libgfortran/ieee/ieee_exceptions.F90 0 → 100644
! 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
libgfortran/ieee/ieee_features.F90 0 → 100644
! 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
libgfortran/libgfortran.h
......@@ -754,15 +754,39 @@ internal_proto(gf_strerror);
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));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment