OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Francois-Xavier Coudert 2014-06-28 14:17:41 +00:00 committed by François-Xavier Coudert
parent a86471635f
commit 8b19810222
36 changed files with 4530 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gcc/fortran/ChangeLog
View File

@ -1,3 +1,24 @@
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

18
gcc/fortran/expr.c
View File

@ -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)
{

5
gcc/fortran/gfortran.h
View File

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

30
gcc/fortran/intrinsic.texi
View File

@ -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

19
gcc/fortran/libgfortran.h
View File

@ -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)

29
gcc/fortran/module.c
View File

@ -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)

86
gcc/fortran/simplify.c
View File

@ -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;
}
@ -5487,6 +5488,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)
{

80
gcc/fortran/trans-decl.c
View File

@ -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);

15
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,18 @@
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.

59
gcc/testsuite/gfortran.dg/ieee/ieee.exp Normal file
View File

@ -0,0 +1,59 @@
# 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

174
gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 Normal file
View File

@ -0,0 +1,174 @@
! { 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

413
gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 Normal file
View File

@ -0,0 +1,413 @@
! { 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

167
gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 Normal file
View File

@ -0,0 +1,167 @@
! { 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

189
gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 Normal file
View File

@ -0,0 +1,189 @@
! { 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

34
gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 Normal file
View File

@ -0,0 +1,34 @@
! { 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

78
gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 Normal file
View File

@ -0,0 +1,78 @@
! { 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

34
gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 Normal file
View File

@ -0,0 +1,34 @@
! { 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

151
gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 Normal file
View File

@ -0,0 +1,151 @@
! { 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

14
gcc/testsuite/lib/target-supports.exp
View File

@ -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

23
libgfortran/ChangeLog
View File

@ -1,3 +1,26 @@
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

45
libgfortran/Makefile.am
View File

@ -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

206
libgfortran/Makefile.in
View File

@ -16,6 +16,7 @@
@SET_MAKE@
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
@ -36,9 +37,10 @@ POST_UNINSTALL = :
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) \
@ -95,7 +97,7 @@ am__uninstall_files_from_dir = { \
}
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 =
@ -245,7 +247,8 @@ am__objects_41 = close.lo file_pos.lo format.lo inquire.lo \
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 \
@ -259,9 +262,11 @@ am__objects_42 = associated.lo abort.lo access.lo args.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 \
@ -285,18 +290,19 @@ am__objects_44 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.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 =
@ -336,6 +342,7 @@ MULTISUBDIR =
MULTIDO = true
MULTICLEAN = true
DATA = $(toolexeclib_DATA)
HEADERS = $(nodist_finclude_HEADERS)
ETAGS = etags
CTAGS = ctags
ACLOCAL = @ACLOCAL@
@ -348,7 +355,7 @@ AMTAR = @AMTAR@
# 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@
@ -376,6 +383,7 @@ FGREP = @FGREP@
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@
@ -516,6 +524,8 @@ libcaf_single_la_SOURCES = caf/single.c
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 \
@ -546,70 +556,39 @@ io/fbuf.h \
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 \
@ -1100,7 +1079,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
@ -1254,9 +1233,9 @@ intrinsics/f2c_specifics.F90
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)
@ -1538,6 +1517,7 @@ distclean-compile:
@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@
@ -1919,6 +1899,12 @@ distclean-compile:
.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
@ -5630,6 +5616,13 @@ in_unpack_generic.lo: runtime/in_unpack_generic.c
@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 $@ $<
@ -5691,6 +5684,24 @@ uninstall-toolexeclibDATA:
@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)'; \
@ -5746,9 +5757,9 @@ distclean-tags:
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)
@ -5808,7 +5819,7 @@ info: info-am
info-am:
install-data-am:
install-data-am: install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
@ -5859,7 +5870,8 @@ ps: ps-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 \
@ -5876,15 +5888,17 @@ uninstall-am: uninstall-cafexeclibLTLIBRARIES \
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 \
@ -5904,6 +5918,20 @@ $(patsubst %.c,%.lo,$(notdir $(i_matmull_c))): AM_CFLAGS += -funroll-loops
# 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
@ -5931,6 +5959,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
@MAINTAINER_MODE_TRUE@$(i_all_c): m4/all.m4 $(I_M4_DEPS2)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 all.m4 > $@

274
libgfortran/config/fpu-387.h
View File

@ -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;
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;
__asm__ __volatile__ ("fstcw\t%0" : "=m" (cw));
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;
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())
@ -130,6 +271,70 @@ get_fpu_except_flags (void)
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)
{
@ -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));
}

267
libgfortran/config/fpu-aix.h
View File

@ -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_trap_exceptions (int trap, int notrap)
{
fptrap_t mode_set = 0, mode_clr = 0;
#ifdef TRP_INVALID
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)
{
fptrap_t mode = 0;
#ifndef TRP_INVALID
if (options.fpe & GFC_FPE_INVALID)
#ifdef TRP_INVALID
mode |= TRP_INVALID;
#else
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);
}

6
libgfortran/config/fpu-generic.h
View File

@ -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)
{

273
libgfortran/config/fpu-glibc.h
View File

@ -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_trap_exceptions (int trap, int notrap)
{
#ifdef FE_INVALID
if (trap & GFC_FPE_INVALID)
feenableexcept (FE_INVALID);
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)
{
if (FE_ALL_EXCEPT != 0)
fedisableexcept (FE_ALL_EXCEPT);
#ifndef FE_INVALID
if (options.fpe & GFC_FPE_INVALID)
#ifdef FE_INVALID
feenableexcept (FE_INVALID);
#else
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);
}

347
libgfortran/config/fpu-sysv.h
View File

@ -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
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
if (notrap & GFC_FPE_INVALID)
cw &= ~FP_X_INV;
#endif
if (options.fpe & GFC_FPE_DENORMAL)
#ifdef FP_X_DNML
if (trap & GFC_FPE_DENORMAL)
cw |= FP_X_DNML;
#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
if (notrap & GFC_FPE_DENORMAL)
cw &= ~FP_X_DNML;
#endif
if (options.fpe & GFC_FPE_ZERO)
#ifdef FP_X_DZ
if (trap & GFC_FPE_ZERO)
cw |= FP_X_DZ;
#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
if (notrap & GFC_FPE_ZERO)
cw &= ~FP_X_DZ;
#endif
if (options.fpe & GFC_FPE_OVERFLOW)
#ifdef FP_X_OFL
if (trap & GFC_FPE_OVERFLOW)
cw |= FP_X_OFL;
#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
if (notrap & GFC_FPE_OVERFLOW)
cw &= ~FP_X_OFL;
#endif
if (options.fpe & GFC_FPE_UNDERFLOW)
#ifdef FP_X_UFL
if (trap & GFC_FPE_UNDERFLOW)
cw |= FP_X_UFL;
#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
if (notrap & GFC_FPE_UNDERFLOW)
cw &= ~FP_X_UFL;
#endif
if (options.fpe & GFC_FPE_INEXACT)
#ifdef FP_X_IMP
if (trap & GFC_FPE_INEXACT)
cw |= FP_X_IMP;
#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
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)
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
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);
}

24
libgfortran/configure vendored
View File

@ -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

9
libgfortran/configure.ac
View File

@ -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)

24
libgfortran/configure.host
View File

@ -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

111
libgfortran/gfortran.map
View File

@ -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;

817
libgfortran/ieee/ieee_arithmetic.F90 Normal file
View File

@ -0,0 +1,817 @@
! 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

218
libgfortran/ieee/ieee_exceptions.F90 Normal file
View File

@ -0,0 +1,218 @@
! 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

49
libgfortran/ieee/ieee_features.F90 Normal file
View File

@ -0,0 +1,49 @@
! 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

407
libgfortran/ieee/ieee_helper.c Normal file
View File

@ -0,0 +1,407 @@
/* 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);
}

26
libgfortran/libgfortran.h
View File

@ -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));