* Re: [fortran, patch] IEEE intrinsic modules
@ 2014-06-05 9:30 Uros Bizjak
2014-06-05 9:35 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Uros Bizjak @ 2014-06-05 9:30 UTC (permalink / raw)
To: gcc-patches; +Cc: FX Coudert, Fortran List
Hello!
> 0. Gradual underflow control is implemented as "not supported by the processor" (its SUPPORT
> function returns false, and the GET and SET procedures abort if you call them). That’s explicitly
> allowed by the standard, so it’s not actually “missing". We can improve on this in the future, if
> people can help.
Please look at libgcc/config/i386/crtfastmath.c for how to set
MXCSR_FTZ from mxcsr. You already have all necessary bits in place,
the function is basically only:
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse |= MXCSR_DAZ;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
Please note, that FTZ applies only to SSE math. x87 and (IIRC) soft-FP
don't handle this setting.
Uros.
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules
2014-06-05 9:30 [fortran, patch] IEEE intrinsic modules Uros Bizjak
@ 2014-06-05 9:35 ` FX
2014-06-05 9:56 ` Uros Bizjak
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-06-05 9:35 UTC (permalink / raw)
To: Uros Bizjak; +Cc: gcc-patches, Fortran List
> Please look at libgcc/config/i386/crtfastmath.c for how to set
> MXCSR_FTZ from mxcsr. You already have all necessary bits in place,
> the function is basically only:
>
> + if (has_sse())
> + {
> + unsigned int cw_sse;
> +
> + __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
> + cw_sse |= MXCSR_DAZ;
> + __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
> + }
Thanks for the suggestion!
> Please note, that FTZ applies only to SSE math. x87 and (IIRC) soft-FP
> don't handle this setting.
Yeah, that’s also why I prefer for now to have it declared as unsupported: the Fortran standard doesn’t really allow for partial support such as this, so I’m still trying to figure out what The Right Thing To Do is.
FX
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules
2014-06-05 9:35 ` FX
@ 2014-06-05 9:56 ` Uros Bizjak
2014-06-15 20:38 ` [fortran, patch] IEEE intrinsic modules (ping) FX
0 siblings, 1 reply; 38+ messages in thread
From: Uros Bizjak @ 2014-06-05 9:56 UTC (permalink / raw)
To: FX; +Cc: gcc-patches, Fortran List
On Thu, Jun 5, 2014 at 11:35 AM, FX <fxcoudert@gmail.com> wrote:
>> Please look at libgcc/config/i386/crtfastmath.c for how to set
>> MXCSR_FTZ from mxcsr. You already have all necessary bits in place,
>> the function is basically only:
>>
>> + if (has_sse())
>> + {
>> + unsigned int cw_sse;
>> +
>> + __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
>> + cw_sse |= MXCSR_DAZ;
>> + __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
>> + }
Oops, the above should read MXCSR_FTZ.
> Thanks for the suggestion!
>
>
>> Please note, that FTZ applies only to SSE math. x87 and (IIRC) soft-FP
>> don't handle this setting.
>
> Yeah, that’s also why I prefer for now to have it declared as unsupported: the Fortran standard doesn’t really allow for partial support such as this, so I’m still trying to figure out what The Right Thing To Do is.
Referring to some older mails [1], this looks like a performance-only
setting (sort of fast-math). So, we can perhaps just set this bit,
regardless of the details. Maybe soft-fp will grow support for FTZ
sometime, it looks like a useful addition from the performance POV.
[1] https://gcc.gnu.org/ml/fortran/2013-11/msg00133.html
Uros.
^ permalink raw reply [flat|nested] 38+ messages in thread
* [fortran, patch] IEEE intrinsic modules (ping)
2014-06-05 9:56 ` Uros Bizjak
@ 2014-06-15 20:38 ` FX
2014-06-23 8:40 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-06-15 20:38 UTC (permalink / raw)
To: gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 2532 bytes --]
ping for the IEEE patch.
Since last time, I incorporated Uros’ comments on the libgfortran/config/fpu-387.h part, and add some documentation to the manual (list of supported targets, and required compilation flags for full IEE support).
OK to commit?
I’d really like to get this into trunk, so it can get some exposure to iron it out…
FX
> Hi,
>
> Last November, I worked on a patch to add the IEEE intrinsic modules to gfortran (thread starting at
> https://gcc.gnu.org/ml/fortran/2013-11/msg00126.html
> ). After a round of review, I continued working on it, then didn’t have time, then development was frozen… Now, I found some time to get back to it, and here’s a more complete patch. I’ve bootstrapped it and regtested on:
>
> – x86_64-linux (both 32-bit and 64-bit); this also uses 387/SSE assembler
> – x86_64-linux with tweaked configure.host to force it to use glibc functions in config/fpu-glibc.h (both 32-bit and 64-bit)
>
> The current state of the patch: as far as I can tell, nearly full support. In particular, since my last patch, I’ve added “saving/restoring FPU state on procedure entry/exit, when IEEE is used”. This is done in trans-decl.c, by wrapping each affected function body between calls to the library:
>
> try
> {
> _gfortran_ieee_procedure_entry ((void *) &fpstate.0);
> /* procedure body goes here */
> }
> finally
> {
> _gfortran_ieee_procedure_exit ((void *) &fpstate.0);
> }
>
>
>
> What’s missing:
>
> 0. Gradual underflow control is implemented as "not supported by the processor" (its SUPPORT function returns false, and the GET and SET procedures abort if you call them). That’s explicitly allowed by the standard, so it’s not actually “missing". We can improve on this in the future, if people can help.
>
> 1. Documenting the flags necessary for full IEEE compatibility: it seems that "-fno-unsafe-math-optimizations -frounding-math -fsignaling-nans” is good, but I’ll have to check that with the floating-point middle-end experts. That’s next on my list: documenting our support, and interaction with compilation flags.
>
> 2. Your review of the patch!
>
>
> I really think getting IEEE support early in stage 1 will benefit the compiler, through good testing before release. I’d like to get this in, but I don’t intend to disappear afterwards… though I’m not stepping back “full time” into the team, I will be there to fix IEEE bugs and issues.
>
> OK to commit?
>
> FX
[-- Attachment #2: ieee_2.ChangeLog --]
[-- Type: application/octet-stream, Size: 2436 bytes --]
gcc/fortran/
2014-06-04 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.
libgfortran/
2014-06-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/29383
* configure.host: Add checks for IEEE support.
* configure.ac: Define IEEE_SUPPORT.
* 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/
2014-06-04 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.
[-- Attachment #3: ieee_2.diff --]
[-- Type: application/octet-stream, Size: 145014 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211688)
+++ gcc/fortran/gfortran.h (working copy)
@@ -660,7 +660,8 @@
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;
@@ -2800,6 +2801,8 @@
/* 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. */
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211688)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211688)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211688)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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;
@@ -4053,7 +4056,10 @@
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));
@@ -6690,6 +6696,7 @@
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);
@@ -6734,6 +6741,26 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211688)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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. */
@@ -1369,8 +1374,9 @@
/* 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
@@ -3262,6 +3268,14 @@
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",
@@ -5507,6 +5521,55 @@
}
+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
@@ -5516,13 +5579,14 @@
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;
@@ -5613,6 +5677,12 @@
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);
@@ -5696,6 +5766,10 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211688)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
Both are equivalent to the value @code{NULL} in C.
+
+
+@node IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES
+@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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211688)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: configure.host
===================================================================
--- configure.host (revision 211688)
+++ configure.host (working copy)
@@ -19,24 +19,30 @@
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
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'
+ ieee_support='yes'
fi
if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes";
then
fpu_host='fpu-aix'
+ ieee_support='yes'
fi
# Some targets require additional compiler options for NaN/Inf.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -539,9 +539,14 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -26,61 +26,140 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ fp_except cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ fp_except cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
@@ -130,7 +209,110 @@
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+#if HAVE_FP_EXCEPT
+ fp_except flags;
+#elif HAVE_FP_EXCEPT_T
+ fp_except_t flags;
+#else
+ choke me
+#endif
+
+ 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)
{
switch (fpgetround ())
@@ -201,3 +383,78 @@
}
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 mask;
+ fp_except sticky;
+ fp_rnd 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);
+
+ s->mask = fpgetmask ();
+ s->sticky = fpgetsticky ();
+ s->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 (s->mask);
+ fpsetsticky (s->sticky);
+ fpsetround (s->round);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211688)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -0,0 +1,53 @@
+# 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 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 "$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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none -O0" }
+
+ 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
[-- Attachment #4: ieee_withregenerated_2.diff --]
[-- Type: application/octet-stream, Size: 164221 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211688)
+++ gcc/fortran/gfortran.h (working copy)
@@ -660,7 +660,8 @@
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;
@@ -2800,6 +2801,8 @@
/* 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. */
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211688)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211688)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211688)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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;
@@ -4053,7 +4056,10 @@
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));
@@ -6690,6 +6696,7 @@
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);
@@ -6734,6 +6741,26 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211688)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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. */
@@ -1369,8 +1374,9 @@
/* 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
@@ -3262,6 +3268,14 @@
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",
@@ -5507,6 +5521,55 @@
}
+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
@@ -5516,13 +5579,14 @@
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;
@@ -5613,6 +5677,12 @@
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);
@@ -5696,6 +5766,10 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211688)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
Both are equivalent to the value @code{NULL} in C.
+
+
+@node IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES
+@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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211688)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: libgfortran/configure
===================================================================
--- libgfortran/configure (revision 211688)
+++ libgfortran/configure (working copy)
@@ -606,6 +606,9 @@
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 @@
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 @@
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 @@
. ${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 @@
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
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 211688)
+++ libgfortran/Makefile.in (working copy)
@@ -16,6 +16,7 @@
@SET_MAKE@
+
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
@@ -36,9 +37,10 @@
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__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 @@
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 @@
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 @@
_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 @@
MULTIDO = true
MULTICLEAN = true
DATA = $(toolexeclib_DATA)
+HEADERS = $(nodist_finclude_HEADERS)
ETAGS = etags
CTAGS = ctags
ACLOCAL = @ACLOCAL@
@@ -348,7 +355,7 @@
# 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 @@
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_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/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 @@
$(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 @@
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 @@
@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 @@
.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 @@
@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,7 +5684,25 @@
@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)'; \
unique=`for i in $$list; do \
@@ -5746,9 +5757,9 @@
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-am:
-install-data-am:
+install-data-am: install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
@@ -5859,7 +5870,8 @@
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 @@
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 @@
# 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 @@
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 > $@
Index: configure.host
===================================================================
--- configure.host (revision 211688)
+++ configure.host (working copy)
@@ -19,24 +19,30 @@
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
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'
+ ieee_support='yes'
fi
if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes";
then
fpu_host='fpu-aix'
+ ieee_support='yes'
fi
# Some targets require additional compiler options for NaN/Inf.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -539,9 +539,14 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -26,61 +26,140 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ fp_except cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ fp_except cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
@@ -130,7 +209,110 @@
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+#if HAVE_FP_EXCEPT
+ fp_except flags;
+#elif HAVE_FP_EXCEPT_T
+ fp_except_t flags;
+#else
+ choke me
+#endif
+
+ 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)
{
switch (fpgetround ())
@@ -201,3 +383,78 @@
}
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 mask;
+ fp_except sticky;
+ fp_rnd 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);
+
+ s->mask = fpgetmask ();
+ s->sticky = fpgetsticky ();
+ s->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 (s->mask);
+ fpsetsticky (s->sticky);
+ fpsetround (s->round);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211688)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -0,0 +1,53 @@
+# 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 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 "$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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none -O0" }
+
+ 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-15 20:38 ` [fortran, patch] IEEE intrinsic modules (ping) FX
@ 2014-06-23 8:40 ` FX
2014-06-23 19:23 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-06-23 8:40 UTC (permalink / raw)
To: gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 3029 bytes --]
ping*2
I understand the size of the patch can be somewhat off-putting, but given its nature it’s rather hard to split it further. Moreover, apart from the OS-specific bits on the library side, it’s not very difficult. If it is hard for anyone to find time to review it in full, may I suggest that it be given a lighter review before commit… then while it gets some real exposure from users/testers, further review can be performed.
FX
> ping for the IEEE patch.
>
> Since last time, I incorporated Uros’ comments on the libgfortran/config/fpu-387.h part, and add some documentation to the manual (list of supported targets, and required compilation flags for full IEE support).
>
> OK to commit?
> I’d really like to get this into trunk, so it can get some exposure to iron it out…
>
> FX
>
>
>
>> Hi,
>>
>> Last November, I worked on a patch to add the IEEE intrinsic modules to gfortran (thread starting at
>> https://gcc.gnu.org/ml/fortran/2013-11/msg00126.html
>> ). After a round of review, I continued working on it, then didn’t have time, then development was frozen… Now, I found some time to get back to it, and here’s a more complete patch. I’ve bootstrapped it and regtested on:
>>
>> – x86_64-linux (both 32-bit and 64-bit); this also uses 387/SSE assembler
>> – x86_64-linux with tweaked configure.host to force it to use glibc functions in config/fpu-glibc.h (both 32-bit and 64-bit)
>>
>> The current state of the patch: as far as I can tell, nearly full support. In particular, since my last patch, I’ve added “saving/restoring FPU state on procedure entry/exit, when IEEE is used”. This is done in trans-decl.c, by wrapping each affected function body between calls to the library:
>>
>> try
>> {
>> _gfortran_ieee_procedure_entry ((void *) &fpstate.0);
>> /* procedure body goes here */
>> }
>> finally
>> {
>> _gfortran_ieee_procedure_exit ((void *) &fpstate.0);
>> }
>>
>>
>>
>> What’s missing:
>>
>> 0. Gradual underflow control is implemented as "not supported by the processor" (its SUPPORT function returns false, and the GET and SET procedures abort if you call them). That’s explicitly allowed by the standard, so it’s not actually “missing". We can improve on this in the future, if people can help.
>>
>> 1. Documenting the flags necessary for full IEEE compatibility: it seems that "-fno-unsafe-math-optimizations -frounding-math -fsignaling-nans” is good, but I’ll have to check that with the floating-point middle-end experts. That’s next on my list: documenting our support, and interaction with compilation flags.
>>
>> 2. Your review of the patch!
>>
>>
>> I really think getting IEEE support early in stage 1 will benefit the compiler, through good testing before release. I’d like to get this in, but I don’t intend to disappear afterwards… though I’m not stepping back “full time” into the team, I will be there to fix IEEE bugs and issues.
>>
>> OK to commit?
>>
>> FX
[-- Attachment #2: ieee_2.ChangeLog --]
[-- Type: application/octet-stream, Size: 2436 bytes --]
gcc/fortran/
2014-06-04 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.
libgfortran/
2014-06-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/29383
* configure.host: Add checks for IEEE support.
* configure.ac: Define IEEE_SUPPORT.
* 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/
2014-06-04 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.
[-- Attachment #3: ieee_2.diff --]
[-- Type: application/octet-stream, Size: 145014 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211688)
+++ gcc/fortran/gfortran.h (working copy)
@@ -660,7 +660,8 @@
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;
@@ -2800,6 +2801,8 @@
/* 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. */
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211688)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211688)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211688)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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;
@@ -4053,7 +4056,10 @@
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));
@@ -6690,6 +6696,7 @@
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);
@@ -6734,6 +6741,26 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211688)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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. */
@@ -1369,8 +1374,9 @@
/* 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
@@ -3262,6 +3268,14 @@
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",
@@ -5507,6 +5521,55 @@
}
+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
@@ -5516,13 +5579,14 @@
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;
@@ -5613,6 +5677,12 @@
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);
@@ -5696,6 +5766,10 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211688)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
Both are equivalent to the value @code{NULL} in C.
+
+
+@node IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES
+@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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211688)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: configure.host
===================================================================
--- configure.host (revision 211688)
+++ configure.host (working copy)
@@ -19,24 +19,30 @@
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
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'
+ ieee_support='yes'
fi
if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes";
then
fpu_host='fpu-aix'
+ ieee_support='yes'
fi
# Some targets require additional compiler options for NaN/Inf.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -539,9 +539,14 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -26,61 +26,140 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ fp_except cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ fp_except cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
@@ -130,7 +209,110 @@
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+#if HAVE_FP_EXCEPT
+ fp_except flags;
+#elif HAVE_FP_EXCEPT_T
+ fp_except_t flags;
+#else
+ choke me
+#endif
+
+ 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)
{
switch (fpgetround ())
@@ -201,3 +383,78 @@
}
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 mask;
+ fp_except sticky;
+ fp_rnd 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);
+
+ s->mask = fpgetmask ();
+ s->sticky = fpgetsticky ();
+ s->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 (s->mask);
+ fpsetsticky (s->sticky);
+ fpsetround (s->round);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211688)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -0,0 +1,53 @@
+# 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 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 "$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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none -O0" }
+
+ 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
[-- Attachment #4: ieee_withregenerated_2.diff --]
[-- Type: application/octet-stream, Size: 164221 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211688)
+++ gcc/fortran/gfortran.h (working copy)
@@ -660,7 +660,8 @@
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;
@@ -2800,6 +2801,8 @@
/* 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. */
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211688)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211688)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211688)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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;
@@ -4053,7 +4056,10 @@
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));
@@ -6690,6 +6696,7 @@
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);
@@ -6734,6 +6741,26 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211688)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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. */
@@ -1369,8 +1374,9 @@
/* 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
@@ -3262,6 +3268,14 @@
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",
@@ -5507,6 +5521,55 @@
}
+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
@@ -5516,13 +5579,14 @@
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;
@@ -5613,6 +5677,12 @@
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);
@@ -5696,6 +5766,10 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211688)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
Both are equivalent to the value @code{NULL} in C.
+
+
+@node IEEE modules: IEEE_EXCEPTIONS, IEEE_ARITHMETIC, and IEEE_FEATURES
+@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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211688)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: libgfortran/configure
===================================================================
--- libgfortran/configure (revision 211688)
+++ libgfortran/configure (working copy)
@@ -606,6 +606,9 @@
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 @@
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 @@
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 @@
. ${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 @@
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
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 211688)
+++ libgfortran/Makefile.in (working copy)
@@ -16,6 +16,7 @@
@SET_MAKE@
+
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
@@ -36,9 +37,10 @@
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__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 @@
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 @@
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 @@
_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 @@
MULTIDO = true
MULTICLEAN = true
DATA = $(toolexeclib_DATA)
+HEADERS = $(nodist_finclude_HEADERS)
ETAGS = etags
CTAGS = ctags
ACLOCAL = @ACLOCAL@
@@ -348,7 +355,7 @@
# 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 @@
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_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/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 @@
$(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 @@
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 @@
@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 @@
.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 @@
@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,7 +5684,25 @@
@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)'; \
unique=`for i in $$list; do \
@@ -5746,9 +5757,9 @@
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-am:
-install-data-am:
+install-data-am: install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
@@ -5859,7 +5870,8 @@
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 @@
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 @@
# 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 @@
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 > $@
Index: configure.host
===================================================================
--- configure.host (revision 211688)
+++ configure.host (working copy)
@@ -19,24 +19,30 @@
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
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'
+ ieee_support='yes'
fi
if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes";
then
fpu_host='fpu-aix'
+ ieee_support='yes'
fi
# Some targets require additional compiler options for NaN/Inf.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -539,9 +539,14 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -26,61 +26,140 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ fp_except cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ fp_except cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
@@ -130,7 +209,110 @@
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+#if HAVE_FP_EXCEPT
+ fp_except flags;
+#elif HAVE_FP_EXCEPT_T
+ fp_except_t flags;
+#else
+ choke me
+#endif
+
+ 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)
{
switch (fpgetround ())
@@ -201,3 +383,78 @@
}
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 mask;
+ fp_except sticky;
+ fp_rnd 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);
+
+ s->mask = fpgetmask ();
+ s->sticky = fpgetsticky ();
+ s->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 (s->mask);
+ fpsetsticky (s->sticky);
+ fpsetround (s->round);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211688)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -0,0 +1,53 @@
+# 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 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 "$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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none -O0" }
+
+ 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-23 8:40 ` FX
@ 2014-06-23 19:23 ` Steve Kargl
2014-06-23 20:20 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: Steve Kargl @ 2014-06-23 19:23 UTC (permalink / raw)
To: FX; +Cc: gcc-patches, Fortran List
I meant to look this over this weekend. Unfortnately, baseball
and soccer (both daughter and USA vs Portugal) got in the way.
First issue,
cd gcc4x
patch < ieee_withregenerated_2.diff
...
--------------------------
|Index: configure.host
|===================================================================
|--- configure.host (revision 211688)
|+++ configure.host (working copy)
--------------------------
File to patch: libgfortran/configure.host
Patching file libgfortran/configure.host using Plan A...
patch: **** malformed patch at line 939: then
As I don't have a top-level configure.host, I guessed that
libgfortran/configure.host was the right file.
All other parts of the patch applied cleanly.
--
steve
On Mon, Jun 23, 2014 at 10:39:30AM +0200, FX wrote:
> ping*2
>
> I understand the size of the patch can be somewhat off-putting, but given its nature it?s rather hard to split it further. Moreover, apart from the OS-specific bits on the library side, it?s not very difficult. If it is hard for anyone to find time to review it in full, may I suggest that it be given a lighter review before commit? then while it gets some real exposure from users/testers, further review can be performed.
>
> FX
>
>
>
>
> > ping for the IEEE patch.
> >
> > Since last time, I incorporated Uros? comments on the libgfortran/config/fpu-387.h part, and add some documentation to the manual (list of supported targets, and required compilation flags for full IEE support).
> >
> > OK to commit?
> > I?d really like to get this into trunk, so it can get some exposure to iron it out?
> >
> > FX
> >
> >
> >
> >> Hi,
> >>
> >> Last November, I worked on a patch to add the IEEE intrinsic modules to gfortran (thread starting at
> >> https://gcc.gnu.org/ml/fortran/2013-11/msg00126.html
> >> ). After a round of review, I continued working on it, then didn?t have time, then development was frozen? Now, I found some time to get back to it, and here?s a more complete patch. I?ve bootstrapped it and regtested on:
> >>
> >> ? x86_64-linux (both 32-bit and 64-bit); this also uses 387/SSE assembler
> >> ? x86_64-linux with tweaked configure.host to force it to use glibc functions in config/fpu-glibc.h (both 32-bit and 64-bit)
> >>
> >> The current state of the patch: as far as I can tell, nearly full support. In particular, since my last patch, I?ve added ?saving/restoring FPU state on procedure entry/exit, when IEEE is used?. This is done in trans-decl.c, by wrapping each affected function body between calls to the library:
> >>
> >> try
> >> {
> >> _gfortran_ieee_procedure_entry ((void *) &fpstate.0);
> >> /* procedure body goes here */
> >> }
> >> finally
> >> {
> >> _gfortran_ieee_procedure_exit ((void *) &fpstate.0);
> >> }
> >>
> >>
> >>
> >> What?s missing:
> >>
> >> 0. Gradual underflow control is implemented as "not supported by the processor" (its SUPPORT function returns false, and the GET and SET procedures abort if you call them). That?s explicitly allowed by the standard, so it?s not actually ?missing". We can improve on this in the future, if people can help.
> >>
> >> 1. Documenting the flags necessary for full IEEE compatibility: it seems that "-fno-unsafe-math-optimizations -frounding-math -fsignaling-nans? is good, but I?ll have to check that with the floating-point middle-end experts. That?s next on my list: documenting our support, and interaction with compilation flags.
> >>
> >> 2. Your review of the patch!
> >>
> >>
> >> I really think getting IEEE support early in stage 1 will benefit the compiler, through good testing before release. I?d like to get this in, but I don?t intend to disappear afterwards? though I?m not stepping back ?full time? into the team, I will be there to fix IEEE bugs and issues.
> >>
> >> OK to commit?
> >>
> >> FX
>
>
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-23 19:23 ` Steve Kargl
@ 2014-06-23 20:20 ` Steve Kargl
2014-06-24 8:11 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Steve Kargl @ 2014-06-23 20:20 UTC (permalink / raw)
To: FX; +Cc: gcc-patches, Fortran List
On Mon, Jun 23, 2014 at 12:23:39PM -0700, Steve Kargl wrote:
> I meant to look this over this weekend. Unfortnately, baseball
> and soccer (both daughter and USA vs Portugal) got in the way.
> First issue,
>
> cd gcc4x
> patch < ieee_withregenerated_2.diff
> ...
> --------------------------
> |Index: configure.host
> |===================================================================
> |--- configure.host (revision 211688)
> |+++ configure.host (working copy)
> --------------------------
> File to patch: libgfortran/configure.host
> Patching file libgfortran/configure.host using Plan A...
> patch: **** malformed patch at line 939: then
>
> As I don't have a top-level configure.host, I guessed that
> libgfortran/configure.host was the right file.
>
Ignoring this chunk, one doesn't get very far with building gcc. :(
if [ xinfo = xinfo ]; then \
rm -f doc/gfortran.info-*; \
makeinfo --split-size=5000000 --split-size=5000000 -I ../../gcc4x/gcc/doc/include -I ../../gcc4x/gcc/fortran \
-o doc/gfortran.info ../../gcc4x/gcc/fortran/gfortran.texi; \
else true; fi
../../gcc4x/gcc/fortran//intrinsic.texi:13399: Prev reference to nonexistent node `IEEE_EXCEPTIONS' (perhaps incorrect sectioning?).
../../gcc4x/gcc/fortran//intrinsic.texi:13372: Next reference to nonexistent node `IEEE_ARITHMETIC' (perhaps incorrect sectioning?).
../../gcc4x/gcc/fortran//intrinsic.texi:13372: Prev reference to nonexistent node `and IEEE_FEATURES' (perhaps incorrect sectioning?).
../../gcc4x/gcc/fortran//intrinsic.texi:13372: `IEEE modules: IEEE_EXCEPTIONS' has no Up field (perhaps incorrect sectioning?).
../../gcc4x/gcc/fortran//intrinsic.texi:13275: Next reference to nonexistent node `IEEE_EXCEPTIONS' (perhaps incorrect sectioning?).
../../gcc4x/gcc/fortran//intrinsic.texi:13158: Menu reference to nonexistent node `IEEE_EXCEPTIONS' (perhaps incorrect sectioning?).
../../gcc4x/gcc/fortran//intrinsic.texi:13372: warning: unreferenced node `IEEE modules: IEEE_EXCEPTIONS'.
makeinfo: Removing output file `doc/gfortran.info' due to errors; use --force to preserve.
gmake[2]: *** [doc/gfortran.info] Error 1
gmake[2]: Leaving directory `/usr/home/kargl/gcc/obj4x/gcc'
gmake[1]: *** [all-gcc] Error 2
gmake[1]: Leaving directory `/usr/home/kargl/gcc/obj4x'
gmake: *** [all] Error 2
laptop-kargl:kargl[239] pwd
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-23 20:20 ` Steve Kargl
@ 2014-06-24 8:11 ` FX
2014-06-24 16:49 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-06-24 8:11 UTC (permalink / raw)
To: Steve Kargl; +Cc: gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 2689 bytes --]
Here’s a patch fixing the diff issue with configure.host and the doc (which apparently is only triggered by some versions of texinfo).
Apart from that, functionnaly identical, so I’ll paste here the “history” of the patch:
---------------------------------------------------
Since last time, I incorporated Uros’ comments on the libgfortran/config/fpu-387.h part, and add some documentation to the manual (list of supported targets, and required compilation flags for full IEE support).
OK to commit?
FX
> Hi,
>
> Last November, I worked on a patch to add the IEEE intrinsic modules to gfortran (thread starting at
> https://gcc.gnu.org/ml/fortran/2013-11/msg00126.html
> ). After a round of review, I continued working on it, then didn’t have time, then development was frozen… Now, I found some time to get back to it, and here’s a more complete patch. I’ve bootstrapped it and regtested on:
>
> – x86_64-linux (both 32-bit and 64-bit); this also uses 387/SSE assembler
> – x86_64-linux with tweaked configure.host to force it to use glibc functions in config/fpu-glibc.h (both 32-bit and 64-bit)
>
> The current state of the patch: as far as I can tell, nearly full support. In particular, since my last patch, I’ve added “saving/restoring FPU state on procedure entry/exit, when IEEE is used”. This is done in trans-decl.c, by wrapping each affected function body between calls to the library:
>
> try
> {
> _gfortran_ieee_procedure_entry ((void *) &fpstate.0);
> /* procedure body goes here */
> }
> finally
> {
> _gfortran_ieee_procedure_exit ((void *) &fpstate.0);
> }
>
>
>
> What’s missing:
>
> 0. Gradual underflow control is implemented as "not supported by the processor" (its SUPPORT function returns false, and the GET and SET procedures abort if you call them). That’s explicitly allowed by the standard, so it’s not actually “missing". We can improve on this in the future, if people can help.
>
> 1. Documenting the flags necessary for full IEEE compatibility: it seems that "-fno-unsafe-math-optimizations -frounding-math -fsignaling-nans” is good, but I’ll have to check that with the floating-point middle-end experts. That’s next on my list: documenting our support, and interaction with compilation flags.
>
> 2. Your review of the patch!
>
>
> I really think getting IEEE support early in stage 1 will benefit the compiler, through good testing before release. I’d like to get this in, but I don’t intend to disappear afterwards… though I’m not stepping back “full time” into the team, I will be there to fix IEEE bugs and issues.
>
> OK to commit?
>
> FX
[-- Attachment #2: ieee_2.ChangeLog --]
[-- Type: application/octet-stream, Size: 2436 bytes --]
gcc/fortran/
2014-06-04 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.
libgfortran/
2014-06-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/29383
* configure.host: Add checks for IEEE support.
* configure.ac: Define IEEE_SUPPORT.
* 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/
2014-06-04 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.
[-- Attachment #3: ieee_withregenerated_2.diff --]
[-- Type: application/octet-stream, Size: 164151 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211688)
+++ gcc/fortran/gfortran.h (working copy)
@@ -660,7 +660,8 @@
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;
@@ -2800,6 +2801,8 @@
/* 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. */
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211688)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211688)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211688)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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;
@@ -4053,7 +4056,10 @@
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));
@@ -6690,6 +6696,7 @@
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);
@@ -6734,6 +6741,26 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211688)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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. */
@@ -1369,8 +1374,9 @@
/* 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
@@ -3262,6 +3268,14 @@
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",
@@ -5507,6 +5521,55 @@
}
+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
@@ -5516,13 +5579,14 @@
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;
@@ -5613,6 +5677,12 @@
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);
@@ -5696,6 +5766,10 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211688)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211688)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: libgfortran/configure
===================================================================
--- libgfortran/configure (revision 211688)
+++ libgfortran/configure (working copy)
@@ -606,6 +606,9 @@
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 @@
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 @@
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 @@
. ${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 @@
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
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 211688)
+++ libgfortran/Makefile.in (working copy)
@@ -16,6 +16,7 @@
@SET_MAKE@
+
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
@@ -36,9 +37,10 @@
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__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 @@
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 @@
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 @@
_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 @@
MULTIDO = true
MULTICLEAN = true
DATA = $(toolexeclib_DATA)
+HEADERS = $(nodist_finclude_HEADERS)
ETAGS = etags
CTAGS = ctags
ACLOCAL = @ACLOCAL@
@@ -348,7 +355,7 @@
# 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 @@
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_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/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 @@
$(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 @@
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 @@
@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 @@
.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 @@
@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,7 +5684,25 @@
@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)'; \
unique=`for i in $$list; do \
@@ -5746,9 +5757,9 @@
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-am:
-install-data-am:
+install-data-am: install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
@@ -5859,7 +5870,8 @@
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 @@
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 @@
# 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 @@
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 > $@
Index: libgfortran/configure.host
===================================================================
--- libgfortran/configure.host (revision 211688)
+++ libgfortran/configure.host (working copy)
@@ -19,24 +19,30 @@
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
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'
+ ieee_support='yes'
fi
if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes"; then
fpu_host='fpu-aix'
+ ieee_support='yes'
fi
# Some targets require additional compiler options for NaN/Inf.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -539,9 +539,14 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -26,61 +26,140 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ fp_except cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ fp_except cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
@@ -130,7 +209,110 @@
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+#if HAVE_FP_EXCEPT
+ fp_except flags;
+#elif HAVE_FP_EXCEPT_T
+ fp_except_t flags;
+#else
+ choke me
+#endif
+
+ 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)
{
switch (fpgetround ())
@@ -201,3 +383,78 @@
}
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 mask;
+ fp_except sticky;
+ fp_rnd 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);
+
+ s->mask = fpgetmask ();
+ s->sticky = fpgetsticky ();
+ s->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 (s->mask);
+ fpsetsticky (s->sticky);
+ fpsetround (s->round);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211688)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -0,0 +1,53 @@
+# 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 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 "$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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none -O0" }
+
+ 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
[-- Attachment #4: ieee_2.diff --]
[-- Type: application/octet-stream, Size: 144944 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211688)
+++ gcc/fortran/gfortran.h (working copy)
@@ -660,7 +660,8 @@
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;
@@ -2800,6 +2801,8 @@
/* 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. */
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211688)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211688)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211688)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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;
@@ -4053,7 +4056,10 @@
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));
@@ -6690,6 +6696,7 @@
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);
@@ -6734,6 +6741,26 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211688)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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. */
@@ -1369,8 +1374,9 @@
/* 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
@@ -3262,6 +3268,14 @@
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",
@@ -5507,6 +5521,55 @@
}
+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
@@ -5516,13 +5579,14 @@
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;
@@ -5613,6 +5677,12 @@
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);
@@ -5696,6 +5766,10 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211688)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211688)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: libgfortran/configure.host
===================================================================
--- libgfortran/configure.host (revision 211688)
+++ libgfortran/configure.host (working copy)
@@ -19,24 +19,30 @@
# DEFAULTS
fpu_host='fpu-generic'
+ieee_support='no'
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'
+ ieee_support='yes'
fi
if test "x${have_fp_enable}" = "xyes" && test "x${have_fp_trap}" = "xyes"; then
fpu_host='fpu-aix'
+ ieee_support='yes'
fi
# Some targets require additional compiler options for NaN/Inf.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -539,9 +539,14 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -26,61 +26,140 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ fp_except cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ fp_except cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
@@ -130,7 +209,110 @@
}
+void
+set_fpu_except_flags (int set, int clear)
+{
+#if HAVE_FP_EXCEPT
+ fp_except flags;
+#elif HAVE_FP_EXCEPT_T
+ fp_except_t flags;
+#else
+ choke me
+#endif
+
+ 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)
{
switch (fpgetround ())
@@ -201,3 +383,78 @@
}
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 mask;
+ fp_except sticky;
+ fp_rnd 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);
+
+ s->mask = fpgetmask ();
+ s->sticky = fpgetsticky ();
+ s->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 (s->mask);
+ fpsetsticky (s->sticky);
+ fpsetround (s->round);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211688)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -0,0 +1,53 @@
+# 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 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 "$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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none -O0" }
+
+ 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
[-- Attachment #5: Type: text/plain, Size: 4 bytes --]
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 8:11 ` FX
@ 2014-06-24 16:49 ` Steve Kargl
2014-06-24 17:46 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: Steve Kargl @ 2014-06-24 16:49 UTC (permalink / raw)
To: FX; +Cc: gcc-patches, Fortran List
On Tue, Jun 24, 2014 at 10:11:32AM +0200, FX wrote:
> Here?s a patch fixing the diff issue with configure.host and the doc (which apparently is only triggered by some versions of texinfo).
> Apart from that, functionnaly identical, so I?ll paste here the ?history? of the patch:
>
> ---------------------------------------------------
>
> Since last time, I incorporated Uros? comments on the libgfortran/config/fpu-387.h part, and add some documentation to the manual (list of supported targets, and required compilation flags for full IEE support).
>
> OK to commit?
>
Not yet.
On i386-*-freebsd
In file included from ../../../gcc4x/libgfortran/runtime/fpu.c:29:0:
./fpu-target.h: In function 'set_fpu_trap_exceptions':
./fpu-target.h:31:3: error: unknown type name 'fp_except'
fp_except cw = fpgetmask();
...
gmake[3]: *** [fpu.lo] Error 1
gmake[3]: Leaving directory `/usr/home/kargl/gcc/obj4x/i386-unknown-freebsd11.0/libgfortran'
gmake[2]: *** [all] Error 2
gmake[2]: Leaving directory `/usr/home/kargl/gcc/obj4x/i386-unknown-freebsd11.0/libgfortran'
gmake[1]: *** [all-target-libgfortran] Error 2
gmake[1]: Leaving directory `/usr/home/kargl/gcc/obj4x'
Looking at the libgfortran/config.log shows that there is an error
in the config test for fp_except_t.
configure:26048: checking for fp_except
configure:26048: /home/kargl/gcc/obj4x/./gcc/xgcc -B/home/kargl/gcc/obj4x/./gcc/ -B/home/kargl/work/i386-unknown-freebsd11.0/bin/ -B/home/kargl/work/i386-unknown-freebsd11.0/lib/ -isystem /home/kargl/work/i386-unknown-freebsd11.0/include -isystem /home/kargl/work/i386-unknown-freebsd11.0/sys-include -c -std=gnu11 -g -O2 conftest.c >&5
conftest.c: In function 'main':
conftest.c:261:13: error: 'fp_except' undeclared (first use in this function)
if (sizeof (fp_except))
^
conftest.c:261:13: note: each undeclared identifier is reported only once for each function it appears in
configure:26048: $? = 1
configure: failed program was:
...
configure:26061: /home/kargl/gcc/obj4x/./gcc/xgcc -B/home/kargl/gcc/obj4x/./gcc/ -B/home/kargl/work/i386-unknown-freebsd11.0/bin/ -B/home/kargl/work/i386-unknown-freebsd11.0/lib/ -isystem /home/kargl/work/i386-unknown-freebsd11.0/include -isystem /home/kargl/work/i386-unknown-freebsd11.0/sys-include -c -std=gnu11 -g -O2 conftest.c >&5
conftest.c: In function 'main':
conftest.c:261:26: error: expected expression before ')' token
if (sizeof ((fp_except_t)))
^
configure:26061: $? = 1
configure: failed program was:
| /* confdefs.h */
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 16:49 ` Steve Kargl
@ 2014-06-24 17:46 ` Steve Kargl
2014-06-24 18:34 ` Tobias Burnus
0 siblings, 1 reply; 38+ messages in thread
From: Steve Kargl @ 2014-06-24 17:46 UTC (permalink / raw)
To: FX; +Cc: gcc-patches, Fortran List
On Tue, Jun 24, 2014 at 09:49:36AM -0700, Steve Kargl wrote:
>
> Not yet.
>
> On i386-*-freebsd
>
> In file included from ../../../gcc4x/libgfortran/runtime/fpu.c:29:0:
> ./fpu-target.h: In function 'set_fpu_trap_exceptions':
> ./fpu-target.h:31:3: error: unknown type name 'fp_except'
> fp_except cw = fpgetmask();
>
The (autogenerated?) fpu-target. h is totally bogus on FreeBSD.
The file includes things like
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);
s->mask = fpgetmask ();
s->sticky = fpgetsticky ();
s->round = fpgetround ();
}
The s-> in the last 3 lines should be state->.
There are several places where fp_except and fp_rnd are used
unconditionally. On FreeBSD (and perhaps other *BSD), there
is no fpsetsticky(). The function is fpresetsticky().
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 17:46 ` Steve Kargl
@ 2014-06-24 18:34 ` Tobias Burnus
2014-06-24 19:19 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: Tobias Burnus @ 2014-06-24 18:34 UTC (permalink / raw)
To: Steve Kargl, FX; +Cc: gcc-patches, Fortran List
Steve Kargl wrote:
> On FreeBSD (and perhaps other *BSD), there is no fpsetsticky(). The function is fpresetsticky().
Solaris has fpsetsticky() (requires ieeefp.h) and BSD has
fpresetsticky() – thus, like at other places in that file, one needs to
conditionally enable one or the other.
Tobias
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 18:34 ` Tobias Burnus
@ 2014-06-24 19:19 ` Steve Kargl
2014-06-24 19:43 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Steve Kargl @ 2014-06-24 19:19 UTC (permalink / raw)
To: Tobias Burnus; +Cc: FX, gcc-patches, Fortran List
On Tue, Jun 24, 2014 at 08:34:23PM +0200, Tobias Burnus wrote:
> Steve Kargl wrote:
> > On FreeBSD (and perhaps other *BSD), there is no fpsetsticky(). The function is fpresetsticky().
>
> Solaris has fpsetsticky() (requires ieeefp.h) and BSD has
> fpresetsticky() ? thus, like at other places in that file, one needs to
> conditionally enable one or the other.
>
I suppose I don't understand the logic in libgfortran/configure.host.
It is picking the wrong config/fpu*.h file.
gmake |& tee sgk.log
shows (long lines wrapped)
cp ../../../gcc4x/libgfortran/config/fpu-sysv.h fpu-target.h
grep '^#define GFC_FPE_' < ../../../gcc4x/libgfortran/../gcc/fortran/\
libgfortran.h > fpu-target.inc || true
grep '^#define GFC_FPE_' < ../../../gcc4x/libgfortran/libgfortran.h \
>> fpu-target.inc || true
gmake all-am
FreeBSD (and the other *BSD) have both feenbleexcept() and
fpsetmask(), but neither check is correct. It seems the check
for feenableexcept assumes glibc and fpsetmask assumes SysV
system.
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 19:19 ` Steve Kargl
@ 2014-06-24 19:43 ` FX
2014-06-24 20:23 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-06-24 19:43 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 1716 bytes --]
Hi Steve,
Thanks for testing on a platform I don’t have access to! I try to answer to the three main points below:
> I suppose I don't understand the logic in libgfortran/configure.host.
> It is picking the wrong config/fpu*.h file.
1. This is a preexisting bug, then. Currently, we have 4 versions of the FPU-specific code:
— fpu-glibc.h works on any platform that has C99 fenv.h + feenableexcept(), fedisableexcept() & fegetexcept() extensions
— fpu-387.h aims at x86/x86_64 systems, and should have priority over fpu-glibc.h (because it allows for control of denormals, which the above does not have)
— fpu-aix.h requires C99 fenv.h + many AIX extensions (fp_trap(), fp_enable(), fp_disable(), fp_is_enabled(), fp_invalid_op())
— fpu-sysv.h requires many SysV function calls: fpgetmask(), fpgetround(), fpgetsticky(), etc.
The logic in configure.host clearly does not accomodate targets who have two styles of calls. I think it should be moved around so that the order of priority is aix < sysv < glibc < 387.
> FreeBSD (and the other *BSD) have both feenbleexcept() and
> fpsetmask(), but neither check is correct. It seems the check
> for feenableexcept assumes glibc and fpsetmask assumes SysV
> system.
2. How does the check fail? What does the config.log say? It looks like a pretty generic check in configure.ac:
AC_CHECK_LIB([m],[feenableexcept],[have_feenableexcept=yes AC_DEFINE([HAVE_FEENABLEEXCEPT],[1],[libm includes feenableexcept])])
checking only if libc or libm contain any call to a feenableexcept() function. Is it a macro on FreeBSD?
3. Does the attached updated patch (libgfortran only, without regenerated files) fix the problem?
FX
[-- Attachment #2: x --]
[-- Type: application/octet-stream, Size: 86108 bytes --]
Index: libgfortran/configure.host
===================================================================
--- libgfortran/configure.host (revision 211688)
+++ libgfortran/configure.host (working copy)
@@ -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
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211688)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211688)
+++ libgfortran/configure.ac (working copy)
@@ -530,6 +530,10 @@
#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 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211688)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211688)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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. */
+
void
-set_fpu (void)
+local_feraiseexcept (int excepts)
{
- int excepts = 0;
+ 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_trap_exceptions (int trap, int notrap)
+{
+ 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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211688)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211688)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -25,73 +25,174 @@
/* 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_trap_exceptions (int trap, int notrap)
+{
+ FP_EXCEPT_TYPE cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
+ cw |= FP_X_INV;
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ FP_EXCEPT_TYPE cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (exceptions & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (exceptions & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (exceptions & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (exceptions & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (exceptions & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (exceptions & 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)
{
- int cw = 0;
-
+#ifndef FP_X_INV
if (options.fpe & GFC_FPE_INVALID)
-#ifdef FP_X_INV
- cw |= FP_X_INV;
-#else
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
int result;
-#if HAVE_FP_EXCEPT
- fp_except set_excepts;
-#elif HAVE_FP_EXCEPT_T
- fp_except_t set_excepts;
-#else
- choke me
-#endif
+ FP_EXCEPT_TYPE set_excepts;
result = 0;
set_excepts = fpgetsticky ();
@@ -130,7 +231,104 @@
}
+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)
{
switch (fpgetround ())
@@ -163,13 +361,7 @@
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 @@
}
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);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211688)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211688)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211688)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 19:43 ` FX
@ 2014-06-24 20:23 ` Steve Kargl
2014-06-24 20:26 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Steve Kargl @ 2014-06-24 20:23 UTC (permalink / raw)
To: FX; +Cc: Tobias Burnus, gcc-patches, Fortran List
On Tue, Jun 24, 2014 at 09:43:06PM +0200, FX wrote:
>
> Thanks for testing on a platform I don?t have access to! I try to
> answer to the three main points below:
>
> > I suppose I don't understand the logic in libgfortran/configure.host.
> > It is picking the wrong config/fpu*.h file.
>
> 1. This is a preexisting bug, then. Currently, we have 4 versions
> of the FPU-specific code:
>
> ? fpu-glibc.h works on any platform that has C99 fenv.h +
> feenableexcept(), fedisableexcept() & fegetexcept() extensions
> ? fpu-387.h aims at x86/x86_64 systems, and should have priority
> over fpu-glibc.h (because it allows for control of denormals,
> which the above does not have)
> ? fpu-aix.h requires C99 fenv.h + many AIX extensions (fp_trap(),
> fp_enable(), fp_disable(), fp_is_enabled(), fp_invalid_op())
> ? fpu-sysv.h requires many SysV function calls: fpgetmask(),
> fpgetround(), fpgetsticky(), etc.
>
> The logic in configure.host clearly does not accomodate targets who
> have two styles of calls. I think it should be moved around so that
> the order of priority is aix < sysv < glibc < 387.
This would work on FreeBSD and probably the other *BSD systems.
> > FreeBSD (and the other *BSD) have both feenbleexcept() and
> > fpsetmask(), but neither check is correct. It seems the check
> > for feenableexcept assumes glibc and fpsetmask assumes SysV
> > system.
>
> 2. How does the check fail?
To get past the build failure, I changed configure.host to
use have_fp_except instead of have_fpsetmask. With FreeBSD
the defined type is fp_except_t instead of the SysV fp_except.
if test "x${have_fp_except}" = "xyes"; then
fpu_host='fpu-sysv'
ieee_support='yes'
fi
I haven't checked to see if haev_dp_except is actually set/unset
by configure. With this change I pick up fpu-i387.h and the build
completes as expected. I'm now in the regression testing stage.
> What does the config.log say? It
> looks like a pretty generic check in configure.ac:
>
> AC_CHECK_LIB([m],[feenableexcept],[have_feenableexcept=yes
> AC_DEFINE([HAVE_FEENABLEEXCEPT],[1],[libm includes feenableexcept])])
config.h eventually ends up with
/* libm includes feenableexcept */
#define HAVE_FEENABLEEXCEPT 1
/* Define to 1 if you have the <fenv.h> header file. */
#define HAVE_FENV_H 1
/* Define if you have fpsetmask. */
#define HAVE_FPSETMASK 1
/* Define to 1 if the system has the type `fp_except'. */
/* #undef HAVE_FP_EXCEPT */
/* Define to 1 if the system has the type `fp_except_t'. */
#define HAVE_FP_EXCEPT_T 1
/* Define to 1 if the system has the type `fp_rnd'. */
/* #undef HAVE_FP_RND */
/* Define to 1 if the system has the type `fp_rnd_t'. */
#define HAVE_FP_RND_T 1
> checking only if libc or libm contain any call to a feenableexcept()
> function. Is it a macro on FreeBSD?
It is function. The problem seems to be that fpu-sysv.h assumes
the types fp_except and fp_rnd whereas FreeBSD has fp_except_t and
fp_rnd_t.
> 3. Does the attached updated patch (libgfortran only, without
> regenerated files) fix the problem?
I'll test it when my regtesting is completed. But, a scan of
the configure.host re-arrangement suggests that it should work.
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 20:23 ` Steve Kargl
@ 2014-06-24 20:26 ` FX
2014-06-24 20:37 ` Steve Kargl
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-06-24 20:26 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, Fortran List
>> 3. Does the attached updated patch (libgfortran only, without
>> regenerated files) fix the problem?
>
> I'll test it when my regtesting is completed. But, a scan of
> the configure.host re-arrangement suggests that it should work.
OK.
If you have some spare cycles, could you then also check it by modifying configure.host so that it uses the updated config/fpu-sysv.h in my patch? I would like to make sure I don’t break anything, but I don’t have access to a Solaris system (and my earlier calls for someone to test it for me were unanswered, so I don’t have much hope there).
Thanks again,
FX
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 20:26 ` FX
@ 2014-06-24 20:37 ` Steve Kargl
[not found] ` <20140624205518.GA81619@troutmask.apl.washington.edu>
2014-07-05 20:42 ` Rainer Orth
0 siblings, 2 replies; 38+ messages in thread
From: Steve Kargl @ 2014-06-24 20:37 UTC (permalink / raw)
To: FX; +Cc: Tobias Burnus, gcc-patches, Fortran List
On Tue, Jun 24, 2014 at 10:26:27PM +0200, FX wrote:
> >> 3. Does the attached updated patch (libgfortran only, without
> >> regenerated files) fix the problem?
> >
> > I'll test it when my regtesting is completed. But, a scan of
> > the configure.host re-arrangement suggests that it should work.
>
> OK.
>
> If you have some spare cycles, could you then also check it by modifying configure.host so that it uses the updated config/fpu-sysv.h in my patch? I would like to make sure I don?t break anything, but I don?t have access to a Solaris system (and my earlier calls for someone to test it for me were unanswered, so I don?t have much hope there).
>
Yes, I'll check the configure.host and fpu-sysv.h changes.
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
[not found] ` <20140624215016.GA81800@troutmask.apl.washington.edu>
@ 2014-06-24 23:41 ` FX
2014-06-25 14:24 ` Steve Kargl
` (2 more replies)
0 siblings, 3 replies; 38+ messages in thread
From: FX @ 2014-06-24 23:41 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, Fortran List, gcc-patches, Janne Blomqvist
[-- Attachment #1: Type: text/plain, Size: 1260 bytes --]
> If I remove the previously installed gcc, the failure again occurs.
> So, it looks like the testsuite is picking up installed *.mod files
> over the freshly built *.mod files. This is not a showstopper.
And this is not all the testsuite, but only ieee_1.F90. After a long chase, it turns out it’s because it has a dg-options, which overrides my IEEE options in ieee.exp. This is because I used dg-options when I should have used dg-additional-options (phew!).
Attached is an updated test gcc/testsuite/gfortran.dg/ieee/ieee_1.F90, please check that it also fixes the spurious errors with non-installed module files.
> I also read through the config/fpu-sysv.h diff. It looks correct
> to me. I do note that I suspect that there is a problem in
> config/fpu-sysv.h.
I concur with your diagnosis. I’ve fixed this, and full new patch is attached (including regenerated files).
> Both Janne and Tobias have stated that they took a quick glance
> over the patch, and with my testing I think you should commit.
> Although you'll probably need to deal with other odd architectures.
I’ll wait a few more days to commit, so others can comment/review and I am sure to be around if there is fallout.
Thanks again for your help!
FX
[-- Attachment #2: ieee_1.F90 --]
[-- Type: application/octet-stream, Size: 4065 bytes --]
! { 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
[-- Attachment #3: ieee_3.diff --]
[-- Type: application/octet-stream, Size: 166177 bytes --]
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 211959)
+++ gcc/fortran/gfortran.h (working copy)
@@ -678,7 +678,8 @@
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 @@
/* 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. */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 211959)
+++ gcc/fortran/expr.c (working copy)
@@ -2460,9 +2460,23 @@
{
gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ gfc_symbol* sym = e->symtree->n.sym;
- 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;
+ }
+ }
+
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 211959)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -35,13 +35,14 @@
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 @@
#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)
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 211959)
+++ gcc/fortran/module.c (working copy)
@@ -190,6 +190,9 @@
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 @@
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 @@
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 @@
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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 211959)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -90,6 +90,9 @@
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_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 @@
/* 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 @@
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 @@
}
+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 @@
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 @@
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 @@
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);
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 211959)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -13155,6 +13155,7 @@
@menu
* ISO_FORTRAN_ENV::
* ISO_C_BINDING::
+* IEEE modules::
* OpenMP Modules OMP_LIB and OMP_LIB_KINDS::
@end menu
@@ -13366,6 +13367,35 @@
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
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 211959)
+++ gcc/fortran/simplify.c (working copy)
@@ -5460,12 +5460,13 @@
if (gfc_real_kinds[i].range >= range)
found_range = 1;
- if (gfc_real_kinds[i].radix >= radix)
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
found_radix = 1;
if (gfc_real_kinds[i].precision >= precision
&& gfc_real_kinds[i].range >= range
- && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < kind)
kind = gfc_real_kinds[i].kind;
}
@@ -5488,6 +5489,87 @@
gfc_expr *
+gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg = expr->value.function.actual;
+ gfc_expr *p = arg->expr, *r = arg->next->expr,
+ *rad = arg->next->next->expr;
+ int precision, range, radix, res;
+ int found_precision, found_range, found_radix, i;
+
+ if (p)
+ {
+ if (p->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (p, &precision) != NULL)
+ return NULL;
+ }
+ else
+ precision = 0;
+
+ if (r)
+ {
+ if (r->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (r, &range) != NULL)
+ return NULL;
+ }
+ else
+ range = 0;
+
+ if (rad)
+ {
+ if (rad->expr_type != EXPR_CONSTANT
+ || gfc_extract_int (rad, &radix) != NULL)
+ return NULL;
+ }
+ else
+ radix = 0;
+
+ res = INT_MAX;
+ found_precision = 0;
+ found_range = 0;
+ found_radix = 0;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ {
+ /* We only support the target's float and double types. */
+ if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
+ continue;
+
+ if (gfc_real_kinds[i].precision >= precision)
+ found_precision = 1;
+
+ if (gfc_real_kinds[i].range >= range)
+ found_range = 1;
+
+ if (radix == 0 || gfc_real_kinds[i].radix == radix)
+ found_radix = 1;
+
+ if (gfc_real_kinds[i].precision >= precision
+ && gfc_real_kinds[i].range >= range
+ && (radix == 0 || gfc_real_kinds[i].radix == radix)
+ && gfc_real_kinds[i].kind < res)
+ res = gfc_real_kinds[i].kind;
+ }
+
+ if (res == INT_MAX)
+ {
+ if (found_radix && found_range && !found_precision)
+ res = -1;
+ else if (found_radix && found_precision && !found_range)
+ res = -2;
+ else if (found_radix && !found_precision && !found_range)
+ res = -3;
+ else if (found_radix)
+ res = -4;
+ else
+ res = -5;
+ }
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
+}
+
+
+gfc_expr *
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
{
gfc_expr *result;
Index: libgfortran/configure
===================================================================
--- libgfortran/configure (revision 211959)
+++ libgfortran/configure (working copy)
@@ -606,6 +606,9 @@
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 @@
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 @@
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 @@
. ${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 @@
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
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 211959)
+++ libgfortran/Makefile.in (working copy)
@@ -16,6 +16,7 @@
@SET_MAKE@
+
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
@@ -36,9 +37,10 @@
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__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 @@
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 @@
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 @@
_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 @@
MULTIDO = true
MULTICLEAN = true
DATA = $(toolexeclib_DATA)
+HEADERS = $(nodist_finclude_HEADERS)
ETAGS = etags
CTAGS = ctags
ACLOCAL = @ACLOCAL@
@@ -348,7 +355,7 @@
# 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 @@
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_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/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 @@
$(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 @@
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 @@
@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 @@
.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 @@
@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,7 +5684,25 @@
@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)'; \
unique=`for i in $$list; do \
@@ -5746,9 +5757,9 @@
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-am:
-install-data-am:
+install-data-am: install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
@@ -5859,7 +5870,8 @@
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 @@
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 @@
# 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 @@
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 > $@
Index: libgfortran/configure.host
===================================================================
--- libgfortran/configure.host (revision 211959)
+++ libgfortran/configure.host (working copy)
@@ -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
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 211959)
+++ libgfortran/gfortran.map (working copy)
@@ -1195,6 +1195,117 @@
_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;
Index: libgfortran/configure.ac
===================================================================
--- libgfortran/configure.ac (revision 211959)
+++ libgfortran/configure.ac (working copy)
@@ -530,6 +530,10 @@
#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 @@
# 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)
Index: libgfortran/ieee/ieee_features.F90
===================================================================
--- libgfortran/ieee/ieee_features.F90 (revision 0)
+++ libgfortran/ieee/ieee_features.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_exceptions.F90
===================================================================
--- libgfortran/ieee/ieee_exceptions.F90 (revision 0)
+++ libgfortran/ieee/ieee_exceptions.F90 (revision 0)
@@ -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
Index: libgfortran/ieee/ieee_helper.c
===================================================================
--- libgfortran/ieee/ieee_helper.c (revision 0)
+++ libgfortran/ieee/ieee_helper.c (revision 0)
@@ -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);
+}
+
Index: libgfortran/ieee/ieee_arithmetic.F90
===================================================================
--- libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
+++ libgfortran/ieee/ieee_arithmetic.F90 (revision 0)
@@ -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
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 211959)
+++ libgfortran/libgfortran.h (working copy)
@@ -754,15 +754,39 @@
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));
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 211959)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,6 +23,8 @@
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,25 +64,123 @@
#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 |= exc_clr;
+ cw &= ~exc_set;
- cw |= _FPU_MASK_ALL;
- cw &= ~excepts;
-
__asm__ __volatile__ ("fnclex\n\tfldcw\t%0" : : "m" (cw));
if (has_sse())
@@ -90,8 +190,8 @@
__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,14 +200,55 @@
}
}
+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)
{
unsigned short cw;
int excepts;
int result = 0;
- __asm__ __volatile__ ("fnstsw\t%0" : "=a" (cw));
+ __asm__ __volatile__ ("fnstsw\t%0" : "=am" (cw));
excepts = cw;
if (has_sse())
@@ -131,6 +272,70 @@
}
void
+set_fpu_except_flags (int set, int clear)
+{
+ my_fenv_t temp;
+ int exc_set = 0, exc_clr = 0;
+
+ /* Translate from GFC_PE_* values to _FPU_MASK_* values. */
+ if (set & GFC_FPE_INVALID)
+ exc_set |= _FPU_MASK_IM;
+ if (clear & GFC_FPE_INVALID)
+ exc_clr |= _FPU_MASK_IM;
+
+ if (set & GFC_FPE_DENORMAL)
+ exc_set |= _FPU_MASK_DM;
+ if (clear & GFC_FPE_DENORMAL)
+ exc_clr |= _FPU_MASK_DM;
+
+ if (set & GFC_FPE_ZERO)
+ exc_set |= _FPU_MASK_ZM;
+ if (clear & GFC_FPE_ZERO)
+ exc_clr |= _FPU_MASK_ZM;
+
+ if (set & GFC_FPE_OVERFLOW)
+ exc_set |= _FPU_MASK_OM;
+ if (clear & GFC_FPE_OVERFLOW)
+ exc_clr |= _FPU_MASK_OM;
+
+ if (set & GFC_FPE_UNDERFLOW)
+ exc_set |= _FPU_MASK_UM;
+ if (clear & GFC_FPE_UNDERFLOW)
+ exc_clr |= _FPU_MASK_UM;
+
+ if (set & GFC_FPE_INEXACT)
+ exc_set |= _FPU_MASK_PM;
+ if (clear & GFC_FPE_INEXACT)
+ exc_clr |= _FPU_MASK_PM;
+
+
+ /* Change the flags. This is tricky on 387 (unlike SSE), because we have
+ FNSTSW but no FLDSW instruction. */
+ __asm__ __volatile__ ("fnstenv\t%0" : "=m" (temp));
+ temp.__status_word &= ~exc_clr;
+ __asm__ __volatile__ ("fldenv\t%0" : : "m" (temp));
+
+ /* Change the flags on SSE. */
+
+ if (has_sse())
+ {
+ unsigned int cw_sse;
+
+ __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+ cw_sse &= ~exc_clr;
+ __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+ }
+
+ local_feraiseexcept (exc_set);
+}
+
+int
+support_fpu_flag (int flag __attribute__((unused)))
+{
+ return 1;
+}
+
+void
set_fpu_rounding_mode (int round)
{
int round_mode;
@@ -213,3 +418,44 @@
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));
+}
+
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 211959)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -33,15 +33,103 @@
#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 @@
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,7 +196,99 @@
}
+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)
{
int rnd_mode;
@@ -188,3 +358,60 @@
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);
+}
+
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 211959)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -25,73 +25,174 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
+/* BSD and Solaris systems have slightly different types and functions
+ naming. We deal with these here, to simplify the code below. */
+
+#if HAVE_FP_EXCEPT
+# define FP_EXCEPT_TYPE fp_except
+#elif HAVE_FP_EXCEPT_T
+# define FP_EXCEPT_TYPE fp_except_t
+#else
+ choke me
+#endif
+
+#if HAVE_FP_RND
+# define FP_RND_TYPE fp_rnd
+#elif HAVE_FP_RND_T
+# define FP_RND_TYPE fp_rnd_t
+#else
+ choke me
+#endif
+
+#if HAVE_FPSETSTICKY
+# define FPSETSTICKY fpsetsticky
+#elif HAVE_FPRESETSTICKY
+# define FPSETSTICKY fpresetsticky
+#else
+ choke me
+#endif
+
+
void
-set_fpu (void)
+set_fpu_trap_exceptions (int trap, int notrap)
{
- int cw = 0;
+ FP_EXCEPT_TYPE cw = fpgetmask();
- if (options.fpe & GFC_FPE_INVALID)
#ifdef FP_X_INV
+ if (trap & GFC_FPE_INVALID)
cw |= FP_X_INV;
-#else
+ if (notrap & GFC_FPE_INVALID)
+ cw &= ~FP_X_INV;
+#endif
+
+#ifdef FP_X_DNML
+ if (trap & GFC_FPE_DENORMAL)
+ cw |= FP_X_DNML;
+ if (notrap & GFC_FPE_DENORMAL)
+ cw &= ~FP_X_DNML;
+#endif
+
+#ifdef FP_X_DZ
+ if (trap & GFC_FPE_ZERO)
+ cw |= FP_X_DZ;
+ if (notrap & GFC_FPE_ZERO)
+ cw &= ~FP_X_DZ;
+#endif
+
+#ifdef FP_X_OFL
+ if (trap & GFC_FPE_OVERFLOW)
+ cw |= FP_X_OFL;
+ if (notrap & GFC_FPE_OVERFLOW)
+ cw &= ~FP_X_OFL;
+#endif
+
+#ifdef FP_X_UFL
+ if (trap & GFC_FPE_UNDERFLOW)
+ cw |= FP_X_UFL;
+ if (notrap & GFC_FPE_UNDERFLOW)
+ cw &= ~FP_X_UFL;
+#endif
+
+#ifdef FP_X_IMP
+ if (trap & GFC_FPE_INEXACT)
+ cw |= FP_X_IMP;
+ if (notrap & GFC_FPE_INEXACT)
+ cw &= ~FP_X_IMP;
+#endif
+
+ fpsetmask(cw);
+}
+
+
+int
+get_fpu_trap_exceptions (void)
+{
+ int res = 0;
+ FP_EXCEPT_TYPE cw = fpgetmask();
+
+#ifdef FP_X_INV
+ if (cw & FP_X_INV) res |= GFC_FPE_INVALID;
+#endif
+
+#ifdef FP_X_DNML
+ if (cw & FP_X_DNML) res |= GFC_FPE_DENORMAL;
+#endif
+
+#ifdef FP_X_DZ
+ if (cw & FP_X_DZ) res |= GFC_FPE_ZERO;
+#endif
+
+#ifdef FP_X_OFL
+ if (cw & FP_X_OFL) res |= GFC_FPE_OVERFLOW;
+#endif
+
+#ifdef FP_X_UFL
+ if (cw & FP_X_UFL) res |= GFC_FPE_UNDERFLOW;
+#endif
+
+#ifdef FP_X_IMP
+ if (cw & FP_X_IMP) res |= GFC_FPE_INEXACT;
+#endif
+
+ return res;
+}
+
+
+int
+support_fpu_trap (int flag)
+{
+ return support_fpu_flag (flag);
+}
+
+
+void
+set_fpu (void)
+{
+#ifndef FP_X_INV
+ if (options.fpe & GFC_FPE_INVALID)
estr_write ("Fortran runtime warning: IEEE 'invalid operation' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DNML
if (options.fpe & GFC_FPE_DENORMAL)
-#ifdef FP_X_DNML
- cw |= FP_X_DNML;
-#else
estr_write ("Fortran runtime warning: Floating point 'denormal operand' "
"exception not supported.\n");
#endif
+#ifndef FP_X_DZ
if (options.fpe & GFC_FPE_ZERO)
-#ifdef FP_X_DZ
- cw |= FP_X_DZ;
-#else
estr_write ("Fortran runtime warning: IEEE 'division by zero' "
"exception not supported.\n");
#endif
+#ifndef FP_X_OFL
if (options.fpe & GFC_FPE_OVERFLOW)
-#ifdef FP_X_OFL
- cw |= FP_X_OFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'overflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_UFL
if (options.fpe & GFC_FPE_UNDERFLOW)
-#ifdef FP_X_UFL
- cw |= FP_X_UFL;
-#else
estr_write ("Fortran runtime warning: IEEE 'underflow' "
"exception not supported.\n");
#endif
+#ifndef FP_X_IMP
if (options.fpe & GFC_FPE_INEXACT)
-#ifdef FP_X_IMP
- cw |= FP_X_IMP;
-#else
estr_write ("Fortran runtime warning: IEEE 'inexact' "
"exception not supported.\n");
#endif
- fpsetmask(cw);
+ set_fpu_trap_exceptions (options.fpe, 0);
}
+
int
get_fpu_except_flags (void)
{
int result;
-#if HAVE_FP_EXCEPT
- fp_except set_excepts;
-#elif HAVE_FP_EXCEPT_T
- fp_except_t set_excepts;
-#else
- choke me
-#endif
+ FP_EXCEPT_TYPE set_excepts;
result = 0;
set_excepts = fpgetsticky ();
@@ -130,7 +231,104 @@
}
+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)
{
switch (fpgetround ())
@@ -163,13 +361,7 @@
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 @@
}
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);
+}
+
Index: libgfortran/config/fpu-generic.h
===================================================================
--- libgfortran/config/fpu-generic.h (revision 211959)
+++ libgfortran/config/fpu-generic.h (working copy)
@@ -51,6 +51,12 @@
"exception not supported.\n");
}
+void
+set_fpu_trap_exceptions (int trap __attribute__((unused)),
+ int notrap __attribute__((unused)))
+{
+}
+
int
get_fpu_except_flags (void)
{
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 211959)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,63 +27,141 @@
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,7 +207,103 @@
}
+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)
{
int rnd_mode;
@@ -199,3 +373,60 @@
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);
+}
+
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 211959)
+++ libgfortran/Makefile.am (working copy)
@@ -54,6 +54,11 @@
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 @@
# 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 @@
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 @@
$(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 %.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 @@
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
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
--- gcc/testsuite/lib/target-supports.exp (revision 211959)
+++ gcc/testsuite/lib/target-supports.exp (working copy)
@@ -1110,6 +1110,20 @@
}
+# 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
Index: gcc/testsuite/gfortran.dg/ieee/ieee.exp
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_1.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_2.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_4.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_5.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 (revision 0)
@@ -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
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 23:41 ` FX
@ 2014-06-25 14:24 ` Steve Kargl
2014-06-29 8:43 ` Andreas Schwab
2019-02-28 19:22 ` Thomas Schwinge
2 siblings, 0 replies; 38+ messages in thread
From: Steve Kargl @ 2014-06-25 14:24 UTC (permalink / raw)
To: FX; +Cc: Tobias Burnus, Fortran List, gcc-patches, Janne Blomqvist
On Wed, Jun 25, 2014 at 01:41:02AM +0200, FX wrote:
> > If I remove the previously installed gcc, the failure again occurs.
> > So, it looks like the testsuite is picking up installed *.mod files
> > over the freshly built *.mod files. This is not a showstopper.
>
> And this is not all the testsuite, but only ieee_1.F90. After a long
> chase, it turns out it?s because it has a dg-options, which overrides
> my IEEE options in ieee.exp. This is because I used dg-options when I
> should have used dg-additional-options (phew!).
Testcase now passes.
>
> > I also read through the config/fpu-sysv.h diff. It looks correct
> > to me. I do note that I suspect that there is a problem in
> > config/fpu-sysv.h.
>
> I concur with your diagnosis. I?ve fixed this, and full new patch
> is attached (including regenerated files).
>
> > Both Janne and Tobias have stated that they took a quick glance
> > over the patch, and with my testing I think you should commit.
> > Although you'll probably need to deal with other odd architectures.
>
> I?ll wait a few more days to commit, so others can comment/review
> and I am sure to be around if there is fallout.
>
I tested the new diff and ieee_1.F90 on x86_64-*-freebsd.
'gmake check-gfortran' passed without any new issues.
Thanks for taking on the IEEE features of Fortran.
--
Steve
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 23:41 ` FX
2014-06-25 14:24 ` Steve Kargl
@ 2014-06-29 8:43 ` Andreas Schwab
2014-06-29 9:53 ` FX
2019-02-28 19:22 ` Thomas Schwinge
2 siblings, 1 reply; 38+ messages in thread
From: Andreas Schwab @ 2014-06-29 8:43 UTC (permalink / raw)
To: FX; +Cc: Steve Kargl, Tobias Burnus, Fortran List, gcc-patches, Janne Blomqvist
FX <fxcoudert@gmail.com> writes:
> Index: gcc/testsuite/gfortran.dg/ieee/ieee_6.f90
> ===================================================================
> --- gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
> +++ gcc/testsuite/gfortran.dg/ieee/ieee_6.f90 (revision 0)
> @@ -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.)
This may raise inexact, see C11 7.6.2.3. Installed as obvious.
Andreas.
* gfortran.dg/ieee/ieee_6.f90: Allow inexact together with
underflow.
Index: gfortran.dg/ieee/ieee_6.f90
===================================================================
--- gfortran.dg/ieee/ieee_6.f90 (revision 212119)
+++ gfortran.dg/ieee/ieee_6.f90 (working copy)
@@ -40,7 +40,9 @@
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
+ .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) call abort
call ieee_get_rounding_mode(mode)
if (mode /= ieee_to_zero) call abort
call ieee_get_halting_mode(ieee_all, halt)
@@ -50,7 +52,9 @@
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
+ .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) call abort
call ieee_get_rounding_mode(mode)
if (mode /= ieee_to_zero) call abort
call ieee_get_halting_mode(ieee_all, halt)
@@ -69,7 +73,9 @@
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
+ .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) &
+ .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) call abort
call ieee_get_rounding_mode(mode)
if (mode /= ieee_to_zero) call abort
call ieee_get_halting_mode(ieee_all, halt)
--
Andreas Schwab, schwab@linux-m68k.org
GPG Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-29 8:43 ` Andreas Schwab
@ 2014-06-29 9:53 ` FX
0 siblings, 0 replies; 38+ messages in thread
From: FX @ 2014-06-29 9:53 UTC (permalink / raw)
To: Andreas Schwab
Cc: Steve Kargl, Tobias Burnus, Fortran List, gcc-patches, Janne Blomqvist
> This may raise inexact, see C11 7.6.2.3. Installed as obvious.
Thanks!
FX
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 20:37 ` Steve Kargl
[not found] ` <20140624205518.GA81619@troutmask.apl.washington.edu>
@ 2014-07-05 20:42 ` Rainer Orth
2014-07-06 20:13 ` FX
1 sibling, 1 reply; 38+ messages in thread
From: Rainer Orth @ 2014-07-05 20:42 UTC (permalink / raw)
To: Steve Kargl; +Cc: FX, Tobias Burnus, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 2251 bytes --]
Steve Kargl <sgk@troutmask.apl.washington.edu> writes:
> On Tue, Jun 24, 2014 at 10:26:27PM +0200, FX wrote:
>> >> 3. Does the attached updated patch (libgfortran only, without
>> >> regenerated files) fix the problem?
>> >
>> > I'll test it when my regtesting is completed. But, a scan of
>> > the configure.host re-arrangement suggests that it should work.
>>
>> OK.
>>
>> If you have some spare cycles, could you then also check it by modifying configure.host so that it uses the updated config/fpu-sysv.h in my patch? I would like to make sure I don?t break anything, but I don?t have access to a Solaris system (and my earlier calls for someone to test it for me were unanswered, so I don?t have much hope there).
>>
>
> Yes, I'll check the configure.host and fpu-sysv.h changes.
I'm currently moving to a new flat, so not much time for GCC work.
Unfortunately, while the patch works fine on Solaris/x86, it broke
Solaris/SPARC bootstrap for trivial reasons: contrary to the ChangeLog,
configure and config.h.in weren't regenerated, thus FPSETSTICKY
wasn't defined.
The following patch corrects this, at the same time fixing this warning:
/fpu-target.h:451:3: warning: implicit declaration of function 'assert' [-Wimplicit-function-declaration]
assert (sizeof(fpu_state_t) <= GFC_FPE_STATE_BUFFER_SIZE);
^
It returns sparc-sun-solaris2.1[01] to bootstrap, thus installed as
obvious.
There's one testsuite failure in this configuration:
FAIL: gfortran.dg/ieee/ieee_6.f90 -O0 execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -O1 execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -O2 execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -O3 -fomit-frame-pointer execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -O3 -fomit-frame-pointer -funroll-loops execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -O3 -fomit-frame-pointer -funroll-all-loops -finline-functions execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -O3 -g execution test
FAIL: gfortran.dg/ieee/ieee_6.f90 -Os execution tes
The test aborts at l.47, but unfortunately I cannot print mode in gdb 7.7.
Rainer
2014-07-05 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* configure, config.h.in: Regenerate.
* config/fpu-sysv.h: Include <assert.h>.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: libgfortran-ieee-bootstrap.patch --]
[-- Type: text/x-patch, Size: 439 bytes --]
diff --git a/libgfortran/config/fpu-sysv.h b/libgfortran/config/fpu-sysv.h
--- a/libgfortran/config/fpu-sysv.h
+++ b/libgfortran/config/fpu-sysv.h
@@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTI
/* FPU-related code for SysV platforms with fpsetmask(). */
+#include <assert.h>
+
/* BSD and Solaris systems have slightly different types and functions
naming. We deal with these here, to simplify the code below. */
[-- Attachment #3: Type: text/plain, Size: 143 bytes --]
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-05 20:42 ` Rainer Orth
@ 2014-07-06 20:13 ` FX
2014-07-07 6:44 ` Janne Blomqvist
2014-07-07 8:30 ` Rainer Orth
0 siblings, 2 replies; 38+ messages in thread
From: FX @ 2014-07-06 20:13 UTC (permalink / raw)
To: Rainer Orth; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 1219 bytes --]
Dear Rainer,
> Unfortunately, while the patch works fine on Solaris/x86, it broke
> Solaris/SPARC bootstrap for trivial reasons: contrary to the ChangeLog,
> configure and config.h.in weren't regenerated, thus FPSETSTICKY
> wasn't defined.
I apologize. Thanks for checking in the fix.
> FAIL: gfortran.dg/ieee/ieee_6.f90 -Os execution test
>
> The test aborts at l.47, but unfortunately I cannot print mode in gdb 7.7.
That’s weird, especially if that one fails but ieee_rounding_1.f90 works. Let me know if I can do anything to help debug this.
> The following patch corrects this, at the same time fixing this warning:
>
> /fpu-target.h:451:3: warning: implicit declaration of function 'assert' [-Wimplicit-function-declaration]
> assert (sizeof(fpu_state_t) <= GFC_FPE_STATE_BUFFER_SIZE);
Actually, it makes a lot of sense to change these into static assertions: this way, any target-specific issues with FP-state buffer size will show up at libgfortran-building-time, rather than be swept under the rug.
Since libgfortran is compiled with GCC, which supports _Static_assert since 4.6, I propose the attached patch.
Built and tested on x86_64-linux, OK to commit?
FX
[-- Attachment #2: static_assert.ChangeLog --]
[-- Type: application/octet-stream, Size: 165 bytes --]
2014-07-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* config/fpu-387.h, config/fpu-aix.h, config/fpu-sysv.h,
config/fpu-glibc.h: Use static assertions.
[-- Attachment #3: static_assert.diff --]
[-- Type: application/octet-stream, Size: 4924 bytes --]
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 212313)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -23,8 +23,6 @@
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
@@ -85,6 +83,11 @@
my_fenv_t;
+/* Check we can actually store the FPU state in the allocated size. */
+_Static_assert (sizeof(my_fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
+ "GFC_FPE_STATE_BUFFER_SIZE is too small");
+
+
/* Raise the supported floating-point exceptions from EXCEPTS. Other
bits in EXCEPTS are ignored. Code originally borrowed from
libatomic/config/x86/fenv.c. */
@@ -429,9 +432,6 @@
{
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
@@ -447,9 +447,6 @@
{
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));
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 212313)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -38,6 +38,11 @@
#endif
+/* Check we can actually store the FPU state in the allocated size. */
+_Static_assert (sizeof(fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
+ "GFC_FPE_STATE_BUFFER_SIZE is too small");
+
+
void
set_fpu_trap_exceptions (int trap, int notrap)
{
@@ -403,18 +408,12 @@
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);
}
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 212313)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -25,8 +25,6 @@
/* FPU-related code for SysV platforms with fpsetmask(). */
-#include <assert.h>
-
/* BSD and Solaris systems have slightly different types and functions
naming. We deal with these here, to simplify the code below. */
@@ -55,6 +53,8 @@
#endif
+
+
void
set_fpu_trap_exceptions (int trap, int notrap)
{
@@ -444,14 +444,16 @@
} fpu_state_t;
+/* Check we can actually store the FPU state in the allocated size. */
+_Static_assert (sizeof(fpu_state_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
+ "GFC_FPE_STATE_BUFFER_SIZE is too small");
+
+
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 ();
@@ -462,9 +464,6 @@
{
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);
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 212313)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -27,13 +27,16 @@
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
+/* Check we can actually store the FPU state in the allocated size. */
+_Static_assert (sizeof(fenv_t) <= (size_t) GFC_FPE_STATE_BUFFER_SIZE,
+ "GFC_FPE_STATE_BUFFER_SIZE is too small");
+
+
void set_fpu_trap_exceptions (int trap, int notrap)
{
#ifdef FE_INVALID
@@ -416,9 +419,6 @@
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);
}
@@ -426,9 +426,6 @@
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);
}
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-06 20:13 ` FX
@ 2014-07-07 6:44 ` Janne Blomqvist
2014-07-07 8:29 ` FX
2014-07-07 8:30 ` Rainer Orth
1 sibling, 1 reply; 38+ messages in thread
From: Janne Blomqvist @ 2014-07-07 6:44 UTC (permalink / raw)
To: FX; +Cc: Rainer Orth, Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
On Sun, Jul 6, 2014 at 11:13 PM, FX <fxcoudert@gmail.com> wrote:
> Actually, it makes a lot of sense to change these into static assertions: this way, any target-specific issues with FP-state buffer size will show up at libgfortran-building-time, rather than be swept under the rug.
>
> Since libgfortran is compiled with GCC, which supports _Static_assert since 4.6, I propose the attached patch.
Furthermore, on 2014-05-12 I committed a patch changing libgfortran to
be built with -std=gnu11 instead of -std=gnu99, so that we can make
use of C11 functionality; see
https://gcc.gnu.org/ml/fortran/2014-04/msg00101.html .
> Built and tested on x86_64-linux, OK to commit?
Ok, thanks.
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 6:44 ` Janne Blomqvist
@ 2014-07-07 8:29 ` FX
2014-07-07 9:10 ` Janne Blomqvist
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-07-07 8:29 UTC (permalink / raw)
To: Janne Blomqvist; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 734 bytes --]
> Furthermore, on 2014-05-12 I committed a patch changing libgfortran to
> be built with -std=gnu11 instead of -std=gnu99, so that we can make
> use of C11 functionality; see
> https://gcc.gnu.org/ml/fortran/2014-04/msg00101.html .
Committed as rev. 212323, thanks for the review.
I now propose the attached patch, which performs a small cleaning up:
- Use the new _Noreturn language feature (supported in GCC since 2011) instead of the old attribute. This makes prototypes shorter and more generic.
- Move the complex-related REALPART, IMAGPART and COMPLEX_ASSIGN macros from libgfortran.h to c99_intrinsics.c, which is the only place they’re ever used.
Built and tested on x86_64-linux, OK to commit?
FX
[-- Attachment #2: clean.ChangeLog --]
[-- Type: application/octet-stream, Size: 247 bytes --]
2014-07-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* runtime/stop.c: Use C11 _Noreturn.
* libgfortran.h: Use C11 _Noreturn in prototypes.
Move REALPART, IMAGPART and COMPLEX_ASSIGN macros...
* intrinsics/c99_functions.c: ... here.
[-- Attachment #3: clean.diff --]
[-- Type: application/octet-stream, Size: 4169 bytes --]
Index: runtime/stop.c
===================================================================
--- runtime/stop.c (revision 212323)
+++ runtime/stop.c (working copy)
@@ -83,8 +83,7 @@
/* A numeric STOP statement. */
-extern void stop_numeric (GFC_INTEGER_4)
- __attribute__ ((noreturn));
+extern _Noreturn void stop_numeric (GFC_INTEGER_4);
export_proto(stop_numeric);
void
@@ -102,8 +101,7 @@
/* A Fortran 2008 numeric STOP statement. */
-extern void stop_numeric_f08 (GFC_INTEGER_4)
- __attribute__ ((noreturn));
+extern _Noreturn void stop_numeric_f08 (GFC_INTEGER_4);
export_proto(stop_numeric_f08);
void
@@ -136,8 +134,7 @@
initiates error termination of execution." Thus, error_stop_string returns
a nonzero exit status code. */
-extern void error_stop_string (const char *, GFC_INTEGER_4)
- __attribute__ ((noreturn));
+extern _Noreturn void error_stop_string (const char *, GFC_INTEGER_4);
export_proto(error_stop_string);
void
@@ -154,8 +151,7 @@
/* A numeric ERROR STOP statement. */
-extern void error_stop_numeric (GFC_INTEGER_4)
- __attribute__ ((noreturn));
+extern _Noreturn void error_stop_numeric (GFC_INTEGER_4);
export_proto(error_stop_numeric);
void
Index: intrinsics/c99_functions.c
===================================================================
--- intrinsics/c99_functions.c (revision 212323)
+++ intrinsics/c99_functions.c (working copy)
@@ -39,6 +39,13 @@
# endif
#endif
+/* Macros to get real and imaginary parts of a complex, and set
+ a complex value. */
+#define REALPART(z) (__real__(z))
+#define IMAGPART(z) (__imag__(z))
+#define COMPLEX_ASSIGN(z_, r_, i_) {__real__(z_) = (r_); __imag__(z_) = (i_);}
+
+
/* Prototypes are included to silence -Wstrict-prototypes
-Wmissing-prototypes. */
Index: libgfortran.h
===================================================================
--- libgfortran.h (revision 212323)
+++ libgfortran.h (working copy)
@@ -235,11 +235,6 @@
#undef signbit
#define signbit(x) __builtin_signbit(x)
-/* TODO: find the C99 version of these an move into above ifdef. */
-#define REALPART(z) (__real__(z))
-#define IMAGPART(z) (__imag__(z))
-#define COMPLEX_ASSIGN(z_, r_, i_) {__real__(z_) = (r_); __imag__(z_) = (i_);}
-
#include "kinds.h"
/* Define the type used for the current record number for large file I/O.
@@ -693,7 +688,7 @@
#define GFC_OTOA_BUF_SIZE (GFC_LARGEST_BUF * 3 + 1)
#define GFC_BTOA_BUF_SIZE (GFC_LARGEST_BUF * 8 + 1)
-extern void sys_abort (void) __attribute__ ((noreturn));
+extern _Noreturn void sys_abort (void);
internal_proto(sys_abort);
extern ssize_t estr_write (const char *);
@@ -709,26 +704,25 @@
extern const char *gfc_xtoa (GFC_UINTEGER_LARGEST, char *, size_t);
internal_proto(gfc_xtoa);
-extern void os_error (const char *) __attribute__ ((noreturn));
+extern _Noreturn void os_error (const char *);
iexport_proto(os_error);
extern void show_locus (st_parameter_common *);
internal_proto(show_locus);
-extern void runtime_error (const char *, ...)
- __attribute__ ((noreturn, format (gfc_printf, 1, 2)));
+extern _Noreturn void runtime_error (const char *, ...)
+ __attribute__ ((format (gfc_printf, 1, 2)));
iexport_proto(runtime_error);
-extern void runtime_error_at (const char *, const char *, ...)
- __attribute__ ((noreturn, format (gfc_printf, 2, 3)));
+extern _Noreturn void runtime_error_at (const char *, const char *, ...)
+ __attribute__ ((format (gfc_printf, 2, 3)));
iexport_proto(runtime_error_at);
extern void runtime_warning_at (const char *, const char *, ...)
__attribute__ ((format (gfc_printf, 2, 3)));
iexport_proto(runtime_warning_at);
-extern void internal_error (st_parameter_common *, const char *)
- __attribute__ ((noreturn));
+extern _Noreturn void internal_error (st_parameter_common *, const char *);
internal_proto(internal_error);
extern const char *translate_error (int);
@@ -875,8 +869,7 @@
/* stop.c */
-extern void stop_string (const char *, GFC_INTEGER_4)
- __attribute__ ((noreturn));
+extern _Noreturn void stop_string (const char *, GFC_INTEGER_4);
export_proto(stop_string);
/* reshape_packed.c */
[-- Attachment #4: Type: text/plain, Size: 596 bytes --]
PS: I didn’t touch libcaf, as I assume this might be compiled with a different compiler. Am I right?
PS2: A third issue I’ve though about is: should we get rid of the following __GNUC__ test? libgfortran is not used as a standalone Fortran runtime library, and I think it is (and never will) be built by something else than a stage3 compiler.
> #ifndef __GNUC__
> #define __attribute__(x)
> #define likely(x) (x)
> #define unlikely(x) (x)
> #else
> #define likely(x) __builtin_expect(!!(x), 1)
> #define unlikely(x) __builtin_expect(!!(x), 0)
> #endif
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-06 20:13 ` FX
2014-07-07 6:44 ` Janne Blomqvist
@ 2014-07-07 8:30 ` Rainer Orth
2014-07-07 8:37 ` FX
1 sibling, 1 reply; 38+ messages in thread
From: Rainer Orth @ 2014-07-07 8:30 UTC (permalink / raw)
To: FX; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
FX <fxcoudert@gmail.com> writes:
>> Unfortunately, while the patch works fine on Solaris/x86, it broke
>> Solaris/SPARC bootstrap for trivial reasons: contrary to the ChangeLog,
>> configure and config.h.in weren't regenerated, thus FPSETSTICKY
>> wasn't defined.
>
> I apologize. Thanks for checking in the fix.
No worries: if only all bootstrap failures were that easy to fix ;-)
>> FAIL: gfortran.dg/ieee/ieee_6.f90 -Os execution test
>>
>> The test aborts at l.47, but unfortunately I cannot print mode in gdb 7.7.
>
> That’s weird, especially if that one fails but ieee_rounding_1.f90
> works. Let me know if I can do anything to help debug this.
I see now what's going on: mode is 1 on that line, while ieee_to_zero is 3.
Looking at Solaris <ieeefp.h> explains what happens:
#if defined(__sparc)
/*
* NOTE: the values given are chosen to match those used by the
* RD (Round Direction) field of the FSR (Floating Point State Register).
*/
typedef enum fp_rnd {
FP_RN = 0, /* round to nearest representable number, tie -> even */
FP_RZ = 1, /* round toward zero (truncate) */
FP_RP = 2, /* round toward plus infinity */
FP_RM = 3 /* round toward minus infinity */
} fp_rnd;
#endif
while the i386/amd64 values are the usual ones. Unfortunately,
gcc/fortran/libgfortran.h hardcodes the more common values for
GFC_FPE_*, and libgfortran/Makefile.am extracts them from there into
fpu-target.inc. I'm unsure what's the best way to handle this.
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 8:30 ` Rainer Orth
@ 2014-07-07 8:37 ` FX
2014-07-07 8:56 ` Rainer Orth
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-07-07 8:37 UTC (permalink / raw)
To: Rainer Orth; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
Hi Rainer,
> while the i386/amd64 values are the usual ones. Unfortunately,
> gcc/fortran/libgfortran.h hardcodes the more common values for
> GFC_FPE_*, and libgfortran/Makefile.am extracts them from there into
> fpu-target.inc. I'm unsure what's the best way to handle this.
No, we don’t hardcode any values (unless I misunderstand what you are saying). Look at libgfortran/config/fpu-sysv.h get_fpu_rounding_mode() and set_fpu_rounding_mode(): we have two switches, to translate between the GFC_FPE_* values and the FP_R* values. So this should work, really.
The only thing I can see is that libgfortran/config/fpu-sysv.h assumes that FP_RM and others are macros, checking them with "#ifdef FP_RM”. Is that the reason?
If so, we might just want to use them unconditionally… unless it creates a mess on some other SysV target!
FX
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 8:37 ` FX
@ 2014-07-07 8:56 ` Rainer Orth
2014-07-07 9:00 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Rainer Orth @ 2014-07-07 8:56 UTC (permalink / raw)
To: FX; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 1463 bytes --]
Hi FX,
>> while the i386/amd64 values are the usual ones. Unfortunately,
>> gcc/fortran/libgfortran.h hardcodes the more common values for
>> GFC_FPE_*, and libgfortran/Makefile.am extracts them from there into
>> fpu-target.inc. I'm unsure what's the best way to handle this.
>
> No, we don’t hardcode any values (unless I misunderstand what you are
> saying). Look at libgfortran/config/fpu-sysv.h get_fpu_rounding_mode() and
> set_fpu_rounding_mode(): we have two switches, to translate between the
> GFC_FPE_* values and the FP_R* values. So this should work, really.
you're right, of course.
> The only thing I can see is that libgfortran/config/fpu-sysv.h assumes that
> FP_RM and others are macros, checking them with "#ifdef FP_RM”. Is that the
> reason?
It is.
> If so, we might just want to use them unconditionally… unless it creates a
> mess on some other SysV target!
FWIW, those FP_* values are also enum values in IRIX 6.5 <ieeefp.h>, the
only other SysV target I have around. Seems this file is common between
all of them, so the risk should be manageable.
The following patch does away with the #ifdef stuff and lets all
gfortran.dg/ieee tests PASS on sparc-sun-solaris2.11.
Ok for mainline?
Rainer
2014-07-07 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* config/fpu-sysv.h (get_fpu_rounding_mode): Use FP_RN, FP_RP,
FP_RM, FP_RZ unconditionally.
(set_fpu_rounding_mode): Likewise.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: libgfortran.patch --]
[-- Type: text/x-patch, Size: 1494 bytes --]
diff --git a/libgfortran/config/fpu-sysv.h b/libgfortran/config/fpu-sysv.h
--- a/libgfortran/config/fpu-sysv.h
+++ b/libgfortran/config/fpu-sysv.h
@@ -333,25 +335,14 @@ get_fpu_rounding_mode (void)
{
switch (fpgetround ())
{
-#ifdef FP_RN
case FP_RN:
return GFC_FPE_TONEAREST;
-#endif
-
-#ifdef FP_RP
case FP_RP:
return GFC_FPE_UPWARD;
-#endif
-
-#ifdef FP_RM
case FP_RM:
return GFC_FPE_DOWNWARD;
-#endif
-
-#ifdef FP_RZ
case FP_RZ:
return GFC_FPE_TOWARDZERO;
-#endif
default:
return GFC_FPE_INVALID;
}
@@ -365,29 +356,18 @@ set_fpu_rounding_mode (int mode)
switch (mode)
{
-#ifdef FP_RN
case GFC_FPE_TONEAREST:
rnd_mode = FP_RN;
break;
-#endif
-
-#ifdef FP_RP
case GFC_FPE_UPWARD:
rnd_mode = FP_RP;
break;
-#endif
-
-#ifdef FP_RM
case GFC_FPE_DOWNWARD:
rnd_mode = FP_RM;
break;
-#endif
-
-#ifdef FP_RZ
case GFC_FPE_TOWARDZERO:
rnd_mode = FP_RZ;
break;
-#endif
default:
return;
}
@@ -401,33 +381,13 @@ 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;
}
[-- Attachment #3: Type: text/plain, Size: 143 bytes --]
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 8:56 ` Rainer Orth
@ 2014-07-07 9:00 ` FX
2014-07-07 9:03 ` Rainer Orth
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-07-07 9:00 UTC (permalink / raw)
To: Rainer Orth; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
> FWIW, those FP_* values are also enum values in IRIX 6.5 <ieeefp.h>, the
> only other SysV target I have around. Seems this file is common between
> all of them, so the risk should be manageable.
>
> The following patch does away with the #ifdef stuff and lets all
> gfortran.dg/ieee tests PASS on sparc-sun-solaris2.11.
Google for a few more targets (BSD, cygwin, etc.) confirms that there is little variation in this part of the file.
Given that your patch fixes a target, and sounds good to both you and me, I suggest you commit it in 24 hours unless someone objects (or you get an actual review).
Also, related to that: could you also confirm that FP_X_INV (and others) are indeed macros, on solaris?
FX
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 9:00 ` FX
@ 2014-07-07 9:03 ` Rainer Orth
0 siblings, 0 replies; 38+ messages in thread
From: Rainer Orth @ 2014-07-07 9:03 UTC (permalink / raw)
To: FX; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
FX <fxcoudert@gmail.com> writes:
>> FWIW, those FP_* values are also enum values in IRIX 6.5 <ieeefp.h>, the
>> only other SysV target I have around. Seems this file is common between
>> all of them, so the risk should be manageable.
>>
>> The following patch does away with the #ifdef stuff and lets all
>> gfortran.dg/ieee tests PASS on sparc-sun-solaris2.11.
>
> Google for a few more targets (BSD, cygwin, etc.) confirms that there is
> little variation in this part of the file.
>
> Given that your patch fixes a target, and sounds good to both you and me, I
> suggest you commit it in 24 hours unless someone objects (or you get an
> actual review).
ok, thanks.
> Also, related to that: could you also confirm that FP_X_INV (and others)
> are indeed macros, on solaris?
I already did, and the rounding mode related ones are the only enums
currently used. There's also fpclass_t, but that's not used right now.
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 8:29 ` FX
@ 2014-07-07 9:10 ` Janne Blomqvist
2014-07-07 9:17 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Janne Blomqvist @ 2014-07-07 9:10 UTC (permalink / raw)
To: FX; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
On Mon, Jul 7, 2014 at 11:29 AM, FX <fxcoudert@gmail.com> wrote:
>> Furthermore, on 2014-05-12 I committed a patch changing libgfortran to
>> be built with -std=gnu11 instead of -std=gnu99, so that we can make
>> use of C11 functionality; see
>> https://gcc.gnu.org/ml/fortran/2014-04/msg00101.html .
>
> Committed as rev. 212323, thanks for the review.
>
> I now propose the attached patch, which performs a small cleaning up:
> - Use the new _Noreturn language feature (supported in GCC since 2011) instead of the old attribute. This makes prototypes shorter and more generic.
> - Move the complex-related REALPART, IMAGPART and COMPLEX_ASSIGN macros from libgfortran.h to c99_intrinsics.c, which is the only place they’re ever used.
>
>
> Built and tested on x86_64-linux, OK to commit?
Ok.
> PS: I didn’t touch libcaf, as I assume this might be compiled with a different compiler. Am I right?
My understanding is that libcaf is delivered in source form, and the
end user is expected to compile it against the correct MPI library on
the target. So yes, one could be a bit more conservative here than in
libgfortran proper (although one could expect the user to have access
to the gcc version corresponding to gfortran..). But Tobias certainly
knows better.
> PS2: A third issue I’ve though about is: should we get rid of the following __GNUC__ test? libgfortran is not used as a standalone Fortran runtime library, and I think it is (and never will) be built by something else than a stage3 compiler.
>
>> #ifndef __GNUC__
>> #define __attribute__(x)
>> #define likely(x) (x)
>> #define unlikely(x) (x)
>> #else
>> #define likely(x) __builtin_expect(!!(x), 1)
>> #define unlikely(x) __builtin_expect(!!(x), 0)
>> #endif
What about --disable-bootstrap? Does it just skip stage1 and stage2,
and stage3 is used to compile libgfortran, or is the host compiler
used to build libgfortran as well? If the former, yes I guess we can
remove #ifnderf __GNUC__ stuff?
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 9:10 ` Janne Blomqvist
@ 2014-07-07 9:17 ` FX
2014-07-07 10:18 ` Janne Blomqvist
0 siblings, 1 reply; 38+ messages in thread
From: FX @ 2014-07-07 9:17 UTC (permalink / raw)
To: Janne Blomqvist; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
> What about --disable-bootstrap? Does it just skip stage1 and stage2,
> and stage3 is used to compile libgfortran, or is the host compiler
> used to build libgfortran as well? If the former, yes I guess we can
> remove #ifnderf __GNUC__ stuff?
Even with --disable-bootstrap, libgfortran is compiled with the freshly-built compiler, not the host compiler.
FX
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 9:17 ` FX
@ 2014-07-07 10:18 ` Janne Blomqvist
2014-07-07 12:01 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Janne Blomqvist @ 2014-07-07 10:18 UTC (permalink / raw)
To: FX; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
On Mon, Jul 7, 2014 at 12:16 PM, FX <fxcoudert@gmail.com> wrote:
>> What about --disable-bootstrap? Does it just skip stage1 and stage2,
>> and stage3 is used to compile libgfortran, or is the host compiler
>> used to build libgfortran as well? If the former, yes I guess we can
>> remove #ifnderf __GNUC__ stuff?
>
> Even with --disable-bootstrap, libgfortran is compiled with the freshly-built compiler, not the host compiler.
>
> FX
Right, that's what I (vaguelly) remembered. Please consider a patch
removing the ifndef __GNUC__ stuff from libgfortran.h pre-approved.
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-07 10:18 ` Janne Blomqvist
@ 2014-07-07 12:01 ` FX
0 siblings, 0 replies; 38+ messages in thread
From: FX @ 2014-07-07 12:01 UTC (permalink / raw)
To: Janne Blomqvist; +Cc: Steve Kargl, Tobias Burnus, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 289 bytes --]
> Right, that's what I (vaguelly) remembered. Please consider a patch
> removing the ifndef __GNUC__ stuff from libgfortran.h pre-approved.
The only occurrence (outside of libcaf) is in libgfortran.h. Committed attached patch as rev. 212328, after building on x86_64-linux.
FX
[-- Attachment #2: x --]
[-- Type: application/octet-stream, Size: 1030 bytes --]
Index: libgfortran.h
===================================================================
--- libgfortran.h (revision 212327)
+++ libgfortran.h (working copy)
@@ -107,14 +107,8 @@ typedef off_t gfc_offset;
heuristic will mark this branch as much less likely as unlikely() would
do. */
-#ifndef __GNUC__
-#define __attribute__(x)
-#define likely(x) (x)
-#define unlikely(x) (x)
-#else
#define likely(x) __builtin_expect(!!(x), 1)
#define unlikely(x) __builtin_expect(!!(x), 0)
-#endif
/* Make sure we have ptrdiff_t. */
Index: ChangeLog
===================================================================
--- ChangeLog (revision 212327)
+++ ChangeLog (working copy)
@@ -1,5 +1,9 @@
2014-07-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+ * libgfortran.h: Assume __GNUC__.
+
+2014-07-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
* runtime/stop.c: Use C11 _Noreturn.
* libgfortran.h: Use C11 _Noreturn in prototypes.
Move REALPART, IMAGPART and COMPLEX_ASSIGN macros...
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-06-24 23:41 ` FX
2014-06-25 14:24 ` Steve Kargl
2014-06-29 8:43 ` Andreas Schwab
@ 2019-02-28 19:22 ` Thomas Schwinge
2019-03-21 19:12 ` Thomas Schwinge
2 siblings, 1 reply; 38+ messages in thread
From: Thomas Schwinge @ 2019-02-28 19:22 UTC (permalink / raw)
To: FX, Rainer Orth, Mike Stump
Cc: Tobias Burnus, Fortran List, gcc-patches, Janne Blomqvist, Steve Kargl
[-- Attachment #1.1: Type: text/plain, Size: 2227 bytes --]
Hi!
While looking for something else -- isn't that always how it happens ;-)
-- I noticed one thing here:
On Wed, 25 Jun 2014 01:41:02 +0200, FX <fxcoudert@gmail.com> wrote:
> I’ll wait a few more days to commit, so others can comment/review and I am sure to be around if there is fallout.
(This got committed to trunk in r212102.)
> --- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
> +++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
> @@ -0,0 +1,59 @@
> +[...]
> +global DEFAULT_FFLAGS
> +if ![info exists DEFAULT_FFLAGS] then {
> + set DEFAULT_FFLAGS ""
> +}
> +[...]
Per my understanding of DejaGnu (and please correct me if that's wrong),
in the same 'runtest' instance, 'global' variables persist from one
'*.exp' file to another. (Which is something debatable, in my
opinion...)
All other '*.exp' files that back then did define 'DEFAULT_FFLAGS' (using
this same construct as shown above), and it's still the same now, are
using " -pedantic-errors" instead of the empty string. Thus this setting
of 'DEFAULT_FFLAGS' is not idempotent, depends on whether
'gfortran.dg/ieee/ieee.exp', or an other defining '*.exp' file is
executed first.
By default, first comes 'gfortran.dg/coarray/caf.exp' (nowadays, did not
yet exist back then), then 'gfortran.dg/dg.exp', then
'gfortran.dg/ieee/ieee.exp'. (And, sometimes also
'gcc.target/powerpc/ppc-fortran/ppc-fortran.exp'.)
And, as I just noticed, 'runtest' seems to always sort the specified
'*.exp' files (?!), so even when you invoke something like
"check-gcc-fortran RUNTESTFLAGS='ieee.exp dg.exp'" to try to provoke some
regressions to appear, you'd still get 'dg.exp' executed first. The
empty string setting in 'ieee.exp' was never really active -- only if
executed on its own, etc.
Fortunately, 'ieee.exp' seems to behave the same way whether running with
or without '-pedantic-errors', so I propose to simply unify that setting,
see attached. OK to commit this to all relevant branches? If approving
this patch, please respond with "Reviewed-by: NAME <EMAIL>" so that your
effort will be recorded in the commit log, see
<https://gcc.gnu.org/wiki/Reviewed-by>.
Grüße
Thomas
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-testsuite-Fortran-Consistently-set-DEFAULT_FFLAGS.patch --]
[-- Type: text/x-diff, Size: 1615 bytes --]
From 214a3ac1b44343c5b1bbd2963bc256b056dac764 Mon Sep 17 00:00:00 2001
From: Thomas Schwinge <thomas@codesourcery.com>
Date: Thu, 28 Feb 2019 20:08:25 +0100
Subject: [PATCH] [testsuite, Fortran] Consistently set 'DEFAULT_FFLAGS'
In the same 'runtest' instance, 'global' variables persist from one '*.exp'
file to another.
All other '*.exp' files are using " -pedantic-errors" instead of the empty
string as the default for 'DEFAULT_FFLAGS'. Thus this setting of
'DEFAULT_FFLAGS' is not idempotent, depends on whether
'gfortran.dg/ieee/ieee.exp', or an other defining '*.exp' file is executed
first.
gcc/testsuite/
PR fortran/29383
* gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
other '*.exp' files.
---
gcc/testsuite/gfortran.dg/ieee/ieee.exp | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee.exp b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
index 05383ce94331..68d4b7816144 100644
--- a/gcc/testsuite/gfortran.dg/ieee/ieee.exp
+++ b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
@@ -22,15 +22,15 @@
load_lib gfortran-dg.exp
load_lib target-supports.exp
-# Initialize `dg'.
-dg-init
-
-# Flags specified in each test
+# If a testcase doesn't have special options, use these.
global DEFAULT_FFLAGS
if ![info exists DEFAULT_FFLAGS] then {
- set DEFAULT_FFLAGS ""
+ set DEFAULT_FFLAGS " -pedantic-errors"
}
+# Initialize `dg'.
+dg-init
+
# Flags for finding the IEEE modules
if [info exists TOOL_OPTIONS] {
set specpath [get_multilibs ${TOOL_OPTIONS}]
--
2.17.1
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 658 bytes --]
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2019-02-28 19:22 ` Thomas Schwinge
@ 2019-03-21 19:12 ` Thomas Schwinge
0 siblings, 0 replies; 38+ messages in thread
From: Thomas Schwinge @ 2019-03-21 19:12 UTC (permalink / raw)
To: fortran, gcc-patches
Cc: FX, Rainer Orth, Mike Stump, Tobias Burnus, Janne Blomqvist, Steve Kargl
[-- Attachment #1: Type: text/plain, Size: 2368 bytes --]
Hi!
On Thu, 28 Feb 2019 20:22:08 +0100, I wrote:
> While looking for something else -- isn't that always how it happens ;-)
> -- I noticed one thing here:
>
> On Wed, 25 Jun 2014 01:41:02 +0200, FX <fxcoudert@gmail.com> wrote:
> > I’ll wait a few more days to commit, so others can comment/review and I am sure to be around if there is fallout.
>
> (This got committed to trunk in r212102.)
>
> > --- gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
> > +++ gcc/testsuite/gfortran.dg/ieee/ieee.exp (revision 0)
> > @@ -0,0 +1,59 @@
> > +[...]
> > +global DEFAULT_FFLAGS
> > +if ![info exists DEFAULT_FFLAGS] then {
> > + set DEFAULT_FFLAGS ""
> > +}
> > +[...]
>
> Per my understanding of DejaGnu (and please correct me if that's wrong),
> in the same 'runtest' instance, 'global' variables persist from one
> '*.exp' file to another. (Which is something debatable, in my
> opinion...)
>
> All other '*.exp' files that back then did define 'DEFAULT_FFLAGS' (using
> this same construct as shown above), and it's still the same now, are
> using " -pedantic-errors" instead of the empty string. Thus this setting
> of 'DEFAULT_FFLAGS' is not idempotent, depends on whether
> 'gfortran.dg/ieee/ieee.exp', or an other defining '*.exp' file is
> executed first.
>
> By default, first comes 'gfortran.dg/coarray/caf.exp' (nowadays, did not
> yet exist back then), then 'gfortran.dg/dg.exp', then
> 'gfortran.dg/ieee/ieee.exp'. (And, sometimes also
> 'gcc.target/powerpc/ppc-fortran/ppc-fortran.exp'.)
>
> And, as I just noticed, 'runtest' seems to always sort the specified
> '*.exp' files (?!), so even when you invoke something like
> "check-gcc-fortran RUNTESTFLAGS='ieee.exp dg.exp'" to try to provoke some
> regressions to appear, you'd still get 'dg.exp' executed first. The
> empty string setting in 'ieee.exp' was never really active -- only if
> executed on its own, etc.
>
> Fortunately, 'ieee.exp' seems to behave the same way whether running with
> or without '-pedantic-errors', so I propose to simply unify that setting,
> see attached.
I convinced myself that this is the right thing to do, and committed
"[testsuite, Fortran] Consistently set 'DEFAULT_FFLAGS'" to trunk in
r269845, to gcc-8-branch in r269846, and to gcc-7-branch in r269847, see
attached.
Grüße
Thomas
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-testsuite-Fortran-Consistently-set-DEFAULT_FFL.trunk.patch --]
[-- Type: text/x-diff, Size: 2158 bytes --]
From c1769f9f2a8314e610c7a3534ee8fc74fe2c8c60 Mon Sep 17 00:00:00 2001
From: tschwinge <tschwinge@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 21 Mar 2019 18:54:50 +0000
Subject: [PATCH] [testsuite, Fortran] Consistently set 'DEFAULT_FFLAGS'
In the same 'runtest' instance, 'global' variables persist from one '*.exp'
file to another.
All other '*.exp' files are using " -pedantic-errors" instead of the empty
string as the default for 'DEFAULT_FFLAGS'. Thus this setting of
'DEFAULT_FFLAGS' is not idempotent, depends on whether
'gfortran.dg/ieee/ieee.exp', or an other defining '*.exp' file is executed
first.
gcc/testsuite/
PR fortran/29383
* gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
other '*.exp' files.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@269845 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/testsuite/ChangeLog | 6 ++++++
gcc/testsuite/gfortran.dg/ieee/ieee.exp | 10 +++++-----
2 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c8f9492130e1..914ba7237033 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-03-21 Thomas Schwinge <thomas@codesourcery.com>
+
+ PR fortran/29383
+ * gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
+ other '*.exp' files.
+
2019-03-21 Richard Biener <rguenther@suse.de>
PR tree-optimization/89779
diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee.exp b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
index 05383ce94331..68d4b7816144 100644
--- a/gcc/testsuite/gfortran.dg/ieee/ieee.exp
+++ b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
@@ -22,15 +22,15 @@
load_lib gfortran-dg.exp
load_lib target-supports.exp
-# Initialize `dg'.
-dg-init
-
-# Flags specified in each test
+# If a testcase doesn't have special options, use these.
global DEFAULT_FFLAGS
if ![info exists DEFAULT_FFLAGS] then {
- set DEFAULT_FFLAGS ""
+ set DEFAULT_FFLAGS " -pedantic-errors"
}
+# Initialize `dg'.
+dg-init
+
# Flags for finding the IEEE modules
if [info exists TOOL_OPTIONS] {
set specpath [get_multilibs ${TOOL_OPTIONS}]
--
2.17.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0001-testsuite-Fortran-Consistently-set-DEFA.gcc-8-branch.patch --]
[-- Type: text/x-diff, Size: 2202 bytes --]
From e18146b75cb782483c996bf58b96a40f622715a1 Mon Sep 17 00:00:00 2001
From: tschwinge <tschwinge@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 21 Mar 2019 18:57:39 +0000
Subject: [PATCH] [testsuite, Fortran] Consistently set 'DEFAULT_FFLAGS'
In the same 'runtest' instance, 'global' variables persist from one '*.exp'
file to another.
All other '*.exp' files are using " -pedantic-errors" instead of the empty
string as the default for 'DEFAULT_FFLAGS'. Thus this setting of
'DEFAULT_FFLAGS' is not idempotent, depends on whether
'gfortran.dg/ieee/ieee.exp', or an other defining '*.exp' file is executed
first.
gcc/testsuite/
PR fortran/29383
* gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
other '*.exp' files.
trunk r269845
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-8-branch@269846 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/testsuite/ChangeLog | 6 ++++++
gcc/testsuite/gfortran.dg/ieee/ieee.exp | 10 +++++-----
2 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b09ab29affff..9aa82da9a4aa 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-03-21 Thomas Schwinge <thomas@codesourcery.com>
+
+ PR fortran/29383
+ * gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
+ other '*.exp' files.
+
2019-03-19 Eric Botcazou <ebotcazou@adacore.com>
* c-c++-common/unroll-7.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee.exp b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
index 987ecaf4bcd3..2ccf2493dc4f 100644
--- a/gcc/testsuite/gfortran.dg/ieee/ieee.exp
+++ b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
@@ -22,15 +22,15 @@
load_lib gfortran-dg.exp
load_lib target-supports.exp
-# Initialize `dg'.
-dg-init
-
-# Flags specified in each test
+# If a testcase doesn't have special options, use these.
global DEFAULT_FFLAGS
if ![info exists DEFAULT_FFLAGS] then {
- set DEFAULT_FFLAGS ""
+ set DEFAULT_FFLAGS " -pedantic-errors"
}
+# Initialize `dg'.
+dg-init
+
# Flags for finding the IEEE modules
if [info exists TOOL_OPTIONS] {
set specpath [get_multilibs ${TOOL_OPTIONS}]
--
2.17.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0001-testsuite-Fortran-Consistently-set-DEFA.gcc-7-branch.patch --]
[-- Type: text/x-diff, Size: 2183 bytes --]
From 72a927a66e52304e1b05dff680de4ed7c8080b37 Mon Sep 17 00:00:00 2001
From: tschwinge <tschwinge@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 21 Mar 2019 18:57:56 +0000
Subject: [PATCH] [testsuite, Fortran] Consistently set 'DEFAULT_FFLAGS'
In the same 'runtest' instance, 'global' variables persist from one '*.exp'
file to another.
All other '*.exp' files are using " -pedantic-errors" instead of the empty
string as the default for 'DEFAULT_FFLAGS'. Thus this setting of
'DEFAULT_FFLAGS' is not idempotent, depends on whether
'gfortran.dg/ieee/ieee.exp', or an other defining '*.exp' file is executed
first.
gcc/testsuite/
PR fortran/29383
* gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
other '*.exp' files.
trunk r269845
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-7-branch@269847 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/testsuite/ChangeLog | 6 ++++++
gcc/testsuite/gfortran.dg/ieee/ieee.exp | 10 +++++-----
2 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 28756b1f6bee..ca849083d7f4 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-03-21 Thomas Schwinge <thomas@codesourcery.com>
+
+ PR fortran/29383
+ * gfortran.dg/ieee/ieee.exp (DEFAULT_FFLAGS): Set the same as in
+ other '*.exp' files.
+
2019-03-21 Matthias Klose <doko@ubuntu.com>
Backport from mainline
diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee.exp b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
index 14741b768c53..1d6eab18e140 100644
--- a/gcc/testsuite/gfortran.dg/ieee/ieee.exp
+++ b/gcc/testsuite/gfortran.dg/ieee/ieee.exp
@@ -22,15 +22,15 @@
load_lib gfortran-dg.exp
load_lib target-supports.exp
-# Initialize `dg'.
-dg-init
-
-# Flags specified in each test
+# If a testcase doesn't have special options, use these.
global DEFAULT_FFLAGS
if ![info exists DEFAULT_FFLAGS] then {
- set DEFAULT_FFLAGS ""
+ set DEFAULT_FFLAGS " -pedantic-errors"
}
+# Initialize `dg'.
+dg-init
+
# Flags for finding the IEEE modules
if [info exists TOOL_OPTIONS] {
set specpath [get_multilibs ${TOOL_OPTIONS}]
--
2.17.1
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
2014-07-10 7:31 Uros Bizjak
@ 2014-07-10 8:46 ` FX
0 siblings, 0 replies; 38+ messages in thread
From: FX @ 2014-07-10 8:46 UTC (permalink / raw)
To: Uros Bizjak; +Cc: Rainer Orth, gcc-patches, Fortran List
[-- Attachment #1: Type: text/plain, Size: 800 bytes --]
> Since all modes are supported, you can unconditionally return 1 in the
> code above, as is the case with fpu-387.h.
Indeed. I’ve committed the attached patch, which performs this trivial cleanup, adds some comments about unreachable cases (I don’t think we want to error out at runtime, but a comment in the code is the least we can do).
It also cleans up the value we return for get_fpu_rounding_mode() when we don’t recognize the rounding mode: it used to be GFC_FPE_INVALID, which is wrong (it’s an “invalid” exception flag, not a marker for an invalid rounding mode). Now, it will return 0, i.e. a nonexisting rounding mode flag, which is more appropriate (though it should never happen in practice).
Committed as rev. 212423 after testing on x86_64-apple-darwin13.
Thanks,
FX
[-- Attachment #2: z --]
[-- Type: application/octet-stream, Size: 3027 bytes --]
Index: libgfortran/config/fpu-387.h
===================================================================
--- libgfortran/config/fpu-387.h (revision 212407)
+++ libgfortran/config/fpu-387.h (working copy)
@@ -421,7 +421,7 @@ get_fpu_rounding_mode (void)
case _FPU_RC_ZERO:
return GFC_FPE_TOWARDZERO;
default:
- return GFC_FPE_INVALID; /* Should be unreachable. */
+ return 0; /* Should be unreachable. */
}
}
Index: libgfortran/config/fpu-aix.h
===================================================================
--- libgfortran/config/fpu-aix.h (revision 212407)
+++ libgfortran/config/fpu-aix.h (working copy)
@@ -291,8 +291,6 @@ support_fpu_flag (int flag)
}
-
-
int
get_fpu_rounding_mode (void)
{
@@ -321,8 +319,9 @@ get_fpu_rounding_mode (void)
case FE_TOWARDZERO:
return GFC_FPE_TOWARDZERO;
#endif
+
default:
- return GFC_FPE_INVALID;
+ return 0; /* Should be unreachable. */
}
}
@@ -357,8 +356,9 @@ set_fpu_rounding_mode (int mode)
rnd_mode = FE_TOWARDZERO;
break;
#endif
+
default:
- return;
+ return; /* Should be unreachable. */
}
fesetround (rnd_mode);
@@ -399,7 +399,7 @@ support_fpu_rounding_mode (int mode)
#endif
default:
- return 0;
+ return 0; /* Should be unreachable. */
}
}
Index: libgfortran/config/fpu-glibc.h
===================================================================
--- libgfortran/config/fpu-glibc.h (revision 212407)
+++ libgfortran/config/fpu-glibc.h (working copy)
@@ -333,8 +333,9 @@ get_fpu_rounding_mode (void)
case FE_TOWARDZERO:
return GFC_FPE_TOWARDZERO;
#endif
+
default:
- return GFC_FPE_INVALID;
+ return 0; /* Should be unreachable. */
}
}
@@ -369,8 +370,9 @@ set_fpu_rounding_mode (int mode)
rnd_mode = FE_TOWARDZERO;
break;
#endif
+
default:
- return;
+ return; /* Should be unreachable. */
}
fesetround (rnd_mode);
@@ -411,7 +413,7 @@ support_fpu_rounding_mode (int mode)
#endif
default:
- return 0;
+ return 0; /* Should be unreachable. */
}
}
Index: libgfortran/config/fpu-sysv.h
===================================================================
--- libgfortran/config/fpu-sysv.h (revision 212407)
+++ libgfortran/config/fpu-sysv.h (working copy)
@@ -342,7 +342,7 @@ get_fpu_rounding_mode (void)
case FP_RZ:
return GFC_FPE_TOWARDZERO;
default:
- return GFC_FPE_INVALID;
+ return 0; /* Should be unreachable. */
}
}
@@ -367,28 +367,16 @@ set_fpu_rounding_mode (int mode)
rnd_mode = FP_RZ;
break;
default:
- return;
+ return; /* Should be unreachable. */
}
fpsetround (rnd_mode);
}
int
-support_fpu_rounding_mode (int mode)
+support_fpu_rounding_mode (int mode __attribute__((unused)))
{
- switch (mode)
- {
- case GFC_FPE_TONEAREST:
- return 1;
- case GFC_FPE_UPWARD:
- return 1;
- case GFC_FPE_DOWNWARD:
- return 1;
- case GFC_FPE_TOWARDZERO:
- return 1;
- default:
- return 0;
- }
+ return 1;
}
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
@ 2014-07-10 7:31 Uros Bizjak
2014-07-10 8:46 ` FX
0 siblings, 1 reply; 38+ messages in thread
From: Uros Bizjak @ 2014-07-10 7:31 UTC (permalink / raw)
To: Rainer Orth; +Cc: gcc-patches, Fortran List, FX Coudert
Hello!
>> The only thing I can see is that libgfortran/config/fpu-sysv.h assumes that
>> FP_RM and others are macros, checking them with "#ifdef FP_RM”. Is that the
>> reason?
>
> It is.
>
>> If so, we might just want to use them unconditionally… unless it creates a
>> mess on some other SysV target!
>
> FWIW, those FP_* values are also enum values in IRIX 6.5 <ieeefp.h>, the
> only other SysV target I have around. Seems this file is common between
> all of them, so the risk should be manageable.
@@ -401,33 +381,13 @@ 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;
Since all modes are supported, you can unconditionally return 1 in the
code above, as is the case with fpu-387.h.
Uros.
^ permalink raw reply [flat|nested] 38+ messages in thread
* Re: [fortran, patch] IEEE intrinsic modules (ping)
@ 2014-07-07 10:02 Tobias Burnus
0 siblings, 0 replies; 38+ messages in thread
From: Tobias Burnus @ 2014-07-07 10:02 UTC (permalink / raw)
To: FX, gcc-patches, fortran
Janne Blomqvist wrote:
> On Mon, Jul 7, 2014 at 11:29 AM, FX <fxcoudert@gmail.com> wrote:
> > PS: I didnât touch libcaf, as I assume this might be compiled with a different compiler. Am I right?
>
> My understanding is that libcaf is delivered in source form, and the
> end user is expected to compile it against the correct MPI library on
> the target. So yes, one could be a bit more conservative here than in
> libgfortran proper (although one could expect the user to have access
> to the gcc version corresponding to gfortran..). But Tobias certainly
> knows better.
I think the proper libcaf handling still has to be sorted out.
libcaf_single, is automatically build and installed with GCC. GCC's
libgfortran/caf/mpi*c is unused. (There is also libgfortran/caf/libcaf.h,
used by single.c and mpi.c.)
The current external library, mostly written by Alessandro, currently ships
with its own libcaf.h plus some minimal definitions from libgfortran.h to
interface to the array descriptor. (To be replaced by TS29113's ISO*h file,
which we provide on the fortran-dev branch.) That external library also
provides a single version but also MPI, GASNet and ARMCI versions. Those
currently build with any C compiler and it should stay that way. This makes
is way easier to build on HPC systems. Especially with GASNet, where the
header files check that one uses exactly the same version of the compiler
as the one used to compile GASNet itself. (Some HPC systems ship with
GASNet libraries; in my case, also in a GCC 4.8 compiled version.)
Due to the MPI dependency, the idea is definitely to be able to continue to
compile the library externally (it also makes the integration into Linux
distros easier as it can then be bundled with MPI instead of being tight to
GCC). One can still think of optionally also building it (MPI, possibly
GASNet, version) with GCC, which means that it also integrates into GCC's
build process.
> > PS2: A third issue Iâve though about is: should we get rid of the following __GNUC__ test? libgfortran is not used as a standalone Fortran runtime library, and I think it is (and never will) be built by something else than a stage3 compiler.
> >
> >> #ifndef __GNUC__
> >> #define __attribute__(x)
> >> #define likely(x) (x)
> >> #define unlikely(x) (x)
> >> #else
> >> #define likely(x) __builtin_expect(!!(x), 1)
> >> #define unlikely(x) __builtin_expect(!!(x), 0)
> >> #endif
>
> What about --disable-bootstrap? Does it just skip stage1 and stage2,
> and stage3 is used to compile libgfortran, or is the host compiler
> used to build libgfortran as well? If the former, yes I guess we can
> remove #ifnderf __GNUC__ stuff?
I think for libgfortran, it uses the just-compiled compiler. However,
for some other libraries like libgcc and libiberty, I think it uses the
system compiler without re-compiling them again with the newly build
compiler.
Tobias
^ permalink raw reply [flat|nested] 38+ messages in thread
end of thread, other threads:[~2019-03-21 19:12 UTC | newest]
Thread overview: 38+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-06-05 9:30 [fortran, patch] IEEE intrinsic modules Uros Bizjak
2014-06-05 9:35 ` FX
2014-06-05 9:56 ` Uros Bizjak
2014-06-15 20:38 ` [fortran, patch] IEEE intrinsic modules (ping) FX
2014-06-23 8:40 ` FX
2014-06-23 19:23 ` Steve Kargl
2014-06-23 20:20 ` Steve Kargl
2014-06-24 8:11 ` FX
2014-06-24 16:49 ` Steve Kargl
2014-06-24 17:46 ` Steve Kargl
2014-06-24 18:34 ` Tobias Burnus
2014-06-24 19:19 ` Steve Kargl
2014-06-24 19:43 ` FX
2014-06-24 20:23 ` Steve Kargl
2014-06-24 20:26 ` FX
2014-06-24 20:37 ` Steve Kargl
[not found] ` <20140624205518.GA81619@troutmask.apl.washington.edu>
[not found] ` <852C0E47-A1AE-4D64-98B5-4338D2EE4CC2@gmail.com>
[not found] ` <20140624215016.GA81800@troutmask.apl.washington.edu>
2014-06-24 23:41 ` FX
2014-06-25 14:24 ` Steve Kargl
2014-06-29 8:43 ` Andreas Schwab
2014-06-29 9:53 ` FX
2019-02-28 19:22 ` Thomas Schwinge
2019-03-21 19:12 ` Thomas Schwinge
2014-07-05 20:42 ` Rainer Orth
2014-07-06 20:13 ` FX
2014-07-07 6:44 ` Janne Blomqvist
2014-07-07 8:29 ` FX
2014-07-07 9:10 ` Janne Blomqvist
2014-07-07 9:17 ` FX
2014-07-07 10:18 ` Janne Blomqvist
2014-07-07 12:01 ` FX
2014-07-07 8:30 ` Rainer Orth
2014-07-07 8:37 ` FX
2014-07-07 8:56 ` Rainer Orth
2014-07-07 9:00 ` FX
2014-07-07 9:03 ` Rainer Orth
2014-07-07 10:02 Tobias Burnus
2014-07-10 7:31 Uros Bizjak
2014-07-10 8:46 ` FX
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).