-! (c)Joe Groff bsd license
-USING: alien.syntax arrays assocs biassocs combinators
-combinators.short-circuit continuations generalizations kernel
-literals locals math math.bitwise sequences sets system
-vocabs.loader ;
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators continuations generalizations
+kernel math math.bitwise sequences sets system vocabs ;
IN: math.floats.env
SINGLETONS:
: fp-env-register ( -- register ) (fp-env-registers) first ;
:: mask> ( bits assoc -- symbols )
- assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
+ assoc [| k v | bits v mask zero? ] assoc-reject keys ;
: >mask ( symbols assoc -- bits )
over empty?
[ 2drop 0 ]
GENERIC: (set-fp-env-register) ( fp-env -- )
GENERIC: (get-exception-flags) ( fp-env -- exceptions )
-GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
+GENERIC#: (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
GENERIC: (get-fp-traps) ( fp-env -- exceptions )
-GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
+GENERIC#: (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
GENERIC: (get-rounding-mode) ( fp-env -- mode )
-GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
+GENERIC#: (set-rounding-mode) 1 ( fp-env mode -- fp-env )
GENERIC: (get-denormal-mode) ( fp-env -- mode )
-GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
+GENERIC#: (set-denormal-mode) 1 ( fp-env mode -- fp-env )
: change-fp-env-registers ( quot -- )
(fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
CONSTANT: vm-error-exception-flag>bit
H{
- { +fp-invalid-operation+ HEX: 01 }
- { +fp-overflow+ HEX: 02 }
- { +fp-underflow+ HEX: 04 }
- { +fp-zero-divide+ HEX: 08 }
- { +fp-inexact+ HEX: 10 }
+ { +fp-invalid-operation+ 0x01 }
+ { +fp-overflow+ 0x02 }
+ { +fp-underflow+ 0x04 }
+ { +fp-zero-divide+ 0x08 }
+ { +fp-inexact+ 0x10 }
}
PRIVATE>
:: with-denormal-mode ( mode quot -- )
denormal-mode :> orig
mode set-denormal-mode
- quot [ orig set-denormal-mode ] [ ] cleanup ; inline
+ quot [ orig set-denormal-mode ] finally ; inline
: rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
:: with-rounding-mode ( mode quot -- )
rounding-mode :> orig
mode set-rounding-mode
- quot [ orig set-rounding-mode ] [ ] cleanup ; inline
+ quot [ orig set-rounding-mode ] finally ; inline
: fp-traps ( -- exceptions )
(fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
clear-fp-exception-flags
fp-traps :> orig
exceptions set-fp-traps
- quot [ orig set-fp-traps ] [ ] cleanup ; inline
+ quot [ orig set-fp-traps ] finally ; inline
: without-fp-traps ( quot -- )
{ } swap with-fp-traps ; inline
-<< {
+{
{ [ cpu x86? ] [ "math.floats.env.x86" require ] }
{ [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
[ "CPU architecture unsupported by math.floats.env" throw ]
-} cond >>
-
+} cond