diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +version 0.4.0.0: + +* removed bindings-dsl; see comments in git log + +* made Quad an instance of Eq and Ord + version 0.2.0.2: * updated .travis.yml for decnumber dependency diff --git a/deka.cabal b/deka.cabal --- a/deka.cabal +++ b/deka.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.2 +version: 0.4.0.0 synopsis: Decimal floating point arithmetic description: @@ -67,18 +67,17 @@ exposed-modules: Data.Deka - , Data.Deka.Decnumber , Data.Deka.Quad , Data.Deka.Docs , Data.Deka.Docs.Examples other-modules: - Data.Deka.Internal + Data.Deka.Decnumber + , Data.Deka.Internal build-depends: base >=4.6 && <4.7 , bytestring ==0.10.* - , bindings-DSL ==1.0.* ghc-options: -Wall default-language: Haskell2010 diff --git a/lib/Data/Deka/Decnumber.hsc b/lib/Data/Deka/Decnumber.hsc --- a/lib/Data/Deka/Decnumber.hsc +++ b/lib/Data/Deka/Decnumber.hsc @@ -1,211 +1,731 @@ {-# LANGUAGE ForeignFunctionInterface #-} --- Bindings-dsl sometimes shadows in do notation --- Bindings-dsl imports unused things -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-imports #-} - -#include #include #include +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + -- | Low-level bindings to the decNumber library. module Data.Deka.Decnumber where -#strict_import +import Foreign.Safe +import Foreign.C +import Control.Applicative -#num NULL +c'NULL :: Num a => a +c'NULL = #const NULL -#integral_t enum rounding -#num DEC_ROUND_CEILING -#num DEC_ROUND_UP -#num DEC_ROUND_HALF_UP -#num DEC_ROUND_HALF_EVEN -#num DEC_ROUND_HALF_DOWN -#num DEC_ROUND_DOWN -#num DEC_ROUND_FLOOR -#num DEC_ROUND_05UP -#num DEC_ROUND_MAX +type C'rounding = #type enum rounding -#integral_t int32_t -#integral_t uint8_t -#integral_t uint16_t -#integral_t uint32_t -#integral_t uint64_t +c'DEC_ROUND_CEILING :: Num a => a +c'DEC_ROUND_CEILING = #const DEC_ROUND_CEILING +c'DEC_ROUND_UP :: Num a => a +c'DEC_ROUND_UP = #const DEC_ROUND_UP -#starttype decContext -#field digits , -#field emax , -#field emin , -#field round , -#field traps , -#field status , -#field clamp , -#stoptype +c'DEC_ROUND_HALF_UP :: Num a => a +c'DEC_ROUND_HALF_UP = #const DEC_ROUND_HALF_UP +c'DEC_ROUND_HALF_EVEN :: Num a => a +c'DEC_ROUND_HALF_EVEN = #const DEC_ROUND_HALF_EVEN + +c'DEC_ROUND_HALF_DOWN :: Num a => a +c'DEC_ROUND_HALF_DOWN = #const DEC_ROUND_HALF_DOWN + +c'DEC_ROUND_DOWN :: Num a => a +c'DEC_ROUND_DOWN = #const DEC_ROUND_DOWN + +c'DEC_ROUND_FLOOR :: Num a => a +c'DEC_ROUND_FLOOR = #const DEC_ROUND_FLOOR + +c'DEC_ROUND_05UP :: Num a => a +c'DEC_ROUND_05UP = #const DEC_ROUND_05UP + +c'DEC_ROUND_MAX :: Num a => a +c'DEC_ROUND_MAX = #const DEC_ROUND_MAX + +type C'int32_t = #type int32_t +type C'uint8_t = #type uint8_t +type C'uint16_t = #type uint16_t +type C'uint32_t = #type uint32_t +type C'uint64_t = #type uint64_t + +data C'decContext = C'decContext + { c'decContext'digits :: C'int32_t + , c'decContext'emax :: C'int32_t + , c'decContext'emin :: C'int32_t + , c'decContext'round :: C'rounding + , c'decContext'traps :: C'uint32_t + , c'decContext'status :: C'uint32_t + , c'decContext'clamp :: C'uint8_t + } deriving (Eq, Show) + +instance Storable C'decContext where + sizeOf _ = #size decContext + alignment _ = #alignment decContext + peek p = + C'decContext + <$> #{peek decContext, digits} p + <*> #{peek decContext, emax} p + <*> #{peek decContext, emin} p + <*> #{peek decContext, round} p + <*> #{peek decContext, traps} p + <*> #{peek decContext, status} p + <*> #{peek decContext, clamp} p + + poke p (C'decContext d ex en r t s c) = + #{poke decContext, digits} p d + >> #{poke decContext, emax} p ex + >> #{poke decContext, emin} p en + >> #{poke decContext, round} p r + >> #{poke decContext, traps} p t + >> #{poke decContext, status} p s + >> #{poke decContext, clamp} p c + +p'decContext'status :: Ptr C'decContext -> Ptr C'uint32_t +p'decContext'status = #ptr decContext, status + +p'decContext'round :: Ptr C'decContext -> Ptr C'rounding +p'decContext'round = #ptr decContext, round + -- decContext -#num DEC_INIT_DECQUAD -#ccall_unsafe decContextDefault , Ptr -> -> IO (Ptr ) +c'DEC_INIT_DECQUAD :: Num a => a +c'DEC_INIT_DECQUAD = #const DEC_INIT_DECQUAD -#integral_t enum decClass -#num DEC_CLASS_SNAN -#num DEC_CLASS_QNAN -#num DEC_CLASS_NEG_INF -#num DEC_CLASS_NEG_NORMAL -#num DEC_CLASS_NEG_SUBNORMAL -#num DEC_CLASS_NEG_ZERO -#num DEC_CLASS_POS_ZERO -#num DEC_CLASS_POS_SUBNORMAL -#num DEC_CLASS_POS_NORMAL -#num DEC_CLASS_POS_INF +foreign import ccall unsafe "decContextDefault" unsafe'c'decContextDefault + :: Ptr C'decContext + -> C'int32_t + -> IO (Ptr C'decContext) -#num DEC_Conversion_syntax -#num DEC_Division_by_zero -#num DEC_Division_impossible -#num DEC_Division_undefined -#num DEC_Insufficient_storage -#num DEC_Inexact -#num DEC_Invalid_context -#num DEC_Invalid_operation -#num DEC_Overflow -#num DEC_Clamped -#num DEC_Rounded -#num DEC_Subnormal -#num DEC_Underflow +type C'decClass = #type enum decClass -#num DEC_IEEE_754_Division_by_zero -#num DEC_IEEE_754_Inexact -#num DEC_IEEE_754_Invalid_operation -#num DEC_IEEE_754_Overflow -#num DEC_IEEE_754_Underflow -#num DEC_Errors -#num DEC_NaNs +c'DEC_CLASS_SNAN :: Num a => a +c'DEC_CLASS_SNAN = #const DEC_CLASS_SNAN -#num DEC_Condition_Length +c'DEC_CLASS_QNAN :: Num a => a +c'DEC_CLASS_QNAN = #const DEC_CLASS_QNAN -#num DEC_INIT_BASE -#num DEC_INIT_DECIMAL32 -#num DEC_INIT_DECIMAL64 -#num DEC_INIT_DECIMAL128 +c'DEC_CLASS_NEG_INF :: Num a => a +c'DEC_CLASS_NEG_INF = #const DEC_CLASS_NEG_INF +c'DEC_CLASS_NEG_NORMAL :: Num a => a +c'DEC_CLASS_NEG_NORMAL = #const DEC_CLASS_NEG_NORMAL -#num DECQUAD_Bytes -#num DECQUAD_Pmax -#num DECQUAD_Emin -#num DECQUAD_Emax -#num DECQUAD_EmaxD -#num DECQUAD_Bias -#num DECQUAD_String -#num DECQUAD_EconL -#num DECQUAD_Declets -#num DECQUAD_Ehigh +c'DEC_CLASS_NEG_SUBNORMAL :: Num a => a +c'DEC_CLASS_NEG_SUBNORMAL = #const DEC_CLASS_NEG_SUBNORMAL -#starttype decQuad -#array_field bytes , -#array_field shorts , -#array_field words , -#stoptype +c'DEC_CLASS_NEG_ZERO :: Num a => a +c'DEC_CLASS_NEG_ZERO = #const DEC_CLASS_NEG_ZERO +c'DEC_CLASS_POS_ZERO :: Num a => a +c'DEC_CLASS_POS_ZERO = #const DEC_CLASS_POS_ZERO -#num DECFLOAT_Sign -#num DECFLOAT_NaN -#num DECFLOAT_qNaN -#num DECFLOAT_sNaN -#num DECFLOAT_Inf -#num DECFLOAT_MinSp +c'DEC_CLASS_POS_SUBNORMAL :: Num a => a +c'DEC_CLASS_POS_SUBNORMAL = #const DEC_CLASS_POS_SUBNORMAL -#num DECPPLUSALT -#num DECPMINUSALT -#num DECPPLUS -#num DECPMINUS -#num DECPPLUSALT2 -#num DECPUNSIGNED +c'DEC_CLASS_POS_NORMAL :: Num a => a +c'DEC_CLASS_POS_NORMAL = #const DEC_CLASS_POS_NORMAL +c'DEC_CLASS_POS_INF :: Num a => a +c'DEC_CLASS_POS_INF = #const DEC_CLASS_POS_INF + +c'DEC_Conversion_syntax :: Num a => a +c'DEC_Conversion_syntax = #const DEC_Conversion_syntax + +c'DEC_Division_by_zero :: Num a => a +c'DEC_Division_by_zero = #const DEC_Division_by_zero + +c'DEC_Division_impossible :: Num a => a +c'DEC_Division_impossible = #const DEC_Division_impossible + +c'DEC_Division_undefined :: Num a => a +c'DEC_Division_undefined = #const DEC_Division_undefined + +c'DEC_Insufficient_storage :: Num a => a +c'DEC_Insufficient_storage = #const DEC_Insufficient_storage + +c'DEC_Inexact :: Num a => a +c'DEC_Inexact = #const DEC_Inexact + +c'DEC_Invalid_context :: Num a => a +c'DEC_Invalid_context = #const DEC_Invalid_context + +c'DEC_Invalid_operation :: Num a => a +c'DEC_Invalid_operation = #const DEC_Invalid_operation + +c'DEC_Overflow :: Num a => a +c'DEC_Overflow = #const DEC_Overflow + +c'DEC_Clamped :: Num a => a +c'DEC_Clamped = #const DEC_Clamped + +c'DEC_Rounded :: Num a => a +c'DEC_Rounded = #const DEC_Rounded + +c'DEC_Subnormal :: Num a => a +c'DEC_Subnormal = #const DEC_Subnormal + +c'DEC_Underflow :: Num a => a +c'DEC_Underflow = #const DEC_Underflow + +c'DEC_IEEE_754_Division_by_zero :: Num a => a +c'DEC_IEEE_754_Division_by_zero = #const DEC_IEEE_754_Division_by_zero + +c'DEC_IEEE_754_Inexact :: Num a => a +c'DEC_IEEE_754_Inexact = #const DEC_IEEE_754_Inexact + +c'DEC_IEEE_754_Invalid_operation :: Num a => a +c'DEC_IEEE_754_Invalid_operation = #const DEC_IEEE_754_Invalid_operation + +c'DEC_IEEE_754_Overflow :: Num a => a +c'DEC_IEEE_754_Overflow = #const DEC_IEEE_754_Overflow + +c'DEC_IEEE_754_Underflow :: Num a => a +c'DEC_IEEE_754_Underflow = #const DEC_IEEE_754_Underflow + +c'DEC_Errors :: Num a => a +c'DEC_Errors = #const DEC_Errors + +c'DEC_NaNs :: Num a => a +c'DEC_NaNs = #const DEC_NaNs + +c'DEC_Condition_Length :: Num a => a +c'DEC_Condition_Length = #const DEC_Condition_Length + +c'DEC_INIT_BASE :: Num a => a +c'DEC_INIT_BASE = #const DEC_INIT_BASE + +c'DEC_INIT_DECIMAL32 :: Num a => a +c'DEC_INIT_DECIMAL32 = #const DEC_INIT_DECIMAL32 + +c'DEC_INIT_DECIMAL64 :: Num a => a +c'DEC_INIT_DECIMAL64 = #const DEC_INIT_DECIMAL64 + +c'DEC_INIT_DECIMAL128 :: Num a => a +c'DEC_INIT_DECIMAL128 = #const DEC_INIT_DECIMAL128 + + +c'DECQUAD_Bytes :: Num a => a +c'DECQUAD_Bytes = #const DECQUAD_Bytes + +c'DECQUAD_Pmax :: Num a => a +c'DECQUAD_Pmax = #const DECQUAD_Pmax + +c'DECQUAD_Emin :: Num a => a +c'DECQUAD_Emin = #const DECQUAD_Emin + +c'DECQUAD_Emax :: Num a => a +c'DECQUAD_Emax = #const DECQUAD_Emax + +c'DECQUAD_EmaxD :: Num a => a +c'DECQUAD_EmaxD = #const DECQUAD_EmaxD + +c'DECQUAD_Bias :: Num a => a +c'DECQUAD_Bias = #const DECQUAD_Bias + +c'DECQUAD_String :: Num a => a +c'DECQUAD_String = #const DECQUAD_String + +c'DECQUAD_EconL :: Num a => a +c'DECQUAD_EconL = #const DECQUAD_EconL + +c'DECQUAD_Declets :: Num a => a +c'DECQUAD_Declets = #const DECQUAD_Declets + +c'DECQUAD_Ehigh :: Num a => a +c'DECQUAD_Ehigh = #const DECQUAD_Ehigh + +newtype C'decQuad = C'decQuad + { c'decQuad'bytes :: [C'uint8_t] + } deriving (Eq, Show) + +p'decQuad'bytes :: Ptr C'decQuad -> Ptr c'decQuad'bytes +p'decQuad'bytes = #ptr decQuad, bytes + +instance Storable C'decQuad where + sizeOf _ = #size decQuad + alignment _ = #alignment decQuad + peek p = + let pArr = p'decQuad'bytes p + in fmap C'decQuad $ peekArray c'DECQUAD_Bytes pArr + poke p (C'decQuad bs) = pokeArray (p'decQuad'bytes p) bs + +c'DECFLOAT_Sign :: Num a => a +c'DECFLOAT_Sign = #const DECFLOAT_Sign + +c'DECFLOAT_NaN :: Num a => a +c'DECFLOAT_NaN = #const DECFLOAT_NaN + +c'DECFLOAT_qNaN :: Num a => a +c'DECFLOAT_qNaN = #const DECFLOAT_qNaN + +c'DECFLOAT_sNaN :: Num a => a +c'DECFLOAT_sNaN = #const DECFLOAT_sNaN + +c'DECFLOAT_Inf :: Num a => a +c'DECFLOAT_Inf = #const DECFLOAT_Inf + +c'DECFLOAT_MinSp :: Num a => a +c'DECFLOAT_MinSp = #const DECFLOAT_MinSp + + +c'DECPPLUSALT :: Num a => a +c'DECPPLUSALT = #const DECPPLUSALT + +c'DECPMINUSALT :: Num a => a +c'DECPMINUSALT = #const DECPMINUSALT + +c'DECPPLUS :: Num a => a +c'DECPPLUS = #const DECPPLUS + +c'DECPMINUS :: Num a => a +c'DECPMINUS = #const DECPMINUS + +c'DECPPLUSALT2 :: Num a => a +c'DECPPLUSALT2 = #const DECPPLUSALT2 + +c'DECPUNSIGNED :: Num a => a +c'DECPUNSIGNED = #const DECPUNSIGNED + + -- Utilities -#ccall_unsafe decQuadToInt32 , Ptr -> Ptr -> -> IO -#ccall_unsafe decQuadToInt32Exact , Ptr -> Ptr -> -> IO +foreign import ccall unsafe "decQuadToInt32" unsafe'c'decQuadToInt32 + :: Ptr C'decQuad + -> Ptr C'decContext + -> C'rounding + -> IO C'int32_t -#ccall_unsafe decQuadFromInt32 , Ptr -> -> IO (Ptr ) -#ccall_unsafe decQuadFromPacked , Ptr -> -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadFromPackedChecked , Ptr -> -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadFromUInt32 , Ptr -> -> IO (Ptr ) -#ccall_unsafe decQuadFromString , Ptr -> CString -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadGetCoefficient , Ptr -> Ptr -> IO -#ccall_unsafe decQuadGetExponent , Ptr -> IO -#ccall_unsafe decQuadSetCoefficient , Ptr -> Ptr -> -> IO (Ptr ) -#ccall_unsafe decQuadSetExponent , Ptr -> Ptr -> -> IO (Ptr ) -#ccall_unsafe decQuadShow , Ptr -> CString -> IO () -#ccall_unsafe decQuadToEngString , Ptr -> CString -> IO CString -#ccall_unsafe decQuadToString , Ptr -> CString -> IO CString -#ccall_unsafe decQuadToUInt32 , Ptr -> Ptr -> -> IO -#ccall_unsafe decQuadToUInt32Exact , Ptr -> Ptr -> -> IO -#ccall_unsafe decQuadZero , Ptr -> IO (Ptr ) -#ccall_unsafe decQuadAbs , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadAdd , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadAnd , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadDivide , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadDivideInteger , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadFMA , Ptr -> Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadFromBCD , Ptr -> -> Ptr -> -> IO (Ptr ) -#ccall_unsafe decQuadInvert , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadLogB , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadMax , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadMaxMag , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadMin , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadMinMag , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadMinus , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadMultiply , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadNextMinus , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadNextPlus , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadNextToward , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadOr , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadPlus , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadQuantize , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadReduce , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadRemainder , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadRemainderNear , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadRotate , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadScaleB , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadShift , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadSubtract , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadToBCD , Ptr -> Ptr -> Ptr -> IO -#ccall_unsafe decQuadToIntegralValue , Ptr -> Ptr -> Ptr -> -> IO (Ptr ) -#ccall_unsafe decQuadToIntegralExact , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadXor , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +foreign import ccall unsafe "decQuadToInt32Exact" unsafe'c'decQuadToInt32Exact + :: Ptr C'decQuad + -> Ptr C'decContext + -> C'rounding + -> IO C'int32_t +foreign import ccall unsafe "decQuadFromInt32" unsafe'c'decQuadFromInt32 + :: Ptr C'decQuad + -> C'int32_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadFromPacked" unsafe'c'decQuadFromPacked + :: Ptr C'decQuad + -> C'int32_t + -> Ptr C'uint8_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadFromPackedChecked" unsafe'c'decQuadFromPackedChecked + :: Ptr C'decQuad + -> C'int32_t + -> Ptr C'uint8_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadFromUInt32" unsafe'c'decQuadFromUInt32 + :: Ptr C'decQuad + -> C'uint32_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadFromString" unsafe'c'decQuadFromString + :: Ptr C'decQuad + -> CString + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadGetCoefficient" unsafe'c'decQuadGetCoefficient + :: Ptr C'decQuad + -> Ptr C'uint8_t + -> IO C'int32_t + +foreign import ccall unsafe "decQuadGetExponent" unsafe'c'decQuadGetExponent + :: Ptr C'decQuad + -> IO C'int32_t + +foreign import ccall unsafe "decQuadSetCoefficient" unsafe'c'decQuadSetCoefficient + :: Ptr C'decQuad + -> Ptr C'uint8_t + -> C'int32_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadSetExponent" unsafe'c'decQuadSetExponent + :: Ptr C'decQuad + -> Ptr C'decContext + -> C'int32_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadShow" unsafe'c'decQuadShow + :: Ptr C'decQuad + -> CString + -> IO () + +foreign import ccall unsafe "decQuadToEngString" unsafe'c'decQuadToEngString + :: Ptr C'decQuad + -> CString + -> IO CString + +foreign import ccall unsafe "decQuadToString" unsafe'c'decQuadToString + :: Ptr C'decQuad + -> CString + -> IO CString + +foreign import ccall unsafe "decQuadToUInt32" unsafe'c'decQuadToUInt32 + :: Ptr C'decQuad + -> Ptr C'decContext + -> C'rounding + -> IO C'uint32_t + + +foreign import ccall unsafe "decQuadToUInt32Exact" unsafe'c'decQuadToUInt32Exact + :: Ptr C'decQuad + -> Ptr C'decContext + -> C'rounding + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadZero" unsafe'c'decQuadZero + :: Ptr C'decQuad + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadAbs" unsafe'c'decQuadAbs + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadAdd" unsafe'c'decQuadAdd + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadAnd" unsafe'c'decQuadAnd + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadDivide" unsafe'c'decQuadDivide + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadDivideInteger" unsafe'c'decQuadDivideInteger + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadFMA" unsafe'c'decQuadFMA + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadFromBCD" unsafe'c'decQuadFromBCD + :: Ptr C'decQuad + -> C'int32_t + -> Ptr C'uint8_t + -> C'int32_t + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadInvert" unsafe'c'decQuadInvert + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadLogB" unsafe'c'decQuadLogB + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadMax" unsafe'c'decQuadMax + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadMaxMag" unsafe'c'decQuadMaxMag + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadMin" unsafe'c'decQuadMin + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadMinMag" unsafe'c'decQuadMinMag + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadMinus" unsafe'c'decQuadMinus + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadMultiply" unsafe'c'decQuadMultiply + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadNextMinus" unsafe'c'decQuadNextMinus + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadNextPlus" unsafe'c'decQuadNextPlus + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadNextToward" unsafe'c'decQuadNextToward + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadOr" unsafe'c'decQuadOr + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadPlus" unsafe'c'decQuadPlus + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadQuantize" unsafe'c'decQuadQuantize + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadReduce" unsafe'c'decQuadReduce + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadRemainder" unsafe'c'decQuadRemainder + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadRemainderNear" unsafe'c'decQuadRemainderNear + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadRotate" unsafe'c'decQuadRotate + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadScaleB" unsafe'c'decQuadScaleB + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadShift" unsafe'c'decQuadShift + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadSubtract" unsafe'c'decQuadSubtract + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadToBCD" unsafe'c'decQuadToBCD + :: Ptr C'decQuad + -> Ptr C'int32_t + -> Ptr C'uint8_t + -> IO C'int32_t + +foreign import ccall unsafe "decQuadToIntegralValue" unsafe'c'decQuadToIntegralValue + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> C'rounding + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadToIntegralExact" unsafe'c'decQuadToIntegralExact + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadXor" unsafe'c'decQuadXor + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + -- Comparisons -#ccall_unsafe decQuadCompare , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCompareSignal , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCompareTotal , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCompareTotalMag , Ptr -> Ptr -> Ptr -> IO (Ptr ) +foreign import ccall unsafe "decQuadCompare" unsafe'c'decQuadCompare + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) +foreign import ccall unsafe "decQuadCompareSignal" unsafe'c'decQuadCompareSignal + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decContext + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadCompareTotal" unsafe'c'decQuadCompareTotal + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadCompareTotalMag" unsafe'c'decQuadCompareTotalMag + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + -- Copies -#ccall_unsafe decQuadCanonical , Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCopyAbs , Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCopyNegate , Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCopySign , Ptr -> Ptr -> Ptr -> IO (Ptr ) -#ccall_unsafe decQuadCopy , Ptr -> Ptr -> IO (Ptr ) +foreign import ccall unsafe "decQuadCanonical" unsafe'c'decQuadCanonical + :: Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) +foreign import ccall unsafe "decQuadCopyAbs" unsafe'c'decQuadCopyAbs + :: Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadCopyNegate" unsafe'c'decQuadCopyNegate + :: Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadCopySign" unsafe'c'decQuadCopySign + :: Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + +foreign import ccall unsafe "decQuadCopy" unsafe'c'decQuadCopy + :: Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + -- Non-computational -#ccall_unsafe decQuadClass , Ptr -> IO -#ccall_unsafe decQuadClassString , Ptr -> IO CString -#ccall_unsafe decQuadDigits , Ptr -> IO -#ccall_unsafe decQuadIsCanonical , Ptr -> IO -#ccall_unsafe decQuadIsFinite , Ptr -> IO -#ccall_unsafe decQuadIsInteger , Ptr -> IO -#ccall_unsafe decQuadIsLogical , Ptr -> IO -#ccall_unsafe decQuadIsInfinite , Ptr -> IO -#ccall_unsafe decQuadIsNaN , Ptr -> IO -#ccall_unsafe decQuadIsNegative , Ptr -> IO -#ccall_unsafe decQuadIsNormal , Ptr -> IO -#ccall_unsafe decQuadIsPositive , Ptr -> IO -#ccall_unsafe decQuadIsSignaling , Ptr -> IO -#ccall_unsafe decQuadIsSigned , Ptr -> IO -#ccall_unsafe decQuadIsSubnormal , Ptr -> IO -#ccall_unsafe decQuadIsZero , Ptr -> IO -#ccall_unsafe decQuadRadix , Ptr -> IO -#ccall_unsafe decQuadSameQuantum , Ptr -> Ptr -> IO -#ccall_unsafe decQuadVersion , IO CString +foreign import ccall unsafe "decQuadClass" unsafe'c'decQuadClass + :: Ptr C'decQuad + -> IO C'decClass + +foreign import ccall unsafe "decQuadClassString" unsafe'c'decQuadClassString + :: Ptr C'decQuad + -> IO CString + +foreign import ccall unsafe "decQuadDigits" unsafe'c'decQuadDigits + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsCanonical" unsafe'c'decQuadIsCanonical + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsFinite" unsafe'c'decQuadIsFinite + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsInteger" unsafe'c'decQuadIsInteger + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsLogical" unsafe'c'decQuadIsLogical + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsInfinite" unsafe'c'decQuadIsInfinite + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsNaN" unsafe'c'decQuadIsNaN + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsNegative" unsafe'c'decQuadIsNegative + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsNormal" unsafe'c'decQuadIsNormal + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsPositive" unsafe'c'decQuadIsPositive + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsSignaling" unsafe'c'decQuadIsSignaling + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsSigned" unsafe'c'decQuadIsSigned + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsSubnormal" unsafe'c'decQuadIsSubnormal + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadIsZero" unsafe'c'decQuadIsZero + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadRadix" unsafe'c'decQuadRadix + :: Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadSameQuantum" unsafe'c'decQuadSameQuantum + :: Ptr C'decQuad + -> Ptr C'decQuad + -> IO C'uint32_t + +foreign import ccall unsafe "decQuadVersion" unsafe'c'decQuadVersion + :: IO CString diff --git a/lib/Data/Deka/Internal.hs b/lib/Data/Deka/Internal.hs --- a/lib/Data/Deka/Internal.hs +++ b/lib/Data/Deka/Internal.hs @@ -14,6 +14,48 @@ import Control.Monad import System.IO.Unsafe (unsafePerformIO) +-- # Helpers + +type Boolean + = Ptr C'decQuad + -> IO C'uint32_t + +boolean + :: Boolean + -> Quad + -> Bool +boolean f d = unsafePerformIO $ + withForeignPtr (unQuad d) $ \pD -> + f pD >>= \r -> + return $ case r of + 1 -> True + 0 -> False + _ -> error "boolean: bad return value" + +-- | Creates a new Quad. Uninitialized, so don't export this +-- function. +newQuad :: IO Quad +newQuad = fmap Quad mallocForeignPtr + +type BinaryCtxFree + = Ptr C'decQuad + -> Ptr C'decQuad + -> Ptr C'decQuad + -> IO (Ptr C'decQuad) + +binaryCtxFree + :: BinaryCtxFree + -> Quad + -> Quad + -> Quad +binaryCtxFree f x y = unsafePerformIO $ + newQuad >>= \r -> + withForeignPtr (unQuad r) $ \pR -> + withForeignPtr (unQuad x) $ \pX -> + withForeignPtr (unQuad y) $ \pY -> + f pR pX pY >> + return r + -- | The Ctx monad -- -- The General Decimal Arithmetic specification states that most @@ -47,6 +89,21 @@ -- particular 'Quad'. newtype Quad = Quad { unQuad :: ForeignPtr C'decQuad } +-- | The Eq instance depends on an IEEE 754 total ordering. In +-- particular, note that, for example, @7.5@ is not equal to @7.50@. +-- See +-- +-- + +instance Eq Quad where + x == y = case compareTotal x y of + EQ -> True + _ -> False + +-- | Like the 'Eq' instance, this uses an IEEE 754 total ordering. +instance Ord Quad where + compare = compareTotal + -- | The Show instance uses 'toByteString'. instance Show Quad where show = BS8.unpack . toByteString @@ -75,4 +132,32 @@ allocaBytes c'DECQUAD_String $ \pS -> f pD pS >> BS8.packCString pS + +-- | Compares using an IEEE 754 total ordering, which takes into +-- account the exponent. IEEE 754 says that this function might +-- return different results depending upon whether the operands are +-- canonical; 'Quad' are always canonical so you don't need to worry +-- about that here. +compareTotal :: Quad -> Quad -> Ordering +compareTotal x y + | isNegative c = LT + | isZero c = EQ + | isPositive c = GT + | otherwise = error "compareTotal: unknown result" + where + c = binaryCtxFree unsafe'c'decQuadCompareTotal x y + +-- # Tests + +-- | True only if @x@ is less than zero and is not an NaN. +isNegative :: Quad -> Bool +isNegative = boolean unsafe'c'decQuadIsNegative + +-- | True only if @x@ is a zero. +isZero :: Quad -> Bool +isZero = boolean unsafe'c'decQuadIsZero + +-- | True only if @x@ is greater than zero and is not an NaN. +isPositive :: Quad -> Bool +isPositive = boolean unsafe'c'decQuadIsPositive diff --git a/lib/Data/Deka/Quad.hs b/lib/Data/Deka/Quad.hs --- a/lib/Data/Deka/Quad.hs +++ b/lib/Data/Deka/Quad.hs @@ -27,7 +27,6 @@ ( -- * Quad Quad - , QuadT(..) -- * Rounding -- | For more on the rounding algorithms, see @@ -95,6 +94,8 @@ , toEngByteString -- * Converting to and from integers + , C'int32_t + , C'uint32_t , fromInt32 , fromUInt32 , toInt32 @@ -556,34 +557,8 @@ | otherwise = error "decClass show: invalid value" --- | A Quad is not a member of 'Eq' or 'Ord' because the semantics --- of the 'compare' function do not easily allow for this. However, --- if you want to compare using a total ordering, you can wrap your --- 'Quad' in 'QuadT'. For more on what a total ordering is, see --- --- --- --- and look under @Which is larger? 7.5 or 7.500?@. As this --- title suggests, when using a total ordering, @7.5@ and @7.500@ --- are not equal. - -newtype QuadT = QuadT { unQuadT :: Quad } - deriving Show - -instance Eq QuadT where - QuadT x == QuadT y = compareTotal x y == EQ - -instance Ord QuadT where - compare (QuadT x) (QuadT y) = compareTotal x y - - -- # Helpers. Do not export these. --- | Creates a new Quad. Uninitialized, so don't export this --- function. -newQuad :: IO Quad -newQuad = fmap Quad mallocForeignPtr - type Unary = Ptr C'decQuad -> Ptr C'decQuad @@ -621,25 +596,6 @@ f pR pX pY pC >> return r -type BinaryCtxFree - = Ptr C'decQuad - -> Ptr C'decQuad - -> Ptr C'decQuad - -> IO (Ptr C'decQuad) - -binaryCtxFree - :: BinaryCtxFree - -> Quad - -> Quad - -> Quad -binaryCtxFree f x y = unsafePerformIO $ - newQuad >>= \r -> - withForeignPtr (unQuad r) $ \pR -> - withForeignPtr (unQuad x) $ \pX -> - withForeignPtr (unQuad y) $ \pY -> - f pR pX pY >> - return r - type UnaryGet a = Ptr C'decQuad -> IO a @@ -674,22 +630,6 @@ f pR pX pY pZ pC >> return r -type Boolean - = Ptr C'decQuad - -> IO C'uint32_t - -boolean - :: Boolean - -> Quad - -> Bool -boolean f d = unsafePerformIO $ - withForeignPtr (unQuad d) $ \pD -> - f pD >>= \r -> - return $ case r of - 1 -> True - 0 -> False - _ -> error "boolean: bad return value" - -- MkString and mkString - moved to Internal so that toByteString -- can use them @@ -767,20 +707,6 @@ compareSignal :: Quad -> Quad -> Ctx Quad compareSignal = binary unsafe'c'decQuadCompareSignal --- | Compares using an IEEE 754 total ordering, which takes into --- account the exponent. IEEE 754 says that this function might --- return different results depending upon whether the operands are --- canonical; 'Quad' are always canonical so you don't need to worry --- about that here. -compareTotal :: Quad -> Quad -> Ordering -compareTotal x y = - let c = binaryCtxFree unsafe'c'decQuadCompareTotal x y - r | isNegative c = LT - | isZero c = EQ - | isPositive c = GT - | otherwise = error "compareTotal: unknown result" - in r - -- | Same as 'compareTotal' but compares the absolute value of the -- two arguments. compareTotalMag :: Quad -> Quad -> Ordering @@ -902,18 +828,10 @@ isNaN :: Quad -> Bool isNaN = boolean unsafe'c'decQuadIsNaN --- | True only if @x@ is less than zero and is not an NaN. -isNegative :: Quad -> Bool -isNegative = boolean unsafe'c'decQuadIsNegative - -- | True only if @x@ is finite, non-zero, and not subnormal. isNormal :: Quad -> Bool isNormal = boolean unsafe'c'decQuadIsNormal --- | True only if @x@ is greater than zero and is not an NaN. -isPositive :: Quad -> Bool -isPositive = boolean unsafe'c'decQuadIsPositive - -- | True only if @x@ is a signaling NaN. isSignaling :: Quad -> Bool isSignaling = boolean unsafe'c'decQuadIsSignaling @@ -927,10 +845,6 @@ -- with a magnitude less than 10 ^ emin. isSubnormal :: Quad -> Bool isSubnormal = boolean unsafe'c'decQuadIsSubnormal - --- | True only if @x@ is a zero. -isZero :: Quad -> Bool -isZero = boolean unsafe'c'decQuadIsZero -- | @logB x@ Returns the adjusted exponent of x, according to IEEE -- 754 rules. If @x@ is infinite, returns +Infinity. If @x@ is