### what you're doing.
### DISABLE_387
### If defined, do not generate 387 floating-point instructions.
+### DISABLE_SSE
+### If defined, do not generate SSE media instructions.
### VALGRIND_MODE
### If defined, modify code to make it work with valgrind.
+
+define(DISABLE_SSE,1)
\f
#### Utility macros and definitions
`define(IFN387,`$1')',
`define(IFN387,`')')
+ifdef(`DISABLE_SSE',
+ `define(IFSSE,`')',
+ `define(IFSSE,`$1')')
+
+ifdef(`DISABLE_SSE',
+ `define(IFNSSE,`$1')',
+ `define(IFNSSE,`')')
+
IF_WIN32(`define(DASM,1)')
ifdef(`WCC386R',`define(WCC386,1)')
define_data(i387_presence)
allocate_longword(i387_presence)
+define_data(sse_presence)
+allocate_longword(sse_presence)
+
define_data(C_Stack_Pointer)
allocate_longword(C_Stack_Pointer)
')
OP(mov,l) TW(REG(eax),ABS(EVR(i387_presence)))
+# FIXME: Some IA-32 systems have SSE support, and since the microcode
+# might use SSE instructions, we need to determine, using CPUID,
+# whether the CPU supports SSE instructions, so that we can save and
+# restore the SSE MXCSR in the floating-point environment.
+
+ OP(mov,l) TW(IMM(0),ABS(EVR(sse_presence)))
+
# Do a bunch of hair to determine if we need to do cache synchronization.
# See if the CPUID instruction is supported.
OP(mov,l) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(eax))
ret
\f
-define_c_label(i387_read_fp_control_word)
-IF387(` OP(cmp,l) TW(IMM(0),ABS(EVR(i387_presence)))
- je i387_read_fp_control_word_lose
- enter IMM(4),IMM(0)
+define_c_label(sse_read_mxcsr)
+IFSSE(` enter IMM(4),IMM(0)
+ stmxcsr IND(REG(esp))
+ OP(mov,l) TW(IND(REG(esp)),REG(eax))
+ leave')
+ ret
+
+define_c_label(sse_write_mxcsr)
+IFSSE(` ldmxcsr LOF(4,REG(esp))')
+ ret
+
+define_c_label(x87_clear_exceptions)
+IF387(` fnclex')
+ ret
+
+define_c_label(x87_trap_exceptions)
+IF387(` fwait')
+ ret
+
+define_c_label(x87_read_control_word)
+IF387(` enter IMM(4),IMM(0)
fnstcw IND(REG(esp))
OP(mov,w) TW(IND(REG(esp)),REG(ax))
- leave
+ leave')
ret
-')
-i387_read_fp_control_word_lose:
- OP(xor,l) TW(REG(eax),REG(eax))
+define_c_label(x87_write_control_word)
+IF387(` fldcw LOF(4,REG(esp))')
ret
-define_c_label(i387_write_fp_control_word)
-IF387(` OP(cmp,l) TW(IMM(0),ABS(EVR(i387_presence)))
- je i387_write_fp_control_word_lose
- fldcw LOF(4,REG(esp))
+define_c_label(x87_read_status_word)
+IF387(` enter IMM(4),IMM(0)
+ fnstsw IND(REG(esp))
+ OP(mov,w) TW(IND(REG(esp)),REG(ax))
+ leave')
+ ret
+
+define_c_label(x87_read_environment)
+IF387(` OP(mov,l) TW(LOF(4,REG(esp)),REG(eax))
+ fnstenv IND(REG(eax))
+ # fnstenv masks all exceptions (go figure), so we must load
+ # the control word back in order to undo that.
+ fldcw IND(REG(eax))')
ret
-')
-i387_write_fp_control_word_lose:
+define_c_label(x87_write_environment)
+IF387(` OP(mov,l) TW(LOF(4,REG(esp)),REG(eax))
+ fldenv IND(REG(eax))')
ret
\f
IFDASM(`end')
OP(mov,q) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(rax))
ret
\f
-define_c_label(x86_64_read_mxcsr)
+define_c_label(sse_read_mxcsr)
enter IMM(8),IMM(0)
stmxcsr IND(REG(rsp))
OP(mov,l) TW(IND(REG(rsp)),REG(eax))
leave
ret
-define_c_label(x86_64_write_mxcsr)
+define_c_label(sse_write_mxcsr)
enter IMM(8),IMM(0)
- OP(mov,l) TW(REG(eax),IND(REG(rsp)))
+ OP(mov,l) TW(REG(edi),IND(REG(rsp)))
ldmxcsr IND(REG(rsp))
leave
ret
+
+define_c_label(x87_clear_exceptions)
+ fnclex
+ ret
+
+define_c_label(x87_trap_exceptions)
+ fwait
+ ret
+
+define_c_label(x87_read_control_word)
+ enter IMM(4),IMM(0)
+ fnstcw IND(REG(esp))
+ OP(mov,w) TW(IND(REG(esp)),REG(ax))
+ leave
+ ret
+
+define_c_label(x87_write_control_word)
+ enter IMM(4),IMM(0)
+ OP(mov,w) TW(REG(di),IND(REG(rsp))
+ fldcw IND(REG(esp))
+ leave
+ ret
+
+define_c_label(x87_read_status_word)
+ enter IMM(4),IMM(0)
+ fnstsw IND(REG(esp))
+ OP(mov,w) TW(IND(REG(esp)),REG(ax))
+ leave
+ ret
+
+define_c_label(x87_read_environment)
+ fnstenv IND(REG(rdi))
+ # fnstenv masks all exceptions (go figure), so we must load
+ # the control word back in order to undo that.
+ fldcw IND(REG(eax))
+ ret
+
+define_c_label(x87_write_environment)
+ fldenv IND(REG(rdi))
+ ret
\f
IFDASM(`end')
}
#endif /* _MACH_UNIX */
}
+
+#ifndef HAVE_FENV_H
+extern int i387_presence;
+extern int sse_presence;
+# define x87_p i387_presence
+# define sse_p sse_presence
+# include "cmpintmd/x86-fenv.c"
+#endif
extern void start_operator_relocation (SCHEME_OBJECT *, reloc_ref_t *);
extern insn_t * read_uuo_target (SCHEME_OBJECT *, reloc_ref_t *);
extern void i386_reset_hook (void);
-extern int i387_read_fp_control_word (void);
-extern void i387_write_fp_control_word (int);
extern int ia32_cpuid_needed;
#ifndef HAVE_FENV_H
-
-# define FE_TONEAREST 0
-# define FE_DOWNWARD 1
-# define FE_UPWARD 2
-# define FE_TOWARDZERO 3
-
-# define HAVE_FEGETROUND
-# define HAVE_FESETROUND
-
-static inline int
-fegetround (void)
-{
- return (3 & ((i387_read_fp_control_word ()) >> 10));
-}
-
-static inline int
-fesetround (int mode)
-{
- switch (mode)
- {
- case 0: case 1: case 2: case 3: break;
- default: return (1);
- }
- i387_write_fp_control_word
- ((mode << 10) | (0xf3ff & (i387_read_fp_control_word ())));
- return (0);
-}
-
-#endif /* HAVE_FENV_H */
+# define CMPINTMD_EMULATES_FENV
+# include "cmpintmd/x86-fenv.h"
+#endif
#endif /* !SCM_CMPINTMD_H_INCLUDED */
}
#endif /* _MACH_UNIX */
}
+
+#ifndef HAVE_FENV_H
+# define x87_p 1
+# define sse_p 1
+# include "cmpintmd/x86-fenv.c"
+#endif
extern insn_t * read_compiled_closure_target (insn_t *);
extern insn_t * read_uuo_target (SCHEME_OBJECT *);
extern void x86_64_reset_hook (void);
-extern int x86_64_read_mxcsr (void);
-extern void x86_64_write_mxcsr (int);
#ifndef HAVE_FENV_H
-
-# define FE_TONEAREST 0
-# define FE_DOWNWARD 1
-# define FE_UPWARD 2
-# define FE_TOWARDZERO 3
-
-# define HAVE_FEGETROUND
-# define HAVE_FESETROUND
-
-static inline int
-fegetround (void)
-{
- return (3 & ((x86_64_read_mxcsr ()) >> 13));
-}
-
-static inline void
-fesetround (int mode)
-{
- switch (mode)
- {
- case 0: case 1: case 2: case 3: break;
- default: return (1);
- }
- x86_64_write_mxcsr ((mode << 13) | (0xffff9fff & (x86_64_read_mxcsr ())));
- return (0);
-}
-
-#endif /* HAVE_FENV_H */
+# define CMPINTMD_EMULATES_FENV
+# define x87_p 1
+# define sse_p 1
+# include "cmpintmd/x86-fenv.h"
+#endif
#endif /* !SCM_CMPINTMD_H_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* C99 <fenv.h> emulation for x86 (shared between i386 and amd64) */
+\f
+extern unsigned int sse_read_mxcsr (void);
+extern void sse_write_mxcsr (unsigned int);
+extern void x87_clear_exceptions (void);
+extern void x87_trap_exceptions (void);
+extern unsigned short x87_read_control_word (void);
+extern void x87_write_control_word (unsigned short);
+extern unsigned short x87_read_status_word (void);
+/* extern void x87_write_status_word (unsigned short); No f(n)stsw. */
+extern void x87_read_environment (unsigned char *);
+extern void x87_write_environment (const unsigned char *);
+
+#ifndef x87_p
+# ifdef HAVE_X87
+static const bool x87_p = true;
+# else
+static const bool x87_p = false;
+# endif
+#endif
+
+#ifndef sse_p
+# ifdef HAVE_SSE
+static const bool sse_p = true;
+# else
+static const bool sse_p = false;
+# endif
+#endif
+
+int
+fegetround (void)
+{
+ int sse_mode = (sse_p ? (3 & ((sse_read_mxcsr ()) >> 13)) : 0);
+ int x87_mode = (x87_p ? (3 & ((x87_read_control_word ()) >> 10)) : 0);
+ if (x87_p && sse_p)
+ return ((sse_mode == x87_mode) ? sse_mode : (-1));
+ else
+ return (x87_p? x87_mode : sse_p? sse_mode : (-1));
+}
+
+int
+fesetround (int mode)
+{
+ switch (mode)
+ {
+ case 0: case 1: case 2: case 3: break;
+ default: return (1);
+ }
+ if (sse_p)
+ sse_write_mxcsr ((mode << 13) | (0xffff9fff & (sse_read_mxcsr ())));
+ if (x87_p)
+ x87_write_control_word
+ ((mode << 10) | (0xf3ff & (x87_read_control_word ())));
+ return (! (sse_p || x87_p));
+}
+\f
+int
+fetestexcept (int excepts)
+{
+ excepts &= FE_ALL_EXCEPT;
+ return
+ ((sse_p ? ((sse_read_mxcsr ()) & excepts) : 0)
+ | (x87_p ? ((x87_read_status_word ()) & excepts) : 0));
+}
+
+int
+feclearexcept (int excepts)
+{
+ if (excepts &~ FE_ALL_EXCEPT)
+ return (-1);
+ if (sse_p)
+ sse_write_mxcsr ((sse_read_mxcsr ()) &~ excepts);
+ if (x87_p)
+ {
+ if (excepts == FE_ALL_EXCEPT)
+ /* This is supposed to be much faster than fetching and storing
+ the environment. */
+ x87_clear_exceptions ();
+ else
+ {
+ x87_fenv_t fenv;
+ x87_read_environment (fenv.environment_bytes);
+ (fenv.environment.x87_status_word) &=~ excepts;
+ x87_write_environment (fenv.environment_bytes);
+ }
+ }
+ return (! (sse_p || x87_p));
+}
+
+int
+feraiseexcept (int excepts)
+{
+ if (excepts &~ FE_ALL_EXCEPT)
+ return (-1);
+ if (sse_p)
+ sse_write_mxcsr ((sse_read_mxcsr ()) | excepts);
+ if (x87_p)
+ {
+ x87_fenv_t fenv;
+ x87_read_environment (fenv.environment_bytes);
+ (fenv.environment.x87_status_word) |= excepts;
+ x87_write_environment (fenv.environment_bytes);
+ x87_trap_exceptions ();
+ }
+ /* There seems to be no good way to request a trap in SSE.
+ Fortunately, I don't think there are any systems with SSE but not
+ x87.
+ if (sse_p && (!x87_p) && (fetestexcept (excepts)))
+ raise (SIGFPE); */
+ return (! (sse_p || x87_p));
+}
+\f
+int
+fegetexceptflag (fexcept_t *flagp, int excepts)
+{
+ if (excepts &~ FE_ALL_EXCEPT)
+ return (-1);
+ (*flagp) = (fetestexcept (excepts));
+ return (! (sse_p || x87_p));
+}
+
+int
+fesetexceptflag (const fexcept_t *flagp, int excepts)
+{
+ if (((*flagp) | excepts) &~ FE_ALL_EXCEPT)
+ return (-1);
+ if (sse_p)
+ sse_write_mxcsr ((sse_read_mxcsr ()) | ((*flagp) & excepts));
+ if (x87_p)
+ {
+ x87_fenv_t fenv;
+ x87_read_environment (fenv.environment_bytes);
+ (fenv.environment.x87_status_word) |= ((*flagp) & excepts);
+ x87_write_environment (fenv.environment_bytes);
+ }
+ return (! (sse_p || x87_p));
+}
+\f
+/* The following are glibc extensions. */
+
+int
+fegetexcept (void)
+{
+ int sse_mask = (sse_p ? ((sse_read_mxcsr ()) >> 7) : (~0));
+ int x87_mask = (x87_p ? (x87_read_control_word ()) : (~0));
+ return (FE_ALL_EXCEPT &~ (sse_mask & x87_mask));
+}
+
+int
+feenableexcept (int excepts)
+{
+ int old_excepts = 0;
+ if (excepts &~ FE_ALL_EXCEPT)
+ return (-1);
+ if (sse_p)
+ {
+ unsigned int mxcsr = (sse_read_mxcsr ());
+ old_excepts |= (FE_ALL_EXCEPT &~ (mxcsr >> 7));
+ sse_write_mxcsr (mxcsr &~ (excepts << 7));
+ }
+ if (x87_p)
+ {
+ unsigned short control_word = (x87_read_control_word ());
+ old_excepts |= (FE_ALL_EXCEPT &~ control_word);
+ x87_write_control_word (control_word &~ excepts);
+ }
+ return ((sse_p || x87_p) ? old_excepts : (-1));
+}
+
+int
+fedisableexcept (int excepts)
+{
+ int old_excepts = 0;
+ if (excepts &~ FE_ALL_EXCEPT)
+ return (-1);
+ if (sse_p)
+ {
+ unsigned int mxcsr = (sse_read_mxcsr ());
+ old_excepts |= (FE_ALL_EXCEPT &~ (mxcsr >> 7));
+ sse_write_mxcsr (mxcsr | (excepts << 7));
+ }
+ if (x87_p)
+ {
+ unsigned short control_word = (x87_read_control_word ());
+ old_excepts |= (FE_ALL_EXCEPT &~ control_word);
+ x87_write_control_word (control_word | excepts);
+ }
+ return ((sse_p || x87_p) ? old_excepts : (-1));
+}
+\f
+int
+fegetenv (fenv_t *envp)
+{
+ if (sse_p)
+ (envp->fenv_sse.sse_mxcsr) = (sse_read_mxcsr ());
+ if (x87_p)
+ x87_read_environment (envp->fenv_x87.environment_bytes);
+ return (! (sse_p || x87_p));
+}
+
+int
+fesetenv (const fenv_t *envp)
+{
+ if (sse_p)
+ sse_write_mxcsr (envp->fenv_sse.sse_mxcsr);
+ if (x87_p)
+ x87_write_environment (envp->fenv_x87.environment_bytes);
+ return (! (sse_p || x87_p));
+}
+
+int
+feholdexcept (fenv_t *envp)
+{
+ int status = (fegetenv (envp));
+ if (status != 0)
+ return (status);
+ if (sse_p)
+ sse_write_mxcsr
+ (((envp->fenv_sse.sse_mxcsr)
+ | (FE_ALL_EXCEPT << 7)) /* Set all mask bits. */
+ &~ FE_ALL_EXCEPT); /* Clear all flag bits. */
+ if (x87_p)
+ {
+ x87_clear_exceptions ();
+ x87_write_control_word
+ ((envp->fenv_x87.environment.x87_control_word) | FE_ALL_EXCEPT);
+ }
+ return (0);
+}
+
+int
+feupdateenv (const fenv_t *envp)
+{
+ int excepts = (fetestexcept (FE_ALL_EXCEPT));
+ int status = (fesetenv (envp));
+ if (status != 0)
+ return (status);
+ return (feraiseexcept (excepts));
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* C99 <fenv.h> emulation for x86 (shared between i386 and amd64) */
+
+#define HAVE_FENV_T
+#define HAVE_FEXCEPT_T
+
+typedef int fexcept_t;
+
+typedef struct
+{
+ int sse_mxcsr;
+} sse_fenv_t;
+
+/* FIXME: This structure needs to be packed. */
+
+struct x87_environment
+{
+ unsigned short x87_control_word;
+ unsigned short x87_unused1;
+ unsigned short x87_status_word;
+ unsigned short x87_unused2;
+ unsigned short x87_tag_word;
+ unsigned short x87_unused3;
+ unsigned int x87_instruction_offset;
+ unsigned short x87_instruction_cs_selector;
+ unsigned short x87_instruction_opcode : 11;
+ unsigned short x87_unused4 : 5;
+ unsigned int x87_data_offset;
+ unsigned short x87_data_ds_selector;
+ unsigned short x87_unused5;
+};
+
+typedef union
+{
+ struct x87_environment environment;
+ unsigned char environment_bytes [sizeof (struct x87_environment)];
+} x87_fenv_t;
+
+typedef struct
+{
+ sse_fenv_t fenv_sse;
+ x87_fenv_t fenv_x87;
+} fenv_t;
+\f
+#define FE_TONEAREST 0
+#define FE_DOWNWARD 1
+#define FE_UPWARD 2
+#define FE_TOWARDZERO 3
+
+#define HAVE_FEGETROUND
+#define HAVE_FESETROUND
+
+extern int fegetround (void);
+extern int fesetround (int);
+
+#define FE_INVALID (1 << 0)
+#define FE_DENORMAL (1 << 1) /* Non-standard */
+#define FE_DIVBYZERO (1 << 2)
+#define FE_OVERFLOW (1 << 3)
+#define FE_UNDERFLOW (1 << 4)
+#define FE_INEXACT (1 << 5)
+
+#define FE_ALL_EXCEPT \
+ (FE_DENORMAL|FE_DIVBYZERO|FE_INEXACT|FE_INVALID|FE_OVERFLOW|FE_UNDERFLOW)
+
+#if FE_ALL_EXCEPT != 0x3f
+# error Floating-point exception set is wrong.
+#endif
+
+#define HAVE_FECLEAREXCEPT
+#define HAVE_FEGETEXCEPTFLAG
+#define HAVE_FERAISEEXCEPT
+#define HAVE_FESETEXCEPTFLAG
+#define HAVE_FETESTEXCEPT
+
+extern int fetestexcept (int);
+extern int feclearexcept (int);
+extern int feraiseexcept (int);
+extern int fegetexceptflag (fexcept_t *, int);
+extern int fesetexceptflag (const fexcept_t *, int);
+
+/* The next three are glibc extensions. */
+
+#define HAVE_FEDISABLEEXCEPT
+#define HAVE_FEENABLEEXCEPT
+#define HAVE_FEGETEXCEPT
+
+extern int fegetexcept (void);
+extern int feenableexcept (int);
+extern int fedisableexcept (int);
+
+#define HAVE_FEGETENV
+#define HAVE_FESETENV
+#define HAVE_FEHOLDEXCEPT
+#define HAVE_FEUPDATEENV
+
+extern int fegetenv (fenv_t *);
+extern int fesetenv (const fenv_t *);
+extern int feholdexcept (fenv_t *);
+extern int feupdateenv (const fenv_t *);
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Floating Point Environment */
+
+#include "scheme.h"
+#include "osscheme.h"
+#include "prims.h"
+
+#include "floenv.h"
+
+#ifndef __GNUC__
+# pragma STDC FENV_ACCESS ON
+#endif
+
+#define VECTOR_8B_LENGTH STRING_LENGTH
+#define VECTOR_8B_P STRING_P
+#define VECTOR_8B_POINTER STRING_POINTER
+#define allocate_vector_8b allocate_string
+
+static SCHEME_OBJECT
+arg_vector_8b (int n)
+{
+ CHECK_ARG (n, VECTOR_8B_P);
+ return (ARG_REF (n));
+}
+
+#ifndef HAVE_FENV_T
+typedef char fenv_t;
+#endif
+
+#ifndef HAVE_FEXCEPT_T
+typedef char fexcept_t;
+#endif
+\f
+static bool scheme_fenv_p = false;
+static fenv_t scheme_fenv;
+
+static void
+cache_float_environment (void)
+{
+#ifdef HAVE_FEGETENV
+ if (0 != (fegetenv (&scheme_fenv)))
+ error_external_return ();
+ scheme_fenv_p = true;
+#endif
+}
+
+void
+fixup_float_environment (void)
+{
+#ifdef HAVE_FESETENV
+ if (scheme_fenv_p)
+ (void) fesetenv (&scheme_fenv);
+#endif
+}
+
+/* FIXME: Alignment? */
+
+static SCHEME_OBJECT
+allocate_fenv (fenv_t **envp_loc)
+{
+ SCHEME_OBJECT environment = (allocate_vector_8b (sizeof (fenv_t)));
+ (*envp_loc) = ((fenv_t *) (VECTOR_8B_POINTER (environment)));
+ return (environment);
+}
+
+static fenv_t *
+arg_fenv (int n)
+{
+ SCHEME_OBJECT environment = (arg_vector_8b (n));
+ if ((sizeof (fenv_t)) != (VECTOR_8B_LENGTH (environment)))
+ error_bad_range_arg (n);
+ return ((fenv_t *) (VECTOR_8B_POINTER (environment)));
+}
+
+static SCHEME_OBJECT
+allocate_fexcept (fexcept_t **flagp_loc)
+{
+ SCHEME_OBJECT flags = (allocate_vector_8b (sizeof (fexcept_t)));
+ (*flagp_loc) = ((fexcept_t *) (VECTOR_8B_POINTER (flags)));
+ return (flags);
+}
+
+static fexcept_t *
+arg_fexcept (int n)
+{
+ SCHEME_OBJECT flags = (arg_vector_8b (n));
+ if ((sizeof (fexcept_t)) != (VECTOR_8B_LENGTH (flags)))
+ error_bad_range_arg (n);
+ return ((fexcept_t *) (VECTOR_8B_POINTER (flags)));
+}
+\f
+DEFINE_PRIMITIVE ("FLOAT-ENVIRONMENT", Prim_float_environment, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETENV
+ {
+ fenv_t *envp;
+ SCHEME_OBJECT environment = (allocate_fenv (&envp));
+ if (0 != (fegetenv (envp)))
+ error_external_return ();
+ PRIMITIVE_RETURN (environment);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SET-FLOAT-ENVIRONMENT", Prim_set_float_environment, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FESETENV
+ if (0 != (fesetenv (arg_fenv (1))))
+ error_external_return ();
+ cache_float_environment ();
+#else
+ error_unimplemented_primitive ();
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("DEFER-FLOAT-EXCEPTIONS", Prim_defer_float_exceptions, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEHOLDEXCEPT
+ {
+ fenv_t *envp;
+ SCHEME_OBJECT environment = (allocate_fenv (&envp));
+ if (0 != (feholdexcept (envp)))
+ error_external_return ();
+ cache_float_environment ();
+ PRIMITIVE_RETURN (environment);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("UPDATE-FLOAT-ENVIRONMENT", Prim_restore_float_environment, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FEUPDATEENV
+ if (0 != (feupdateenv (arg_fenv (1))))
+ error_external_return ();
+ cache_float_environment ();
+#else
+ error_unimplemented_primitive ();
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+enum { FRMODE_NEAREST, FRMODE_TOWARD_ZERO, FRMODE_DOWNWARD, FRMODE_UPWARD };
+
+DEFINE_PRIMITIVE ("FLOAT-ROUNDING-MODES", Prim_float_rounding_modes, 0, 0, 0)
+{
+ unsigned int modes = 0;
+ PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETROUND
+# ifdef FE_TONEAREST
+ modes |= (1 << FRMODE_NEAREST);
+# endif
+# ifdef FE_TOWARDZERO
+ modes |= (1 << FRMODE_TOWARD_ZERO);
+# endif
+# ifdef FE_DOWNWARD
+ modes |= (1 << FRMODE_DOWNWARD);
+# endif
+# ifdef FE_UPWARD
+ modes |= (1 << FRMODE_UPWARD);
+# endif
+#endif
+ PRIMITIVE_RETURN (ulong_to_integer (modes));
+}
+
+DEFINE_PRIMITIVE ("GET-FLOAT-ROUNDING-MODE", Prim_get_float_rounding_mode, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETROUND
+ {
+ int mode = (fegetround ());
+ if (mode < 0)
+ error_external_return ();
+ switch (mode)
+ {
+#ifdef FE_TONEAREST
+ case FE_TONEAREST: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_NEAREST));
+#endif
+#ifdef FE_TOWARDZERO
+ case FE_TOWARDZERO: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_TOWARD_ZERO));
+#endif
+#ifdef FE_DOWNWARD
+ case FE_DOWNWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_DOWNWARD));
+#endif
+#ifdef FE_UPWARD
+ case FE_UPWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_UPWARD));
+#endif
+ default: PRIMITIVE_RETURN (SHARP_F);
+ }
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SET-FLOAT-ROUNDING-MODE", Prim_set_float_rounding_mode, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FESETROUND
+ {
+ int mode = (-1);
+ switch (arg_ulong_integer (1))
+ {
+#ifdef FE_TONEAREST
+ case FRMODE_NEAREST: mode = FE_TONEAREST; break;
+#endif
+#ifdef FE_TOWARDZERO
+ case FRMODE_TOWARD_ZERO: mode = FE_TOWARDZERO; break;
+#endif
+#ifdef FE_DOWNWARD
+ case FRMODE_DOWNWARD: mode = FE_DOWNWARD; break;
+#endif
+#ifdef FE_UPWARD
+ case FRMODE_UPWARD: mode = FE_UPWARD; break;
+#endif
+ default: error_bad_range_arg (1); break;
+ }
+ if ((fesetround (mode)) != 0)
+ error_external_return ();
+ cache_float_environment ();
+ }
+#else
+ error_unimplemented_primitive ();
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/* The following two definitions could be replaced by a more complex
+ mapping between the system's representation of exception sets and a
+ system-independent representation of them for Scheme, like the
+ rounding modes above. While OS-independent representations are
+ generally good, (a) machine-dependent representations don't matter
+ much, (b) the system-dependent representations are likely to be
+ machine-dependent but OS-independent, and (c) it would be nice to
+ open-code all the floating-point environment hackery. */
+
+#define FLOAT_EXCEPTIONS_RESULT(EXCEPTIONS) \
+ PRIMITIVE_RETURN (ULONG_TO_FIXNUM (EXCEPTIONS))
+
+static int
+arg_float_exceptions (int n)
+{
+ CHECK_ARG (n, UNSIGNED_FIXNUM_P);
+ {
+ unsigned long scheme_exceptions = (FIXNUM_TO_ULONG (ARG_REF (n)));
+ if (scheme_exceptions &~ FE_ALL_EXCEPT)
+ error_bad_range_arg (n);
+ return (scheme_exceptions);
+ }
+}
+
+/* It is not safe to run Scheme with the inexact result exception
+ unmasked, but the exception can sometimes be useful to test.
+ Consequently, we go to some trouble to make sure that it is masked,
+ and signal an error if anyone ever tries to unmask it. */
+
+static const int always_masked_exceptions = 0
+#ifdef FE_INEXACT
+ | FE_INEXACT
+#endif
+ ;
+
+static int
+arg_maskable_float_exceptions (int n)
+{
+ return (always_masked_exceptions | (arg_float_exceptions (n)));
+}
+
+static int
+arg_unmaskable_float_exceptions (int n)
+{
+ int exceptions = (arg_float_exceptions (n));
+ if (exceptions & always_masked_exceptions)
+ error_bad_range_arg (n);
+ return (exceptions);
+}
+
+static int
+arg_float_exception_mask (int n)
+{
+ int exceptions = (arg_float_exceptions (n));
+ if (! (exceptions & always_masked_exceptions))
+ error_bad_range_arg (n);
+ return (exceptions);
+}
+\f
+#define FLOAT_EXCEPTIONS_PRIMITIVE(E) \
+{ \
+ PRIMITIVE_HEADER (0); \
+ FLOAT_EXCEPTIONS_RESULT (E); \
+}
+
+#define UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE() \
+{ \
+ PRIMITIVE_HEADER (0); \
+ /* error_unimplemented_primitive (); */ \
+ FLOAT_EXCEPTIONS_RESULT (0); \
+}
+
+DEFINE_PRIMITIVE ("FLOAT-INVALID-OPERATION-EXCEPTION", Prim_float_invalid_operation_exception, 0, 0, 0)
+#ifdef FE_INVALID
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_INVALID)
+#else
+ UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
+#endif
+
+DEFINE_PRIMITIVE ("FLOAT-DIVIDE-BY-ZERO-EXCEPTION", Prim_float_divide_by_zero_exception, 0, 0, 0)
+#ifdef FE_DIVBYZERO
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_DIVBYZERO)
+#else
+ UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
+#endif
+
+DEFINE_PRIMITIVE ("FLOAT-OVERFLOW-EXCEPTION", Prim_float_overflow_exception, 0, 0, 0)
+#ifdef FE_OVERFLOW
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_OVERFLOW)
+#else
+ UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
+#endif
+
+DEFINE_PRIMITIVE ("FLOAT-UNDERFLOW-EXCEPTION", Prim_float_underflow_exception, 0, 0, 0)
+#ifdef FE_UNDERFLOW
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_UNDERFLOW)
+#else
+ UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
+#endif
+
+DEFINE_PRIMITIVE ("FLOAT-INEXACT-RESULT-EXCEPTION", Prim_float_inexact_result_exception, 0, 0, 0)
+#ifdef FE_INEXACT
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_INEXACT)
+#else
+ UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
+#endif
+\f
+DEFINE_PRIMITIVE ("FLOAT-EXCEPTIONS", Prim_float_exceptions, 0, 0, 0)
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_ALL_EXCEPT)
+
+DEFINE_PRIMITIVE ("UNMASKABLE-FLOAT-EXCEPTIONS", Prim_unmaskable_float_exceptions, 0, 0, 0)
+ FLOAT_EXCEPTIONS_PRIMITIVE (FE_ALL_EXCEPT &~ always_masked_exceptions)
+
+DEFINE_PRIMITIVE ("TEST-FLOAT-EXCEPTIONS", Prim_test_float_exceptions, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FETESTEXCEPT
+ FLOAT_EXCEPTIONS_RESULT (fetestexcept (arg_float_exceptions (1)));
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("CLEAR-FLOAT-EXCEPTIONS", Prim_clear_float_exceptions, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FECLEAREXCEPT
+ if (0 != (feclearexcept (arg_float_exceptions (1))))
+ error_external_return ();
+ cache_float_environment ();
+#else
+ error_unimplemented_primitive ();
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("RAISE-FLOAT-EXCEPTIONS", Prim_raise_float_exceptions, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FERAISEEXCEPT
+ if (0 != (feraiseexcept (arg_float_exceptions (1))))
+ error_external_return ();
+ /* cache_float_environment (); */
+#else
+ error_unimplemented_primitive ();
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("SAVE-FLOAT-EXCEPTION-FLAGS", Prim_save_float_exception_flags, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETEXCEPTFLAG
+ {
+ fexcept_t *flagp;
+ SCHEME_OBJECT flags = (allocate_fexcept (&flagp));
+ if (0 != (fegetexceptflag (flagp, (arg_float_exceptions (1)))))
+ error_external_return ();
+ PRIMITIVE_RETURN (flags);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("TEST-FLOAT-EXCEPTION-FLAGS", Prim_test_float_exception_flags, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ /* Oops! IEEE 754-2008 requests this operation, but C99 doesn't
+ provide it. */
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("RESTORE-FLOAT-EXCEPTION-FLAGS", Prim_restore_float_exception_flags, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+#ifdef HAVE_FESETEXCEPTFLAG
+ if (0 > (fesetexceptflag ((arg_fexcept (1)), (arg_float_exceptions (2)))))
+ error_external_return ();
+ cache_float_environment ();
+#else
+ error_unimplemented_primitive ();
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("MASKED-FLOAT-EXCEPTIONS", Prim_masked_float_exceptions, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+#ifdef HAVE_FEGETEXCEPT
+ {
+ int exceptions = (fegetexcept ());
+ if (exceptions < 0) error_external_return ();
+ FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ exceptions);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SET-MASKED-FLOAT-EXCEPTIONS", Prim_set_masked_float_exceptions, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#if ((defined (HAVE_FEENABLEEXCEPT)) && (defined (HAVE_FEDISABLEEXCEPT)))
+ {
+ int masked_exceptions = (arg_float_exception_mask (1));
+ int previous_exceptions = (fedisableexcept (masked_exceptions));
+ if ((0 > previous_exceptions)
+ || (0 > (feenableexcept (FE_ALL_EXCEPT &~ masked_exceptions))))
+ error_external_return ();
+ cache_float_environment ();
+ FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ previous_exceptions);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("MASK-FLOAT-EXCEPTIONS", Prim_mask_float_exceptions, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FEDISABLEEXCEPT
+ {
+ int exceptions = (arg_maskable_float_exceptions (1));
+ int previous_exceptions = (fedisableexcept (exceptions));
+ if (previous_exceptions < 0) error_external_return ();
+ cache_float_environment ();
+ FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ previous_exceptions);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
+
+DEFINE_PRIMITIVE ("UNMASK-FLOAT-EXCEPTIONS", Prim_unmask_float_exceptions, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+#ifdef HAVE_FEENABLEEXCEPT
+ {
+ int exceptions = (arg_unmaskable_float_exceptions (1));
+ int previous_exceptions = (feenableexcept (exceptions));
+ if (previous_exceptions < 0) error_external_return ();
+ cache_float_environment ();
+ FLOAT_EXCEPTIONS_RESULT (FE_ALL_EXCEPT &~ previous_exceptions);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Floating Point Environment */
+
+#ifdef HAVE_CONFIG_H
+# include "config.h"
+#endif
+
+#include "cmpintmd.h"
+
+#if (defined (HAVE_FENV_H))
+# include <fenv.h>
+#elif ((!defined (CMPINTMD_EMULATES_FENV)) && (defined (HAVE_IEEEFP_H)))
+
+/* Assumption: If we have <ieeefp.h>, then we don't need to test for
+ individual definitions in it. If you come across a different
+ <ieeefp.h> from what one finds on BSD systems, you'll have to fix
+ this code. */
+
+# include <ieeefp.h>
+
+# define FE_TONEAREST FP_RN
+# define FE_DOWNWARD FP_RM
+# define FE_UPWARD FP_RP
+# define FE_TOWARDZERO FP_RZ
+
+# define fegetround fpgetround
+# define fesetround(rm) ((fpsetround (rm)), 0)
+
+# define FE_INVALID FP_X_INV
+# define FE_DIVBYZERO FP_X_DZ
+# define FE_OVERFLOW FP_X_OFL
+# define FE_UNDERFLOW FP_X_UFL
+# define FE_INEXACT FP_X_IMP
+/* FP_X_IOV? */
+
+# define fexcept_t fp_except
+
+# define fetestexcepts(excepts) ((excepts) & (fpgetsticky ()))
+# define fecleareexcept(excepts) \
+ (fpsetsticky ((fpgetsticky ()) &~ (FE_ALL_EXCEPT & (excepts))))
+
+/* This isn't right -- it doesn't necessarily actually raise the
+ exception until some floating-point operation is performed. */
+# define feraiseexcept(excepts) \
+ (fpsetsticky ((fpgetsticky ()) || (FE_ALL_EXCEPT & (excepts)))
+
+# define fegetexceptflag(flagp, excepts) \
+ (((* ((0 ? ((int *) 0) : flagp))) = ((excepts) & (fpgetsticky ()))), 0)
+# define fesetexceptflag(flagp, excepts) \
+ (fpsetsticky \
+ (FE_ALL_EXCEPT & (excepts) & (* ((0 ? ((const int *) 0) : flagp)))))
+
+# define fegetexcept fpgetmask
+# define feenableexcept(excepts) \
+ (fpsetmask ((fpgetmask ()) || (FE_ALL_EXCEPT & (excepts))))
+# define fedisableexcept(excepts) \
+ (fpsetmask ((fpgetmask ()) &~ (FE_ALL_EXCEPT & (excepts))))
+
+typedef struct
+{
+ fp_except fe_enabled_exceptions;
+ fp_except fe_sticky_exceptions;
+ fp_rnd fe_rounding_mode;
+} fenv_t;
+
+static inline int
+fegetenv (fenv_t *fe)
+{
+ (fe->fe_enabled_exceptions) = (fpgetmask ());
+ (fe->fe_sticky_exceptions) = (fpgetsticky ());
+ (fe->fe_rounding_mode) = (fpgetround ());
+ return (0);
+}
+
+static inline int
+fesetenv (const fenv_t *fe)
+{
+ (void) fpsetmask (fe->fe_enabled_exceptions);
+ (void) fpsetsticky (fe->fe_sticky_exceptions);
+ (void) fpsetround (fe->fe_rounding_mode);
+ return (0);
+}
+
+static inline int
+feholdexcept (fenv_t *fe)
+{
+ (void) fegetenv (fe);
+ fpsetmask (0);
+ return (0);
+}
+
+static inline int
+feupdateenv (const fenv_t *fe)
+{
+ fp_except exceptions = (fpgetsticky ());
+ (void) fesetenv (fe);
+ /* Unfortunately, this doesn't actually do anything, because of the
+ useless definition of feraiseexcept above. */
+ (void) feraiseexcept (exceptions);
+}
+#endif
extern void * obstack_chunk_alloc (size_t);
#define obstack_chunk_free free
extern void preserve_signal_mask (void);
-extern void fixup_float_rounding_mode (void);
+extern void fixup_float_environment (void);
\f
/* In order to make the interpreter tail recursive (i.e.
* to avoid calling procedures and thus saving unnecessary
bind_interpreter_state (&new_state);
dispatch_code = (setjmp (interpreter_catch_env));
preserve_signal_mask ();
- fixup_float_rounding_mode ();
+ fixup_float_environment ();
switch (dispatch_code)
{
"fasl"
"fasload"
"fixnum"
+"floenv"
"flonum"
"gcloop"
"generic"
#include "ostty.h"
#include "ostop.h"
-#ifdef HAVE_FENV_H
-# include <fenv.h>
-#endif
-
extern long OS_set_trap_state (long);
extern double arg_flonum (int);
\f
CHECK_ARG (1, CC_BLOCK_P);
PRIMITIVE_RETURN (cc_block_linkage_info (ARG_REF (1)));
}
-\f
-/* Emulate <fenv.h> with BSD's <ieeefp.h>. */
-
-#if !defined(HAVE_FENV_H) && defined(HAVE_IEEEFP_H)
-# include <ieeefp.h>
-#endif
-
-#if !defined(HAVE_FEGETROUND) && defined(HAVE_FPGETROUND)
-# define fegetround fpgetround
-# define HAVE_FEGETROUND
-#endif
-
-#if !defined(HAVE_FESETROUND) && defined(HAVE_FPSETROUND)
-
-static inline int
-fesetround (int mode)
-{
- /* fpsetround never fails; instead, it returns the old rounding mode,
- which has only a one-in-four chance in general of being 0 as the
- SET-FLOAT-ROUNDING-MODE primitive wants. */
- (void) fpsetround (mode);
- return (0);
-}
-
-# define HAVE_FESETROUND
-#endif
-
-#if !defined(FE_TONEAREST) && defined(FP_RN)
-# define FE_TONEAREST FP_RN
-#endif
-
-#if !defined(FE_TOWARDZERO) && defined(FP_RZ)
-# define FE_TOWARDZERO FP_RZ
-#endif
-
-#if !defined(FE_DOWNWARD) && defined(FP_RM)
-# define FE_DOWNWARD FP_RM
-#endif
-
-#if !defined(FE_UPWARD) && defined(FP_RP)
-# define FE_UPWARD FP_RP
-#endif
-\f
-#ifndef __GNUC__
-# pragma STDC FENV_ACCESS ON
-#endif
-
-enum { FRMODE_NEAREST, FRMODE_TOWARD_ZERO, FRMODE_DOWNWARD, FRMODE_UPWARD };
-
-DEFINE_PRIMITIVE ("FLOAT-ROUNDING-MODES", Prim_float_rounding_modes, 0, 0, 0)
-{
- unsigned int modes = 0;
- PRIMITIVE_HEADER (0);
-#ifdef HAVE_FEGETROUND
-# ifdef FE_TONEAREST
- modes |= (1 << FRMODE_NEAREST);
-# endif
-# ifdef FE_TOWARDZERO
- modes |= (1 << FRMODE_TOWARD_ZERO);
-# endif
-# ifdef FE_DOWNWARD
- modes |= (1 << FRMODE_DOWNWARD);
-# endif
-# ifdef FE_UPWARD
- modes |= (1 << FRMODE_UPWARD);
-# endif
-#endif
- PRIMITIVE_RETURN (ulong_to_integer (modes));
-}
-
-DEFINE_PRIMITIVE ("GET-FLOAT-ROUNDING-MODE", Prim_get_float_rounding_mode, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
-#ifdef HAVE_FEGETROUND
- {
- int mode = (fegetround ());
- if (mode < 0)
- error_external_return ();
- switch (mode)
- {
-#ifdef FE_TONEAREST
- case FE_TONEAREST: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_NEAREST));
-#endif
-#ifdef FE_TOWARDZERO
- case FE_TOWARDZERO: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_TOWARD_ZERO));
-#endif
-#ifdef FE_DOWNWARD
- case FE_DOWNWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_DOWNWARD));
-#endif
-#ifdef FE_UPWARD
- case FE_UPWARD: PRIMITIVE_RETURN (ulong_to_integer (FRMODE_UPWARD));
-#endif
- default: PRIMITIVE_RETURN (SHARP_F);
- }
- }
-#else
- error_unimplemented_primitive ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-#endif
-}
-
-#ifdef HAVE_FESETROUND
-static int float_rounding_mode = (-1);
-#endif
-
-DEFINE_PRIMITIVE ("SET-FLOAT-ROUNDING-MODE", Prim_set_float_rounding_mode, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
-#ifdef HAVE_FESETROUND
- {
- int mode = (-1);
- switch (arg_ulong_integer (1))
- {
-#ifdef FE_TONEAREST
- case FRMODE_NEAREST: mode = FE_TONEAREST; break;
-#endif
-#ifdef FE_TOWARDZERO
- case FRMODE_TOWARD_ZERO: mode = FE_TOWARDZERO; break;
-#endif
-#ifdef FE_DOWNWARD
- case FRMODE_DOWNWARD: mode = FE_DOWNWARD; break;
-#endif
-#ifdef FE_UPWARD
- case FRMODE_UPWARD: mode = FE_UPWARD; break;
-#endif
- default: error_bad_range_arg (1); break;
- }
- if ((fesetround (mode)) != 0)
- {
- float_rounding_mode = (-1);
- error_bad_range_arg (1);
- }
- else
- float_rounding_mode = mode;
- }
-#else
- error_unimplemented_primitive ();
-#endif
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* This kludge is to work around the fact that setjmp saves the
- floating-point rounding mode and longjmp restores it. */
-
-void
-fixup_float_rounding_mode (void)
-{
-#ifdef HAVE_FESETROUND
- if (float_rounding_mode >= 0)
- fesetround (float_rounding_mode);
-#endif
-}
DEFUN_STD_HANDLER (sighnd_fpe,
{
FPE_RESET_TRAPS ();
- if (executing_scheme_primitive_p ())
- error_floating_point_exception ();
trap_handler ("floating-point exception", signo, info, scp);
})
#endif
(define condition-type:error)
(define condition-type:file-error)
(define condition-type:file-operation-error)
+(define condition-type:floating-point-divide-by-zero)
(define condition-type:floating-point-overflow)
(define condition-type:floating-point-underflow)
(define condition-type:illegal-datum)
(define condition-type:illegal-pathname-component)
+(define condition-type:inexact-floating-point-result)
+(define condition-type:integer-divide-by-zero)
+(define condition-type:invalid-floating-point-operation)
(define condition-type:macro-binding)
(define condition-type:no-such-restart)
(define condition-type:not-8-bit-char)
" the same "
(get-noun condition)
" again.")))))
-\f
+
(set! condition-type:variable-error
(make-condition-type 'VARIABLE-ERROR condition-type:cell-error
'(ENVIRONMENT)
(lambda (condition port)
(write-string "Variable reference to a syntactic keyword: " port)
(write (access-condition condition 'LOCATION) port))))
-
+\f
(let ((arithmetic-error-report
(lambda (description)
(lambda (condition port)
(make-condition-type 'DIVIDE-BY-ZERO condition-type:arithmetic-error
'()
(arithmetic-error-report "Division by zero")))
+ (set! condition-type:integer-divide-by-zero
+ (make-condition-type 'INTEGER-DIVIDE-BY-ZERO
+ condition-type:divide-by-zero
+ '()
+ (arithmetic-error-report "Integer division by zero")))
+ (set! condition-type:floating-point-divide-by-zero
+ (make-condition-type 'FLOATING-POINT-DIVIDE-BY-ZERO
+ condition-type:divide-by-zero
+ '()
+ (arithmetic-error-report "Floating-point division by zero")))
+ (set! condition-type:inexact-floating-point-result
+ (make-condition-type 'INEXACT-FLOATING-POINT-RESULT
+ condition-type:arithmetic-error
+ '()
+ (arithmetic-error-report "Inexact floating-point result")))
+ (set! condition-type:invalid-floating-point-operation
+ (make-condition-type 'INVALID-FLOATING-POINT-OPERATION
+ condition-type:arithmetic-error
+ '()
+ (arithmetic-error-report "Invalid floating-point operation")))
(set! condition-type:floating-point-overflow
(make-condition-type 'FLOATING-POINT-OVERFLOW
condition-type:arithmetic-error
condition-type:arithmetic-error
'()
(arithmetic-error-report "Floating-point underflow"))))
-
+\f
(set! condition-type:not-8-bit-char
(make-condition-type 'NOT-8-BIT-CHAR condition-type:error '(CHAR)
(lambda (condition port)
(write-string "Character too large for 8-bit string: " port)
(write (access-condition condition 'CHAR) port)
(newline port))))
-\f
+
(set! make-simple-error
(condition-constructor condition-type:simple-error
'(MESSAGE IRRITANTS)))
(define (->flonum x)
(guarantee-real x '->FLONUM)
- (exact->inexact (real-part x)))
-\f
-(define-primitives
- (float-rounding-modes 0)
- (get-float-rounding-mode 0)
- (set-float-rounding-mode 1))
-
-(define float-rounding-mode-names
- '#(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD))
-
-(define (flo:rounding-modes)
- (let ((n (vector-length float-rounding-mode-names))
- (m (float-rounding-modes)))
- (let loop ((i 0) (names '()))
- (if (fix:< i n)
- (loop (fix:+ i 1)
- (if (fix:= (fix:and (fix:lsh 1 i) m) 0)
- names
- (cons (vector-ref float-rounding-mode-names i) names)))
- names))))
-
-(define (flo:rounding-mode)
- (let ((m (get-float-rounding-mode)))
- (if (not (fix:< m (vector-length float-rounding-mode-names)))
- (error "Unknown float rounding mode:" m))
- (vector-ref float-rounding-mode-names m)))
-
-(define (flo:set-rounding-mode! mode)
- (set-float-rounding-mode (%mode-name->number mode 'FLO:SET-ROUNDING-MODE!)))
-
-(define (flo:with-rounding-mode mode thunk)
- (let ((inside-mode (%mode-name->number mode 'FLO:WITH-ROUNDING-MODE))
- (outside-mode))
- (shallow-fluid-bind (lambda ()
- (set! outside-mode (get-float-rounding-mode))
- (set-float-rounding-mode inside-mode)
- (set! inside-mode)
- unspecific)
- thunk
- (lambda ()
- (set! inside-mode (get-float-rounding-mode))
- (set-float-rounding-mode outside-mode)
- (set! outside-mode)
- unspecific))))
-
-(define (%mode-name->number mode caller)
- (guarantee-interned-symbol mode caller)
- (let ((n (vector-length float-rounding-mode-names)))
- (let loop ((i 0))
- (if (not (fix:< i n))
- (error:bad-range-argument mode caller))
- (if (eq? mode (vector-ref float-rounding-mode-names i))
- i
- (loop (fix:+ i 1))))))
\ No newline at end of file
+ (exact->inexact (real-part x)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Floating-Point Environment
+;;; package: (runtime floating-point-environment)
+
+(declare (usual-integrations))
+\f
+;;;; Floating-Point Environment
+
+(define-primitives
+ (flo:environment float-environment 0)
+ (flo:set-environment! set-float-environment 1)
+ (flo:defer-exceptions! defer-float-exceptions 0)
+ (flo:update-environment! update-float-environment 1))
+
+(define (flo:deferring-exceptions procedure)
+ (flo:preserving-environment
+ (lambda ()
+ (let ((environment (flo:defer-exceptions!)))
+ (let ((result (procedure)))
+ (flo:update-environment! environment)
+ result)))))
+
+(define (flo:ignoring-exceptions procedure)
+ (flo:preserving-environment
+ (lambda ()
+ (flo:defer-exceptions!)
+ (procedure))))
+
+(define (flo:preserving-environment procedure)
+ (let ((environment (flo:environment)))
+ (define (swap)
+ (let ((temporary environment))
+ (set! environment (flo:environment))
+ (flo:set-environment! temporary)))
+ (dynamic-wind swap procedure swap)))
+
+(define (flo:with-default-environment procedure)
+ (flo:preserving-environment
+ (lambda ()
+ (flo:set-environment! (flo:default-environment))
+ (procedure))))
+
+(define default-environment)
+
+(define (flo:default-environment)
+ default-environment)
+
+(define (initialize-package!)
+ (set! default-environment
+ (let ((environment (flo:environment)))
+ (flo:set-rounding-mode! (flo:default-rounding-mode))
+ (flo:clear-exceptions! (flo:supported-exceptions))
+ (flo:set-masked-exceptions! (flo:default-exception-mask))
+ (let ((environment* (flo:environment)))
+ (flo:set-environment! environment)
+ environment*)))
+ unspecific)
+\f
+(define-primitives
+ (float-rounding-modes 0)
+ (get-float-rounding-mode 0)
+ (set-float-rounding-mode 1))
+
+(define float-rounding-mode-names
+ '#(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD))
+
+(define (flo:rounding-modes)
+ (let ((n (vector-length float-rounding-mode-names))
+ (m (float-rounding-modes)))
+ (let loop ((i 0) (names '()))
+ (if (fix:< i n)
+ (loop (fix:+ i 1)
+ (if (fix:= (fix:and (fix:lsh 1 i) m) 0)
+ names
+ (cons (vector-ref float-rounding-mode-names i) names)))
+ names))))
+
+(define (flo:default-rounding-mode)
+ 'TO-NEAREST)
+
+(define (flo:rounding-mode)
+ (let ((m (get-float-rounding-mode)))
+ (if (not (fix:< m (vector-length float-rounding-mode-names)))
+ (error "Unknown float rounding mode:" m))
+ (vector-ref float-rounding-mode-names m)))
+
+(define (flo:set-rounding-mode! mode)
+ (set-float-rounding-mode (%mode-name->number mode 'FLO:SET-ROUNDING-MODE!)))
+
+(define (flo:with-rounding-mode mode thunk)
+ (let ((mode (%mode-name->number mode 'FLO:WITH-ROUNDING-MODE)))
+ (flo:preserving-environment
+ (lambda ()
+ (set-float-rounding-mode mode)
+ (thunk)))))
+
+(define (%mode-name->number mode caller)
+ (guarantee-interned-symbol mode caller)
+ (let ((n (vector-length float-rounding-mode-names)))
+ (let loop ((i 0))
+ (if (not (fix:< i n))
+ (error:bad-range-argument mode caller))
+ (if (eq? mode (vector-ref float-rounding-mode-names i))
+ i
+ (loop (fix:+ i 1))))))
+\f
+(define-primitives
+ (flo:supported-exceptions float-exceptions 0)
+ (flo:exception:divide-by-zero float-divide-by-zero-exception 0)
+ (flo:exception:invalid-operation float-invalid-operation-exception 0)
+ (flo:exception:underflow float-underflow-exception 0)
+ (flo:exception:overflow float-overflow-exception 0)
+ (flo:exception:inexact-result float-inexact-result-exception 0)
+ (flo:test-exceptions test-float-exceptions 1)
+ (flo:clear-exceptions! clear-float-exceptions 1)
+ (flo:raise-exceptions! raise-float-exceptions 1)
+ (flo:save-exception-flags save-float-exception-flags 1)
+ (flo:test-exception-flags test-float-exception-flags 2)
+ (flo:restore-exception-flags! restore-float-exception-flags 2)
+ (flo:masked-exceptions masked-float-exceptions 0)
+ (flo:set-masked-exceptions! set-masked-float-exceptions 1)
+ (flo:mask-exceptions! mask-float-exceptions 1)
+ (flo:unmask-exceptions! unmask-float-exceptions 1)
+ (flo:unmaskable-exceptions unmaskable-float-exceptions 0))
+
+(define (flo:default-exception-mask)
+ ;; By default, we unmask the standard IEEE 754 exceptions that Scheme
+ ;; can safely run with, in order to report errors as soon as they
+ ;; happen. Scheme cannot safely run with the inexact result
+ ;; exception (which you almost never want *trapping* anyway), and
+ ;; there are some non-standard exceptions which we will mask in order
+ ;; to keep behaviour consistent between host systems.
+ (fix:andc (flo:supported-exceptions)
+ (fix:or (fix:or (flo:exception:divide-by-zero)
+ (flo:exception:invalid-operation))
+ (fix:or (flo:exception:overflow)
+ (flo:exception:underflow)))))
+
+(define (flo:with-exception-mask exceptions procedure)
+ (flo:preserving-environment
+ (lambda ()
+ (flo:set-masked-exceptions! exceptions)
+ (procedure))))
+
+(define (flo:with-exceptions-masked exceptions procedure)
+ (flo:preserving-environment
+ (lambda ()
+ (flo:mask-exceptions! exceptions)
+ (procedure))))
+
+;++ Include machine-dependent bits, by number rather than by name.
+
+(define (flo:exceptions->names exceptions)
+ (define (n name bits tail)
+ (if (fix:zero? (fix:and bits exceptions))
+ tail
+ (cons name tail)))
+ (guarantee-index-fixnum exceptions 'FLO:EXCEPTIONS->NAMES)
+ (if (not (fix:zero? (fix:andc exceptions (flo:supported-exceptions))))
+ (error:bad-range-argument exceptions 'FLO:EXCEPTIONS->NAMES))
+ (n 'DIVIDE-BY-ZERO (flo:exception:divide-by-zero)
+ (n 'INEXACT-RESULT (flo:exception:inexact-result)
+ (n 'INVALID-OPERATION (flo:exception:invalid-operation)
+ (n 'OVERFLOW (flo:exception:overflow)
+ (n 'UNDERFLOW (flo:exception:underflow)
+ '()))))))
+
+(define (flo:names->exceptions names)
+ (define (name->exceptions name)
+ (case name
+ ((DIVIDE-BY-ZERO) (flo:exception:divide-by-zero))
+ ((INEXACT-RESULT) (flo:exception:inexact-result))
+ ((INVALID-OPERATION) (flo:exception:invalid-operation))
+ ((OVERFLOW) (flo:exception:overflow))
+ ((UNDERFLOW) (flo:exception:underflow))
+ (else (error:bad-range-argument names 'FLO:NAMES->EXCEPTIONS))))
+ (guarantee-list-of-unique-symbols names 'FLO:NAMES->EXCEPTIONS)
+ (reduce fix:or 0 (map name->exceptions names)))
\ No newline at end of file
((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!)
;; System dependent stuff
((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!)
+ ;; Floating-point environment -- needed by threads.
+ (RUNTIME FLOATING-POINT-ENVIRONMENT)
;; Threads
(RUNTIME THREAD)
;; I/O
)
(package/add-child! system-global-package 'USER user-initial-environment)
+;; Might be better to do this sooner, to trap on floating-point
+;; mistakes earlier in the cold load.
+(flo:set-environment! (flo:default-environment))
(start-thread-timer)
(initial-top-level-repl)
\ No newline at end of file
flo:positive?
flo:round
flo:round->exact
- flo:rounding-mode
- flo:rounding-modes
- flo:set-rounding-mode!
flo:sin
flo:sqrt
flo:tan
flo:vector-length
flo:vector-ref
flo:vector-set!
- flo:with-rounding-mode
flo:zero?
guarantee-fixnum
guarantee-index-fixnum
non-positive-fixnum?
positive-fixnum?))
+(define-package (runtime floating-point-environment)
+ (files "floenv")
+ (parent (runtime))
+ (export ()
+ flo:clear-exceptions!
+ flo:default-environment
+ flo:default-exception-mask
+ flo:default-rounding-mode
+ flo:defer-exceptions!
+ flo:deferring-exceptions
+ flo:environment
+ flo:exception:divide-by-zero
+ flo:exception:inexact-result
+ flo:exception:invalid-operation
+ flo:exception:overflow
+ flo:exception:underflow
+ flo:exceptions->names
+ flo:ignoring-exceptions
+ flo:mask-exceptions!
+ flo:masked-exceptions
+ flo:names->exceptions
+ flo:preserving-environment
+ flo:raise-exceptions!
+ flo:restore-exception-flags!
+ flo:rounding-mode
+ flo:rounding-modes
+ flo:save-exception-flags
+ flo:set-environment!
+ flo:set-masked-exceptions!
+ flo:set-rounding-mode!
+ flo:supported-exceptions
+ flo:test-exception-flags
+ flo:test-exceptions
+ flo:unmask-exceptions!
+ flo:unmaskable-exceptions
+ flo:update-environment!
+ flo:with-default-environment
+ flo:with-exception-mask
+ flo:with-exceptions-masked
+ flo:with-rounding-mode)
+ (initialization (initialize-package!)))
+
(define-package (runtime integer-bits)
(files "integer-bits")
(parent (runtime))
continuation/block-thread-events?
continuation/control-point
continuation/dynamic-state
+ continuation/floating-point-environment
continuation?
error:not-continuation
guarantee-continuation
stack-frame/compiled-code?
stack-frame/dynamic-state
stack-frame/elements
+ stack-frame/floating-point-environment
stack-frame/interrupt-mask
stack-frame/length
stack-frame/next
condition-type:error
condition-type:file-error
condition-type:file-operation-error
+ condition-type:floating-point-divide-by-zero
condition-type:floating-point-overflow
condition-type:floating-point-underflow
condition-type:illegal-datum
condition-type:illegal-pathname-component
+ condition-type:inexact-floating-point-result
+ condition-type:integer-divide-by-zero
+ condition-type:invalid-floating-point-operation
condition-type:macro-binding
condition-type:no-such-restart
condition-type:not-8-bit-char
;; Root state-point of the local state space of the thread. Used to
;; unwind the thread's state space when it is exited.
+ (floating-point-environment #f)
+ ;; Thread-local floating-point environment.
+
(mutexes '())
;; List of mutexes that this thread owns or is waiting to own. Used
;; to disassociate the thread from those mutexes when it is exited.
(define (make-thread continuation)
(let ((thread (%make-thread)))
(set-thread/continuation! thread continuation)
+ (set-thread/floating-point-environment! thread (flo:default-environment))
(set-thread/root-state-point! thread
(current-state-point state-space:local))
(add-to-population!/unsafe thread-population thread)
(wait-for-io))))
\f
(define (run-thread thread)
- (let ((continuation (thread/continuation thread)))
+ (let ((continuation (thread/continuation thread))
+ (fp-env (thread/floating-point-environment thread)))
(set-thread/continuation! thread #f)
+ (set-thread/floating-point-environment! thread #f)
(%within-continuation continuation #t
(lambda ()
+ (flo:set-environment! fp-env)
(%resume-current-thread thread)))))
(define (%resume-current-thread thread)
(define (%suspend-current-thread)
(call-with-current-thread #f
(lambda (thread)
- (let ((block-events? (thread/block-events? thread)))
+ (let ((fp-env (flo:environment))
+ (block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
(maybe-signal-io-thread-events)
(let ((any-events? (handle-thread-events thread)))
(call-with-current-continuation
(lambda (continuation)
(set-thread/continuation! thread continuation)
+ (set-thread/floating-point-environment! thread fp-env)
(set-thread/block-events?! thread #f)
(thread-not-running thread 'WAITING)))))))))
(call-with-current-continuation
(lambda (continuation)
(set-thread/continuation! thread continuation)
+ (set-thread/floating-point-environment! thread (flo:environment))
(thread-not-running thread 'STOPPED))))))))
(define (restart-thread thread discard-events? event)
(set-thread/execution-state! (current-thread) 'RUNNING))
(define (thread-timer-interrupt-handler)
- (set! next-scheduled-timeout #f)
- (set-interrupt-enables! interrupt-mask/gc-ok)
- (deliver-timer-events)
- (maybe-signal-io-thread-events)
- (let ((thread first-running-thread))
- (cond ((not thread)
- (%maybe-toggle-thread-timer))
- ((thread/continuation thread)
- (run-thread thread))
- ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
- (thread/execution-state thread)))
- (yield-thread thread))
- (else
- (%resume-current-thread thread)))))
+ ;; Preserve the floating-point environment here to guarantee that the
+ ;; thread timer won't raise or clear exceptions (particularly the
+ ;; inexact result exception) that the interrupted thread cares about.
+ (let ((fp-env (flo:environment)))
+ (flo:set-environment! (flo:default-environment))
+ (set! next-scheduled-timeout #f)
+ (set-interrupt-enables! interrupt-mask/gc-ok)
+ (deliver-timer-events)
+ (maybe-signal-io-thread-events)
+ (let ((thread first-running-thread))
+ (cond ((not thread)
+ (%maybe-toggle-thread-timer))
+ ((thread/continuation thread)
+ (run-thread thread))
+ ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
+ (thread/execution-state thread)))
+ (yield-thread thread fp-env))
+ (else
+ (flo:set-environment! fp-env)
+ (%resume-current-thread thread))))))
(define (yield-current-thread)
(without-interrupts
(set-thread/execution-state! thread 'RUNNING)
(yield-thread thread))))))
-(define (yield-thread thread)
+(define (yield-thread thread #!optional fp-env)
(let ((next (thread/next thread)))
(if (not next)
- (%resume-current-thread thread)
+ (begin
+ (if (not (default-object? fp-env))
+ (flo:set-environment! fp-env))
+ (%resume-current-thread thread))
(call-with-current-continuation
(lambda (continuation)
(set-thread/continuation! thread continuation)
+ (set-thread/floating-point-environment! thread
+ (if (default-object? fp-env)
+ (flo:environment)
+ fp-env))
(set-thread/next! thread #f)
(set-thread/next! last-running-thread thread)
(set! last-running-thread thread)
(string-replace (symbol-name error-type) #\- #\space)
(string-append "error " (write-to-string error-type)))))
+;++ Whattakludge!
+
(define (normalize-trap-code-name name)
- (let loop ((prefixes '("floating-point " "integer ")))
- (if (not (null? prefixes))
- (if (string-prefix-ci? (car prefixes) name)
- (set! name (string-tail name (string-length (car prefixes))))
- (loop (cdr prefixes)))))
- (let loop ((suffixes '(" trap" " fault")))
- (if (not (null? suffixes))
- (if (string-suffix-ci? (car suffixes) name)
- (set! name
- (string-head name
- (- (string-length name)
- (string-length (car suffixes)))))
- (loop (cdr suffixes)))))
- (cond ((string-ci=? "underflow" name) 'UNDERFLOW)
- ((string-ci=? "overflow" name) 'OVERFLOW)
- ((or (string-ci=? "divide by 0" name)
- (string-ci=? "divide by zero" name))
+ (cond ((or (string-prefix-ci? "integer divide by 0" name)
+ (string-prefix-ci? "integer divide by zero" name))
+ 'INTEGER-DIVIDE-BY-ZERO)
+ ((or (string-prefix-ci? "floating-point divide by 0" name)
+ (string-prefix-ci? "floating-point divide by zero" name))
+ 'FLOATING-POINT-DIVIDE-BY-ZERO)
+ ((or (string-prefix-ci? "divide by 0" name)
+ (string-prefix-ci? "divide by zero" name))
'DIVIDE-BY-ZERO)
- (else false)))
+ ((or (string-prefix-ci? "inexact result" name)
+ (string-prefix-ci? "inexact operation" name)
+ (string-prefix-ci? "floating-point inexact result" name))
+ 'INEXACT-RESULT)
+ ((or (string-prefix-ci? "invalid operation" name)
+ (string-prefix-ci? "invalid floating-point operation" name))
+ 'INVALID-OPERATION)
+ ((or (string-prefix-ci? "overflow" name)
+ (string-prefix-ci? "floating-point overflow" name))
+ 'OVERFLOW)
+ ((or (string-prefix-ci? "underflow" name)
+ (string-prefix-ci? "floating-point underflow" name))
+ 'UNDERFLOW)
+ (else #f)))
\f
(define (file-primitive-description primitive)
(cond ((or (eq? primitive (ucode-primitive file-exists? 1))
"User microcode reset"))
(set! hook/hardware-trap
- (let ((signal-user-microcode-reset
- (condition-signaller condition-type:user-microcode-reset '()))
+ (let ((signal-arithmetic-error
+ (condition-signaller condition-type:arithmetic-error
+ '(OPERATOR OPERANDS)))
(signal-divide-by-zero
(condition-signaller condition-type:divide-by-zero
'(OPERATOR OPERANDS)))
+ (signal-floating-point-divide-by-zero
+ (condition-signaller condition-type:floating-point-divide-by-zero
+ '(OPERATOR OPERANDS)))
(signal-floating-point-overflow
(condition-signaller condition-type:floating-point-overflow
'(OPERATOR OPERANDS)))
(signal-floating-point-underflow
(condition-signaller condition-type:floating-point-underflow
'(OPERATOR OPERANDS)))
- (signal-arithmetic-error
- (condition-signaller condition-type:arithmetic-error
- '(OPERATOR OPERANDS)))
(signal-hardware-trap
- (condition-signaller condition-type:hardware-trap '(NAME CODE))))
+ (condition-signaller condition-type:hardware-trap '(NAME CODE)))
+ (signal-inexact-floating-point-result
+ (condition-signaller condition-type:inexact-floating-point-result
+ '(OPERATOR OPERANDS)))
+ (signal-integer-divide-by-zero
+ (condition-signaller condition-type:integer-divide-by-zero
+ '(OPERATOR OPERANDS)))
+ (signal-invalid-floating-point-operation
+ (condition-signaller
+ condition-type:invalid-floating-point-operation
+ '(OPERATOR OPERANDS)))
+ (signal-user-microcode-reset
+ (condition-signaller condition-type:user-microcode-reset '())))
(lambda (name)
(call-with-current-continuation
(lambda (k)
((or (string=? "XCPT_FLOAT_OVERFLOW" name)
(string=? "XCPT_INTEGER_OVERFLOW" name))
(signal-floating-point-overflow k #f '()))
- ((or (string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name)
- (string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name))
- (signal-divide-by-zero k #f '()))
+ ((string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name)
+ (signal-floating-point-divide-by-zero k #f '()))
+ ((string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name)
+ (signal-integer-divide-by-zero k #f '()))
+ ((string=? "XCPT_FLOAT_INEXACT_RESULT" name)
+ (signal-inexact-floating-point-result k #f '()))
+ ((string=? "XCPT_FLOAT_INVALID_OPERATION" name)
+ (signal-invalid-floating-point-operation k #f '()))
((or (string=? "XCPT_FLOAT_DENORMAL_OPERAND" name)
- (string=? "XCPT_FLOAT_INEXACT_RESULT" name)
- (string=? "XCPT_FLOAT_INVALID_OPERATION" name)
(string=? "XCPT_FLOAT_STACK_CHECK" name)
(string=? "XCPT_B1NPX_ERRATA_02" name))
(signal-arithmetic-error k #f '()))
(if (string=? "SIGFPE" name)
((case (and (string? code)
(normalize-trap-code-name code))
- ((UNDERFLOW) signal-floating-point-underflow)
- ((OVERFLOW) signal-floating-point-overflow)
((DIVIDE-BY-ZERO) signal-divide-by-zero)
+ ((FLOATING-POINT-DIVIDE-BY-ZERO)
+ signal-floating-point-divide-by-zero)
+ ((INEXACT-RESULT)
+ signal-inexact-floating-point-result)
+ ((INTEGER-DIVIDE-BY-ZERO)
+ signal-integer-divide-by-zero)
+ ((INVALID-OPERATION)
+ signal-invalid-floating-point-operation)
+ ((OVERFLOW) signal-floating-point-overflow)
+ ((UNDERFLOW) signal-floating-point-underflow)
(else signal-arithmetic-error))
- k false '())
- (signal-hardware-trap k
- name
- code)))))))))))
+ k #f '())
+ (signal-hardware-trap k name code)))))))))))
;;; end INITIALIZE-PACKAGE!.
)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of the floating-point environment
+
+(declare (usual-integrations))
+\f
+(define-test 'FLO:DEFAULT-ROUNDING-MODE
+ (lambda ()
+ (assert-eqv (flo:default-rounding-mode) 'TO-NEAREST)))
+
+(define-test 'FLO:ROUNDING-MODES
+ (lambda ()
+ (assert-eqv
+ (lset-difference eq?
+ (flo:rounding-modes)
+ '(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD))
+ '())))
+
+(define-test 'FLO:ROUNDING-MODE
+ (lambda ()
+ (assert-memv (flo:rounding-mode) (flo:rounding-modes))))
+
+(define (for-each-rounding-mode receiver)
+ (for-each receiver '(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD)))
+
+(for-each-rounding-mode
+ (lambda (mode)
+ (define-test (symbol-append 'FLO:SET-ROUNDING-MODE ': mode)
+ (lambda ()
+ (let ((mode* (flo:rounding-mode)))
+ (dynamic-wind (lambda () (flo:set-rounding-mode! mode))
+ (lambda () (assert-eqv (flo:rounding-mode) mode))
+ (lambda () (flo:set-rounding-mode! mode*)))
+ (assert-eqv (flo:rounding-mode) mode*))))))
+
+(for-each-rounding-mode
+ (lambda (mode)
+ (define-test (symbol-append 'FLO:WITH-ROUNDING-MODE ': mode)
+ (lambda ()
+ (let ((mode* (flo:rounding-mode)))
+ (flo:with-rounding-mode mode
+ (lambda ()
+ (assert-eqv (flo:rounding-mode) mode)))
+ (assert-eqv (flo:rounding-mode) mode*))))))
+
+(for-each-rounding-mode
+ (lambda (mode)
+ (define inputs '(-2.0 -1.5 -1.0 -0.5 -0.0 0.0 0.5 1.0 1.5 2.0))
+ (define (define-rounding-test name operator outputs)
+ (define-test (symbol-append 'ROUNDING-MODE-INDEPENDENT ': mode '/ name)
+ (lambda ()
+ (do ((inputs inputs (cdr inputs))
+ (outputs outputs (cdr outputs))
+ (i 0 (+ i 1)))
+ ((not (and (pair? inputs) (pair? outputs))))
+ (let ((input (car inputs)) (output (car outputs)))
+ (run-sub-test
+ (lambda ()
+ (assert-eqv
+ (flo:with-rounding-mode mode (lambda () (operator input)))
+ output))))))))
+ (define-rounding-test 'CEILING ceiling
+ '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 1.0 1.0 2.0 2.0))
+ (define-rounding-test 'FLOOR floor
+ '(-2.0 -2.0 -1.0 -1.0 -0.0 0.0 0.0 1.0 1.0 2.0))
+ (define-rounding-test 'ROUND round
+ '(-2.0 -2.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 2.0 2.0))
+ (define-rounding-test 'TRUNCATE truncate
+ '(-2.0 -1.0 -1.0 -0.0 -0.0 0.0 0.0 1.0 1.0 2.0))))
+
+;++ Add tests for rounding-mode-dependent operations...
+\f
+(define floating-point-exception-descriptors '())
+
+(define (no-op x) x) ;Do not integrate!
+
+(define (define-fpe-descriptor name unmaskable? exception condition-type)
+ (let ((descriptor (list name exception condition-type unmaskable? '())))
+ (cond ((assq name floating-point-exception-descriptors)
+ => (lambda (descriptor*)
+ (set-cdr! descriptor* (cdr descriptor))))
+ (else
+ (set! floating-point-exception-descriptors
+ (cons descriptor floating-point-exception-descriptors))
+ unspecific))))
+
+(define (define-fpe-elicitor name elicitor-name procedure)
+ (cond ((assq name floating-point-exception-descriptors)
+ => (lambda (descriptor)
+ (let ((elicitors (list-ref descriptor 4)))
+ (cond ((assq elicitor-name elicitors)
+ => (lambda (pair) (set-cdr! pair procedure)))
+ (else
+ (set-car! (list-tail descriptor 4)
+ (cons (cons elicitor-name procedure)
+ elicitors)))))))
+ (else
+ (error:bad-range-argument name 'DEFINE-FPE-ELICITOR))))
+
+(define (for-each-exception receiver)
+ (for-each (lambda (descriptor)
+ (apply receiver descriptor))
+ floating-point-exception-descriptors))
+
+(define (for-each-unmaskable-exception receiver)
+ (for-each-exception
+ (lambda (name exception condition-type unmaskable? elicitors)
+ (if unmaskable?
+ (receiver name exception condition-type elicitors)))))
+
+(define (for-each-exception-elicitor receiver)
+ (for-each-exception
+ (lambda (name exception condition-type unmaskable? elicitors)
+ (for-each (lambda (name.elicitor)
+ (receiver name exception condition-type unmaskable?
+ (car name.elicitor)
+ (cdr name.elicitor)))
+ elicitors))))
+
+(define (for-each-unmaskable-exception-elicitor receiver)
+ (for-each-unmaskable-exception
+ (lambda (name exception condition-type elicitors)
+ (for-each (lambda (name.elicitor)
+ (receiver name exception condition-type
+ (car name.elicitor)
+ (cdr name.elicitor)))
+ elicitors))))
+\f
+(define-fpe-descriptor 'DIVIDE-BY-ZERO #t flo:exception:divide-by-zero
+ condition-type:floating-point-divide-by-zero)
+
+(define-fpe-elicitor 'DIVIDE-BY-ZERO 'RAISE
+ (lambda () (flo:raise-exceptions! (flo:exception:divide-by-zero))))
+
+(define-fpe-elicitor 'DIVIDE-BY-ZERO 'POSITIVE-ONE-OVER-ZERO
+ (lambda () (flo:/ (no-op +1.) (no-op 0.))))
+
+(define-fpe-elicitor 'DIVIDE-BY-ZERO 'NEGATIVE-ONE-OVER-ZERO
+ (lambda () (flo:/ (no-op -1.) (no-op 0.))))
+
+(define-fpe-elicitor 'DIVIDE-BY-ZERO 'LOG-ZERO
+ (lambda () (flo:log (no-op 0.))))
+
+(define-fpe-descriptor 'INEXACT-RESULT #f flo:exception:inexact-result
+ condition-type:inexact-floating-point-result)
+
+(define-fpe-elicitor 'INEXACT-RESULT 'RAISE
+ (lambda () (flo:raise-exceptions! (flo:exception:inexact-result))))
+
+(define-fpe-elicitor 'INEXACT-RESULT 'ONE-PLUS-EPSILON-OVER-TWO
+ (lambda ()
+ (flo:+ (no-op 1.) (flo:* (no-op .5) microcode-id/floating-epsilon))))
+
+(define-fpe-descriptor 'INVALID-OPERATION #t flo:exception:invalid-operation
+ condition-type:invalid-floating-point-operation)
+
+(define-fpe-elicitor 'INVALID-OPERATION 'RAISE
+ (lambda () (flo:raise-exceptions! (flo:exception:invalid-operation))))
+
+(define-fpe-elicitor 'INVALID-OPERATION 'ZERO-OVER-ZERO
+ (lambda ()
+ (flo:/ (no-op 0.) (no-op 0.))))
+
+(define-fpe-descriptor 'OVERFLOW #t flo:exception:overflow
+ condition-type:floating-point-overflow)
+
+(define-fpe-elicitor 'OVERFLOW 'RAISE
+ (lambda () (flo:raise-exceptions! (flo:exception:overflow))))
+
+;++ The maximum and minimum exponents should not be hard-coded here.
+
+(define-fpe-elicitor 'OVERFLOW 'MOST-POSITIVE-NUMBER-TIMES-TWO
+ (let ((flo:shift (make-primitive-procedure 'FLONUM-DENORMALIZE 2)))
+ (lambda ()
+ (flo:* (no-op 2.) (flo:shift (no-op 1.) 1023)))))
+
+(define-fpe-descriptor 'UNDERFLOW #t flo:exception:underflow
+ condition-type:floating-point-underflow)
+
+(define-fpe-elicitor 'UNDERFLOW 'RAISE
+ (lambda () (flo:raise-exceptions! (flo:exception:underflow))))
+
+(define-fpe-elicitor 'UNDERFLOW 'LEAST-POSITIVE-NUMBER-OVER-TWO
+ (let ((flo:shift (make-primitive-procedure 'FLONUM-DENORMALIZE 2)))
+ (lambda ()
+ ;; Problem: On every machine I tested (several different models
+ ;; of each of x87, amd64, and sparc), if this doesn't trap, it
+ ;; doesn't set the underflow exception flag either. So all tests
+ ;; relying on the exception flag will fail.
+ (flo:* (no-op .5) (flo:shift (no-op 1.) -1022)))))
+\f
+(define (for-each-unmaskable-exception receiver)
+ (for-each-exception
+ (lambda (name exception condition-type unmaskable? elicitors)
+ (if unmaskable? (receiver name exception condition-type elicitors)))))
+
+(for-each-exception
+ (lambda (name exception condition-type unmaskable? elicitors)
+ condition-type unmaskable? elicitors ;ignore
+ (define-test (symbol-append 'FLO:EXCEPTIONS->NAMES ': name)
+ (lambda ()
+ (assert-equal (flo:exceptions->names (exception)) (list name))))
+ (define-test (symbol-append 'FLO:NAMES->EXCEPTIONS ': name)
+ (lambda ()
+ (assert-equal (flo:names->exceptions (list name)) (exception))))))
+
+(define-test 'FLO:EXCEPTIONS->NAMES
+ (lambda ()
+ (let ((descriptors floating-point-exception-descriptors))
+ (assert-equal
+ (lset-difference
+ eq?
+ (flo:exceptions->names
+ (reduce fix:or 0 (map (lambda (f) (f)) (map cadr descriptors))))
+ (map car descriptors))
+ '()))))
+
+(define-test 'FLO:NAMES->EXCEPTIONS
+ (lambda ()
+ (let ((descriptors floating-point-exception-descriptors))
+ (assert-eqv
+ (flo:names->exceptions (map car descriptors))
+ (reduce fix:or 0 (map (lambda (f) (f)) (map cadr descriptors)))))))
+\f
+(define-test 'FLO:SUPPORTED-EXCEPTIONS
+ (lambda ()
+ (flo:supported-exceptions)))
+
+(define-test 'FLO:SUPPORTED-EXCEPTION-NAMES
+ (lambda ()
+ (assert-eqv
+ (lset-difference eq?
+ (flo:exceptions->names (flo:supported-exceptions))
+ (map car floating-point-exception-descriptors))
+ '())))
+
+(define-test 'FLO:MASKED-EXCEPTIONS
+ (lambda ()
+ (flo:masked-exceptions)))
+
+(define (define-set-masked-exceptions-test name to-mask)
+ (define-test (symbol-append 'FLO:SET-MASKED-EXCEPTIONS! ': name)
+ (lambda ()
+ (let ((exceptions (fix:andc (flo:supported-exceptions) (to-mask)))
+ (mask (flo:masked-exceptions)))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (assert-eqv (flo:set-masked-exceptions! exceptions) mask)
+ (assert-eqv (flo:masked-exceptions) exceptions))
+ (lambda () (flo:set-masked-exceptions! mask)))))))
+
+(define (define-with-exception-mask-test name to-mask)
+ (define-test (symbol-append 'FLO:WITH-EXCEPTION-MASK ': name)
+ (lambda ()
+ (let ((exceptions (fix:andc (flo:supported-exceptions) (to-mask))))
+ (flo:with-exception-mask exceptions
+ (lambda ()
+ (assert-eqv (flo:masked-exceptions) exceptions)))))))
+
+(define-set-masked-exceptions-test 'ALL (lambda () 0))
+(define-set-masked-exceptions-test 'NONE flo:unmaskable-exceptions)
+
+(define-with-exception-mask-test 'ALL (lambda () 0))
+(define-with-exception-mask-test 'NONE flo:unmaskable-exceptions)
+
+(for-each-unmaskable-exception
+ (lambda (name exception condition-type elicitors)
+ elicitors ;ignore
+ (define-test (symbol-append 'FLO:WITH-EXCEPTION-MASK ': name)
+ (lambda ()
+ (let ((mask (fix:andc (flo:supported-exceptions) (exception))))
+ (flo:with-exception-mask mask
+ (lambda ()
+ (assert-eqv (flo:masked-exceptions) mask))))))))
+\f
+(for-each-unmaskable-exception
+ (lambda (name exception condition-type elicitors)
+ elicitors ;ignore
+ (define-test (symbol-append 'FLO:MASK-EXCEPTIONS! ': name)
+ (lambda ()
+ (let ((mask
+ (fix:andc (flo:supported-exceptions)
+ (flo:unmaskable-exceptions))))
+ (flo:with-exception-mask mask
+ (lambda ()
+ (assert-eqv (flo:mask-exceptions! (exception)) mask)
+ (assert-eqv (flo:masked-exceptions)
+ (fix:or mask (exception))))))))))
+
+(for-each-unmaskable-exception
+ (lambda (name exception condition-type elicitors)
+ elicitors ;ignore
+ (define-test (symbol-append 'FLO:UNMASK-EXCEPTIONS! ': name)
+ (lambda ()
+ (flo:with-exception-mask (flo:supported-exceptions)
+ (lambda ()
+ (assert-eqv (flo:unmask-exceptions! (exception))
+ (flo:supported-exceptions))
+ (assert-eqv (flo:masked-exceptions)
+ (fix:andc (flo:supported-exceptions) (exception)))))))))
+
+(for-each-unmaskable-exception
+ (lambda (name exception condition-type elicitors)
+ elicitors ;ignore
+ (define-test (symbol-append 'FLO:SET-MASKED-EXCEPTIONS! ': name ': 'ENABLE)
+ (lambda ()
+ (let ((mask
+ (fix:andc (flo:supported-exceptions)
+ (flo:unmaskable-exceptions))))
+ (flo:with-exception-mask (fix:or mask (exception))
+ (lambda ()
+ (assert-eqv (flo:set-masked-exceptions! mask)
+ (fix:or mask (exception)))
+ (assert-eqv (flo:masked-exceptions) mask))))))))
+
+(for-each-unmaskable-exception
+ (lambda (name exception condition-type elicitors)
+ elicitors ;ignore
+ (define-test (symbol-append 'FLO:SET-MASKED-EXCEPTIONS! ': name ': 'DISABLE)
+ (lambda ()
+ (let ((mask (fix:andc (flo:supported-exceptions) (exception))))
+ (flo:with-exception-mask (flo:supported-exceptions)
+ (lambda ()
+ (assert-eqv (flo:set-masked-exceptions! mask)
+ (flo:supported-exceptions))
+ (assert-eqv (flo:masked-exceptions) mask))))))))
+\f
+(for-each-unmaskable-exception-elicitor
+ (lambda (name exception condition-type elicitor-name elicitor)
+ (define-test (symbol-append 'ELICIT ': name ': elicitor-name)
+ (lambda ()
+ (assert-error (lambda ()
+ (flo:with-exception-mask
+ (fix:andc (flo:supported-exceptions) (exception))
+ elicitor))
+ (list condition-type))))))
+
+(for-each-unmaskable-exception-elicitor
+ (lambda (name exception condition-type elicitor-name elicitor)
+ (define-test (symbol-append 'ELICIT-DEFERRED ': name ': elicitor-name)
+ (lambda ()
+ (assert-error
+ (lambda ()
+ (flo:with-exception-mask
+ (fix:andc (flo:supported-exceptions) (flo:unmaskable-exceptions))
+ (lambda ()
+ (flo:deferring-exceptions
+ (lambda ()
+ (let ((flag #f))
+ (dynamic-wind (lambda () unspecific)
+ (lambda () (elicitor) (set! flag #t))
+ (lambda () (assert-true flag)))))))))
+ (list condition-type))))))
+
+(for-each-exception-elicitor
+ (lambda (name exception condition-type unmaskable? elicitor-name elicitor)
+ unmaskable? ;ignore
+ (define-test (symbol-append 'ELICIT-IGNORED ': name ': elicitor-name)
+ (lambda ()
+ (flo:ignoring-exceptions elicitor)))))
+
+(for-each-exception-elicitor
+ (lambda (name exception condition-type unmaskable? elicitor-name elicitor)
+ unmaskable? ;ignore
+ (define-test (symbol-append 'ELICIT-AND-TEST ': name ': elicitor-name)
+ (lambda ()
+ (assert-eqv (flo:ignoring-exceptions
+ (lambda ()
+ (elicitor)
+ (flo:test-exceptions (exception))))
+ (exception))))))
+
+(for-each-exception-elicitor
+ (lambda (name exception condition-type unmaskable? elicitor-name elicitor)
+ unmaskable? ;ignore
+ (define-test (symbol-append 'ELICIT-CLEAR-TEST ': name ': elicitor-name)
+ (lambda ()
+ (assert-eqv (flo:ignoring-exceptions
+ (lambda ()
+ (elicitor)
+ (flo:clear-exceptions! (exception))
+ (flo:test-exceptions (exception))))
+ 0)))))
+\f
+(define-test 'FLO:ENVIRONMENT
+ (lambda ()
+ (flo:environment)))
+
+(define-test 'FLO:SET-ENVIRONMENT
+ (lambda ()
+ (flo:set-environment! (flo:environment))))
+
+(define-test 'FLO:DEFAULT-ENVIRONMENT
+ (lambda ()
+ (flo:default-environment)))
+
+(define-test 'FLO:SET-DEFAULT-ENVIRONMENT
+ (lambda ()
+ (let ((environment (flo:environment)))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda () (flo:set-environment! (flo:default-environment)))
+ (lambda () (flo:set-environment! environment))))))
+
+(define-test 'FLO:WITH-DEFAULT-ENVIRONMENT
+ (lambda ()
+ (flo:with-default-environment (lambda () 0))))
+
+(define (define-default-environment-test name procedure)
+ (define-test (symbol-append 'FLO:DEFAULT-ENVIRONMENT ': name)
+ (lambda ()
+ (flo:preserving-environment
+ (lambda ()
+ ;; Futz with the floating-point environment first,
+ ;; guaranteeing that it is not the default one.
+ (flo:set-rounding-mode!
+ (if (eq? 'UPWARD (flo:default-rounding-mode))
+ 'TO-NEAREST
+ 'UPWARD))
+ (flo:set-masked-exceptions!
+ (if (= (flo:supported-exceptions) (flo:default-exception-mask))
+ (fix:andc (flo:supported-exceptions)
+ (flo:unmaskable-exceptions))
+ (flo:supported-exceptions)))
+ (flo:with-default-environment procedure))))))
+
+(define-default-environment-test 'ROUNDING-MODE
+ (lambda ()
+ (assert-eqv (flo:rounding-mode) (flo:default-rounding-mode))))
+
+(define-default-environment-test 'MASKED-EXCEPTIONS
+ (lambda ()
+ (assert-eqv (flo:masked-exceptions) (flo:default-exception-mask))))
(define-for-tests assert-boolean-!=
(binary-assertion (lambda (x y) (not (boolean=? x y)))))
+(define-for-tests assert-memv
+ (binary-assertion (lambda (actual-value expected-list)
+ (and (memv actual-value expected-list) #t))))
+
(define-for-tests (assert-error thunk condition-types . properties)
(call-with-current-continuation
(lambda (k)
projects / mit-scheme.git / commitdiff