--- /dev/null
-import Data.Map as Map hiding (showTree)
+ -- automatically generated by BNF Converter
+ module Main where
+
+
+ import IO ( stdin, hGetContents )
+ import System ( getArgs, getProgName )
+
+ import Lexsyntax
+ import Parsyntax
+ import Skelsyntax
+ import Printsyntax
+ import Abssyntax
+
+ import Typecheck
+ import Interpret
+ import Compile
-
-cHeader = "#include <stdio.h>\nint read(){\nint n;\nscanf(\"%d\",&n);\nreturn n;\n}\nint main(void){\n"
-
-cFooter = "return 0;}"
+
+ import ErrM
+
+ type ParseFun a = [Token] -> Err a
+
+ myLLexer = myLexer
+
-runFile :: ([Stm] -> IO()) -> ParseFun Stms -> FilePath -> IO ()
++splitFunStm :: [FuncStm] -> ([Func],[Stm])
++splitFunStm [] = ([],[])
++splitFunStm ((F f):fss) = let (fs,ss) = splitFunStm fss in (f:fs,ss)
++splitFunStm ((S s):fss) = let (fs,ss) = splitFunStm fss in (fs,s:ss)
+
+ putStrV :: Int -> String -> IO ()
+ putStrV v s = if v > 1 then putStrLn s else return ()
+
-run :: ([Stm] -> IO()) -> ParseFun Stms -> String -> IO ()
++runFile :: ([Func] -> [Stm] -> IO()) -> ParseFun Program -> FilePath -> IO ()
+ runFile e p f = readFile f >>= run e p
+
- Ok (Program s) -> do
- typeCheck s
- e s
++run :: ([Func] -> [Stm] -> IO()) -> ParseFun Program -> String -> IO ()
+ run e p s = let ts = myLLexer s in case p ts of
+ Bad s -> do
+ putStrLn "\nParse Failed...\n"
+ putStrLn "Tokens:"
+ putStrLn $ show ts
+ putStrLn s
- [] -> hGetContents stdin >>= run interpret pStms
- "-c":f:[] -> runFile (writeFile (f++".c") . compile) pStms f
- f:[] -> runFile interpret pStms f
++ Ok (Program s) -> let (fun,st) = splitFunStm (s) in do
++ typeCheck fun st
++ e fun st
+
+ main :: IO ()
+ main = do
+ args <- getArgs
+ case args of
++ [] -> hGetContents stdin >>= run interpret pProgram
++ "-c":f:[] -> runFile (\fun st -> writeFile (f++".c") $ compile fun st) pProgram f
++ f:[] -> runFile interpret pProgram f
+ _ -> print "Too many arguments"
- module Compile (compileExp, compileStm) where
+ module Compile (compile,compileExp, compileStm) where
import Abssyntax
import Prelude hiding (lookup)
-compile :: [Stm] -> String
-compile s = cHeader++concat (map compileStm s)++cFooter
+ cHeader = "#include <stdio.h>\nint read(){\nint n;\nscanf(\"%d\",&n);\nreturn n;\n}\nint main(void){\n"
+
+ cFooter = "return 0;}"
+
++compile :: [Func] -> [Stm] -> String
++compile f s = cHeader++concat (map compileStm s)++cFooter
+
compileExp :: Exp -> String
compileExp (EBool True) = "1";
compileExp (EBool False) = "0";
- module Interpret (eval, execute,addFunction, emptyState, Value(..), State(..)) where
-module Interpret (interpret, eval, execute, Value(VInt, VBool)) where
++module Interpret (interpret, eval, execute,addFunction, emptyState, Value(..), State(..)) where
import Abssyntax
-import Control.Monad.State
+import Control.Monad.State hiding (State)
+import Control.Monad.Error
+import Control.Concurrent.MVar
import Data.Map as Map
import Prelude hiding (lookup)
+emptyState = State{variables=[empty], functions=(empty)}
+
data Value = VInt Integer | VBool Bool deriving Eq
instance Show Value where
show (VBool False) = "0"
type Variables = [Map Ident Value]
+type Function = ([Decl],[Stm])
+
+data State = State {variables::Variables,functions::(Map Ident Function),ret::(MVar Value)}
-interpret :: [Stm] -> IO ()
-interpret s = runStateT (mapM execute s) [empty] >> return ()
++interpret :: [Func] -> [Stm] -> IO ()
++interpret fun st = do
++ mv <- newEmptyMVar
++ runStateT (do mapM Interpret.addFunction fun; mapM execute st) emptyState{ret=mv}
++ return ()
+
--eval :: (MonadState Variables m) => Exp -> m Value
-eval :: Exp -> StateT Variables IO Value
+eval :: Exp -> StateT State IO Value
eval (EBool b) = return (VBool b)
eval (EInt n) = return (VInt n)
eval (EVar i) = getVariableValue i
eval EReadB = do
s <- lift $ getWord
return $ VBool $ if (read s == 0) then False else True
+eval (EFunc i as) = do
+ vs <- mapM eval as
+ state <- get
+ (ds,ss) <- lookup i $ functions state
+ let m = foldr (\((Decl t i),v) m -> insert i v m) empty $ zip ds vs
+ in modify (\s -> s{variables=[m]})
+ mapM_ execute ss `catchError` (\_ -> return ())
+ v <- lift $ takeMVar $ ret state
+ put state
+ return v
getWord :: IO String
getWord = do
op Gt = \e e' -> VBool $ e > e'
op EGt = \e e' -> VBool $ e >= e'
-getVariableValue :: (MonadState Variables m) => Ident -> m Value
+getVariableValue :: (MonadState State m) => Ident -> m Value
getVariableValue i = do
- ms <- get
- findVariable i ms
+ s <- get
+ findVariable i $ variables s
-findVariable :: (MonadState Variables m) => Ident -> Variables -> m Value
+findVariable :: (MonadState State m) => Ident -> Variables -> m Value
findVariable i [] = fail $ "Variable "++show i++" not found in any scope."
findVariable i (m:ms) = if member i m then lookup i m else findVariable i ms
--setVariableValue :: (MonadState Variables m) => Ident -> Exp -> m Value
--setVariableValue :: (MonadState Variables m) => Ident -> Exp -> m Value
-setVariableValue :: Ident -> Exp -> StateT Variables IO Value
+setVariableValue :: Ident -> Exp -> StateT State IO Value
setVariableValue i e = do
v <- eval e
- ms <- get
- put $ updateVariable i v ms
+ state <- get
+ modify (\s -> s{variables= updateVariable i v $ variables state} )
return v
updateVariable :: Ident -> Value -> Variables -> Variables
updateVariable _ _ [] = []
updateVariable i v (m:ms) = if member i m then insert i v m:ms else m:updateVariable i v ms
-pushAndPop :: (MonadState Variables m) => m a -> m ()
+pushAndPop :: (MonadState State m) => m a -> m ()
pushAndPop s = do
- modify (empty:)
+ modify (\s -> s { variables = empty:variables s})
s
- modify tail
+ modify (\s -> s { variables = tail $ variables s})
-- execute :: (MonadState Variables m) => Stm -> m ()
-execute :: Stm -> StateT Variables IO ()
+execute :: Stm -> StateT State IO ()
execute (SNoop) = return ()
execute (SExp e) = eval e >> return ()
execute (SIf b s s') = do
TBool -> EBool False
execute (SDecl t i e) =do
v <- eval e
- (m:ms) <- get
- put $ (insert i v m):ms
+ state <- get
+ let (m:ms) = variables state in modify (\s -> s{variables=insert i v m:ms })
+execute (SReturn e) = do
+ v <- eval e
+ s <- get
+ lift $ putMVar (ret s) v
+ throwError $ userError "Returning.."
+
+addFunction :: (MonadState State m) => Func -> m ()
+addFunction (Func _ i d ss) = modify (\s -> s{functions=insert i (d,ss) (functions s) })
import Typecheck
import Interpret
- import Control.Monad.State hiding (State)
- import Control.Concurrent.MVar
-import Control.Monad.State
--import Data.Map as Map hiding (showTree)
import ErrM
type Verbosity = Int
+splitFunStm :: [FuncStm] -> ([Func],[Stm])
+splitFunStm [] = ([],[])
+splitFunStm ((F f):fss) = let (fs,ss) = splitFunStm fss in (f:fs,ss)
+splitFunStm ((S s):fss) = let (fs,ss) = splitFunStm fss in (fs,s:ss)
+
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
-runFile :: Verbosity -> ParseFun Stms -> FilePath -> IO ()
+runFile :: Verbosity -> ParseFun Program -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
-run :: Verbosity -> ParseFun Stms -> String -> IO ()
+run :: Verbosity -> ParseFun Program -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do
putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
- Ok (Program s) -> do
- --putStrLn "\nParse Successful!"
- --showTree v (Program s)
- typeCheck s
- --print "The program is type-correct!!"
- --print "Running program:"
- interpret s
- --print "Done running program!"
+ Ok (Program s) -> let (fun,st) = splitFunStm (s) in do
+ putStrLn "\nParse Successful!"
+ showTree v (Program s)
- runStateT (do mapM Typecheck.addFunction fun; mapM typeCheckFunction fun; mapM typeCheckStm st) Typecheck.emptyState
++ typeCheck fun st
+ print "The program is type-correct!!"
+ print "Running program:"
- mv <- newEmptyMVar
- runStateT (do mapM Interpret.addFunction fun; mapM execute st) Interpret.emptyState{ret=mv}
++ interpret fun st
+ print "Done running program!"
- return ()
showTree :: (Show a, Print a) => Int -> a -> IO ()
showTree v tree
main :: IO ()
main = do args <- getArgs
case args of
- [] -> hGetContents stdin >>= run 2 pStms
- "-s":fs -> mapM_ (runFile 0 pStms) fs
- fs -> mapM_ (runFile 2 pStms) fs
+ [] -> hGetContents stdin >>= run 2 pProgram
+ "-s":fs -> mapM_ (runFile 0 pProgram) fs
+ fs -> mapM_ (runFile 2 pProgram) fs
- module Typecheck (typeCheckExp, typeCheckStm, typeCheckVar, typeCheckFunction, addFunction, emptyState, State(..)) where
-module Typecheck (typeCheck,typeCheckExp, typeCheckStm, typeCheckVar) where
++module Typecheck (typeCheck, typeCheckExp, typeCheckStm, typeCheckVar, typeCheckFunction, addFunction, emptyState, State(..)) where
import Abssyntax
-import Control.Monad.State
-import Data.Map as Map
+import Control.Monad.State hiding (State)
+import Data.Map as Map hiding (map)
import Prelude hiding (lookup)
type Types = [Map Ident Type]
+type Function = (Type, [Type])
-inList :: Eq a => a -> [a] -> Bool
-inList _ [] = False
-inList a (x:xs) = if a == x then True else inList a xs
+data State = State {variables::Types,functions::(Map Ident Function),function::Ident}
+
+emptyState = State{variables=[empty], functions=(empty), function=(Ident "")}
assert :: Monad m => Bool -> String -> m ()
assert True _ = return ()
assert False s = fail s
-typeCheck :: [Stm] -> IO ()
-typeCheck s = runStateT (mapM typeCheckStm s) [empty] >> return ()
++typeCheck :: [Func] -> [Stm] -> IO ()
++typeCheck fun st = do
++ runStateT (do mapM addFunction fun; mapM typeCheckFunction fun; mapM typeCheckStm st) emptyState
++ return ()
+
-typeCheckExp :: (MonadState Types m) => Exp -> m Type
+typeCheckExp :: (MonadState State m) => Exp -> m Type
typeCheckExp (BiOpExp e o e') = do
t1 <- typeCheckExp e
t2 <- typeCheckExp e'
assert (t1 == t2) "The parameters for the binary operator aren't equal"
- if inList o [Eq,NEq] then return TBool
+ if elem o [Eq,NEq] then return TBool
else do
assert (t1 == TInt) "The parameters need to be of type int"
- if inList o [Plus,Minus,Times,Div]
+ if elem o [Plus,Minus,Times,Div]
then return TInt
else return TBool
typeCheckExp (EVar i) = typeCheckVar i
typeCheckExp (ENot e) = do
TBool <- typeCheckExp e
return TBool
+typeCheckExp (EFunc i as) = do
+ state <- get
+ (t,ts) <- lookup i $ functions state
+ checkParams as ts
+ return t
+
+checkParams :: (MonadState State m) => [Exp] -> [Type] -> m ()
+checkParams [] [] = return ()
+checkParams [] _ = fail "Too for arguments when calling function"
+checkParams _ [] = fail "Too many arguments when calling function"
+checkParams (e:es) (t:ts) = do
+ t2 <- typeCheckExp e
+ assert (t == t2) "Arugments does not match"
+ checkParams es ts
-typeCheckVar :: (MonadState Types m) => Ident -> m Type
+typeCheckVar :: (MonadState State m) => Ident -> m Type
typeCheckVar i = do
- ms <- get
- findVariable i ms
+ s <- get
+ findVariable i $ variables s
-findVariable :: (MonadState Types m) => Ident -> Types -> m Type
+findVariable :: (MonadState State m) => Ident -> Types -> m Type
findVariable i [] = fail $ "Variable "++show i++" not found in any scope."
findVariable i (m:ms) = if member i m then lookup i m else findVariable i ms
-pushAndPop :: (MonadState Types m) => m a -> m ()
+pushAndPop :: (MonadState State m) => m a -> m ()
pushAndPop s = do
- modify (empty:)
+ modify (\s -> s { variables = empty:variables s})
s
- modify tail
+ modify (\s -> s { variables = tail $ variables s})
-typeCheckStm :: (MonadState Types m) => Stm -> m ()
+typeCheckStm :: (MonadState State m) => Stm -> m ()
typeCheckStm SNoop = return ()
typeCheckStm (SExp e) = do
typeCheckExp e
typeCheckStm (SPrint e) = do
typeCheckExp e
return ()
+typeCheckStm (SReturn e) = do
+ t <- typeCheckExp e
+ state <- get
+ (t2,_) <- lookup (function state) $ functions state
+ assert (t == t2) $ "Illegal to return "++show t++" in function "++show (function state)++" which returns "++show t2
-addVariable :: (MonadState Types m) => Ident -> Type -> m ()
+
+addVariable :: (MonadState State m) => Ident -> Type -> m ()
addVariable i t = do
- (m:ms) <- get
- case insertLookupWithKey (\k a1 a2 -> a1) i t m of
- (Nothing,m') -> put (m':ms)
+ s <- get
+ let (m:ms) = variables s in case insertLookupWithKey (\k a1 a2 -> a1) i t m of
+ (Nothing,m') -> modify (\s -> s{ variables = m':ms})
+ _ -> fail $ "Duplicate variable declaration: "++show i
+
+typeCheckFunction :: (MonadState State m) => Func -> m ()
+typeCheckFunction (Func t i d s) = do
+ state <- get
+ modify (\s -> s{variables=[empty], function=i})
+ mapM (\(Decl t i) -> addVariable i t) d
+ case last s of
+ (SReturn _) -> return ()
+ _ -> fail $ "Function "++show i++" doesn't end with return statement"
+ mapM typeCheckStm s
+ put state
+
+addFunction :: (MonadState State m) => Func -> m ()
+addFunction (Func t i d _) = do
+ s <- get
+ let m = functions s in case insertLookupWithKey (\k a1 a2 -> a1) i (t, map (\(Decl t i) -> t) d) m of
+ (Nothing,m') -> modify (\s -> s{ functions = m'})
_ -> fail $ "Duplicate variable declaration: "++show i
projects / proglang.git / commitdiff