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 +! +! 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 +! . */ + +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 +! +! 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 +! . */ + +#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 + +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 +. */ + +#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 +! +! 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 +! . */ + +#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 . */ +#include + #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 #endif +#ifdef HAVE_FENV_H +#include +#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 + #ifdef HAVE_FENV_H #include #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 +# . + +# 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