msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

check if optional labels match for block instructions

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-16 15:37:28 -07:00
parent 035ffe05da
commit 6c4183c930
3 changed files with 110 additions and 68 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Lexer.x
+10 -10
View File
@@ -124,31 +124,31 @@ parseHexalSignedInt :: AlexAction Lexeme
parseHexalSignedInt = token $ \(pos, _, s, _) len ->
let (sign, slen) = parseSign s in
let num = readHexFromPrefix (len - 2 - slen) $ LBSUtf8.drop (2 + slen) s in
Lexeme pos $ TIntLit $ sign num
Lexeme (Just pos) $ TIntLit $ sign num
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 $ makeNaN $ fromIntegral num
Lexeme (Just pos) $ TFloatLit $ sign $ makeNaN $ fromIntegral num
parseDecimalSignedInt :: AlexAction Lexeme
parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
let (sign, slen) = parseSign s in
let num = readDecFromPrefix (len - slen) $ LBSUtf8.drop slen s in
Lexeme pos $ TIntLit $ sign num
Lexeme (Just pos) $ TIntLit $ sign num
parseDecFloat :: AlexAction Lexeme
parseDecFloat = token $ \(pos, _, s, _) len ->
let (sign, slen) = parseSign s in
let str = filter (/= '_') $ takeChars (len - slen) $ LBSUtf8.drop slen s in
Lexeme pos $ TFloatLit $ sign $ readDecFloat str
Lexeme (Just pos) $ TFloatLit $ sign $ readDecFloat str
parseHexFloat :: AlexAction Lexeme
parseHexFloat = token $ \(pos, _, s, _) len ->
let (sign, slen) = parseSign s in
let ('0' : 'x' : str) = filter (/= '_') $ takeChars (len - slen) $ LBS.drop slen s in
Lexeme pos $ TFloatLit $ sign $ readHexFloat str
Lexeme (Just pos) $ TFloatLit $ sign $ readHexFloat str
startBlockComment :: AlexAction Lexeme
startBlockComment _inp _len = do
@@ -212,13 +212,13 @@ endStringLiteral (pos, _, _inp, _) _len = do
setLexerStringFlag False
str <- LBS.pack . reverse <$> getLexerStringValue
setLexerStringValue []
return $ Lexeme pos $ TStringLit str
return $ Lexeme (Just pos) $ TStringLit str
tokenStr :: (LBS.ByteString -> Token) -> AlexAction Lexeme
tokenStr f = token $ \(pos, _, s, _) len -> (Lexeme pos $ f $ LBS.take len s)
tokenStr f = token $ \(pos, _, s, _) len -> (Lexeme (Just pos) $ f $ LBS.take len s)
constToken :: Token -> AlexAction Lexeme
constToken tok = token $ \(pos, _, _, _) _len -> (Lexeme pos tok)
constToken tok = token $ \(pos, _, _, _) _len -> (Lexeme (Just pos) tok)
{- End Lexem Helpers -}
@@ -233,7 +233,7 @@ data Token = TKeyword LBS.ByteString
| EOF
deriving (Show, Eq)
data Lexeme = Lexeme { pos :: AlexPosn, tok :: Token } deriving (Show, Eq)
data Lexeme = Lexeme { pos :: Maybe AlexPosn, tok :: Token } deriving (Show, Eq)
data AlexUserState = AlexUserState {
lexerCommentDepth :: Int,
@@ -280,7 +280,7 @@ addCharCodeToLexerStringValue c = Alex $ \s ->
let ust = alex_ust s in
Right (s{ alex_ust = ust{ lexerStringValue = c : lexerStringValue ust } }, ())
alexEOF = return $ Lexeme (error "Trying to read EOF position") EOF
alexEOF = return $ Lexeme Nothing EOF
takeChars :: Int64 -> LBS.ByteString -> String
takeChars n str = reverse $ go n str []
src/Language/Wasm/Parser.y
+99 -57
View File
@@ -66,7 +66,7 @@ import qualified Data.Text.Lazy.Read as TLRead
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSChar8
import Data.Maybe (fromMaybe, fromJust)
import Data.Maybe (fromMaybe, fromJust, isNothing)
import Data.List (foldl', findIndex, find)
import Control.Monad (guard)
@@ -323,10 +323,7 @@ import Debug.Trace as Debug
'output' { Lexeme _ (TKeyword "output") }
-- script extension end
id { Lexeme _ (TId $$) }
u32 { Lexeme _ (TIntLit (asUInt32 -> Just $$)) }
i32 { Lexeme _ (TIntLit (asInt32 -> Just $$)) }
i64 { Lexeme _ (TIntLit (asInt64 -> Just $$)) }
unrestricted_int { Lexeme _ (TIntLit $$) }
int { Lexeme _ (TIntLit $$) }
f64 { Lexeme _ (TFloatLit $$) }
offset { Lexeme _ (TKeyword (asOffset -> Just $$)) }
align { Lexeme _ (TKeyword (asAlign -> Just $$)) }
@@ -383,26 +380,32 @@ memidx :: { MemoryIndex }
| ident { Named $1 }
int32 :: { Integer }
: u32 { fromIntegral $1 }
| i32 { $1 }
: int {%
if $1 >= -(2^31) && $1 < 2^32
then Right $1
else Left ("Int literal value is out of signed int32 boundaries: " ++ show $1)
}
u32 :: { Natural }
: int {%
if $1 >= 0 && $1 < 2^32
then Right (fromIntegral $1)
else Left ("Int literal value is out of unsigned int32 boundaries: " ++ show $1)
}
int64 :: { Integer }
: u32 { fromIntegral $1 }
| i32 { $1 }
| i64 { $1 }
: int {%
if $1 >= -(2^63) && $1 < 2^64
then Right $1
else Left ("Int literal value is out of signed int64 boundaries: " ++ show $1)
}
float32 :: { Float }
: u32 { fromIntegral $1 }
| i32 { fromIntegral $1 }
| i64 { fromIntegral $1 }
| unrestricted_int { fromIntegral $1 }
: int { fromIntegral $1 }
| f64 { asFloat32 $1 }
float64 :: { Double }
: u32 { fromIntegral $1 }
| i32 { fromIntegral $1 }
| i64 { fromIntegral $1 }
| unrestricted_int { fromIntegral $1 }
: int { fromIntegral $1 }
| f64 { $1 }
plaininstr :: { PlainInstr }
@@ -644,56 +647,104 @@ instruction :: { [Instruction] }
raw_instr :: { [Instruction] }
: plaininstr { [PlainInstr $1] }
| 'call_indirect' raw_call_indirect { $2 }
| 'block' opt(ident) raw_block { [$3 $2] }
| 'loop' opt(ident) raw_loop { [$3 $2] }
| 'if' opt(ident) raw_if_result { $3 $2 }
| 'block' opt(ident) raw_block {% (: []) `fmap` $3 $2 }
| 'loop' opt(ident) raw_loop {% (: []) `fmap` $3 $2 }
| 'if' opt(ident) raw_if_result {% $3 $2 }
raw_block :: { Maybe Ident -> Instruction }
: 'end' opt(ident) { \ident -> BlockInstr ident [] [] }
| raw_instr list(instruction) 'end' opt(ident) { \ident -> BlockInstr ident [] ($1 ++ concat $2) }
raw_block :: { Maybe Ident -> Either String Instruction }
: 'end' opt(ident) {
\ident ->
if ident == $2 || isNothing $2
then Right $ BlockInstr ident [] []
else Left "Block labels have to match"
}
| raw_instr list(instruction) 'end' opt(ident) {
\ident ->
if ident == $4 || isNothing $4
then Right $ BlockInstr ident [] ($1 ++ concat $2)
else Left "Block labels have to match"
}
| '(' raw_block1 { $2 }
raw_block1 :: { Maybe Ident -> Instruction }
raw_block1 :: { Maybe Ident -> Either String Instruction }
: 'result' valtype ')' list(instruction) 'end' opt(ident) {
\ident -> BlockInstr ident [$2] (concat $4)
\ident ->
if ident == $6 || isNothing $6
then Right $ BlockInstr ident [$2] (concat $4)
else Left "Block labels have to match"
}
| foldedinstr1 list(instruction) 'end' opt(ident) {
\ident -> BlockInstr ident [] ($1 ++ concat $2)
\ident ->
if ident == $4 || isNothing $4
then Right $ BlockInstr ident [] ($1 ++ concat $2)
else Left "Block labels have to match"
}
raw_loop :: { Maybe Ident -> Instruction }
: 'end' opt(ident) { \ident -> LoopInstr ident [] [] }
raw_loop :: { Maybe Ident -> Either String Instruction }
: 'end' opt(ident) {
\ident ->
if ident == $2 || isNothing $2
then Right $ LoopInstr ident [] []
else Left "Loop labels have to match"
}
| raw_instr list(instruction) 'end' opt(ident) {
\ident -> LoopInstr ident [] ($1 ++ concat $2)
\ident ->
if ident == $4 || isNothing $4
then Right $ LoopInstr ident [] ($1 ++ concat $2)
else Left "Loop labels have to match"
}
| '(' raw_loop1 { $2 }
raw_loop1 :: { Maybe Ident -> Instruction }
raw_loop1 :: { Maybe Ident -> Either String Instruction }
: 'result' valtype ')' list(instruction) 'end' opt(ident) {
\ident -> LoopInstr ident [$2] (concat $4)
\ident ->
if ident == $6 || isNothing $6
then Right $ LoopInstr ident [$2] (concat $4)
else Left "Loop labels have to match"
}
| foldedinstr1 list(instruction) 'end' opt(ident) {
\ident -> LoopInstr ident [] ($1 ++ concat $2)
\ident ->
if ident == $4 || isNothing $4
then Right $ LoopInstr ident [] ($1 ++ concat $2)
else Left "Loop labels have to match"
}
raw_if_result :: { Maybe Ident -> [Instruction] }
: raw_else { \ident -> [IfInstr ident [] [] $1] }
raw_if_result :: { Maybe Ident -> Either String [Instruction] }
: raw_else {
\ident ->
if ident == (snd $1) || isNothing (snd $1)
then Right [IfInstr ident [] [] $ fst $1]
else Left "If labels have to match"
}
| raw_instr list(instruction) raw_else {
\ident -> [IfInstr ident [] ($1 ++ concat $2) $3]
\ident ->
if ident == (snd $3) || isNothing (snd $3)
then Right [IfInstr ident [] ($1 ++ concat $2) $ fst $3]
else Left "If labels have to match"
}
| '(' raw_if_result1 { $2 }
raw_if_result1 :: { Maybe Ident -> [Instruction] }
raw_if_result1 :: { Maybe Ident -> Either String [Instruction] }
: 'result' valtype ')' list(instruction) raw_else {
\ident -> [IfInstr ident [$2] (concat $4) $5]
\ident ->
if ident == (snd $5) || isNothing (snd $5)
then Right [IfInstr ident [$2] (concat $4) $ fst $5]
else Left "If labels have to match"
}
| foldedinstr1 list(instruction) raw_else {
\ident -> [IfInstr ident [] ($1 ++ concat $2) $3]
\ident ->
if ident == (snd $3) || isNothing (snd $3)
then Right [IfInstr ident [] ($1 ++ concat $2) $ fst $3]
else Left "If labels have to match"
}
raw_else :: { [Instruction] }
: 'end' opt(ident) { [] }
| 'else' opt(ident) list(instruction) 'end' opt(ident) { concat $3 }
raw_else :: { ([Instruction], Maybe Ident) }
: 'end' opt(ident) { ([], $2) }
| 'else' opt(ident) list(instruction) 'end' opt(ident) {%
if matchIdents $2 $5
then Right (concat $3, if isNothing $2 then $5 else $2)
else Left "If labels have to match"
}
raw_call_indirect :: { [Instruction] }
: '(' raw_call_indirect_typeuse { (PlainInstr $ CallIndirect $ fst $2) : snd $2 }
@@ -1100,20 +1151,10 @@ prependFuncResults prep f@(Function { funcType = AnonimousTypeUse ft }) =
mergeFuncType :: FuncType -> FuncType -> FuncType
mergeFuncType (FuncType lps lrs) (FuncType rps rrs) = FuncType (lps ++ rps) (lrs ++ rrs)
asUInt32 :: Integer -> Maybe Natural
asUInt32 val
| val >= 0, val < 2 ^ 32 = Just $ fromIntegral val
| otherwise = Nothing
asInt32 :: Integer -> Maybe Integer
asInt32 val
| val >= -2 ^ 31, val < 2 ^ 32 = Just $ fromIntegral val
| otherwise = Nothing
asInt64 :: Integer -> Maybe Integer
asInt64 val
| val >= -2 ^ 63, val < 2 ^ 64 = Just $ fromIntegral val
| otherwise = Nothing
matchIdents :: Maybe Ident -> Maybe Ident -> Bool
matchIdents Nothing _ = True
matchIdents _ Nothing = True
matchIdents a b = a == b
asFloat32 :: Double -> Float
asFloat32 v = doubleToFloat v
@@ -1372,7 +1413,8 @@ data ModuleField =
deriving(Show, Eq, Generic, NFData)
happyError (Lexeme _ EOF : []) = Left $ "Error occuried during parsing phase at the end of file"
happyError (Lexeme (AlexPn abs line col) tok : tokens) = Left $
happyError (Lexeme Nothing tok : tokens) = Left $ "Error occuried during parsing phase at the end of file"
happyError (Lexeme (Just (AlexPn abs line col)) tok : tokens) = Left $
"Error occuried during parsing phase. " ++
"Line " ++ show line ++ ", " ++
"Column " ++ show col ++ ", " ++
tests/Test.hs
+1 -1
View File
@@ -34,7 +34,7 @@ compile file = do
main :: IO ()
main = do
files <- Directory.listDirectory "tests/samples"
-- let files = ["utf8-invalid-encoding.wast"]
-- let files = ["int_literals.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
content <- LBS.readFile $ "tests/samples/" ++ file
let Right script = Lexer.scanner content >>= Parser.parseScript