added line position for failed asserts and implemented mutable globals import/export proposal
This commit is contained in:
@@ -19,7 +19,8 @@ module Language.Wasm.Interpreter (
|
|||||||
emptyStore,
|
emptyStore,
|
||||||
emptyImports,
|
emptyImports,
|
||||||
makeHostModule,
|
makeHostModule,
|
||||||
makeMutGlobal
|
makeMutGlobal,
|
||||||
|
makeConstGlobal
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
@@ -177,6 +178,9 @@ data GlobalInstance = GIConst ValueType Value | GIMut ValueType (IORef Value)
|
|||||||
makeMutGlobal :: Value -> IO GlobalInstance
|
makeMutGlobal :: Value -> IO GlobalInstance
|
||||||
makeMutGlobal val = GIMut (getValueType val) <$> newIORef val
|
makeMutGlobal val = GIMut (getValueType val) <$> newIORef val
|
||||||
|
|
||||||
|
makeConstGlobal :: Value -> GlobalInstance
|
||||||
|
makeConstGlobal val = GIConst (getValueType val) val
|
||||||
|
|
||||||
getValueType :: Value -> ValueType
|
getValueType :: Value -> ValueType
|
||||||
getValueType (VI32 _) = I32
|
getValueType (VI32 _) = I32
|
||||||
getValueType (VI64 _) = I64
|
getValueType (VI64 _) = I64
|
||||||
@@ -364,13 +368,11 @@ calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, gl
|
|||||||
ExternGlobal globalAddr -> return globalAddr
|
ExternGlobal globalAddr -> return globalAddr
|
||||||
_ -> err
|
_ -> err
|
||||||
let globalInst = gs ! globalAddr
|
let globalInst = gs ! globalAddr
|
||||||
let vt = case globalType of
|
let typesMatch = case (globalType, globalInst) of
|
||||||
Const vt -> vt
|
(Const vt, GIConst vt' _) -> vt == vt'
|
||||||
Mut vt -> vt
|
(Mut vt, GIMut vt' _) -> vt == vt'
|
||||||
let vt' = case globalInst of
|
_ -> False
|
||||||
GIConst vt _ -> vt
|
if typesMatch then return idx else err
|
||||||
GIMut vt _ -> vt
|
|
||||||
if vt == vt' then return idx else err
|
|
||||||
checkImportType imp@(Import _ _ (ImportMemory limit)) = do
|
checkImportType imp@(Import _ _ (ImportMemory limit)) = do
|
||||||
idx <- getImpIdx imp
|
idx <- getImpIdx imp
|
||||||
memAddr <- case idx of
|
memAddr <- case idx of
|
||||||
|
|||||||
+50
-27
@@ -313,14 +313,14 @@ import Language.Wasm.Lexer (
|
|||||||
'register' { Lexeme _ (TKeyword "register") }
|
'register' { Lexeme _ (TKeyword "register") }
|
||||||
'invoke' { Lexeme _ (TKeyword "invoke") }
|
'invoke' { Lexeme _ (TKeyword "invoke") }
|
||||||
'get' { Lexeme _ (TKeyword "get") }
|
'get' { Lexeme _ (TKeyword "get") }
|
||||||
'assert_return' { Lexeme _ (TKeyword "assert_return") }
|
'assert_return' { Lexeme $$ (TKeyword "assert_return") }
|
||||||
'assert_return_canonical_nan' { Lexeme _ (TKeyword "assert_return_canonical_nan") }
|
'assert_return_canonical_nan' { Lexeme $$ (TKeyword "assert_return_canonical_nan") }
|
||||||
'assert_return_arithmetic_nan' { Lexeme _ (TKeyword "assert_return_arithmetic_nan") }
|
'assert_return_arithmetic_nan' { Lexeme $$ (TKeyword "assert_return_arithmetic_nan") }
|
||||||
'assert_trap' { Lexeme _ (TKeyword "assert_trap") }
|
'assert_trap' { Lexeme $$ (TKeyword "assert_trap") }
|
||||||
'assert_malformed' { Lexeme _ (TKeyword "assert_malformed") }
|
'assert_malformed' { Lexeme $$ (TKeyword "assert_malformed") }
|
||||||
'assert_invalid' { Lexeme _ (TKeyword "assert_invalid") }
|
'assert_invalid' { Lexeme $$ (TKeyword "assert_invalid") }
|
||||||
'assert_unlinkable' { Lexeme _ (TKeyword "assert_unlinkable") }
|
'assert_unlinkable' { Lexeme $$ (TKeyword "assert_unlinkable") }
|
||||||
'assert_exhaustion' { Lexeme _ (TKeyword "assert_exhaustion") }
|
'assert_exhaustion' { Lexeme $$ (TKeyword "assert_exhaustion") }
|
||||||
'script' { Lexeme _ (TKeyword "script") }
|
'script' { Lexeme _ (TKeyword "script") }
|
||||||
'input' { Lexeme _ (TKeyword "input") }
|
'input' { Lexeme _ (TKeyword "input") }
|
||||||
'output' { Lexeme _ (TKeyword "output") }
|
'output' { Lexeme _ (TKeyword "output") }
|
||||||
@@ -1104,7 +1104,7 @@ command1 :: { Command }
|
|||||||
: module1 { ModuleDef $1 }
|
: module1 { ModuleDef $1 }
|
||||||
| 'register' string opt(ident) ')' { Register $2 $3 }
|
| 'register' string opt(ident) ')' { Register $2 $3 }
|
||||||
| action1 { Action $1 }
|
| action1 { Action $1 }
|
||||||
| assertion1 { Assertion $1 }
|
| assertion1 { let (Just (AlexPn _ line _), a) = $1 in Assertion line a }
|
||||||
| meta1 { Meta $1 }
|
| meta1 { Meta $1 }
|
||||||
|
|
||||||
module1 :: { ModuleDef }
|
module1 :: { ModuleDef }
|
||||||
@@ -1117,15 +1117,15 @@ action1 :: { Action }
|
|||||||
: 'invoke' opt(ident) string list(folded_instr) ')' { Invoke $2 $3 (map (map constInstructionToValue) $4) }
|
: 'invoke' opt(ident) string list(folded_instr) ')' { Invoke $2 $3 (map (map constInstructionToValue) $4) }
|
||||||
| 'get' opt(ident) string ')' { Get $2 $3 }
|
| 'get' opt(ident) string ')' { Get $2 $3 }
|
||||||
|
|
||||||
assertion1 :: { Assertion }
|
assertion1 :: { (Maybe AlexPosn, Assertion) }
|
||||||
: 'assert_return' '(' action1 list(folded_instr) ')' { AssertReturn $3 (map (map constInstructionToValue) $4) }
|
: 'assert_return' '(' action1 list(folded_instr) ')' { ($1, AssertReturn $3 (map (map constInstructionToValue) $4)) }
|
||||||
| 'assert_return_canonical_nan' '(' action1 ')' { AssertReturnCanonicalNaN $3 }
|
| 'assert_return_canonical_nan' '(' action1 ')' { ($1, AssertReturnCanonicalNaN $3) }
|
||||||
| 'assert_return_arithmetic_nan' '(' action1 ')' { AssertReturnArithmeticNaN $3 }
|
| 'assert_return_arithmetic_nan' '(' action1 ')' { ($1, AssertReturnArithmeticNaN $3) }
|
||||||
| 'assert_trap' '(' assertion_trap string ')' { AssertTrap $3 $4 }
|
| 'assert_trap' '(' assertion_trap string ')' { ($1, AssertTrap $3 $4) }
|
||||||
| 'assert_malformed' '(' module1 string ')' { AssertMalformed $3 $4 }
|
| 'assert_malformed' '(' module1 string ')' { ($1, AssertMalformed $3 $4) }
|
||||||
| 'assert_invalid' '(' module1 string ')' { AssertInvalid $3 $4 }
|
| 'assert_invalid' '(' module1 string ')' { ($1, AssertInvalid $3 $4) }
|
||||||
| 'assert_unlinkable' '(' module1 string ')' { AssertUnlinkable $3 $4 }
|
| 'assert_unlinkable' '(' module1 string ')' { ($1, AssertUnlinkable $3 $4) }
|
||||||
| 'assert_exhaustion' '(' action1 string ')' { AssertExhaustion $3 $4 }
|
| 'assert_exhaustion' '(' action1 string ')' { ($1, AssertExhaustion $3 $4) }
|
||||||
|
|
||||||
assertion_trap :: { Either Action ModuleDef }
|
assertion_trap :: { Either Action ModuleDef }
|
||||||
: action1 { Left $1 }
|
: action1 { Left $1 }
|
||||||
@@ -1454,7 +1454,7 @@ data Command
|
|||||||
= ModuleDef ModuleDef
|
= ModuleDef ModuleDef
|
||||||
| Register TL.Text (Maybe Ident)
|
| Register TL.Text (Maybe Ident)
|
||||||
| Action Action
|
| Action Action
|
||||||
| Assertion Assertion
|
| Assertion Int Assertion
|
||||||
| Meta Meta
|
| Meta Meta
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
@@ -1518,6 +1518,7 @@ desugarize fields = do
|
|||||||
segments <- mapM (synDataToStruct mod) $ datas mod
|
segments <- mapM (synDataToStruct mod) $ datas mod
|
||||||
globs <- mapM (synGlobalToStruct mod) $ globals mod
|
globs <- mapM (synGlobalToStruct mod) $ globals mod
|
||||||
checkMemoryIdentsUniqueness mod
|
checkMemoryIdentsUniqueness mod
|
||||||
|
checkGlobalIdentsUniqueness mod
|
||||||
return S.Module {
|
return S.Module {
|
||||||
S.types = map synTypeDefToStruct $ types mod,
|
S.types = map synTypeDefToStruct $ types mod,
|
||||||
S.functions = funs,
|
S.functions = funs,
|
||||||
@@ -1855,7 +1856,7 @@ desugarize fields = do
|
|||||||
getMemIndexes :: Module -> Ident -> [Natural]
|
getMemIndexes :: Module -> Ident -> [Natural]
|
||||||
getMemIndexes Module { imports, mems } id =
|
getMemIndexes Module { imports, mems } id =
|
||||||
let memImports = zip [0..] $ filter isMemImport imports in
|
let memImports = zip [0..] $ filter isMemImport imports in
|
||||||
let importIndexes = map fst $ filter (\((_, Import { desc = ImportMemory ident _ })) -> ident == Just id) memImports in
|
let importIndexes = map fst $ filter (\(_, Import { desc = ImportMemory ident _ }) -> ident == Just id) memImports in
|
||||||
let isIdent (_, (Memory _ (Just id) _)) = True in
|
let isIdent (_, (Memory _ (Just id) _)) = True in
|
||||||
let memIndexes = map fst $ filter isIdent $ zip [length memImports..] mems in
|
let memIndexes = map fst $ filter isIdent $ zip [length memImports..] mems in
|
||||||
map fromIntegral $ importIndexes ++ memIndexes
|
map fromIntegral $ importIndexes ++ memIndexes
|
||||||
@@ -1873,6 +1874,23 @@ desugarize fields = do
|
|||||||
let ctx = FunCtx mod [] [] [] in
|
let ctx = FunCtx mod [] [] [] in
|
||||||
S.Global globalType <$> mapM (synInstrToStruct ctx) initializer
|
S.Global globalType <$> mapM (synInstrToStruct ctx) initializer
|
||||||
|
|
||||||
|
checkGlobalIdentsUniqueness :: Module -> Either String ()
|
||||||
|
checkGlobalIdentsUniqueness m@Module { imports, globals } = do
|
||||||
|
mapM_ checkImportUniqueness $ filter isGlobalImport imports
|
||||||
|
mapM_ checkGlobalUniqueness globals
|
||||||
|
where
|
||||||
|
checkImportUniqueness Import { desc = ImportGlobal (Just id) _ } =
|
||||||
|
if length (getGlobalIndexes m id) > 1
|
||||||
|
then Left "duplicate global"
|
||||||
|
else return ()
|
||||||
|
checkImportUniqueness _ = return ()
|
||||||
|
|
||||||
|
checkGlobalUniqueness (Global _ (Just id) _ _) =
|
||||||
|
if length (getGlobalIndexes m id) > 1
|
||||||
|
then Left "duplicate global"
|
||||||
|
else return ()
|
||||||
|
checkGlobalUniqueness _ = return ()
|
||||||
|
|
||||||
extractGlobal :: [Global] -> ModuleField -> [Global]
|
extractGlobal :: [Global] -> ModuleField -> [Global]
|
||||||
extractGlobal globals (MFGlobal global) = global : globals
|
extractGlobal globals (MFGlobal global) = global : globals
|
||||||
extractGlobal globals _ = globals
|
extractGlobal globals _ = globals
|
||||||
@@ -1881,14 +1899,19 @@ desugarize fields = do
|
|||||||
isGlobalImport Import { desc = ImportGlobal _ _ } = True
|
isGlobalImport Import { desc = ImportGlobal _ _ } = True
|
||||||
isGlobalImport _ = False
|
isGlobalImport _ = False
|
||||||
|
|
||||||
|
getGlobalIndexes :: Module -> Ident -> [Natural]
|
||||||
|
getGlobalIndexes Module { imports, globals } id =
|
||||||
|
let globalImports = zip [0..] $ filter isGlobalImport imports in
|
||||||
|
let importIndexes = map fst $ filter (\(_, Import { desc = ImportGlobal ident _ }) -> ident == Just id) globalImports in
|
||||||
|
let isIdent (_, Global { ident }) = ident == Just id in
|
||||||
|
let globalIndexes = map fst $ filter isIdent $ zip [length globalImports..] globals in
|
||||||
|
map fromIntegral $ importIndexes ++ globalIndexes
|
||||||
|
|
||||||
getGlobalIndex :: Module -> GlobalIndex -> Maybe Natural
|
getGlobalIndex :: Module -> GlobalIndex -> Maybe Natural
|
||||||
getGlobalIndex Module { imports, globals } (Named id) =
|
getGlobalIndex mod@Module { imports, globals } (Named id) =
|
||||||
let globalImports = filter isGlobalImport imports in
|
case getGlobalIndexes mod id of
|
||||||
case findIndex (\(Import { desc = ImportGlobal ident _ }) -> ident == Just id) globalImports of
|
[idx] -> return idx
|
||||||
Just idx -> return $ fromIntegral idx
|
_ -> Nothing
|
||||||
Nothing ->
|
|
||||||
let isIdent (Global { ident }) = ident == Just id in
|
|
||||||
fromIntegral . (+ length globalImports) <$> findIndex isIdent globals
|
|
||||||
getGlobalIndex Module { imports, globals } (Index idx) = Just idx
|
getGlobalIndex Module { imports, globals } (Index idx) = Just idx
|
||||||
|
|
||||||
-- elem segment
|
-- elem segment
|
||||||
|
|||||||
+40
-33
@@ -47,7 +47,7 @@ emptyState = ScriptState {
|
|||||||
|
|
||||||
runScript :: OnAssertFail -> Script -> IO ()
|
runScript :: OnAssertFail -> Script -> IO ()
|
||||||
runScript onAssertFail script = do
|
runScript onAssertFail script = do
|
||||||
(globI32, globF32, globF64) <- hostGlobals
|
(globI32, globI64, globF32, globF64) <- hostGlobals
|
||||||
(st, inst) <- Interpreter.makeHostModule Interpreter.emptyStore [
|
(st, inst) <- Interpreter.makeHostModule Interpreter.emptyStore [
|
||||||
("print", hostPrint []),
|
("print", hostPrint []),
|
||||||
("print_i32", hostPrint [Struct.I32]),
|
("print_i32", hostPrint [Struct.I32]),
|
||||||
@@ -56,6 +56,7 @@ runScript onAssertFail script = do
|
|||||||
("print_f32", hostPrint [Struct.F32]),
|
("print_f32", hostPrint [Struct.F32]),
|
||||||
("print_f64", hostPrint [Struct.F64]),
|
("print_f64", hostPrint [Struct.F64]),
|
||||||
("global_i32", globI32),
|
("global_i32", globI32),
|
||||||
|
("global_i64", globI64),
|
||||||
("global_f32", globF32),
|
("global_f32", globF32),
|
||||||
("global_f64", globF64),
|
("global_f64", globF64),
|
||||||
("memory", Interpreter.HostMemory $ Struct.Limit 1 (Just 2)),
|
("memory", Interpreter.HostMemory $ Struct.Limit 1 (Just 2)),
|
||||||
@@ -65,10 +66,16 @@ runScript onAssertFail script = do
|
|||||||
where
|
where
|
||||||
hostPrint paramTypes = Interpreter.HostFunction (Struct.FuncType paramTypes []) (\args -> return [])
|
hostPrint paramTypes = Interpreter.HostFunction (Struct.FuncType paramTypes []) (\args -> return [])
|
||||||
hostGlobals = do
|
hostGlobals = do
|
||||||
globI32 <- Interpreter.makeMutGlobal $ Interpreter.VI32 666
|
let globI32 = Interpreter.makeConstGlobal $ Interpreter.VI32 666
|
||||||
|
let globI64 = Interpreter.makeConstGlobal $ Interpreter.VI64 666
|
||||||
globF32 <- Interpreter.makeMutGlobal $ Interpreter.VF32 666
|
globF32 <- Interpreter.makeMutGlobal $ Interpreter.VF32 666
|
||||||
globF64 <- Interpreter.makeMutGlobal $ Interpreter.VF64 666
|
globF64 <- Interpreter.makeMutGlobal $ Interpreter.VF64 666
|
||||||
return (Interpreter.HostGlobal globI32, Interpreter.HostGlobal globF32, Interpreter.HostGlobal globF64)
|
return (
|
||||||
|
Interpreter.HostGlobal globI32,
|
||||||
|
Interpreter.HostGlobal globI64,
|
||||||
|
Interpreter.HostGlobal globF32,
|
||||||
|
Interpreter.HostGlobal globF64
|
||||||
|
)
|
||||||
|
|
||||||
go [] _ = return ()
|
go [] _ = return ()
|
||||||
go (c:cs) st = runCommand st c >>= go cs
|
go (c:cs) st = runCommand st c >>= go cs
|
||||||
@@ -130,19 +137,19 @@ runScript onAssertFail script = do
|
|||||||
isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = identicalIEEE v1 v2
|
isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = identicalIEEE v1 v2
|
||||||
isValueEqual _ _ = False
|
isValueEqual _ _ = False
|
||||||
|
|
||||||
isNaNReturned :: ScriptState -> Action -> Assertion -> IO ()
|
isNaNReturned :: ScriptState -> String -> Action -> Assertion -> IO ()
|
||||||
isNaNReturned st action assert = do
|
isNaNReturned st pos action assert = do
|
||||||
result <- runAction st action
|
result <- runAction st action
|
||||||
case result of
|
case result of
|
||||||
Just [Interpreter.VF32 v] ->
|
Just [Interpreter.VF32 v] ->
|
||||||
if isNaN v
|
if isNaN v
|
||||||
then return ()
|
then return ()
|
||||||
else onAssertFail ("Expected NaN, but action returned " ++ show v) assert
|
else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert
|
||||||
Just [Interpreter.VF64 v] ->
|
Just [Interpreter.VF64 v] ->
|
||||||
if isNaN v
|
if isNaN v
|
||||||
then return ()
|
then return ()
|
||||||
else onAssertFail ("Expected NaN, but action returned " ++ show v) assert
|
else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert
|
||||||
_ -> onAssertFail ("Expected NaN, but action returned " ++ show result) assert
|
_ -> onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show result) assert
|
||||||
|
|
||||||
buildModule :: ModuleDef -> (Maybe Ident, Struct.Module)
|
buildModule :: ModuleDef -> (Maybe Ident, Struct.Module)
|
||||||
buildModule (RawModDef ident m) = (ident, m)
|
buildModule (RawModDef ident m) = (ident, m)
|
||||||
@@ -178,67 +185,67 @@ runScript onAssertFail script = do
|
|||||||
getFailureString Validate.InvalidStartFunctionType = ["start function"]
|
getFailureString Validate.InvalidStartFunctionType = ["start function"]
|
||||||
getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]]
|
getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]]
|
||||||
|
|
||||||
runAssert :: ScriptState -> Assertion -> IO ()
|
runAssert :: ScriptState -> String -> Assertion -> IO ()
|
||||||
runAssert st assert@(AssertReturn action expected) = do
|
runAssert st pos assert@(AssertReturn action expected) = do
|
||||||
result <- runAction st action
|
result <- runAction st action
|
||||||
case result of
|
case result of
|
||||||
Just result -> do
|
Just result -> do
|
||||||
if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected))
|
if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected))
|
||||||
then return ()
|
then return ()
|
||||||
else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
|
else onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
|
||||||
Nothing -> onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
|
Nothing -> onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
|
||||||
runAssert st assert@(AssertReturnCanonicalNaN action) = isNaNReturned st action assert
|
runAssert st pos assert@(AssertReturnCanonicalNaN action) = isNaNReturned st pos action assert
|
||||||
runAssert st assert@(AssertReturnArithmeticNaN action) = isNaNReturned st action assert
|
runAssert st pos assert@(AssertReturnArithmeticNaN action) = isNaNReturned st pos action assert
|
||||||
runAssert st assert@(AssertInvalid moduleDef failureString) =
|
runAssert st pos assert@(AssertInvalid moduleDef failureString) =
|
||||||
let (_, m) = buildModule moduleDef in
|
let (_, m) = buildModule moduleDef in
|
||||||
case Validate.validate m of
|
case Validate.validate m of
|
||||||
Right _ -> onAssertFail "An invalid module passed validation step" assert
|
Right _ -> onAssertFail (pos ++ ": An invalid module passed validation step") assert
|
||||||
Left reason ->
|
Left reason ->
|
||||||
if failureString `elem` getFailureString reason
|
if failureString `elem` getFailureString reason
|
||||||
then return ()
|
then return ()
|
||||||
else
|
else
|
||||||
let msg = "Module is invalid for other reason. Expected "
|
let msg = pos ++ ": Module is invalid for other reason. Expected "
|
||||||
++ show failureString
|
++ show failureString
|
||||||
++ ", but actual is "
|
++ ", but actual is "
|
||||||
++ show (getFailureString reason)
|
++ show (getFailureString reason)
|
||||||
in onAssertFail msg assert
|
in onAssertFail msg assert
|
||||||
runAssert st assert@(AssertMalformed (TextModDef _ textRep) failureString) =
|
runAssert st pos assert@(AssertMalformed (TextModDef _ textRep) failureString) =
|
||||||
case DeepSeq.force $ Lexer.scanner (TLEncoding.encodeUtf8 textRep) >>= Parser.parseModule of
|
case DeepSeq.force $ Lexer.scanner (TLEncoding.encodeUtf8 textRep) >>= Parser.parseModule of
|
||||||
Right _ -> onAssertFail ("Module parsing should fail with failure string " ++ show failureString) assert
|
Right _ -> onAssertFail (pos ++ ": Module parsing should fail with failure string " ++ show failureString) assert
|
||||||
Left _ -> return ()
|
Left _ -> return ()
|
||||||
runAssert st assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) =
|
runAssert st pos assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) =
|
||||||
case Binary.decodeModuleLazy binaryRep of
|
case Binary.decodeModuleLazy binaryRep of
|
||||||
Right _ -> onAssertFail ("Module decoding should fail with failure string " ++ show failureString) assert
|
Right _ -> onAssertFail (pos ++ ": Module decoding should fail with failure string " ++ show failureString) assert
|
||||||
Left _ -> return ()
|
Left _ -> return ()
|
||||||
runAssert st assert@(AssertMalformed (RawModDef _ _) failureString) = return ()
|
runAssert st _ assert@(AssertMalformed (RawModDef _ _) failureString) = return ()
|
||||||
runAssert st assert@(AssertUnlinkable moduleDef failureString) =
|
runAssert st pos assert@(AssertUnlinkable moduleDef failureString) =
|
||||||
let (_, m) = buildModule moduleDef in
|
let (_, m) = buildModule moduleDef in
|
||||||
case Validate.validate m of
|
case Validate.validate m of
|
||||||
Right m -> do
|
Right m -> do
|
||||||
res <- Interpreter.instantiate (store st) (buildImports st) m
|
res <- Interpreter.instantiate (store st) (buildImports st) m
|
||||||
case res of
|
case res of
|
||||||
Left err -> return ()
|
Left err -> return ()
|
||||||
Right _ -> onAssertFail ("Module linking should fail with failure string " ++ show failureString) assert
|
Right _ -> onAssertFail (pos ++ ": Module linking should fail with failure string " ++ show failureString) assert
|
||||||
Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
|
Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason
|
||||||
runAssert st assert@(AssertTrap (Left action) failureString) = do
|
runAssert st pos assert@(AssertTrap (Left action) failureString) = do
|
||||||
result <- runAction st action
|
result <- runAction st action
|
||||||
if isNothing result
|
if isNothing result
|
||||||
then return ()
|
then return ()
|
||||||
else onAssertFail ("Expected trap, but action returned " ++ show (fromJust result)) assert
|
else onAssertFail (pos ++ ":Expected trap, but action returned " ++ show (fromJust result)) assert
|
||||||
runAssert st assert@(AssertTrap (Right moduleDef) failureString) =
|
runAssert st pos assert@(AssertTrap (Right moduleDef) failureString) =
|
||||||
let (_, m) = buildModule moduleDef in
|
let (_, m) = buildModule moduleDef in
|
||||||
case Validate.validate m of
|
case Validate.validate m of
|
||||||
Right m -> do
|
Right m -> do
|
||||||
res <- Interpreter.instantiate (store st) (buildImports st) m
|
res <- Interpreter.instantiate (store st) (buildImports st) m
|
||||||
case res of
|
case res of
|
||||||
Left "Start function terminated with trap" -> return ()
|
Left "Start function terminated with trap" -> return ()
|
||||||
_ -> onAssertFail ("Module linking should fail with trap during execution of a start function") assert
|
_ -> onAssertFail (pos ++ ": Module linking should fail with trap during execution of a start function") assert
|
||||||
Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
|
Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason
|
||||||
runAssert st assert@(AssertExhaustion action failureString) = do
|
runAssert st pos assert@(AssertExhaustion action failureString) = do
|
||||||
result <- runAction st action
|
result <- runAction st action
|
||||||
if isNothing result
|
if isNothing result
|
||||||
then return ()
|
then return ()
|
||||||
else onAssertFail ("Expected exhaustion, but action returned " ++ show (fromJust result)) assert
|
else onAssertFail (pos ++ ": Expected exhaustion, but action returned " ++ show (fromJust result)) assert
|
||||||
|
|
||||||
runCommand :: ScriptState -> Command -> IO ScriptState
|
runCommand :: ScriptState -> Command -> IO ScriptState
|
||||||
runCommand st (ModuleDef moduleDef) =
|
runCommand st (ModuleDef moduleDef) =
|
||||||
@@ -246,5 +253,5 @@ runScript onAssertFail script = do
|
|||||||
addModule ident m st
|
addModule ident m st
|
||||||
runCommand st (Register name i) = return $ addToRegistery name i st
|
runCommand st (Register name i) = return $ addToRegistery name i st
|
||||||
runCommand st (Action action) = runAction st action >> return st
|
runCommand st (Action action) = runAction st action >> return st
|
||||||
runCommand st (Assertion assertion) = runAssert st assertion >> return st
|
runCommand st (Assertion pos assertion) = runAssert st ("Line " ++ show pos) assertion >> return st
|
||||||
runCommand st _ = return st
|
runCommand st _ = return st
|
||||||
|
|||||||
+1
-1
@@ -17,7 +17,7 @@ import qualified Data.List as List
|
|||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec"
|
files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec"
|
||||||
-- let files = ["linking.wast"]
|
-- let files = ["global.wast"]
|
||||||
scriptTestCases <- (`mapM` files) $ \file -> do
|
scriptTestCases <- (`mapM` files) $ \file -> do
|
||||||
test <- LBS.readFile ("tests/spec/" ++ file)
|
test <- LBS.readFile ("tests/spec/" ++ file)
|
||||||
return $ testCase file $ do
|
return $ testCase file $ do
|
||||||
|
|||||||
Reference in New Issue
Block a user