From ef311436a6bf18f58e2c4c96aa9ab35689029b3f Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Thu, 21 Dec 2023 23:27:17 +0100 Subject: [PATCH 01/26] Rename lib file --- lvtrun/src/{Lib.hs => TypeCheck.hs} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename lvtrun/src/{Lib.hs => TypeCheck.hs} (100%) diff --git a/lvtrun/src/Lib.hs b/lvtrun/src/TypeCheck.hs similarity index 100% rename from lvtrun/src/Lib.hs rename to lvtrun/src/TypeCheck.hs From 289ffe271cb679524bf521c48c53c9da7ee294d9 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 17:49:59 +0100 Subject: [PATCH 02/26] Add AST --- lvtrun/src/AST.hs | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 lvtrun/src/AST.hs diff --git a/lvtrun/src/AST.hs b/lvtrun/src/AST.hs new file mode 100644 index 0000000..f881dc9 --- /dev/null +++ b/lvtrun/src/AST.hs @@ -0,0 +1,36 @@ + +getType :: Type -> String +getType Int32 = "Int32" +getType _ = Nothing + +type Type = String + +type TypeValue = Int32 | Bool | String + +data Value = Var String | StaticValue TypeValue | Function FuncCall + + +-- Function + +type Var = (Symbol, Type) + +type ReturnType = Type | Void + +type FuncPrototype = (Symbol, [Var], ReturnType) + +type FuncDeclaration = (FuncPrototype, [Instruction]) + + +-- condition + +type Condition = (Value, [Instruction], [Instruction]) + +-- Instruction + +type FuncCall = (Symbol, [Value]) + +type VarDeclaration = (Var, Value) + +type VarAssignation = (Symbol, Value) + +data Instruction = Function FuncCall | Return Value | Declaration VarDeclaration | Assignation VarAssignation | Cond Condition From 7bead121fda8d3d1d2b17f3477d8298b26586283 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 17:58:32 +0100 Subject: [PATCH 03/26] Fix file location --- {lvtrun => lvtc}/src/AST.hs | 0 lvtc/src/TypeCheck.hs | 49 +++++++++++++++++++++++++++++++++++++ lvtrun/src/TypeCheck.hs | 13 ---------- 3 files changed, 49 insertions(+), 13 deletions(-) rename {lvtrun => lvtc}/src/AST.hs (100%) create mode 100644 lvtc/src/TypeCheck.hs delete mode 100644 lvtrun/src/TypeCheck.hs diff --git a/lvtrun/src/AST.hs b/lvtc/src/AST.hs similarity index 100% rename from lvtrun/src/AST.hs rename to lvtc/src/AST.hs diff --git a/lvtc/src/TypeCheck.hs b/lvtc/src/TypeCheck.hs new file mode 100644 index 0000000..4286278 --- /dev/null +++ b/lvtc/src/TypeCheck.hs @@ -0,0 +1,49 @@ +{- +-- EPITECH PROJECT, 2023 +-- Leviator compiler +-- File description: +-- Type checker +-} + +module Lib + ( someFunc + ) where + +import AST + +functions :: [FuncDeclaration], + +checkFuncCall + +checkCondition :: Condition -> TypeEnv -> Maybe TypeEnv +checkCondition (Symbol s, xs, ys) env = +checkCondition (Type t, xs, ys) env = +checkCondition (FuncCall (symbol, values), xs, ys) env = checkBoolFunc (checkFuncCall (FuncCall (symbol, values)) env) xs ys +checkCondition _ _ = Nothing + +checkInstructions :: [Instruction] -> TypeEnv -> Maybe TypeEnv +checkInstructions ((Symbol s):xs) env = +checkInstructions ((Type t):xs) env = +checkInstructions ((FuncCall f):xs) env = +checkInstructions ((Return r):xs) env = +checkInstructions ((VarDeclaration v):xs) env = +checkInstructions ((Condition c):xs) env = checkCondition c env +checkInstructions _ _ = Nothing + +checkFunctionInstructions :: Maybe TypeEnv -> [ASTExpression] -> Maybe TypeEnv +checkFunctionInstructions (Just env) xs = typeCheck xs env +checkFunctionInstructions _ _ _ = Nothing + +checkFunc :: FuncDeclaration -> TypeEnv -> [ASTExpression] -> Maybe TypeEnv +checkFunc (FuncDeclaration (Prototype (symbol, vars, (Void))) []) env xs = Just env +checkFunc (FuncDeclaration _ []) env xs = Nothing +checkFunc (FuncDeclaration prototype instructions) env xs = checkFuncInstructions (checkInstructions instructions env) xs +checkFunc _ _ _ = Nothing + +typeCheck :: [FuncDeclaration] -> TypeEnv -> Maybe TypeEnv +typeCheck ((FuncDeclaration func):xs) (Env functions a) = checkFunc func (Env functions ++ [func] a) xs +typeCheck ((Alias symbol value):xs) env = checkAlias (Alias symbol value) env xs +typeCheck _ _ = Nothing + +handleTypeCheck :: [FuncDeclaration] -> Maybe TypeEnv +handleTypeCheck expressions = typeCheck expressions (TypeEnv [] []) diff --git a/lvtrun/src/TypeCheck.hs b/lvtrun/src/TypeCheck.hs deleted file mode 100644 index 3f12ee2..0000000 --- a/lvtrun/src/TypeCheck.hs +++ /dev/null @@ -1,13 +0,0 @@ -{- --- EPITECH PROJECT, 2023 --- Leviator Run --- File description: --- Lib --} - -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" From 4ce0c16e9bfda8f0d908cd4049bfb86b43b0b7f9 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 17:59:47 +0100 Subject: [PATCH 04/26] Add header --- lvtc/src/AST.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index f881dc9..389d87b 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -1,3 +1,9 @@ +{- +-- EPITECH PROJECT, 2023 +-- Leviator Run +-- File description: +-- AST +-} getType :: Type -> String getType Int32 = "Int32" From b6e2464f69a37b6e59e97feacb778fabb304f5df Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 18:05:55 +0100 Subject: [PATCH 05/26] Add exports --- lvtc/src/AST.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 389d87b..0de7c5d 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -5,6 +5,22 @@ -- AST -} +module AST + ( + , Type + , Value + , Var + , FuncCall + , FuncPrototype + , FuncDeclaration + , Instruction + , VarDeclaration + , VarAssignation + , Condition + , ReturnType + , TypeValue + ) where + getType :: Type -> String getType Int32 = "Int32" getType _ = Nothing From 924b8297e93ad755d1f3ca8564d04ffdf35b6378 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 18:10:00 +0100 Subject: [PATCH 06/26] Fix TypeValue --- lvtc/src/AST.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 0de7c5d..153152a 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -27,9 +27,7 @@ getType _ = Nothing type Type = String -type TypeValue = Int32 | Bool | String - -data Value = Var String | StaticValue TypeValue | Function FuncCall +data Value = Var String | Function FuncCall | Boolean Bool | Integer Int32 | StringView String -- Function @@ -55,4 +53,5 @@ type VarDeclaration = (Var, Value) type VarAssignation = (Symbol, Value) -data Instruction = Function FuncCall | Return Value | Declaration VarDeclaration | Assignation VarAssignation | Cond Condition +data Instruction = + Function FuncCall | Return Value | Declaration VarDeclaration | Assignation VarAssignation | Cond Condition From 4287510ab8d58ea0eb02143f813d36bad901b862 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 18:13:12 +0100 Subject: [PATCH 07/26] Fix norm + returnValue --- lvtc/src/AST.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 153152a..00cac3f 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -7,7 +7,7 @@ module AST ( - , Type + Type , Value , Var , FuncCall @@ -18,7 +18,6 @@ module AST , VarAssignation , Condition , ReturnType - , TypeValue ) where getType :: Type -> String @@ -27,16 +26,16 @@ getType _ = Nothing type Type = String -data Value = Var String | Function FuncCall | Boolean Bool | Integer Int32 | StringView String +data Value = + Var String | Function FuncCall | Boolean Bool | Integer Int32 | + StringView String -- Function type Var = (Symbol, Type) -type ReturnType = Type | Void - -type FuncPrototype = (Symbol, [Var], ReturnType) +type FuncPrototype = (Symbol, [Var], Type) type FuncDeclaration = (FuncPrototype, [Instruction]) @@ -54,4 +53,5 @@ type VarDeclaration = (Var, Value) type VarAssignation = (Symbol, Value) data Instruction = - Function FuncCall | Return Value | Declaration VarDeclaration | Assignation VarAssignation | Cond Condition + Function FuncCall | Return Value | Declaration VarDeclaration | + Assignation VarAssignation | Cond Condition From e15385b599037c6f02622588f1d67318a1f54a8e Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 18:20:29 +0100 Subject: [PATCH 08/26] Fix --- lvtc/src/AST.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 00cac3f..3a2e66f 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -17,7 +17,6 @@ module AST , VarDeclaration , VarAssignation , Condition - , ReturnType ) where getType :: Type -> String @@ -27,7 +26,7 @@ getType _ = Nothing type Type = String data Value = - Var String | Function FuncCall | Boolean Bool | Integer Int32 | + Var String | FuncValue FuncCall | Boolean Bool | Integer Int32 | StringView String From cac38e523bd2a1dbd8eb71b0638f0fa3575e0e0f Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 18:27:01 +0100 Subject: [PATCH 09/26] Fix type --- lvtc/src/AST.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 3a2e66f..2f789aa 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -6,8 +6,7 @@ -} module AST - ( - Type + ( Type , Value , Var , FuncCall @@ -19,9 +18,9 @@ module AST , Condition ) where -getType :: Type -> String -getType Int32 = "Int32" -getType _ = Nothing +import Data.Int (Int32) + +type Symbol = String type Type = String From 2b5c4c334e61f11df1f386a5b51608b42f612343 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Wed, 3 Jan 2024 18:31:33 +0100 Subject: [PATCH 10/26] Fix export --- lvtc/src/AST.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 2f789aa..c86c82d 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -7,12 +7,12 @@ module AST ( Type - , Value + , Value (..) , Var , FuncCall , FuncPrototype , FuncDeclaration - , Instruction + , Instruction (..) , VarDeclaration , VarAssignation , Condition From a3a0beb2e71e438d2de64238687369287a0644a1 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Sun, 7 Jan 2024 01:17:53 +0100 Subject: [PATCH 11/26] Add current progress --- lvtc/src/AST.hs | 4 +- lvtc/src/TypeCheck.hs | 126 ++++++++++++++++++++++++++++++------------ 2 files changed, 92 insertions(+), 38 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index c86c82d..30c8344 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -16,7 +16,7 @@ module AST , VarDeclaration , VarAssignation , Condition - ) where +) where import Data.Int (Int32) @@ -51,5 +51,5 @@ type VarDeclaration = (Var, Value) type VarAssignation = (Symbol, Value) data Instruction = - Function FuncCall | Return Value | Declaration VarDeclaration | + Call FuncCall | Return Value | Declaration VarDeclaration | Assignation VarAssignation | Cond Condition diff --git a/lvtc/src/TypeCheck.hs b/lvtc/src/TypeCheck.hs index 4286278..fa6d525 100644 --- a/lvtc/src/TypeCheck.hs +++ b/lvtc/src/TypeCheck.hs @@ -11,39 +11,93 @@ module Lib import AST -functions :: [FuncDeclaration], - -checkFuncCall - -checkCondition :: Condition -> TypeEnv -> Maybe TypeEnv -checkCondition (Symbol s, xs, ys) env = -checkCondition (Type t, xs, ys) env = -checkCondition (FuncCall (symbol, values), xs, ys) env = checkBoolFunc (checkFuncCall (FuncCall (symbol, values)) env) xs ys -checkCondition _ _ = Nothing - -checkInstructions :: [Instruction] -> TypeEnv -> Maybe TypeEnv -checkInstructions ((Symbol s):xs) env = -checkInstructions ((Type t):xs) env = -checkInstructions ((FuncCall f):xs) env = -checkInstructions ((Return r):xs) env = -checkInstructions ((VarDeclaration v):xs) env = -checkInstructions ((Condition c):xs) env = checkCondition c env -checkInstructions _ _ = Nothing - -checkFunctionInstructions :: Maybe TypeEnv -> [ASTExpression] -> Maybe TypeEnv -checkFunctionInstructions (Just env) xs = typeCheck xs env -checkFunctionInstructions _ _ _ = Nothing - -checkFunc :: FuncDeclaration -> TypeEnv -> [ASTExpression] -> Maybe TypeEnv -checkFunc (FuncDeclaration (Prototype (symbol, vars, (Void))) []) env xs = Just env -checkFunc (FuncDeclaration _ []) env xs = Nothing -checkFunc (FuncDeclaration prototype instructions) env xs = checkFuncInstructions (checkInstructions instructions env) xs -checkFunc _ _ _ = Nothing - -typeCheck :: [FuncDeclaration] -> TypeEnv -> Maybe TypeEnv -typeCheck ((FuncDeclaration func):xs) (Env functions a) = checkFunc func (Env functions ++ [func] a) xs -typeCheck ((Alias symbol value):xs) env = checkAlias (Alias symbol value) env xs -typeCheck _ _ = Nothing - -handleTypeCheck :: [FuncDeclaration] -> Maybe TypeEnv -handleTypeCheck expressions = typeCheck expressions (TypeEnv [] []) +--checkCondition :: Condition -> TypeEnv -> Maybe TypeEnv +--checkCondition (Symbol s, xs, ys) env = +--checkCondition (Type t, xs, ys) env = +--checkCondition (FuncCall (symbol, values), xs, ys) env = checkBoolFunc (checkFuncCall (FuncCall (symbol, values)) env) xs ys +--checkCondition _ _ = Nothing + +findVarInParams :: Value -> [Var] -> Maybe Type +findVarInParams (Var s) ((Var s, t):xs) + | s == s = Just t + | otherwise = findVarInParams (Var s) xs +findVarInParams _ [] = Nothing + +findVarIn + +findValueType :: Value -> [Var] -> [VarAssignation] -> [FuncDeclaration] -> Maybe Type +findSymbol (Var s) params vars env = (findVarParams (Var s) params) <|> () + +checkValueType :: Type -> Maybe Type -> Bool +checkValueType _ Nothing = False +checkValueType t (Just t') = t == t' + +assertTypeAndValue :: Type -> Value -> [Var] -> [VarAssignation] -> [FuncDeclaration] -> Bool +assertTypeAndValue _ (Var s) [] [] [] = False +assertTypeAndValue "Int" (Integer _) _ = True +assertTypeAndValue "Bool" (Boolean _) _ = True +assertTypeAndValue t v params vars env = checkValueType $ t (findValueType v params vars env) +assertTypeAndValue _ _ _ = False + +isTypeValid :: Type -> Bool +isTypeValid "Int" = True +isTypeValid "Bool" = True +isTypeValid _ = False + +checkVars :: [Value] -> Maybe [Var] -> [Var] -> [VarAssignation] -> [FuncDeclaration] -> Bool +checkVarsTypes [] _ _ _ _ = False +checkVarsTypes _ [] _ _ _ = False +checkVarsTypes values param _ _ _ | length fst /= length scd = False +checkVarsTypes [(fs v)] [(ss t)] params vars env = assertTypeAndValue t v params vars env +checkVarsTypes ((fs v):xs) ((ss t):ys) params vars env + | assertTypeAndValue t v params vars env = checkVars xs ys params vars env + | otherwise = False + +findFunc :: Symbol -> [FuncDeclaration] -> Maybe [Var] +findFunc s [] = Nothing +findFunc s ((FuncDeclaration (FuncPrototype s params _) _):xs) | s == s = Just params +findFunc s (_:xs) = findFunc s xs + +checkCall :: FuncPrototype -> FuncCall -> [VarAssignation] -> [FuncDeclaration] -> [Instructions] -> Maybe [FuncDeclaration] +checkCall (FuncPrototype s params t) (symbol, values) vars env xs + | s == symbol && checkVars values (Just params) params vars env = + checkInstructions (FuncPrototype s param t) xs env vars + | otherwise = Nothing +checkCall (FuncPrototype _ params t) (s, values) vars env xs + | checkVars values (findFunc s env) params vars env = + checkInstructions (FuncPrototype s param t) xs env vars + +checkInstructions :: FuncPrototype -> [Instructions] -> [FuncDeclaration] -> [VarAssignation] -> Maybe [FuncDeclaration] +checkInstructions prototype ((Call func):xs) env vars = checkCall prototype func vars env xs +checkInstructions prototype ((Return ret):xs) env vars = checkReturn prototype ret vars env xs +checkInstructions prototype ((Declaration declaration):xs) env vars = checkDeclaration prototype declaration vars env xs +checkInstructions prototype ((Assignation assignation):xs) env vars = checkAssignation prototype declaration vars env xs +checkInstructions prototype ((Condition assignation):xs) env vars = checkAssignation prototype declaration vars env xs +checkInstructions _ _ _ = Nothing + +checkVarTypes :: [Var] -> Bool +checkVarTypes [] = False +checkVarTypes [x] = isTypeValid (snd x) +checkVarTypes (x:xs) | isTypeValid (snd x) = checkVarTypes xs + +checkFunction :: FuncDeclaration -> [FuncDeclaration] -> Maybe [FuncDeclaration] +checkFunction (FuncDeclaration (FuncPrototype _ args _) _) | not (checkVarTypes args) = Nothing +checkFunction (FuncDeclaration (FuncPrototype _ _ t) _) | not (isTypeValid t) = Nothing +checkFunction (FuncDeclaration prototype instructions) env = checkInstructions prototype instructions env [] + +checkNotExisting :: FuncDeclaration -> [FuncDeclaration] -> Bool +checkNotExisting _ [] = True +checkNotExisting (FuncDeclaration (FuncPrototype s _ _) _) ((FuncDeclaration (FuncPrototype ls _ _) _):xs) + | s == ls = False + | otherwise = checkNotExisting (FuncDeclaration (FuncPrototype s _ _) _) xs + +checkDeclarations :: [FuncDeclaration] -> Maybe [FuncDeclaration] -> Maybe [FuncDeclaration] +checkDeclarations _ Nothing = Nothing +checkDeclarations ((FuncDeclaration func):xs) (Just env) + | checkNotExisting func env = + checkDeclarations xs (checkFunction func env) + | otherwise = Nothing +checkDeclarations _ _ = Nothing + +handleTypeCheck :: [FuncDeclaration] -> Maybe [FuncDeclaration] +handleTypeCheck expressions = checkDeclarations expressions (Just []) From a637ac3134521a58081f236639367d7e6ae15098 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Sun, 14 Jan 2024 14:45:37 +0100 Subject: [PATCH 12/26] Add awaiting tests --- lvtc/app/Main.hs | 5 +- lvtc/lvtc.cabal | 4 +- lvtc/src/AST.hs | 1 + lvtc/src/TypeCheck.hs | 209 ++++++++++++++++++++++++++++------------- lvtc/test/typeCheck.hs | 22 +++++ 5 files changed, 173 insertions(+), 68 deletions(-) create mode 100644 lvtc/test/typeCheck.hs diff --git a/lvtc/app/Main.hs b/lvtc/app/Main.hs index 52b8bd5..512aa74 100644 --- a/lvtc/app/Main.hs +++ b/lvtc/app/Main.hs @@ -7,7 +7,8 @@ module Main (main) where -import Lib +import AST +import TypeCheck main :: IO () -main = someFunc +main = return () diff --git a/lvtc/lvtc.cabal b/lvtc/lvtc.cabal index b102c44..e5ca9fc 100644 --- a/lvtc/lvtc.cabal +++ b/lvtc/lvtc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -25,7 +25,9 @@ source-repository head library exposed-modules: + AST Lib + TypeCheck other-modules: Paths_lvtc autogen-modules: diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 30c8344..6d41474 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -9,6 +9,7 @@ module AST ( Type , Value (..) , Var + , Symbol , FuncCall , FuncPrototype , FuncDeclaration diff --git a/lvtc/src/TypeCheck.hs b/lvtc/src/TypeCheck.hs index fa6d525..61c8f40 100644 --- a/lvtc/src/TypeCheck.hs +++ b/lvtc/src/TypeCheck.hs @@ -5,99 +5,178 @@ -- Type checker -} -module Lib - ( someFunc +module TypeCheck + ( typeCheck ) where import AST +import Debug.Trace + +data Env = Env FuncPrototype [VarAssignation] [FuncPrototype] + +findVarInParams :: Symbol -> [Var] -> Env -> Maybe Type +findVarInParams _ [] _ = Nothing +findVarInParams s ((s', t):xs) env + | s == s' = Just t + | otherwise = findVarInParams s xs env + +findVarInVar :: Symbol -> [VarAssignation] -> Env -> Maybe Type +findVarInVar _ [] _ = Nothing +findVarInVar s ((s', v):xs) env + | s == s' = findValueType v env + | otherwise = findVarInVar s xs env + +findTypeReturnFunc :: Symbol -> [FuncPrototype] -> Maybe FuncPrototype +findTypeReturnFunc _ [] = Nothing +findTypeReturnFunc s ((s', ps, t):xs) + | s == s' = Just (s', ps, t) + | otherwise = findTypeReturnFunc s xs + +getValueType :: Value -> Maybe Type +getValueType (Integer _) = Just "Int" +getValueType (Boolean _) = Just "Bool" +getValueType (StringView _) = Just "String" +getValueType _ = Nothing + +checkFuncType :: [Value] -> Env -> Maybe FuncPrototype -> Maybe Type +checkFuncType _ _ Nothing = Nothing +checkFuncType [] _ _ = Nothing +checkFuncType callParams (Env proto params env) (Just (_, ps, t)) + | checkVarsTypes callParams (Just ps) (Env proto params env) = Just t + | otherwise = Nothing ---checkCondition :: Condition -> TypeEnv -> Maybe TypeEnv ---checkCondition (Symbol s, xs, ys) env = ---checkCondition (Type t, xs, ys) env = ---checkCondition (FuncCall (symbol, values), xs, ys) env = checkBoolFunc (checkFuncCall (FuncCall (symbol, values)) env) xs ys ---checkCondition _ _ = Nothing - -findVarInParams :: Value -> [Var] -> Maybe Type -findVarInParams (Var s) ((Var s, t):xs) - | s == s = Just t - | otherwise = findVarInParams (Var s) xs -findVarInParams _ [] = Nothing - -findVarIn +handleFinders :: Maybe Type -> Symbol -> Env -> Maybe Type +handleFinders _ _ (Env (_, [], _) [] _) = Nothing +handleFinders Nothing s (Env proto vars env) = findVarInVar s vars (Env proto vars env) +handleFinders (Just t) _ _ = Just t -findValueType :: Value -> [Var] -> [VarAssignation] -> [FuncDeclaration] -> Maybe Type -findSymbol (Var s) params vars env = (findVarParams (Var s) params) <|> () +findValueType :: Value -> Env -> Maybe Type +findValueType (Var s) (Env (ps, params, t) vars env) = + handleFinders (findVarInParams s params (Env (ps, params, t) vars env)) s (Env (ps, params, t) vars env) +findValueType (FuncValue (s, vs)) (Env proto vars env) = checkFuncType vs (Env proto vars env) (findTypeReturnFunc s env) +findValueType v _ = getValueType v checkValueType :: Type -> Maybe Type -> Bool checkValueType _ Nothing = False checkValueType t (Just t') = t == t' -assertTypeAndValue :: Type -> Value -> [Var] -> [VarAssignation] -> [FuncDeclaration] -> Bool -assertTypeAndValue _ (Var s) [] [] [] = False -assertTypeAndValue "Int" (Integer _) _ = True -assertTypeAndValue "Bool" (Boolean _) _ = True -assertTypeAndValue t v params vars env = checkValueType $ t (findValueType v params vars env) -assertTypeAndValue _ _ _ = False +assertTypeAndValue :: Type -> Value -> Env -> Bool +assertTypeAndValue _ (Var _) (Env (_, [], _) [] _) = False +assertTypeAndValue _ (FuncValue _) (Env (_, _, _) _ []) = False +assertTypeAndValue t v env = checkValueType t (findValueType v env) + +assertMTypeAndValue :: Maybe Type -> Value -> Env -> Bool +assertMTypeAndValue Nothing _ _ = False +assertMTypeAndValue (Just t) v env = assertTypeAndValue t v env isTypeValid :: Type -> Bool isTypeValid "Int" = True isTypeValid "Bool" = True isTypeValid _ = False -checkVars :: [Value] -> Maybe [Var] -> [Var] -> [VarAssignation] -> [FuncDeclaration] -> Bool -checkVarsTypes [] _ _ _ _ = False -checkVarsTypes _ [] _ _ _ = False -checkVarsTypes values param _ _ _ | length fst /= length scd = False -checkVarsTypes [(fs v)] [(ss t)] params vars env = assertTypeAndValue t v params vars env -checkVarsTypes ((fs v):xs) ((ss t):ys) params vars env - | assertTypeAndValue t v params vars env = checkVars xs ys params vars env +checkVarsTypes :: [Value] -> Maybe [Var] -> Env -> Bool +checkVarsTypes [] _ _ = False +checkVarsTypes _ Nothing _ = False +checkVarsTypes values (Just param) _ | length values /= length param = False +checkVarsTypes [v] (Just [(_, t)]) env = assertTypeAndValue t v env +checkVarsTypes (v:vs) (Just ((_, t):xs)) env + | assertTypeAndValue t v env = checkVarsTypes vs (Just xs) env | otherwise = False +checkVarsTypes _ _ _ = False -findFunc :: Symbol -> [FuncDeclaration] -> Maybe [Var] -findFunc s [] = Nothing -findFunc s ((FuncDeclaration (FuncPrototype s params _) _):xs) | s == s = Just params +findFunc :: Symbol -> [FuncPrototype] -> Maybe [Var] +findFunc _ [] = Nothing +findFunc s ((s', params, _):_) | s == s' = Just params findFunc s (_:xs) = findFunc s xs -checkCall :: FuncPrototype -> FuncCall -> [VarAssignation] -> [FuncDeclaration] -> [Instructions] -> Maybe [FuncDeclaration] -checkCall (FuncPrototype s params t) (symbol, values) vars env xs - | s == symbol && checkVars values (Just params) params vars env = - checkInstructions (FuncPrototype s param t) xs env vars - | otherwise = Nothing -checkCall (FuncPrototype _ params t) (s, values) vars env xs - | checkVars values (findFunc s env) params vars env = - checkInstructions (FuncPrototype s param t) xs env vars - -checkInstructions :: FuncPrototype -> [Instructions] -> [FuncDeclaration] -> [VarAssignation] -> Maybe [FuncDeclaration] -checkInstructions prototype ((Call func):xs) env vars = checkCall prototype func vars env xs -checkInstructions prototype ((Return ret):xs) env vars = checkReturn prototype ret vars env xs -checkInstructions prototype ((Declaration declaration):xs) env vars = checkDeclaration prototype declaration vars env xs -checkInstructions prototype ((Assignation assignation):xs) env vars = checkAssignation prototype declaration vars env xs -checkInstructions prototype ((Condition assignation):xs) env vars = checkAssignation prototype declaration vars env xs -checkInstructions _ _ _ = Nothing +checkCall :: FuncCall -> Env -> [Instruction] -> Bool +checkCall (symbol, values) (Env (s, params, t) vars env) xs + | s == symbol && checkVarsTypes values (Just params) (Env (s, params, t) vars env) || + checkVarsTypes values (findFunc symbol env) (Env (s, params, t) vars env) = + checkInstructions xs (Env (s, params, t) vars env) + | otherwise = False + +checkReturn :: Value -> Env -> [Instruction] -> Bool +checkReturn v (Env (s, params, t) vars env) xs + | assertTypeAndValue t v (Env (s, params, t) vars env) = + checkInstructions xs (Env (s, params, t) vars env) +checkReturn _ _ _ = False + +checkDeclaration :: VarDeclaration -> Env -> [Instruction] -> Bool +checkDeclaration ((s, t), v) (Env proto vars env) xs | + assertTypeAndValue t v (Env proto vars env) = + checkInstructions xs (Env proto ((s, v):vars) env) +checkDeclaration _ _ _ = False + +checkAssignation :: VarAssignation -> Env -> [Instruction] -> Bool +checkAssignation (s, v) env xs | assertMTypeAndValue (findValueType (Var s) env) v env = + checkInstructions xs env +checkAssignation _ _ _ = False + +checkCondition :: Condition -> Env -> [Instruction] -> Bool +checkCondition (v, fst_, snd_) env xs + | assertTypeAndValue "Bool" v env && checkInstructions fst_ env && + checkInstructions snd_ env = checkInstructions xs env +checkCondition _ _ _ = False + +checkInstructions :: [Instruction] -> Env -> Bool +checkInstructions [] _ = True +checkInstructions ((Call func):xs) env = checkCall func env xs +checkInstructions ((Return ret):xs) env = checkReturn ret env xs +checkInstructions ((Declaration declaration):xs) env = checkDeclaration declaration env xs +checkInstructions ((Assignation assignation):xs) env = checkAssignation assignation env xs +checkInstructions ((Cond condition):xs) env = checkCondition condition env xs checkVarTypes :: [Var] -> Bool -checkVarTypes [] = False +checkVarTypes [] = True checkVarTypes [x] = isTypeValid (snd x) checkVarTypes (x:xs) | isTypeValid (snd x) = checkVarTypes xs -checkFunction :: FuncDeclaration -> [FuncDeclaration] -> Maybe [FuncDeclaration] -checkFunction (FuncDeclaration (FuncPrototype _ args _) _) | not (checkVarTypes args) = Nothing -checkFunction (FuncDeclaration (FuncPrototype _ _ t) _) | not (isTypeValid t) = Nothing -checkFunction (FuncDeclaration prototype instructions) env = checkInstructions prototype instructions env [] +checkFunction :: FuncDeclaration -> [FuncPrototype] -> Bool +checkFunction ((_, args, _), _) _ | not (checkVarTypes args) = False +checkFunction ((_, _, t), _) _ | not (isTypeValid t) = False +checkFunction (prototype, instructions) env + | checkInstructions instructions (Env prototype [] env) = True +checkFunction _ _ = False -checkNotExisting :: FuncDeclaration -> [FuncDeclaration] -> Bool +checkNotExisting :: FuncDeclaration -> [FuncPrototype] -> Bool checkNotExisting _ [] = True -checkNotExisting (FuncDeclaration (FuncPrototype s _ _) _) ((FuncDeclaration (FuncPrototype ls _ _) _):xs) +checkNotExisting ((s, args, t), instr) ((ls, _, _):xs) | s == ls = False - | otherwise = checkNotExisting (FuncDeclaration (FuncPrototype s _ _) _) xs + | otherwise = checkNotExisting ((s, args, t), instr) xs + +receiveCheckFuncRes :: Bool -> [FuncDeclaration] -> FuncDeclaration -> [FuncPrototype] -> Bool +receiveCheckFuncRes True xs (prototype, _) env = checkDeclarations xs (Just (prototype:env)) +receiveCheckFuncRes _ _ _ _ = False -checkDeclarations :: [FuncDeclaration] -> Maybe [FuncDeclaration] -> Maybe [FuncDeclaration] -checkDeclarations _ Nothing = Nothing -checkDeclarations ((FuncDeclaration func):xs) (Just env) +checkDeclarations :: [FuncDeclaration] -> Maybe [FuncPrototype] -> Bool +checkDeclarations _ Nothing = False +checkDeclarations [] (Just _) = True +checkDeclarations (func:xs) (Just env) | checkNotExisting func env = - checkDeclarations xs (checkFunction func env) - | otherwise = Nothing -checkDeclarations _ _ = Nothing + receiveCheckFuncRes (checkFunction func env) xs func env + | otherwise = False + +createCalcPrototype :: Symbol -> Type -> FuncPrototype +createCalcPrototype s t = (s, [("x", t), ("y", t)], "Int") + +createCompPrototype :: Symbol -> Type -> FuncPrototype +createCompPrototype s t = (s, [("x", t), ("y", t)], "Bool") + +createCompPolyMorph :: Symbol -> [Type] -> [FuncPrototype] +createCompPolyMorph _ [] = [] +createCompPolyMorph s (x:xs) = createCompPrototype s x : createCompPolyMorph s xs + +createCompOp :: [Symbol] -> [FuncPrototype] +createCompOp [] = [] +createCompOp (x:xs) = createCompPolyMorph x ["Int", "Bool"] ++ createCompOp xs + +createCalcOp :: [Symbol] -> [FuncPrototype] +createCalcOp [] = [] +createCalcOp (x:xs) = createCalcPrototype x "Int" : createCalcOp xs + +defaultEnv :: Maybe [FuncPrototype] +defaultEnv = Just (createCalcOp ["+", "-", "*", "%", "/"] ++ createCompOp ["==", "!=", "<", ">", "<=", ">="]) -handleTypeCheck :: [FuncDeclaration] -> Maybe [FuncDeclaration] -handleTypeCheck expressions = checkDeclarations expressions (Just []) +typeCheck :: [FuncDeclaration] -> Bool +typeCheck expressions = checkDeclarations expressions defaultEnv diff --git a/lvtc/test/typeCheck.hs b/lvtc/test/typeCheck.hs new file mode 100644 index 0000000..534eeef --- /dev/null +++ b/lvtc/test/typeCheck.hs @@ -0,0 +1,22 @@ +import Test.Tasty +import Test.Tasty.HUnit +import AST + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "typeCheck tests" + [testReturn] + +testReturn :: TestTree +testReturn = testGroup "testReturn" [ + testCase "testReturn" (True == + (typeCheck (("main", [], "Int"), ([Declaration (("a", "Int"), Integer 0), Return (Integer 69)])))) +] + +shouldBeTrue :: [FuncDeclaration] -> Assertion +shouldBeTrue funcs = (typeCheck funcs) @?= True + +shouldBeFalse :: [FuncDeclaration] -> Assertion +shouldBeFalse funcs = (typeCheck funcs) @?= False From 2cd861617f5131595362c354c6c371e7a95e9f23 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Sun, 14 Jan 2024 14:48:43 +0100 Subject: [PATCH 13/26] Add awaiting tests --- lvtrun/app/Main.hs | 4 +--- lvtrun/lvtrun.cabal | 4 +--- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/lvtrun/app/Main.hs b/lvtrun/app/Main.hs index 0726d58..82bb18b 100644 --- a/lvtrun/app/Main.hs +++ b/lvtrun/app/Main.hs @@ -7,7 +7,5 @@ module Main (main) where -import Lib - main :: IO () -main = someFunc +main = return () diff --git a/lvtrun/lvtrun.cabal b/lvtrun/lvtrun.cabal index 4e28df2..fc42d2e 100644 --- a/lvtrun/lvtrun.cabal +++ b/lvtrun/lvtrun.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -24,8 +24,6 @@ source-repository head location: https://github.com/githubuser/lvtrun library - exposed-modules: - Lib other-modules: Paths_lvtrun autogen-modules: From d2d17aa06d6daabd3e8275b51f1256c986316761 Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Sun, 14 Jan 2024 20:18:11 +0100 Subject: [PATCH 14/26] Add while --- lvtc/src/AST.hs | 6 ++++ lvtc/src/Lexeme.hs | 2 ++ lvtc/src/ParseLvt.hs | 11 +++++++ lvtc/src/WasmUtils.hs | 4 +++ lvtc/src/WatAST.hs | 2 ++ lvtc/src/WatLike.hs | 14 +++++++++ lvtc/src/WatLikeToWat.hs | 62 ++++++++++++++++++++++------------------ lvtc/src/WriteWasm.hs | 4 +++ lvtc/test/lvt/Test.lvt | 15 ++++------ 9 files changed, 82 insertions(+), 38 deletions(-) diff --git a/lvtc/src/AST.hs b/lvtc/src/AST.hs index 16a6e80..bf071fd 100644 --- a/lvtc/src/AST.hs +++ b/lvtc/src/AST.hs @@ -18,6 +18,7 @@ module AST , Condition , Symbol , IsFuncExport + , WhileBlock ) where import Data.Int (Int32) @@ -77,12 +78,15 @@ type VarDeclaration = (Var, Value) type VarAssignation = (Symbol, Value) +type WhileBlock = (Value, [Instruction]) + data Instruction = Function FuncCall | Return Value | Declaration VarDeclaration | Assignation VarAssignation | Cond Condition + | While WhileBlock instance Show Instruction where show (Function x) = @@ -95,6 +99,8 @@ instance Show Instruction where "Assignation[< " ++ show x ++ " >]" show (Cond x) = "Cond[< " ++ show x ++ " >]" + show (While x) = + "While[< " ++ show x ++ " >]" instance Eq Instruction where (==) (Function x) (Function y) = x == y diff --git a/lvtc/src/Lexeme.hs b/lvtc/src/Lexeme.hs index f102d87..083d301 100644 --- a/lvtc/src/Lexeme.hs +++ b/lvtc/src/Lexeme.hs @@ -66,6 +66,8 @@ lexeme 0 ('i':'f':' ':xs) = lexeme 0 ('i':'f':xs) lexeme 0 (' ':'i':'f':xs) = lexeme 0 ('i':'f':xs) lexeme 0 ('e':'l':'s':'e':' ':xs) = lexeme 0 ('e':'l':'s':'e':xs) lexeme 0 (' ':'e':'l':'s':'e':xs) = lexeme 0 ('e':'l':'s':'e':xs) +lexeme 0 ('w':'h':'i':'l':'e':' ':xs) = lexeme 0 ('w':'h':'i':'l':'e':xs) +lexeme 0 (' ':'w':'h':'i':'l':'e':xs) = lexeme 0 ('w':'h':'i':'l':'e':xs) lexeme 0 ('\\':x:xs) = x : lexeme 0 xs lexeme 1 ('\\':x:xs) = x : lexeme 1 xs lexeme 0 (' ':' ':xs) = lexeme 0 (' ':xs) diff --git a/lvtc/src/ParseLvt.hs b/lvtc/src/ParseLvt.hs index c93fa17..74e6667 100644 --- a/lvtc/src/ParseLvt.hs +++ b/lvtc/src/ParseLvt.hs @@ -24,6 +24,7 @@ module ParseLvt parseDeclaration, parseAssignation, parseCond, + parseWhile, -- Function parseFuncDeclaration ) where @@ -269,9 +270,19 @@ parseCond = Parser f Nothing -> Nothing Just (ifBlock, ys) -> runParser (parseCond' val ifBlock) ys +parseWhileComp :: Parser Value +parseWhileComp = parseString "while(" *> parseValue <* parseString ")" + +parseWhileBlock :: Parser [Instruction] +parseWhileBlock = parseString "{" *> parseInstructions <* parseString "}" + +parseWhile :: Parser Instruction +parseWhile = While <$> ((,) <$> parseWhileComp <*> parseWhileBlock) + parseInstruction :: Parser Instruction parseInstruction = (parseCond + <|> parseWhile <|> parseReturn <|> parseDeclaration <|> parseAssignation diff --git a/lvtc/src/WasmUtils.hs b/lvtc/src/WasmUtils.hs index 07be5e2..f8fd87b 100644 --- a/lvtc/src/WasmUtils.hs +++ b/lvtc/src/WasmUtils.hs @@ -181,6 +181,8 @@ getSizeOpCode (LocalSet _) = 2 getSizeOpCode (I32Const _) = 2 getSizeOpCode (Call _) = 2 getSizeOpCode (If _) = 2 +getSizeOpCode (Loop _) = 2 +getSizeOpCode (Br _) = 2 getSizeOpCode _ = 1 fillBlankCodeSectionCode :: CodeSectionCode -> CodeSectionCode @@ -254,6 +256,8 @@ opCodeByte (Call _) = 0x10 opCodeByte (If EmptyType) = 0x04 opCodeByte Else = 0x05 opCodeByte End = 0x0b +opCodeByte (Loop EmptyType) = 0x03 +opCodeByte (Br _) = 0x0c ifTypeByte :: IfType -> Int ifTypeByte EmptyType = 0x40 diff --git a/lvtc/src/WatAST.hs b/lvtc/src/WatAST.hs index 91b353b..98cee4f 100644 --- a/lvtc/src/WatAST.hs +++ b/lvtc/src/WatAST.hs @@ -41,6 +41,8 @@ data OpCode = | If IfType | Else | End + | Loop IfType + | Br Int32 deriving (Show, Eq) data Type = diff --git a/lvtc/src/WatLike.hs b/lvtc/src/WatLike.hs index 0306fc3..ea8c9d0 100644 --- a/lvtc/src/WatLike.hs +++ b/lvtc/src/WatLike.hs @@ -119,6 +119,13 @@ modifyAll ((Cond (vValue, insIf, insElse)):xs) vsInd fsInd = (insElse', vsInd''', fsInd''') = modifyAll insElse vsInd'' fsInd'' newCond = Cond (vValue', insIf', insElse') (ins', vsInd'''', fsInd'''') = modifyAll xs vsInd''' fsInd''' +modifyAll ((While (vValue, ins)):xs) vsInd fsInd = + (newWhile:ins', vsInd''', fsInd''') + where + (vValue', vsInd', fsInd') = modifyAll' vValue vsInd fsInd + (insWhile, vsInd'', fsInd'') = modifyAll ins vsInd' fsInd' + newWhile = While (vValue', insWhile) + (ins', vsInd''', fsInd''') = modifyAll xs vsInd'' fsInd'' transformType :: Type -> Type transformType "Void" = "Int" @@ -266,6 +273,13 @@ instructionToWatLike (vsInd''', vInsFalse') = instructionsToWatLike vInsFalse oldFuncs vsInd'' newCond = Cond (vValCond', vInsTrue', vInsFalse') +instructionToWatLike + (While (vValCond, vIns)) oldFuncs vsInd = + (vsInd'', insCond ++ [newWhile]) + where + (vsInd', insCond, vValCond') = valueToWatLike vValCond oldFuncs vsInd + (vsInd'', vIns') = instructionsToWatLike vIns oldFuncs vsInd' + newWhile = While (vValCond', vIns' ++ insCond) instructionsToWatLike :: [Instruction] -> ([FuncDeclare], [Index]) -> [Index] -> ([Index], [Instruction]) diff --git a/lvtc/src/WatLikeToWat.hs b/lvtc/src/WatLikeToWat.hs index 5279a04..e0ce686 100644 --- a/lvtc/src/WatLikeToWat.hs +++ b/lvtc/src/WatLikeToWat.hs @@ -39,6 +39,8 @@ findTypeFromInstructions name ((Declaration ((name', typ), _)):xs) | otherwise = findTypeFromInstructions name xs findTypeFromInstructions name ((Cond (_, insIf, insElse)):xs) = findTypeFromInstructions name (insIf ++ insElse ++ xs) +findTypeFromInstructions name ((While (_, ins)):xs) = + findTypeFromInstructions name (ins ++ xs) findTypeFromInstructions name (_:xs) = findTypeFromInstructions name xs varsToDecl :: [Index] -> [Instruction] -> [Var] -> [(WatAST.Type, Int32)] @@ -76,43 +78,47 @@ valueToWat _ = error "value not supported" valuesToWat :: [Value] -> [OpCode] valuesToWat = concatMap valueToWat -instructionToWat :: Instruction -> [OpCode] -instructionToWat (AST.Return (Var indexName)) = +instructionToWat :: Instruction -> Int32 -> [OpCode] +instructionToWat (AST.Return (Var indexName)) _ = [ LocalGet (read indexName :: Int32) , WatAST.Return ] -instructionToWat (AST.Return _) = error "Return need a var" -instructionToWat (Declaration ((indexName, _), val)) = +instructionToWat (AST.Return _) _ = error "Return need a var" +instructionToWat (Declaration ((indexName, _), val)) _ = valueToWat val - ++ [ - LocalSet (read indexName :: Int32) - ] -instructionToWat (Assignation (indexName, val)) = + ++ [ LocalSet (read indexName :: Int32) ] +instructionToWat (Assignation (indexName, val)) _ = valueToWat val - ++ [ - LocalSet (read indexName :: Int32) - ] -instructionToWat (Function (indexName, values)) = + ++ [ LocalSet (read indexName :: Int32) ] +instructionToWat (Function (indexName, values)) _ = valuesToWat values - ++ [ - Call (read indexName :: Int32) - ] -instructionToWat (Cond (value, ifTrue, [])) = + ++ [ Call (read indexName :: Int32) ] +instructionToWat (Cond (value, ifTrue, [])) n = + valueToWat value + ++ [ If EmptyType ] ++ ins ++ [ End ] + where + ins = instructionsToWat ifTrue (n + 1) +instructionToWat (Cond (value, ifTrue, ifFalse)) n = valueToWat value - ++ [ If EmptyType ] - ++ instructionsToWat ifTrue - ++ [ End ] -instructionToWat (Cond (value, ifTrue, ifFalse)) = + ++ [ If EmptyType ] ++ insT ++ [ Else ] ++ insF ++ [ End ] + where + insT = instructionsToWat ifTrue (n + 1) + insF = instructionsToWat ifFalse (n + 1) +instructionToWat (While (value, ins)) n = valueToWat value - ++ [ If EmptyType ] - ++ instructionsToWat ifTrue - ++ [ Else ] - ++ instructionsToWat ifFalse - ++ [ End ] + ++ [ If EmptyType, Loop EmptyType ] + ++ ins' ++ valueToWat value ++ [ If EmptyType, Br (n + 1), End] + ++ [ End, End ] + where + ins' = instructionsToWat ins (n + 2) -instructionsToWat :: [Instruction] -> [OpCode] -instructionsToWat = concatMap instructionToWat +instructionsToWat :: [Instruction] -> Int32 -> [OpCode] +instructionsToWat [] _ = [] +instructionsToWat (x:xs) n = ins ++ inss + where + ins = instructionToWat x n + inss = instructionsToWat xs n -- -- instructionsToWat = foldr ((++) . instructionToWat) [] -- @@ -130,7 +136,7 @@ watLikeToWat (((isExp, fName, params, returnType), ins), vars, originName) pType = paramsToTypes params rType = typeStringToType returnType vDecl = groupVarsToDecl $ varsToDecl vars ins params - opcodes = instructionsToWat ins + opcodes = instructionsToWat ins 0 watsLikeToWat :: [FuncDeclare] -> [FuncDef] watsLikeToWat = map watLikeToWat diff --git a/lvtc/src/WriteWasm.hs b/lvtc/src/WriteWasm.hs index 8182161..7f8dd67 100644 --- a/lvtc/src/WriteWasm.hs +++ b/lvtc/src/WriteWasm.hs @@ -125,6 +125,10 @@ opCodeToByte (Call a) = B.pack [fromIntegral (opCodeByte (Call a)), fromIntegral a] opCodeToByte (If a) = B.pack [fromIntegral (opCodeByte (If a)), fromIntegral (ifTypeByte a)] +opCodeToByte (Br a) = + B.pack [fromIntegral (opCodeByte (Br a)), fromIntegral a] +opCodeToByte (Loop a) = + B.pack [fromIntegral (opCodeByte (Loop a)), fromIntegral (ifTypeByte a)] opCodeToByte op = B.pack [fromIntegral (opCodeByte op)] codeSectionCodeToByte :: CodeSectionCode -> B.ByteString diff --git a/lvtc/test/lvt/Test.lvt b/lvtc/test/lvt/Test.lvt index cb0a607..958840f 100644 --- a/lvtc/test/lvt/Test.lvt +++ b/lvtc/test/lvt/Test.lvt @@ -1,14 +1,9 @@ -fn factorial(n: Int) -> Int +export fn start() -> Int { - @Int a = n - 1; - if (a == 0) + @Int i = 0; + while (i < 10) { - <- 1; + i = i + 1; }; - <- n * factorial(a); -}; - -export fn start() -> Int -{ - <- factorial(5); + <- i; }; From 14f5dfd47834bf6c3261f13ee5e76d548a0aa47c Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Sun, 14 Jan 2024 20:20:11 +0100 Subject: [PATCH 15/26] Add while to bnf --- docs/BNF.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/docs/BNF.md b/docs/BNF.md index 1434673..fa144da 100644 --- a/docs/BNF.md +++ b/docs/BNF.md @@ -27,7 +27,7 @@ ::= ": " ::= ::= ";\n" - ::= | | | | + ::= | | | | | ::= "@" " " " = " ::= " = " ::= "(" * ")" @@ -39,6 +39,7 @@ ::= ::= "if (" ")\n{\n" * "}\n" ::= "else\n{\n" * "}\n" + ::= "while (" ")\n{\n" * "}\n" ::= "'" "'" ::= "True" | "False" From 63e6cd71504f417614ec4c04097c773525679f97 Mon Sep 17 00:00:00 2001 From: Tenshi Date: Sun, 14 Jan 2024 20:34:39 +0100 Subject: [PATCH 16/26] add some operations --- lvtrun/src/Run/Vm.hs | 44 +++++++++++++++++++++++++++++++++++++++++ lvtrun/src/Types.hs | 3 +++ lvtrun/test/while.wasm | Bin 0 -> 216 bytes 3 files changed, 47 insertions(+) create mode 100644 lvtrun/test/while.wasm diff --git a/lvtrun/src/Run/Vm.hs b/lvtrun/src/Run/Vm.hs index 6bee410..6723d3b 100644 --- a/lvtrun/src/Run/Vm.hs +++ b/lvtrun/src/Run/Vm.hs @@ -109,6 +109,41 @@ execIf cEx@(CurrentExec {ceStack = stack}) = case stackTop stack of I_32 _ -> throw $ RuntimeError "execIf: bad if statement" _ -> throw $ RuntimeError "execIf: bad type" +execI32GtS :: CurrentExec -> CurrentExec +execI32GtS cEx@(CurrentExec {ceStack = stack}) = + case (stackPopN stack 2) of + ([I_32 val2, I_32 val1], newStack) -> case (val1 > val2) of + True -> cEx { ceStack = stackPush newStack (I_32 1) } + False -> cEx { ceStack = stackPush newStack (I_32 0) } + +execI32GeS :: CurrentExec -> CurrentExec +execI32GeS cEx@(CurrentExec {ceStack = stack}) = + case (stackPopN stack 2) of + ([I_32 val2, I_32 val1], newStack) -> case (val1 >= val2) of + True -> cEx { ceStack = stackPush newStack (I_32 1) } + False -> cEx { ceStack = stackPush newStack (I_32 0) } + +execI32LtS :: CurrentExec -> CurrentExec +execI32LtS cEx@(CurrentExec {ceStack = stack}) = + case (stackPopN stack 2) of + ([I_32 val2, I_32 val1], newStack) -> case (val1 < val2) of + True -> cEx { ceStack = stackPush newStack (I_32 1) } + False -> cEx { ceStack = stackPush newStack (I_32 0) } + +execI32LeS :: CurrentExec -> CurrentExec +execI32LeS cEx@(CurrentExec {ceStack = stack}) = + case (stackPopN stack 2) of + ([I_32 val2, I_32 val1], newStack) -> case (val1 <= val2) of + True -> cEx { ceStack = stackPush newStack (I_32 1) } + False -> cEx { ceStack = stackPush newStack (I_32 0) } + +execI32GtU :: CurrentExec -> CurrentExec +execI32GtU cEx@(CurrentExec {ceStack = stack}) = + case (stackPopN stack 2) of + ([I_32 val2, I_32 val1], newStack) -> case ((fromIntegral val1) > (fromIntegral val2)) of + True -> cEx { ceStack = stackPush newStack (I_32 1) } + False -> cEx { ceStack = stackPush newStack (I_32 0) } + execOpCode :: VM -> CurrentExec -> Instruction -> CurrentExec execOpCode _ cEx (Unreachable) = throw $ RuntimeError "execOpCode: unreachable" execOpCode _ cEx (End) = decrementBlockIdx cEx @@ -126,8 +161,17 @@ execOpCode _ cEx (SetLocal localIdx) = execSetLocal cEx localIdx execOpCode _ cEx (BrIf labelIdx) = execBrIf cEx execOpCode vm cEx (Call funcIdx) = execCall vm cEx funcIdx execOpCode _ cEx (If) = execIf cEx +execOpCode _ cEx (I32Gts) = execI32GtS cEx +execOpCode _ cEx (I32Ges) = execI32GeS cEx +execOpCode _ cEx (I32Lts) = execI32LtS cEx +execOpCode _ cEx (I32Les) = execI32LeS cEx +execOpCode _ cEx (I32Gtu) = execI32GtU cEx execOpCode _ cEx _ = cEx +--IF/ELSE +--LOOP +--BR + execOpCodes :: VM -> [Instruction] -> CurrentExec execOpCodes vm [] = currentExec vm execOpCodes vm instructions diff --git a/lvtrun/src/Types.hs b/lvtrun/src/Types.hs index 6807b19..7d91761 100644 --- a/lvtrun/src/Types.hs +++ b/lvtrun/src/Types.hs @@ -130,6 +130,9 @@ data Instruction = | MemorySize | MemoryGrow deriving (Eq) +--IF/ELSE +--LOOP +--BR instance Show Instruction where show Unreachable = "\n\t\t\t\tunreachable" diff --git a/lvtrun/test/while.wasm b/lvtrun/test/while.wasm new file mode 100644 index 0000000000000000000000000000000000000000..6e810de67508e7782e04ce9dffb22d06c58f474f GIT binary patch literal 216 zcmZY2I}XAy7z1EC4<7j|rAJ6^(kulb#2MNZ=t8^aE}WDM{Ub(=pMLikcnNJxCf9WTXOu_#8xRdG|?6%WNF%E&`4$V|*AA)EGN adY^5wZm>gPcCB$evQPeh(NRPaqWl1&Q50kV literal 0 HcmV?d00001 From a4b3a3727cc2c28e0317d739f5e38d83fb1e0e76 Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Sun, 14 Jan 2024 21:03:06 +0100 Subject: [PATCH 17/26] Fix documentation --- book.toml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/book.toml b/book.toml index c40f347..9725d91 100644 --- a/book.toml +++ b/book.toml @@ -1,7 +1,7 @@ [book] -title = "Koaky (Yet Another Programming Language)" +title = "Leviator (Yet Another Programming Language)" authors = ["@Saverio976", "@TTENSHII", "@guillaumeAbel"] -description = "Documentation of Koaky" +description = "Documentation of Leviator" src = "docs" [build] @@ -10,8 +10,8 @@ create-missing = false use-default-preprocessors = true [output.html] -git-repository-url = "https://github.com/X-R-G-B/koak" -edit-url-template = "https://github.com/X-R-G-B/koak/edit/main/{path}" +git-repository-url = "https://github.com/X-R-G-B/Leviator" +edit-url-template = "https://github.com/X-R-G-B/Leviator/edit/main/{path}" [output.html.search] enable = true From 4010983a2c7c84730b7761888e9991db1be9333e Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Sun, 14 Jan 2024 21:04:41 +0100 Subject: [PATCH 18/26] Fix type char --- lvtc/src/WatLike.hs | 14 +++++++------- lvtc/test/lvt/Test.lvt | 13 ++++++------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/lvtc/src/WatLike.hs b/lvtc/src/WatLike.hs index ea8c9d0..2c9d5b8 100644 --- a/lvtc/src/WatLike.hs +++ b/lvtc/src/WatLike.hs @@ -74,6 +74,12 @@ modifyAll' x varsIndex funcsIndex = (x, varsIndex, funcsIndex) --- +transformType :: Type -> Type +transformType "Void" = "Int" +transformType "Char" = "Int" +transformType "Bool" = "Int" +transformType x = x + modifyAll :: [Instruction] -> [Index] -> [Index] -> ([Instruction], [Index], [Index]) modifyAll [] varsIndex funcsIndex = ([], varsIndex, funcsIndex) @@ -127,12 +133,6 @@ modifyAll ((While (vValue, ins)):xs) vsInd fsInd = newWhile = While (vValue', insWhile) (ins', vsInd''', fsInd''') = modifyAll xs vsInd'' fsInd'' -transformType :: Type -> Type -transformType "Void" = "Int" -transformType "Char" = "Int" -transformType "Bool" = "Int" -transformType x = x - registerParams :: FuncDeclare -> FuncDeclare registerParams (((isExp, fName, [], typ), ins), varsIndex, oName) = (((isExp, fName, [], transformType typ), ins), varsIndex, oName) @@ -244,7 +244,7 @@ instructionToWatLike (varsIndex', ins' ++ [newDeclaration]) where (varsIndex', ins', vValue') = valueToWatLike vValue oldFuncs varsIndex - newDeclaration = Declaration ((vName, vTyp), vValue') + newDeclaration = Declaration ((vName, transformType vTyp), vValue') instructionToWatLike (Assignation (vName, vValue)) oldFuncs varsIndex = (varsIndex', ins' ++ [newAssignation]) diff --git a/lvtc/test/lvt/Test.lvt b/lvtc/test/lvt/Test.lvt index 958840f..2681727 100644 --- a/lvtc/test/lvt/Test.lvt +++ b/lvtc/test/lvt/Test.lvt @@ -1,9 +1,8 @@ -export fn start() -> Int +export fn start() -> Char { - @Int i = 0; - while (i < 10) - { - i = i + 1; - }; - <- i; + @Int a = 0 + 1; + @Int b = a - 1; + @Int c = a * b; + @Int d = c / a; + <- d; }; From 7ef7c25228a816ebc97e7aa56c649e067e280abf Mon Sep 17 00:00:00 2001 From: Tenshi Date: Sun, 14 Jan 2024 21:59:57 +0100 Subject: [PATCH 19/26] add loop --- lvtrun/src/OpCodes.hs | 6 +++--- lvtrun/src/Run/Functions.hs | 8 ++++---- lvtrun/src/Run/Locals.hs | 12 ++++++------ lvtrun/src/Run/Types.hs | 36 ++++++++++++++++++++++++++++++++++-- lvtrun/src/Run/Vm.hs | 14 ++++++++++++-- lvtrun/src/Types.hs | 2 ++ 6 files changed, 61 insertions(+), 17 deletions(-) diff --git a/lvtrun/src/OpCodes.hs b/lvtrun/src/OpCodes.hs index a8788da..8ef96a7 100644 --- a/lvtrun/src/OpCodes.hs +++ b/lvtrun/src/OpCodes.hs @@ -21,7 +21,6 @@ import Leb128 (getLEB128ToI32, getLEB128ToI64) import Types (Instruction(..), MemArg(..), BlockType(..)) extractOpCode' :: [Word8] -> ([Word8], BSL.ByteString) -extractOpCode' (0x03:rest) = ([0x03], BSL.pack rest) extractOpCode' (0x11:rest) = ([0x11], BSL.pack rest) extractOpCode' (0x00:rest) = ([0x00], BSL.pack rest) extractOpCode' (0x0b:rest) = ([0x0b], BSL.pack rest) @@ -61,13 +60,13 @@ extractOpCode' (0x47:rest) = ([0x47], BSL.pack rest) extractOpCode' (0x3f:0x00:rest) = ([0x3f, 0x00], BSL.pack rest) extractOpCode' (0x40:0x00:rest) = ([0x40, 0x00], BSL.pack rest) extractOpCode' (0x04:0x40:rest) = ([0x04, 0x40], BSL.pack rest) -extractOpCode' _ = throw $ WasmError "ExtractOpCode: bad opcode" +extractOpCode' (0x03:0x40:rest) = ([0x03, 0x40], BSL.pack rest) +extractOpCode' idx = throw $ WasmError "ExtractOpCode: bad opcode" extractOpCode :: BSL.ByteString -> ([Word8], BSL.ByteString) extractOpCode bytes = extractOpCode' (BSL.unpack bytes) createInstruction :: [Word8] -> BSL.ByteString -> (Instruction, BSL.ByteString) -createInstruction [0x03] bytes = (Nop, bytes) createInstruction [0x11] bytes = (Nop, bytes) createInstruction [0x00] bytes = (Unreachable, bytes) createInstruction [0x01] bytes = (Nop, bytes) @@ -89,6 +88,7 @@ createInstruction [0x4e] bytes = (I32Ges, bytes) createInstruction [0x4c] bytes = (I32Les, bytes) createInstruction [0x71] bytes = (I32And, bytes) createInstruction [0x04, 0x40] bytes = (If, bytes) +createInstruction [0x03, 0x40] bytes = (Loop, bytes) createInstruction [0x3f, 0x00] bytes = (MemorySize, bytes) createInstruction [0x40, 0x00] bytes = (MemoryGrow, bytes) createInstruction [0x0d] bytes = (\(value, rest) -> diff --git a/lvtrun/src/Run/Functions.hs b/lvtrun/src/Run/Functions.hs index 293a968..b85f113 100644 --- a/lvtrun/src/Run/Functions.hs +++ b/lvtrun/src/Run/Functions.hs @@ -21,16 +21,16 @@ import Errors (CustomException(..)) import Types (Export(..), ExportDesc(..), Function(..), FuncType(..)) getStartFunctionId :: [Export] -> Int32 -getStartFunctionId [] = throw $ WasmError "No start function" +getStartFunctionId [] = throw $ RuntimeError "No start function" getStartFunctionId (x:xs) | expName x == "start" = case expDesc x of ExportFunc idx -> idx - _ -> throw $ WasmError "getStartFunctionId: bad export" + _ -> throw $ RuntimeError "getStartFunctionId: bad export" | otherwise = getStartFunctionId xs getFunctionFromId :: Int32 -> [Function] -> Function -getFunctionFromId _ [] = throw $ WasmError "getFunctionFromId: bad id" +getFunctionFromId _ [] = throw $ RuntimeError "getFunctionFromId: bad id" getFunctionFromId id (x:xs) | funcIdx x == id = x | otherwise = getFunctionFromId id xs @@ -40,7 +40,7 @@ getStartFunction exports functions = getFunctionFromId (getStartFunctionId exports) functions getFuncTypeFromId :: Int32 -> [FuncType] -> FuncType -getFuncTypeFromId _ [] = throw $ WasmError "getFuncTypeFromId: bad id" +getFuncTypeFromId _ [] = throw $ RuntimeError "getFuncTypeFromId: bad id" getFuncTypeFromId id (x:xs) | typeId x == id = x | otherwise = getFuncTypeFromId id xs diff --git a/lvtrun/src/Run/Locals.hs b/lvtrun/src/Run/Locals.hs index 4c9c30f..8ee99f0 100644 --- a/lvtrun/src/Run/Locals.hs +++ b/lvtrun/src/Run/Locals.hs @@ -25,9 +25,9 @@ import Run.Stack (Stack, stackPopN) type Locals = [Value] getLocalFromId' :: Int32 -> LocalIdx -> Locals -> Value -getLocalFromId' _ _ [] = throw $ WasmError "getLocalFromId: bad id" +getLocalFromId' _ _ [] = throw $ RuntimeError "getLocalFromId: bad id" getLocalFromId' idx idntifier (x:xs) - | idx > idntifier = throw $ WasmError "getLocalFromId: bad id" + | idx > idntifier = throw $ RuntimeError "getLocalFromId: bad id" | idx == idntifier = x | otherwise = getLocalFromId' (idx + 1) idntifier xs @@ -35,9 +35,9 @@ getLocalFromId :: Locals -> LocalIdx -> Value getLocalFromId lcals idntifier = getLocalFromId' 0 idntifier lcals setLocalWithId :: Int32 -> Locals -> Value -> LocalIdx -> Locals -setLocalWithId _ [] _ _ = throw $ WasmError "setLocalWithId: bad id" +setLocalWithId _ [] _ _ = throw $ RuntimeError "setLocalWithId: bad id" setLocalWithId idx (x:xs) value idntifier - | idx > idntifier = throw $ WasmError "setLocalWithId: bad id" + | idx > idntifier = throw $ RuntimeError "setLocalWithId: bad id" | idx == idntifier = value : xs | otherwise = x : setLocalWithId (idx + 1) xs value idntifier @@ -64,7 +64,7 @@ createLocalsParams (F32:xs) (F_32 val:xs2) = (F_32 val : createLocalsParams xs xs2) createLocalsParams (F64:xs) (F_64 val:xs2) = (F_64 val : createLocalsParams xs xs2) -createLocalsParams _ _ = throw $ WasmError "createLocalsParams: bad type" +createLocalsParams _ _ = throw $ RuntimeError "createLocalsParams: bad type" initLocalsParams' :: (Locals, Stack) -> [TypeName] -> (Locals, Stack) initLocalsParams' ([], newStack) _ = ([], newStack) @@ -74,7 +74,7 @@ initLocalsParams' (values, newStack) prms = initLocalsParams :: [TypeName] -> Stack -> (Locals, Stack) initLocalsParams [] stack = ([], stack) initLocalsParams prms stack - | length prms > length stack = throw $ WasmError "initLocalsParam: bad nb" + | length prms > length stack = throw $ RuntimeError "initLocalsParam: bad nb" | otherwise = initLocalsParams' (stackPopN stack (length prms)) prms initLocals :: [Local] -> [TypeName] -> Stack -> (Locals, Stack) diff --git a/lvtrun/src/Run/Types.hs b/lvtrun/src/Run/Types.hs index e3f8de6..9a3ebf1 100644 --- a/lvtrun/src/Run/Types.hs +++ b/lvtrun/src/Run/Types.hs @@ -13,22 +13,29 @@ module Run.Types createVm, incrementInstIdx, createEmptyExec, - decrementBlockIdx + decrementBlockIdx, + getLabelOpIdx, + addLabel, + incrementBlockIdx, + goToLabel ) where import Data.Word (Word8) +import Control.Exception (throw) import Types +import Data.Int (Int32) import Run.Stack (Stack) import Run.Locals (Locals) +import Errors (CustomException(..)) data CurrentExec = CurrentExec { ceLocals :: Locals, ceStack :: Stack, ceInstructions :: [Instruction], ceInstIdx :: Int, - ceLabels :: [Int], + ceLabels :: [Int32], ceParams :: [TypeName], ceResults :: [TypeName], crBlockIndents :: Int @@ -58,9 +65,34 @@ createVm wasmMod = VM { vmStack = [], wasmModule = wasmMod } +goToLabel :: CurrentExec -> LabelIdx -> CurrentExec +goToLabel cEx labelIdx = cEx {ceInstIdx = fromIntegral (getLabelOpIdx cEx labelIdx)} + +getLabelOpIdx :: CurrentExec -> LabelIdx -> Int +getLabelOpIdx cEx labelIdx + | labelIdx >= fromIntegral (length (ceLabels cEx)) = + throw $ RuntimeError "getLabelOpIdx: bad index" + | otherwise = (fromIntegral (ceLabels cEx !! fromIntegral labelIdx)) + +doesLabelExist :: [Int32] -> LabelIdx -> Bool +doesLabelExist [] _ = False +doesLabelExist (x:xs) labelIdx + | x == labelIdx = True + | otherwise = doesLabelExist xs labelIdx + +addLabel :: CurrentExec -> CurrentExec +addLabel cEx + | doesLabelExist (ceLabels cEx) labelIdx = cEx + | otherwise = cEx { ceLabels = (ceLabels cEx) ++ [labelIdx] } + where + labelIdx = fromIntegral (ceInstIdx cEx) + incrementInstIdx :: CurrentExec -> CurrentExec incrementInstIdx cEx = cEx { ceInstIdx = ceInstIdx cEx + 1 } +incrementBlockIdx :: CurrentExec -> CurrentExec +incrementBlockIdx cEx = cEx { crBlockIndents = (crBlockIndents cEx) + 1 } + decrementBlockIdx :: CurrentExec -> CurrentExec decrementBlockIdx cEx = cEx { crBlockIndents = (crBlockIndents cEx) - 1 } diff --git a/lvtrun/src/Run/Vm.hs b/lvtrun/src/Run/Vm.hs index 6723d3b..96d62c5 100644 --- a/lvtrun/src/Run/Vm.hs +++ b/lvtrun/src/Run/Vm.hs @@ -105,7 +105,7 @@ execCall vm cEx funcIdx = cEx { ceStack = newStack } execIf :: CurrentExec -> CurrentExec execIf cEx@(CurrentExec {ceStack = stack}) = case stackTop stack of I_32 0 -> goToEndInstruction cEx - I_32 1 -> cEx { crBlockIndents = (crBlockIndents cEx) + 1 } + I_32 1 -> addLabel (cEx { crBlockIndents = (crBlockIndents cEx) + 1 }) I_32 _ -> throw $ RuntimeError "execIf: bad if statement" _ -> throw $ RuntimeError "execIf: bad type" @@ -144,13 +144,18 @@ execI32GtU cEx@(CurrentExec {ceStack = stack}) = True -> cEx { ceStack = stackPush newStack (I_32 1) } False -> cEx { ceStack = stackPush newStack (I_32 0) } +incrementBlockIndent :: CurrentExec -> CurrentExec +incrementBlockIndent cEx = cEx { crBlockIndents = (crBlockIndents cEx) + 1 } + +execBr :: CurrentExec -> LabelIdx -> CurrentExec +execBr cEx labelIdx = goToLabel cEx labelIdx + execOpCode :: VM -> CurrentExec -> Instruction -> CurrentExec execOpCode _ cEx (Unreachable) = throw $ RuntimeError "execOpCode: unreachable" execOpCode _ cEx (End) = decrementBlockIdx cEx execOpCode _ cEx (Return) = decrementBlockIdx cEx execOpCode _ cEx (I32Const val) = execI32Const cEx val execOpCode _ cEx (I32Eqz) = execI32Eqz cEx -execOpCode _ cEx (Block _) = cEx { crBlockIndents = (crBlockIndents cEx) + 1 } execOpCode _ cEx (I32Eq) = execI32Eq cEx execOpCode _ cEx (I32Add) = execI32Add cEx execOpCode _ cEx (I32Sub) = execI32Sub cEx @@ -166,12 +171,17 @@ execOpCode _ cEx (I32Ges) = execI32GeS cEx execOpCode _ cEx (I32Lts) = execI32LtS cEx execOpCode _ cEx (I32Les) = execI32LeS cEx execOpCode _ cEx (I32Gtu) = execI32GtU cEx +execOpCode _ cEx (Block _) = incrementBlockIndent (addLabel cEx) +execOpCode _ cEx (Br labelIdx) = execBr cEx labelIdx +execOpCode _ cEx (Loop) = incrementBlockIndent (addLabel cEx) execOpCode _ cEx _ = cEx --IF/ELSE --LOOP --BR + + execOpCodes :: VM -> [Instruction] -> CurrentExec execOpCodes vm [] = currentExec vm execOpCodes vm instructions diff --git a/lvtrun/src/Types.hs b/lvtrun/src/Types.hs index 7d91761..0c2ac91 100644 --- a/lvtrun/src/Types.hs +++ b/lvtrun/src/Types.hs @@ -121,6 +121,7 @@ data Instruction = | I32Les | I32Ges | I32Ne + | Loop | LocalTee LocalIdx | BrIf LabelIdx | If @@ -173,6 +174,7 @@ instance Show Instruction where show (Br idx) = "\n\t\t\t\tbr " ++ (show idx) show End = "\n\t\t\t\tend" show (Block blockType) = "\n\t\t\t\tblock " ++ (show blockType) + show (Loop) = "\n\t\t\t\tloop" -- Module section From 38ea15597bea2ce34a55f8ebc01b90b8971f4d20 Mon Sep 17 00:00:00 2001 From: Tenshi Date: Sun, 14 Jan 2024 22:08:46 +0100 Subject: [PATCH 20/26] fix norm --- lvtrun/src/Run/Types.hs | 3 ++- lvtrun/src/Run/Vm.hs | 13 ++++--------- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/lvtrun/src/Run/Types.hs b/lvtrun/src/Run/Types.hs index 9a3ebf1..737efb7 100644 --- a/lvtrun/src/Run/Types.hs +++ b/lvtrun/src/Run/Types.hs @@ -66,7 +66,8 @@ createVm wasmMod = VM { vmStack = [], } goToLabel :: CurrentExec -> LabelIdx -> CurrentExec -goToLabel cEx labelIdx = cEx {ceInstIdx = fromIntegral (getLabelOpIdx cEx labelIdx)} +goToLabel cEx labelIdx = + cEx {ceInstIdx = fromIntegral (getLabelOpIdx cEx labelIdx)} getLabelOpIdx :: CurrentExec -> LabelIdx -> Int getLabelOpIdx cEx labelIdx diff --git a/lvtrun/src/Run/Vm.hs b/lvtrun/src/Run/Vm.hs index 96d62c5..ef0b6b1 100644 --- a/lvtrun/src/Run/Vm.hs +++ b/lvtrun/src/Run/Vm.hs @@ -140,9 +140,10 @@ execI32LeS cEx@(CurrentExec {ceStack = stack}) = execI32GtU :: CurrentExec -> CurrentExec execI32GtU cEx@(CurrentExec {ceStack = stack}) = case (stackPopN stack 2) of - ([I_32 val2, I_32 val1], newStack) -> case ((fromIntegral val1) > (fromIntegral val2)) of - True -> cEx { ceStack = stackPush newStack (I_32 1) } - False -> cEx { ceStack = stackPush newStack (I_32 0) } + ([I_32 val2, I_32 val1], newStack) -> + case ((fromIntegral val1) > (fromIntegral val2)) of + True -> cEx { ceStack = stackPush newStack (I_32 1) } + False -> cEx { ceStack = stackPush newStack (I_32 0) } incrementBlockIndent :: CurrentExec -> CurrentExec incrementBlockIndent cEx = cEx { crBlockIndents = (crBlockIndents cEx) + 1 } @@ -176,12 +177,6 @@ execOpCode _ cEx (Br labelIdx) = execBr cEx labelIdx execOpCode _ cEx (Loop) = incrementBlockIndent (addLabel cEx) execOpCode _ cEx _ = cEx ---IF/ELSE ---LOOP ---BR - - - execOpCodes :: VM -> [Instruction] -> CurrentExec execOpCodes vm [] = currentExec vm execOpCodes vm instructions From a0f771e7ce6755d6eec37a86c2105400c14750b8 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Sun, 14 Jan 2024 22:36:56 +0100 Subject: [PATCH 21/26] Add type checker --- lvtc/lvtc.cabal | 102 +++++++++++++++++++++++++++++++++++++ lvtc/src/TypeCheck.hs | 107 ++++++++++++++++++++++++--------------- lvtc/test/Spec.hs | 4 +- lvtc/test/UTTypeCheck.hs | 64 +++++++++++++++++++++++ lvtc/test/typeCheck.hs | 22 -------- 5 files changed, 235 insertions(+), 64 deletions(-) create mode 100644 lvtc/lvtc.cabal create mode 100644 lvtc/test/UTTypeCheck.hs delete mode 100644 lvtc/test/typeCheck.hs diff --git a/lvtc/lvtc.cabal b/lvtc/lvtc.cabal new file mode 100644 index 0000000..bf73442 --- /dev/null +++ b/lvtc/lvtc.cabal @@ -0,0 +1,102 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: lvtc +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/lvtc#readme +bug-reports: https://github.com/githubuser/lvtc/issues +author: Author name here +maintainer: example@example.com +copyright: 2023 Author name here +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/githubuser/lvtc + +library + exposed-modules: + Alias + AST + Builtins + Expression + Leb128Encode + Lexeme + Lib + LvtLibVersion + ParseLvt + Parser + ParseUtil + ShuntingYard + TypeCheck + Wasm + WasmUtils + WatAST + WatLike + WatLikeToWat + WatToWasm + WriteWasm + other-modules: + Paths_lvtc + autogen-modules: + Paths_lvtc + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , bytestring + default-language: Haskell2010 + +executable lvtc-exe + main-is: Main.hs + other-modules: + Args + Run + Version + Paths_lvtc + autogen-modules: + Paths_lvtc + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , directory + , filepath + , lvtc + default-language: Haskell2010 + +test-suite lvtc-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + UTLexeme + UTParseLvt + UTShuntingYard + UTTypeCheck + UTWasm + UTWat + UTWatLike + Paths_lvtc + autogen-modules: + Paths_lvtc + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , lvtc + , process + , tasty + , tasty-hunit + default-language: Haskell2010 diff --git a/lvtc/src/TypeCheck.hs b/lvtc/src/TypeCheck.hs index dd536f8..9a2f09d 100644 --- a/lvtc/src/TypeCheck.hs +++ b/lvtc/src/TypeCheck.hs @@ -10,7 +10,6 @@ module TypeCheck ) where import AST -import Debug.Trace data Env = Env FuncPrototype [VarAssignation] [FuncPrototype] @@ -26,11 +25,12 @@ findVarInVar s ((s', v):xs) env | s == s' = findValueType v env | otherwise = findVarInVar s xs env -findTypeReturnFunc :: Symbol -> [FuncPrototype] -> Maybe FuncPrototype -findTypeReturnFunc _ [] = Nothing -findTypeReturnFunc s ((s', ps, t):xs) - | s == s' = Just (s', ps, t) - | otherwise = findTypeReturnFunc s xs +findTypeReturnFunc :: Symbol -> Env -> Maybe FuncPrototype +findTypeReturnFunc s (Env (e, s', ps, t) _ _) | s == s' = Just (e, s', ps, t) +findTypeReturnFunc _ (Env _ _ []) = Nothing +findTypeReturnFunc s (Env proto vars ((e, s', ps, t):xs)) + | s == s' = Just (e, s', ps, t) + | otherwise = findTypeReturnFunc s (Env proto vars xs) getValueType :: Value -> Maybe Type getValueType (Integer _) = Just "Int" @@ -40,20 +40,22 @@ getValueType _ = Nothing checkFuncType :: [Value] -> Env -> Maybe FuncPrototype -> Maybe Type checkFuncType _ _ Nothing = Nothing -checkFuncType [] _ _ = Nothing -checkFuncType callParams (Env proto params env) (Just (_, ps, t)) +checkFuncType callParams (Env proto params env) (Just (_, _, ps, t)) | checkVarsTypes callParams (Just ps) (Env proto params env) = Just t | otherwise = Nothing handleFinders :: Maybe Type -> Symbol -> Env -> Maybe Type -handleFinders _ _ (Env (_, [], _) [] _) = Nothing -handleFinders Nothing s (Env proto vars env) = findVarInVar s vars (Env proto vars env) +handleFinders _ _ (Env (_, _, [], _) [] _) = Nothing +handleFinders Nothing s (Env proto vars env) = + findVarInVar s vars (Env proto vars env) handleFinders (Just t) _ _ = Just t findValueType :: Value -> Env -> Maybe Type -findValueType (Var s) (Env (ps, params, t) vars env) = - handleFinders (findVarInParams s params (Env (ps, params, t) vars env)) s (Env (ps, params, t) vars env) -findValueType (FuncValue (s, vs)) (Env proto vars env) = checkFuncType vs (Env proto vars env) (findTypeReturnFunc s env) +findValueType (Var s) (Env (e, ps, params, t) vars env) = + handleFinders (findVarInParams s params (Env (e, ps, params, t) vars env)) + s (Env (e, ps, params, t) vars env) +findValueType (FuncValue (s, vs)) env = + checkFuncType vs env (findTypeReturnFunc s env) findValueType v _ = getValueType v checkValueType :: Type -> Maybe Type -> Bool @@ -61,22 +63,21 @@ checkValueType _ Nothing = False checkValueType t (Just t') = t == t' assertTypeAndValue :: Type -> Value -> Env -> Bool -assertTypeAndValue _ (Var _) (Env (_, [], _) [] _) = False -assertTypeAndValue _ (FuncValue _) (Env (_, _, _) _ []) = False +assertTypeAndValue _ (Var _) (Env (_, _, [], _) [] _) = False assertTypeAndValue t v env = checkValueType t (findValueType v env) assertMTypeAndValue :: Maybe Type -> Value -> Env -> Bool assertMTypeAndValue Nothing _ _ = False assertMTypeAndValue (Just t) v env = assertTypeAndValue t v env -sFu + isTypeValid :: Type -> Bool isTypeValid "Int" = True isTypeValid "Bool" = True isTypeValid _ = False checkVarsTypes :: [Value] -> Maybe [Var] -> Env -> Bool -checkVarsTypes [] _ _ = False checkVarsTypes _ Nothing _ = False +checkVarsTypes [] (Just []) _ = True checkVarsTypes values (Just param) _ | length values /= length param = False checkVarsTypes [v] (Just [(_, t)]) env = assertTypeAndValue t v env checkVarsTypes (v:vs) (Just ((_, t):xs)) env @@ -86,30 +87,48 @@ checkVarsTypes _ _ _ = False findFunc :: Symbol -> [FuncPrototype] -> Maybe [Var] findFunc _ [] = Nothing -findFunc s ((s', params, _):_) | s == s' = Just params +findFunc s ((_, s', params, _):_) | s == s' = Just params findFunc s (_:xs) = findFunc s xs checkCall :: FuncCall -> Env -> [Instruction] -> Bool -checkCall (symbol, values) (Env (s, params, t) vars env) xs - | s == symbol && checkVarsTypes values (Just params) (Env (s, params, t) vars env) || - checkVarsTypes values (findFunc symbol env) (Env (s, params, t) vars env) = - checkInstructions xs (Env (s, params, t) vars env) +checkCall (symbol, values) (Env (e, s, params, t) vars env) xs + | s == symbol && + checkVarsTypes values (Just params) (Env (e, s, params, t) vars env) || + checkVarsTypes values (findFunc symbol env) + (Env (e, s, params, t) vars env) = + checkInstructions xs (Env (e, s, params, t) vars env) | otherwise = False checkReturn :: Value -> Env -> [Instruction] -> Bool -checkReturn v (Env (s, params, t) vars env) xs - | assertTypeAndValue t v (Env (s, params, t) vars env) = - checkInstructions xs (Env (s, params, t) vars env) +checkReturn v (Env (e, s, params, t) vars env) xs + | assertTypeAndValue t v (Env (e, s, params, t) vars env) = + checkInstructions xs (Env (e, s, params, t) vars env) checkReturn _ _ _ = False +findInVar :: Symbol -> [Var] -> Bool +findInVar _ [] = False +findInVar s ((s', _):_) | s == s' = True +findInVar s (_:xs) = findInVar s xs + +searchName :: Symbol -> [VarAssignation] -> [Var] -> Bool +searchName s [] vars = findInVar s vars +searchName s ((s', _):_) _ | s == s' = True +searchName s (_:xs) params = searchName s xs params + +nameExist :: Symbol -> FuncPrototype -> [VarAssignation] -> Bool +nameExist s (_, s', _, _) _ | s == s' = True +nameExist s (_, _, params, _) vs = searchName s vs params + checkDeclaration :: VarDeclaration -> Env -> [Instruction] -> Bool -checkDeclaration ((s, t), v) (Env proto vars env) xs | - assertTypeAndValue t v (Env proto vars env) = - checkInstructions xs (Env proto ((s, v):vars) env) +checkDeclaration ((s, t), v) (Env proto vars env) xs + | not (nameExist s proto vars) && + assertTypeAndValue t v (Env proto vars env) = + checkInstructions xs (Env proto ((s, v):vars) env) checkDeclaration _ _ _ = False checkAssignation :: VarAssignation -> Env -> [Instruction] -> Bool -checkAssignation (s, v) env xs | assertMTypeAndValue (findValueType (Var s) env) v env = +checkAssignation (s, v) env xs | + assertMTypeAndValue (findValueType (Var s) env) v env = checkInstructions xs env checkAssignation _ _ _ = False @@ -121,32 +140,36 @@ checkCondition _ _ _ = False checkInstructions :: [Instruction] -> Env -> Bool checkInstructions [] _ = True -checkInstructions ((Call func):xs) env = checkCall func env xs +checkInstructions ((Function func):xs) env = checkCall func env xs checkInstructions ((Return ret):xs) env = checkReturn ret env xs -checkInstructions ((Declaration declaration):xs) env = checkDeclaration declaration env xs -checkInstructions ((Assignation assignation):xs) env = checkAssignation assignation env xs +checkInstructions ((Declaration declaration):xs) env = + checkDeclaration declaration env xs +checkInstructions ((Assignation assignation):xs) env = + checkAssignation assignation env xs checkInstructions ((Cond condition):xs) env = checkCondition condition env xs checkVarTypes :: [Var] -> Bool checkVarTypes [] = True checkVarTypes [x] = isTypeValid (snd x) checkVarTypes (x:xs) | isTypeValid (snd x) = checkVarTypes xs +checkVarTypes _ = False checkFunction :: FuncDeclaration -> [FuncPrototype] -> Bool -checkFunction ((_, args, _), _) _ | not (checkVarTypes args) = False -checkFunction ((_, _, t), _) _ | not (isTypeValid t) = False +checkFunction ((_, _, args, _), _) _ | not (checkVarTypes args) = False +checkFunction ((_, _, _, t), _) _ | not (isTypeValid t) = False checkFunction (prototype, instructions) env | checkInstructions instructions (Env prototype [] env) = True checkFunction _ _ = False checkNotExisting :: FuncDeclaration -> [FuncPrototype] -> Bool checkNotExisting _ [] = True -checkNotExisting ((s, args, t), instr) ((ls, _, _):xs) +checkNotExisting ((e, s, args, t), instr) ((_, ls, _, _):xs) | s == ls = False - | otherwise = checkNotExisting ((s, args, t), instr) xs + | otherwise = checkNotExisting ((e, s, args, t), instr) xs receiveCheckFuncRes :: Bool -> [FuncDeclaration] -> FuncDeclaration -> [FuncPrototype] -> Bool -receiveCheckFuncRes True xs (prototype, _) env = checkDeclarations xs (Just (prototype:env)) +receiveCheckFuncRes True xs (prototype, _) env = + checkDeclarations xs (Just (prototype:env)) receiveCheckFuncRes _ _ _ _ = False checkDeclarations :: [FuncDeclaration] -> Maybe [FuncPrototype] -> Bool @@ -158,14 +181,15 @@ checkDeclarations (func:xs) (Just env) | otherwise = False createCalcPrototype :: Symbol -> Type -> FuncPrototype -createCalcPrototype s t = (s, [("x", t), ("y", t)], "Int") +createCalcPrototype s t = (False, s, [("x", t), ("y", t)], "Int") createCompPrototype :: Symbol -> Type -> FuncPrototype -createCompPrototype s t = (s, [("x", t), ("y", t)], "Bool") +createCompPrototype s t = (False, s, [("x", t), ("y", t)], "Bool") createCompPolyMorph :: Symbol -> [Type] -> [FuncPrototype] createCompPolyMorph _ [] = [] -createCompPolyMorph s (x:xs) = createCompPrototype s x : createCompPolyMorph s xs +createCompPolyMorph s (x:xs) = + createCompPrototype s x : createCompPolyMorph s xs createCompOp :: [Symbol] -> [FuncPrototype] createCompOp [] = [] @@ -176,7 +200,8 @@ createCalcOp [] = [] createCalcOp (x:xs) = createCalcPrototype x "Int" : createCalcOp xs defaultEnv :: Maybe [FuncPrototype] -defaultEnv = Just (createCalcOp ["+", "-", "*", "%", "/"] ++ createCompOp ["==", "!=", "<", ">", "<=", ">="]) +defaultEnv = Just (createCalcOp ["+", "-", "*", "%", "/"] ++ + createCompOp ["==", "!=", "<", ">", "<=", ">="]) typeCheck :: [FuncDeclaration] -> Bool typeCheck expressions = checkDeclarations expressions defaultEnv diff --git a/lvtc/test/Spec.hs b/lvtc/test/Spec.hs index 9e5229b..e106fca 100644 --- a/lvtc/test/Spec.hs +++ b/lvtc/test/Spec.hs @@ -18,6 +18,7 @@ import UTWatLike import UTWat import UTWasm import UTLexeme +import UTTypeCheck main :: IO () main = defaultMain tests @@ -33,7 +34,8 @@ tests = testGroup "Leviator Tests - Compiler" utWatLike, utWat, utWasm, - utLexeme + utLexeme, + uTTypeCheck ] testParserHelper :: String -> String -> Expression -> IO () diff --git a/lvtc/test/UTTypeCheck.hs b/lvtc/test/UTTypeCheck.hs new file mode 100644 index 0000000..b85efad --- /dev/null +++ b/lvtc/test/UTTypeCheck.hs @@ -0,0 +1,64 @@ +{- +-- EPITECH PROJECT, 2023 +-- Leviator compiler +-- File description: +-- UTShuntingYard +-} + +module UTTypeCheck ( + uTTypeCheck +) where + +import Test.Tasty +import Test.Tasty.HUnit +import AST +import TypeCheck + +uTTypeCheck :: TestTree +uTTypeCheck = testGroup "typeCheck tests" + [testReturn, testFuncCall, testVars] + +testReturn :: TestTree +testReturn = testGroup "testReturn" + [ + testCase "testReturn" (shouldBeTrue + [((True, "main", [], "Int"), ([Return (Integer 0)]))]), + testCase "testWrongReturnType" (shouldBeFalse + [((True, "main", [], "Int"), ([Return (Boolean True)]))]), + testCase "test return param" (shouldBeFalse + [((True, "main", [("a", "Int"), ("b", "Bool")], "Int"), [Return (Var "b")])]) + ] + +testFuncCall :: TestTree +testFuncCall = testGroup "testFuncCall" + [ + testCase "test recursive" (shouldBeTrue + [((True, "main", [], "Int"), [Return (FuncValue ("main", []))])]), + testCase "test return wrong type" (shouldBeFalse + [((True, "main", [], "Int"), [Return (Integer 0)]), ((True, "snd", [], "Bool"), [Return (FuncValue ("main", []))])]), + testCase "test call with params" (shouldBeTrue + [((True, "main", [("a", "Int"), ("b", "Bool")], "Int"), [Return (Var "a")]), ((True, "snd", [], "Int"), [Return (FuncValue ("main", [(Integer 0), (Boolean True)]))])]), + testCase "test call with wrongs params" (shouldBeFalse + [((True, "main", [("a", "Int"), ("b", "Bool")], "Int"), [Return (Var "a")]), ((True, "snd", [], "Int"), [Return (FuncValue ("main", [(Integer 0), (Integer 2)]))])]) + ] + +testVars :: TestTree +testVars = testGroup "testVars" + [ + testCase "test vars" (shouldBeTrue + [((True, "main", [], "Int"), [Declaration (("a", "Int"), Integer 0), Assignation ("a", (FuncValue ("+", [(Var "a"), (Integer 1)]))), Return (Var "a")])]), + testCase "test params" (shouldBeTrue + [((True, "main", [("a", "Int")], "Int"), [Assignation ("a", (FuncValue ("+", [(Var "a"), (Integer 1)]))), Return (Var "a")])]), + testCase "test params" (shouldBeTrue + [((True, "main", [("a", "Int")], "Int"), [Declaration (("b", "Int"), (Var "a")), Declaration (("c", "Int"), (Var "b")), Return (Var "c")])]), + testCase "test wrong var declaration" (shouldBeFalse + [((True, "main", [("a", "Int")], "Int"), [Declaration (("a", "Int"), Integer 0)])]), + testCase "test double func name" (shouldBeFalse + [((True, "main", [("a", "Int")], "Int"), [Return (Integer 0)]), ((True, "main", [("a", "Int")], "Int"), [Return (Integer 0)])]) + ] + +shouldBeTrue :: [FuncDeclaration] -> Assertion +shouldBeTrue funcs = (typeCheck funcs) @?= True + +shouldBeFalse :: [FuncDeclaration] -> Assertion +shouldBeFalse funcs = (typeCheck funcs) @?= False diff --git a/lvtc/test/typeCheck.hs b/lvtc/test/typeCheck.hs deleted file mode 100644 index 534eeef..0000000 --- a/lvtc/test/typeCheck.hs +++ /dev/null @@ -1,22 +0,0 @@ -import Test.Tasty -import Test.Tasty.HUnit -import AST - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "typeCheck tests" - [testReturn] - -testReturn :: TestTree -testReturn = testGroup "testReturn" [ - testCase "testReturn" (True == - (typeCheck (("main", [], "Int"), ([Declaration (("a", "Int"), Integer 0), Return (Integer 69)])))) -] - -shouldBeTrue :: [FuncDeclaration] -> Assertion -shouldBeTrue funcs = (typeCheck funcs) @?= True - -shouldBeFalse :: [FuncDeclaration] -> Assertion -shouldBeFalse funcs = (typeCheck funcs) @?= False From 0b8402408c2c60a84220c95db23004b263e62435 Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Sun, 14 Jan 2024 22:49:12 +0100 Subject: [PATCH 22/26] Add stdlib --- lvtc/app/Args.hs | 14 +++++++--- lvtc/app/Main.hs | 6 ++--- lvtc/app/Run.hs | 11 ++++++-- lvtc/src/Lexeme.hs | 1 + lvtc/src/ParseLvt.hs | 4 +-- lvtc/stdlib/Convert.lvt | 30 ++++++++++++++++++++++ lvtc/stdlib/Logic.lvt | 40 +++++++++++++++++++++++++++++ lvtc/stdlib/Math.lvt | 57 +++++++++++++++++++++++++++++++++++++++++ 8 files changed, 153 insertions(+), 10 deletions(-) create mode 100644 lvtc/stdlib/Convert.lvt create mode 100644 lvtc/stdlib/Logic.lvt create mode 100644 lvtc/stdlib/Math.lvt diff --git a/lvtc/app/Args.hs b/lvtc/app/Args.hs index 5d40246..56ae89a 100644 --- a/lvtc/app/Args.hs +++ b/lvtc/app/Args.hs @@ -22,7 +22,8 @@ data Args = Args { action :: Action, folderPath :: String, outFile :: String, - verbose :: Bool + verbose :: Bool, + folders :: [String] } parseArgs' :: [String] -> Args -> Either Args String @@ -42,6 +43,10 @@ parseArgs' ["-o"] _ = Right "Missing argument for -o" parseArgs' ("--verbose":xs) args = parseArgs' xs (args {verbose = True}) +parseArgs' ("--lib":x:xs) args = + parseArgs' xs (args {folders = x : folders args}) +parseArgs' ("-l":x:xs) args = + parseArgs' xs (args {folders = x : folders args}) parseArgs' (('-':xs):_) _ = Right ("Unknown option: " ++ xs) parseArgs' (x:xs) args = @@ -51,7 +56,8 @@ parseArgs :: [String] -> IO (Either Args String) parseArgs args = getCurrentDirectory >>= \path -> return (parseArgs' args (Args { - action = Run, folderPath = path, outFile = "out.wasm", verbose = False + action = Run, folderPath = path, outFile = "out.wasm", + verbose = False, folders = [] })) hLine1 :: String @@ -77,9 +83,11 @@ hLine9 = part1 ++ part2 part2 = " source code recursively from FOLDER\n" hLine10 :: String hLine10 = "\t--verbose\n\t\tVerbose mode\n" +hLine11 :: String +hLine11 = "\t-l, --lib\n\t\tAdd folder to compiled Leviator source code\n" printHelp :: IO () printHelp = putStr hLine1 >> putStr hLine2 >> putStr hLine3 >> putStr hLine4 >> putStr hLine5 >> putStr hLine6 >> putStr hLine7 >> putStr hLine8 - >> putStr hLine9 >> putStr hLine10 + >> putStr hLine9 >> putStr hLine10 >> putStr hLine11 diff --git a/lvtc/app/Main.hs b/lvtc/app/Main.hs index cb24862..0f41aca 100644 --- a/lvtc/app/Main.hs +++ b/lvtc/app/Main.hs @@ -14,9 +14,9 @@ import Run (run) import Version (printVersion) dispatchArgs :: Args -> IO () -dispatchArgs (Args Run fPath oFile v) = run (Args Run fPath oFile v) -dispatchArgs (Args ShowHelp _ _ _) = printHelp -dispatchArgs (Args ShowVersion _ _ _) = printVersion +dispatchArgs (Args Run fPath oFile v fs) = run (Args Run fPath oFile v fs) +dispatchArgs (Args ShowHelp _ _ _ _) = printHelp +dispatchArgs (Args ShowVersion _ _ _ _) = printVersion dispatchIfOk :: Either Args String -> IO () dispatchIfOk (Left args) = dispatchArgs args diff --git a/lvtc/app/Run.hs b/lvtc/app/Run.hs index 1a454fe..768ccd4 100644 --- a/lvtc/app/Run.hs +++ b/lvtc/app/Run.hs @@ -67,6 +67,13 @@ listAllFiles v path = p True = putStrLn ("Compiling Folder: " ++ show path) p False = return () +listsAllFiles :: Bool -> [FilePath] -> IO [FilePath] +listsAllFiles _ [] = return [] +listsAllFiles v (f:fs) = + listAllFiles v f + >>= (\files -> listsAllFiles v fs + >>= (\others -> return (files ++ others))) + getAllFunc :: Bool -> [Expression] -> IO [FuncDeclaration] getAllFunc _ [] = return [] getAllFunc v ((Expression.Function str):expressions) = @@ -119,10 +126,10 @@ showDebug True wasm = print wasm showDebug False _ = return () run :: Args -> IO () -run (Args Run fPath oFile v) = +run (Args Run fPath oFile v fPaths) = transformedWasm >>= \wasm -> (showDebug v wasm >> writeWasm wasm oFile) where - expressions = listAllFiles v fPath >>= getFilesExpression v + expressions = listsAllFiles v (fPath:fPaths) >>= getFilesExpression v funcs = expressions >>= getAllFunc v transformedWatLike = transformToWatLike v (checkAst v funcs) transformedWat = transformToWat v transformedWatLike diff --git a/lvtc/src/Lexeme.hs b/lvtc/src/Lexeme.hs index 083d301..fe8a845 100644 --- a/lvtc/src/Lexeme.hs +++ b/lvtc/src/Lexeme.hs @@ -13,6 +13,7 @@ module Lexeme replaceN :: Int -> String -> String replaceN _ [] = [] replaceN 0 ('"':xs) = '"' : replaceN 1 xs +replaceN 1 ('\\':'0':xs) = '\0' : replaceN 1 xs replaceN 1 ('\\':'n':xs) = '\n' : replaceN 1 xs replaceN 1 ('\\':'t':xs) = '\t' : replaceN 1 xs replaceN 1 ('\\':'v':xs) = '\v' : replaceN 1 xs diff --git a/lvtc/src/ParseLvt.hs b/lvtc/src/ParseLvt.hs index 74e6667..67a6a7b 100644 --- a/lvtc/src/ParseLvt.hs +++ b/lvtc/src/ParseLvt.hs @@ -95,8 +95,8 @@ parseOperatorOp = Var <$> (parseString "+" <|> parseString "-" <|> parseString "*" <|> parseString "/" <|> parseString "{" <|> parseString "}" - <|> parseString "==" <|> parseString "!=" <|> parseString "<" - <|> parseString ">" <|> parseString "<=" <|> parseString ">=") + <|> parseString "==" <|> parseString "!=" <|> parseString "<=" + <|> parseString ">=" <|> parseString "<" <|> parseString ">") parseOperator' :: ShuntingYardState -> Parser ShuntingYardState parseOperator' sys = diff --git a/lvtc/stdlib/Convert.lvt b/lvtc/stdlib/Convert.lvt new file mode 100644 index 0000000..b60fbf6 --- /dev/null +++ b/lvtc/stdlib/Convert.lvt @@ -0,0 +1,30 @@ +fn intToBool(a: Int) -> Bool +{ + if (a == 1) + { + <- True; + }; + <- False; +}; + +fn boolToInt(a: Bool) -> Int +{ + if (a) + { + <- 1; + }; + <- 0; +}; + +fn charToInt(a: Char) -> Int +{ + @Char i = '\0'; + @Int res = 0; + + while (i < a) + { + res = res + 1; + i = i + 1; + }; + <- res; +}; diff --git a/lvtc/stdlib/Logic.lvt b/lvtc/stdlib/Logic.lvt new file mode 100644 index 0000000..66289a3 --- /dev/null +++ b/lvtc/stdlib/Logic.lvt @@ -0,0 +1,40 @@ +fn or(a: Bool, b: Bool) -> Bool +{ + if (a) + { + <- True; + }; + <- b; +}; + +fn and(a: Bool, b: Bool) -> Bool +{ + if (a) + { + <- b; + }; + <- False; +}; + +fn not(a: Bool) -> Bool +{ + if (a) + { + <- False; + }; + <- True; +}; + +fn xor(a: Bool, b: Bool) -> Bool +{ + if (a) + { + <- not(b); + }; + <- b; +}; + +fn nand(a: Bool, b: Bool) -> Bool +{ + <- not(and(a, b)); +}; diff --git a/lvtc/stdlib/Math.lvt b/lvtc/stdlib/Math.lvt new file mode 100644 index 0000000..7b734b4 --- /dev/null +++ b/lvtc/stdlib/Math.lvt @@ -0,0 +1,57 @@ +fn mod(a: Int, b: Int) -> Int +{ + @Int res = a; + @Int q = a / b; + @Int r = q * b; + res = res - r; + <- res; +}; + +fn square(a: Int) -> Int +{ + <- a * a; +}; + +fn cube(a: Int) -> Int +{ + <- a * a * a; +}; + +fn pow(a: Int, b: Int) -> Int +{ + @Int res = 1; + @Int i = 0; + + while (i < b) + { + res = res * a; + i = i + 1; + }; + <- res; +}; + +fn factorial(a: Int) -> Int +{ + @Int res = 1; + @Int i = 2; + + while (i <= a) + { + res = res * i; + i = i + 1; + }; + <- res; +}; + +fn factorialRec(a: Int) -> Int +{ + if (a == 0) + { + <- 1; + }; + if (a == 1) + { + <- 1; + }; + <- a * factorialRec(a - 1); +}; From 907e8c311fd5d5a969fbca00413ed860a2007983 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Sun, 14 Jan 2024 23:18:01 +0100 Subject: [PATCH 23/26] Add --- lvtc/src/TypeCheck.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lvtc/src/TypeCheck.hs b/lvtc/src/TypeCheck.hs index c3471fd..6300c87 100644 --- a/lvtc/src/TypeCheck.hs +++ b/lvtc/src/TypeCheck.hs @@ -215,5 +215,6 @@ checkStart (((_, _, _, _), _):xs) = checkStart xs checkStart [] = False typeCheck :: [FuncDeclaration] -> Bool -typeCheck expressions | checkStart expressions = checkDeclarations expressions defaultEnv +typeCheck expressions | checkStart expressions = + checkDeclarations expressions defaultEnv typeCheck _ = False From a93fdb09fbcb9d241544ca8f99bd440a2501c7e0 Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Sun, 14 Jan 2024 23:20:10 +0100 Subject: [PATCH 24/26] Call typecheck --- lvtc/app/Run.hs | 7 ++++--- lvtc/test/lvt/Test.lvt | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lvtc/app/Run.hs b/lvtc/app/Run.hs index 768ccd4..5efb4b8 100644 --- a/lvtc/app/Run.hs +++ b/lvtc/app/Run.hs @@ -21,6 +21,7 @@ import WatLikeToWat (watsLikeToWat) import Wasm (Wasm) import WatToWasm (watToWasm) import WriteWasm (writeWasm) +import TypeCheck (typeCheck) import Args import System.Directory (listDirectory) @@ -90,9 +91,9 @@ getAllFunc v (x : expressions) = p v >> getAllFunc v expressions checkAst :: Bool -> IO [FuncDeclaration] -> IO [FuncDeclaration] checkAst _ funcsIo = funcsIo - >>= (\funcs -> case Just funcs of - Just f -> return f - Nothing -> fail "Invalid Code") + >>= (\funcs -> case typeCheck funcs of + True -> return funcs + False -> fail "Invalid Code") transformToWatLike :: Bool -> IO [FuncDeclaration] -> IO [FuncDeclare] transformToWatLike v funcsIo = diff --git a/lvtc/test/lvt/Test.lvt b/lvtc/test/lvt/Test.lvt index 2681727..4acfa3e 100644 --- a/lvtc/test/lvt/Test.lvt +++ b/lvtc/test/lvt/Test.lvt @@ -1,4 +1,4 @@ -export fn start() -> Char +export fn start() -> Int { @Int a = 0 + 1; @Int b = a - 1; From 01a507034c05d1830cefcedc9cea85e15c67545a Mon Sep 17 00:00:00 2001 From: Tenshi Date: Sun, 14 Jan 2024 23:37:20 +0100 Subject: [PATCH 25/26] add else --- lvtrun/README.md | 24 ++++++++++++++---------- lvtrun/src/OpCodes.hs | 2 ++ lvtrun/src/Run/Vm.hs | 27 +++++++++++++++++++++++++-- lvtrun/src/Types.hs | 1 + 4 files changed, 42 insertions(+), 12 deletions(-) diff --git a/lvtrun/README.md b/lvtrun/README.md index 66f147e..cb22056 100644 --- a/lvtrun/README.md +++ b/lvtrun/README.md @@ -32,17 +32,21 @@ # ----------------------- 2 ----------------------- -02 +02 24 # 02 is the id of the import section -24 01 16 77 -61 73 69 5f -73 6e 61 70 -73 68 6f 74 -5f 70 72 65 -76 69 65 77 -31 09 70 72 -6f 63 5f 65 -78 69 74 00 +# 1 vector +01 +# name is 16hex = 22dec bytes long +16 +# name = "wasi_snapshot_preview1" +77 61 73 69 5f 73 6e 61 70 73 68 6f 74 5f 70 72 65 76 69 65 77 31 +# name is 09 +09 +# name = "proct_exit" +70 72 6f 63 5f 65 78 69 74 +# 00 = func = function +00 +# 00 = typeidx = 0 02 # ----------------------- 3 ----------------------- diff --git a/lvtrun/src/OpCodes.hs b/lvtrun/src/OpCodes.hs index 8ef96a7..9c2030c 100644 --- a/lvtrun/src/OpCodes.hs +++ b/lvtrun/src/OpCodes.hs @@ -57,6 +57,7 @@ extractOpCode' (0x4a:rest) = ([0x4a], BSL.pack rest) extractOpCode' (0x4c:rest) = ([0x4c], BSL.pack rest) extractOpCode' (0x4e:rest) = ([0x4e], BSL.pack rest) extractOpCode' (0x47:rest) = ([0x47], BSL.pack rest) +extractOpCode' (0x05:rest) = ([0x05], BSL.pack rest) extractOpCode' (0x3f:0x00:rest) = ([0x3f, 0x00], BSL.pack rest) extractOpCode' (0x40:0x00:rest) = ([0x40, 0x00], BSL.pack rest) extractOpCode' (0x04:0x40:rest) = ([0x04, 0x40], BSL.pack rest) @@ -72,6 +73,7 @@ createInstruction [0x00] bytes = (Unreachable, bytes) createInstruction [0x01] bytes = (Nop, bytes) createInstruction [0x02] bytes = (Block EmptyType, bytes) createInstruction [0x0b] bytes = (End, bytes) +createInstruction [0x05] bytes = (Else, bytes) createInstruction [0x48] bytes = (I32Lts, bytes) createInstruction [0x0f] bytes = (Return, bytes) createInstruction [0x4b] bytes = (I32Gtu, bytes) diff --git a/lvtrun/src/Run/Vm.hs b/lvtrun/src/Run/Vm.hs index ef0b6b1..3fc31d9 100644 --- a/lvtrun/src/Run/Vm.hs +++ b/lvtrun/src/Run/Vm.hs @@ -102,10 +102,32 @@ execCall vm cEx funcIdx = cEx { ceStack = newStack } currentStack = ceStack cEx res = ceResults (currentExec newVm) +doesElseExist' :: [Instruction] -> Bool +doesElseExist' [] = False +doesElseExist' (Else:_) = True +doesElseExist' (_:rest) = doesElseExist' rest + +doesElseExist :: CurrentExec -> Bool +doesElseExist cEx = doesElseExist' (drop (ceInstIdx cEx) (ceInstructions cEx)) + +getElseIndex' :: [Instruction] -> Int -> Int +getElseIndex' [] _ = throw $ RuntimeError "getElseIndex: missing else" +getElseIndex' (Else:_) idx = idx +getElseIndex' (_:rest) idx = getElseIndex' rest (idx + 1) + +getElseIndex :: CurrentExec -> Int +getElseIndex cEx = getElseIndex' (drop (ceInstIdx cEx) (ceInstructions cEx)) 0 + +executeElse :: CurrentExec -> CurrentExec +executeElse cEx@(CurrentExec {ceStack = stack}) = + case doesElseExist cEx of + False -> cEx + True -> cEx { ceInstIdx = getElseIndex cEx } + execIf :: CurrentExec -> CurrentExec execIf cEx@(CurrentExec {ceStack = stack}) = case stackTop stack of I_32 0 -> goToEndInstruction cEx - I_32 1 -> addLabel (cEx { crBlockIndents = (crBlockIndents cEx) + 1 }) + I_32 1 -> executeElse (addLabel (cEx { crBlockIndents = (crBlockIndents cEx) + 1 })) I_32 _ -> throw $ RuntimeError "execIf: bad if statement" _ -> throw $ RuntimeError "execIf: bad type" @@ -175,7 +197,8 @@ execOpCode _ cEx (I32Gtu) = execI32GtU cEx execOpCode _ cEx (Block _) = incrementBlockIndent (addLabel cEx) execOpCode _ cEx (Br labelIdx) = execBr cEx labelIdx execOpCode _ cEx (Loop) = incrementBlockIndent (addLabel cEx) -execOpCode _ cEx _ = cEx +execOpCode _ cEx (Else) = throw $ RuntimeError "elseWithoutIf" +execOpCode _ cEx _ = throw $ RuntimeError "execOpCode: not implemented" execOpCodes :: VM -> [Instruction] -> CurrentExec execOpCodes vm [] = currentExec vm diff --git a/lvtrun/src/Types.hs b/lvtrun/src/Types.hs index 0c2ac91..121c239 100644 --- a/lvtrun/src/Types.hs +++ b/lvtrun/src/Types.hs @@ -117,6 +117,7 @@ data Instruction = | I32Leu | I32Eq | I32Lts + | Else | I32Gts | I32Les | I32Ges From 0bb3f8f85a3fef1fc6481eaf9b280989f390ba30 Mon Sep 17 00:00:00 2001 From: Tenshi Date: Sun, 14 Jan 2024 23:40:02 +0100 Subject: [PATCH 26/26] fix norm --- lvtrun/src/Run/Vm.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lvtrun/src/Run/Vm.hs b/lvtrun/src/Run/Vm.hs index 3fc31d9..9b7c161 100644 --- a/lvtrun/src/Run/Vm.hs +++ b/lvtrun/src/Run/Vm.hs @@ -127,7 +127,8 @@ executeElse cEx@(CurrentExec {ceStack = stack}) = execIf :: CurrentExec -> CurrentExec execIf cEx@(CurrentExec {ceStack = stack}) = case stackTop stack of I_32 0 -> goToEndInstruction cEx - I_32 1 -> executeElse (addLabel (cEx { crBlockIndents = (crBlockIndents cEx) + 1 })) + I_32 1 -> + executeElse (addLabel (cEx { crBlockIndents = (crBlockIndents cEx) + 1 })) I_32 _ -> throw $ RuntimeError "execIf: bad if statement" _ -> throw $ RuntimeError "execIf: bad type"