fix parsing of functions with incorrect type indexes

src/Language/Wasm/Parser.y

@@ -1528,12 +1528,9 @@ desugarize fields =
         getTypeIndex defs (IndexedTypeUse (Named ident) Nothing) =
             fromIntegral <$> findIndex (\(TypeDef i _) -> i == Just ident) defs
         getTypeIndex defs (IndexedTypeUse (Index n) (Just funcType)) = do
-            guard $ length defs > fromIntegral n
             guard $ matchTypeFunc funcType $ defs !! fromIntegral n
             return n
-        getTypeIndex defs (IndexedTypeUse (Index n) Nothing) = do
-            guard $ length defs > fromIntegral n
-            return n
+        getTypeIndex defs (IndexedTypeUse (Index n) Nothing) = return n
         
         -- imports
         synImportToStruct :: [TypeDef] -> Import -> S.Import
@@ -1649,8 +1646,9 @@ desugarize fields =
                     IndexedTypeUse _ (Just FuncType { params }) -> params
                     AnonimousTypeUse FuncType { params } -> params
                     _ ->
-                        let TypeDef _ FuncType { params } = types mod !! fromIntegral typeIdx in
-                        params
+                        if fromIntegral typeIdx < length (types mod)
+                        then let TypeDef _ FuncType { params } = types mod !! fromIntegral typeIdx in params
+                        else []
             in
             let ctx = FunCtx mod [] locals params in
             S.Function {

src/Language/Wasm/Script.hs

@@ -162,11 +162,13 @@ runScript onAssertFail script = do
         getFailureString Validate.FunctionIndexOutOfRange = "unknown function"
         getFailureString Validate.GlobalIndexOutOfRange = "unknown global"
         getFailureString Validate.LabelIndexOutOfRange = "unknown label"
+        getFailureString Validate.TypeIndexOutOfRange = "unknown type"
         getFailureString Validate.MinMoreThanMaxInMemoryLimit = "size minimum must not be greater than maximum"
         getFailureString Validate.MemoryLimitExceeded = "memory size must be at most 65536 pages (4GiB)"
         getFailureString Validate.AlignmentOverflow = "alignment must not be larger than natural"
         getFailureString (Validate.DuplicatedExportNames _) = "duplicate export name"
         getFailureString Validate.InvalidConstantExpr = "constant expression required"
+        getFailureString Validate.InvalidResultArity = "invalid result arity"
         -- getFailureString Validate.ImportedGlobalIsNotConst = "global is immutable"
         getFailureString _ = "not implemented"
 

src/Language/Wasm/Validate.hs

@@ -39,6 +39,7 @@ data ValidationResult =
     | TypeIndexOutOfRange
     | ResultTypeDoesntMatch
     | TypeMismatch { actual :: Arrow, expected :: Arrow }
+    | InvalidResultArity
     | InvalidConstantExpr
     | InvalidStartFunctionType
     | ImportedGlobalIsNotConst
@@ -402,7 +403,7 @@ unify (from `Arrow` to) (from' `Arrow` to') =
 getExpressionType :: [Instruction] -> Checker Arrow
 getExpressionType instrs =
     case reverse instrs of
-        [] -> return $ Any ==> Any
+        [] -> return $ empty ==> empty
         (i:rest) -> do
             arr <- getInstrType i
             go arr rest
@@ -466,15 +467,21 @@ ctxFromModule locals labels returns m@Module {types, tables, mems, globals, impo
 
 isFunctionValid :: Function -> Validator
 isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types} =
-    let FuncType params results = types !! fromIntegral funcType in
-    let r = safeHead results in
-    let ctx = ctxFromModule (params ++ locals) [r] r mod in
-    case runChecker ctx $ getExpressionType body of
-        Left err -> err
-        Right arr ->
-            if isArrowMatch arr (empty ==> results)
-            then Valid
-            else TypeMismatch arr (empty ==> results)
+    if fromIntegral funcType < length types
+    then
+        let FuncType params results = types !! fromIntegral funcType in
+        if length results > 1
+        then InvalidResultArity
+        else
+            let r = safeHead results in
+            let ctx = ctxFromModule (params ++ locals) [r] r mod in
+            case runChecker ctx $ getExpressionType body of
+                Left err -> err
+                Right arr ->
+                    if isArrowMatch arr (empty ==> results)
+                    then Valid
+                    else TypeMismatch arr (empty ==> results)
+    else TypeIndexOutOfRange
 
 functionsShouldBeValid :: Validator
 functionsShouldBeValid mod@Module {functions} =

tests/Test.hs

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