diff options
| -rw-r--r-- | app/Main.hs | 16 | ||||
| -rw-r--r-- | src/Eval.hs | 58 | ||||
| -rw-r--r-- | src/Lib.hs | 6 | ||||
| -rw-r--r-- | src/Syntax.hs | 12 | ||||
| -rw-r--r-- | src/Typecheck.hs | 24 |
5 files changed, 86 insertions, 30 deletions
diff --git a/app/Main.hs b/app/Main.hs index de1c1ab..efe495b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,18 @@ module Main where -import Lib +import Syntax +import Typecheck +import Eval +import Control.Monad.Except main :: IO () -main = someFunc +main = do + input <-getContents + let program = (read input)::Program + case runExcept $ wfProgram program of + Left s -> print s + Right () -> + let (ret,state) = runProgram program in + case ret of + Left err-> print$ "Program finished with error" ++show err ++ "in state " ++ show state + Right _ -> print$ "Program finished by going to the end to state" ++ show state diff --git a/src/Eval.hs b/src/Eval.hs index 9047469..c454843 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE TupleSections #-} module Eval - () + (runProgram) where import Syntax import Typecheck () import Control.Monad.State.Lazy import Control.Monad.Except +import Control.Monad.Reader data Value = VInt Int | VRecord [(Idnt,Value)] | VVariant Idnt Value @@ -17,8 +19,11 @@ type Variables = [(Idnt,Value)] type Heap = (Int,[(Int,Value)]) data ProgramState= ProgramState Variables Heap + deriving (Show) + +type EvalMonad = ReaderT [(Idnt,FuncDecl)] (ExceptT String (State ProgramState)) +--type EvalMonad = ExceptT String (State ProgramState) -type EvalMonad = ExceptT String (State ProgramState) assertInt :: Value -> EvalMonad Int assertInt (VInt i) = return i @@ -163,10 +168,10 @@ runCom (Save var expr) = do Just x -> return x put $ ProgramState vars (heapCnt,heap') get -runCom (SMatch e cases) = do +runCom c@(SMatch e cases) = do v <- evalExpr e (label,value) <- assertVar v - case lookup label (map (\(a,b,c)-> (a,(b,c)) )cases) of + case lookup label (map (\(a,b,c)-> (a,(b,c)) ) cases) of Just (bind,com) -> do st@(ProgramState vars heap) <- get put $ ProgramState ((bind,value):vars) heap @@ -176,15 +181,38 @@ runCom (SMatch e cases) = do put $ ProgramState vars' heap get Nothing -> throwError $ "Unsupported label"++ show label ++ "in case" ++ show c -runCom (FunctionCall var fname arugments) = undefined --TODO - - - - - - - - - - +runCom (FunctionCall var fname arguments) = do + funcs <- ask + case lookup fname funcs of + Nothing -> throwError "no such function defined" + Just (Func _ args locals body ret) ->do + (ProgramState vars heap) <- get + vargs <- mapM evalExpr arguments -- evaluate arguments + --evaluate local variables in new environment + put $ ProgramState (zip (map fst args) vargs) heap + vlocals <- mapM (\(var,expr) -> (var,) <$> evalExpr expr) locals + --evaluate function body and return in newer environment + (ProgramState vars' heap') <- get + put $ ProgramState (vlocals++vars') heap' + runCom body + vret <- evalExpr ret + --restore old local variables with new heap + (ProgramState _ newheap) <- get + put (ProgramState vars newheap) + get + + + + + + +runProgram :: Program -> (Either String ProgramState,ProgramState) +runProgram (Program decls locals com) = + let dec = map ( \d@(Func n _ _ _ _)-> (n,d) ) decls in + runState ( runExceptT ( runReaderT (do + env <- mapM (\(var,expr) -> (var,) <$> evalExpr expr) locals + put (ProgramState env (0,[])) + runCom com + ) dec) )(ProgramState [] (0,[])) + --runState ( runExceptT (runReaderT (_) decls)) (ProgramState [] []) diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index d36ff27..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/src/Syntax.hs b/src/Syntax.hs index 18949d2..065f91d 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -6,7 +6,7 @@ data Typ = TInt | TRecord TypeDict | TVariant TypeDict | TPtr Typ - deriving(Eq,Show) + deriving(Eq,Show,Read) type TypeDict = [(Idnt,Typ)] data Expr = Var Idnt @@ -20,7 +20,7 @@ data Expr = Var Idnt | Match Expr [(Idnt, Idnt, Expr)] -- Variant,Binder, Expression | Proj Idnt Expr | Annot Expr Typ - deriving(Eq,Show) + deriving(Eq,Show,Read) data Com = Skip | Seq Com Com | If Expr Com Com @@ -31,13 +31,13 @@ data Com = Skip | Save Idnt Expr | SMatch Expr [(Idnt, Idnt, Com)] | FunctionCall Idnt Idnt [Expr] -- variable function_name parameters - deriving(Eq,Show) + deriving(Eq,Show,Read) data FuncDecl = Func Idnt [(Idnt, Typ)] [(Idnt,Expr)] Com Expr -- function_name [parameters] [local variables] body return_val - deriving(Eq,Show) + deriving(Eq,Show,Read) data FuncSign = FuncSign [Typ] Typ deriving(Eq,Show) type FuncEnv = [(Idnt,FuncSign)] -data Program = P [FuncDecl] [(Idnt, Int)] Com - deriving(Eq,Show) +data Program = Program [FuncDecl] [(Idnt, Expr)] Com + deriving(Eq,Show,Read) diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 7136e64..8c1755f 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -3,8 +3,10 @@ module Typecheck (inferExpr, checkExpr, wellFormed, + wfProgram, Environment, - bool + bool, + Error ) where import Syntax @@ -171,6 +173,26 @@ wellFormed c@(FunctionCall v f args) env fa= do argsOk xs ys +getFuncSign :: FuncDecl -> Error (Idnt,FuncSign) +getFuncSign (Func name arguments locals body ret) = do + localTypes <- mapM (\(var,expr)-> (var,) <$> inferExpr expr arguments) locals + ret <- inferExpr ret (localTypes++arguments) + return $ (name,FuncSign (map snd arguments) ret) + +wfFunction :: FuncDecl-> FuncEnv -> Error () +wfFunction (Func name params locals body ret) fe = do + localTypes <- mapM (\(var,expr)-> (var,) <$> inferExpr expr params) locals + wellFormed body (localTypes++params) fe + inferExpr ret (localTypes++params) + return () + +wfProgram :: Program -> Error () +wfProgram (Program decls locals main) =do + fe <- mapM getFuncSign decls + localTypes <- mapM (\(var,expr)-> (var,) <$> inferExpr expr []) locals + wellFormed main localTypes fe + + |