pass all assert_return tests

src/Language/Wasm/FloatUtils.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Language.Wasm.FloatUtils (
+    wordToFloat,
+    floatToWord,
+    wordToDouble,
+    doubleToWord,
+    makeNaN,
+    doubleToFloat
+) where
+
+import Data.Word (Word32, Word64)
+import Data.Bits ((.|.), (.&.), shiftR)
+import Data.Array.ST (newArray, readArray, MArray, STUArray)
+import Data.Array.Unsafe (castSTUArray)
+import GHC.ST (runST, ST)
+
+-- brough from https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa
+wordToFloat :: Word32 -> Float
+wordToFloat x = runST (cast x)
+
+floatToWord :: Float -> Word32
+floatToWord x = runST (cast x)
+
+wordToDouble :: Word64 -> Double
+wordToDouble x = runST (cast x)
+
+doubleToWord :: Double -> Word64
+doubleToWord x = runST (cast x)
+
+{-# INLINE cast #-}
+cast :: (MArray (STUArray s) a (ST s),
+         MArray (STUArray s) b (ST s)) => a -> ST s b
+cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0
+
+makeNaN :: Word64 -> Double
+makeNaN w = wordToDouble $ 0x7FF0000000000000 .|. (0x000FFFFFFFFFFFFF .&. w)
+
+doubleToFloat :: Double -> Float
+doubleToFloat d =
+    let w = doubleToWord d in
+    if 0x7FF0000000000000 == (w .&. 0x7FF0000000000000) && (w .&. 0x0007FFFFFFFFFFFF) /= 0
+    then wordToFloat $ fromIntegral $ ((0x8000000000000000 .&. w) `shiftR` 32) .|. 0x7F800000 .|. (0x7FFFFF .&. w)
+    else realToFrac d

src/Language/Wasm/Interpreter.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Language.Wasm.Interpreter (
@@ -49,14 +48,18 @@ import Data.Bits (
         countLeadingZeros,
         countTrailingZeros
     )
-import Data.Array.ST (newArray, readArray, MArray, STUArray)
-import Data.Array.Unsafe (castSTUArray)
-import GHC.ST (runST, ST)
 import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE)
 
 import Debug.Trace as Debug
 
 import Language.Wasm.Structure as Struct
+import Language.Wasm.FloatUtils (
+        wordToFloat,
+        floatToWord,
+        wordToDouble,
+        doubleToWord,
+        makeNaN
+    )
 
 data Value =
     VI32 Word32
@@ -87,24 +90,6 @@ asWord64 i
     | i >= 0 = fromIntegral i
     | otherwise = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1
 
--- brough from https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa
-wordToFloat :: Word32 -> Float
-wordToFloat x = runST (cast x)
-
-floatToWord :: Float -> Word32
-floatToWord x = runST (cast x)
-
-wordToDouble :: Word64 -> Double
-wordToDouble x = runST (cast x)
-
-doubleToWord :: Double -> Word64
-doubleToWord x = runST (cast x)
-
-{-# INLINE cast #-}
-cast :: (MArray (STUArray s) a (ST s),
-         MArray (STUArray s) b (ST s)) => a -> ST s b
-cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0
-
 nearest :: (IEEE a) => a -> a
 nearest f
     | f >= 0 && f <= 0.5 = copySign 0 f

src/Language/Wasm/Lexer.x

@@ -1,4 +1,6 @@
 {
+{-# LANGUAGE FlexibleContexts #-}
+
 module Language.Wasm.Lexer (
     Lexeme(..),
     Token(..),
@@ -11,7 +13,10 @@ import qualified Data.Char as Char
 import qualified Data.ByteString.Lazy.UTF8 as LBSUtf8
 import Control.Applicative ((<$>))
 import Control.Monad (when)
-import Numeric.IEEE (infinity, nan, nanWithPayload)
+import Numeric.IEEE (infinity, nan)
+import Language.Wasm.FloatUtils (makeNaN)
+
+import qualified Debug.Trace as Debug
 
 }
 
@@ -124,7 +129,7 @@ parseNanSigned :: AlexAction Lexeme
 parseNanSigned = token $ \(pos, _, s, _) len -> 
     let (sign, slen) = parseSign s in
     let num = readHexFromPrefix (len - 6 - slen) $ LBSUtf8.drop (6 + slen) s in
-    Lexeme pos $ TFloatLit $ sign $ nanWithPayload $ fromIntegral num
+    Lexeme pos $ TFloatLit $ sign $ makeNaN $ fromIntegral num
 
 parseDecimalSignedInt :: AlexAction Lexeme
 parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
@@ -134,8 +139,9 @@ parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
 
 parseDecFloat :: AlexAction Lexeme
 parseDecFloat = token $ \(pos, _, s, _) len ->
-    let str = filter (/= '_') $ takeChars len s in
+    let (sign, slen) = parseSign s in
-    Lexeme pos $ TFloatLit $ read str
+    let str = filter (/= '_') $ takeChars (len - slen) $ LBSUtf8.drop slen s in
+    Lexeme pos $ TFloatLit $ sign $ readDecFloat str
 
 parseHexFloat :: AlexAction Lexeme
 parseHexFloat = token $ \(pos, _, s, _) len ->
@@ -349,6 +355,13 @@ readHexFloat str =
             let len = length val in
             sum $ zipWith (\i c -> readHexFromChar c / (16 ^ i)) [1..] val
 
+readDecFloat :: String -> Double
+readDecFloat str =
+    let (val, exp) = splitBy (\c -> c == 'E' || c == 'e') str in
+    let (int, frac) = splitBy (== '.') val in
+    let nullIfEmpty str = if null str then "0" else str in
+    read $ nullIfEmpty int ++ "." ++ nullIfEmpty frac ++ "e" ++ nullIfEmpty exp
+
 scanner :: LBS.ByteString -> Either String [Lexeme]
 scanner str = runAlex str loop
     where

src/Language/Wasm/Parser.y

@@ -72,6 +72,7 @@ import Numeric.Natural (Natural)
 import Data.Word (Word32, Word64)
 import Data.Bits ((.|.))
 import Numeric.IEEE (infinity, nan)
+import Language.Wasm.FloatUtils (doubleToFloat)
 
 import Language.Wasm.Lexer (
         Token (
@@ -1103,7 +1104,7 @@ asInt64 val
     | otherwise = Nothing
 
 asFloat32 :: Double -> Float
-asFloat32 v = realToFrac v
+asFloat32 v = doubleToFloat v
 
 asOffset :: LBS.ByteString -> Maybe Natural
 asOffset str = do

tests/Test.hs

@@ -34,7 +34,7 @@ compile file = do
 main :: IO ()
 main = do
   files <- Directory.listDirectory "tests/samples"
-  -- let files = ["conversions.wast"]
+  -- let files = ["float_literals.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     content <- LBS.readFile $ "tests/samples/" ++ file
     let Right script = Parser.parseScript <$> Lexer.scanner content

wasm.cabal

@@ -43,6 +43,7 @@ library
       Language.Wasm.Validate
       Language.Wasm.Interpreter
       Language.Wasm.Script
+      Language.Wasm.FloatUtils
       Language.Wasm
   other-modules:
       Paths_wasm