From: Michael Andreen <harv@ruin.nu>
Date: Tue, 14 Mar 2006 18:08:37 +0000 (+0000)
Subject: merged changes to function branch
X-Git-Url: https://ruin.nu/git/?p=proglang.git;a=commitdiff_plain;h=04f0a9566794cf761b7bcf83190051a400ec3653;hp=-c

merged changes to function branch
---

04f0a9566794cf761b7bcf83190051a400ec3653
diff --combined CompInt.hs
index 0000000,1188466..d5aa2ca
mode 000000,100644..100644
--- a/CompInt.hs
+++ b/CompInt.hs
@@@ -1,0 -1,54 +1,53 @@@
+ -- 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
 -import Data.Map as Map hiding (showTree)
+ 
+ import ErrM
+ 
+ type ParseFun a = [Token] -> Err a
+ 
+ myLLexer = myLexer
+ 
 -
 -cHeader = "#include <stdio.h>\nint read(){\nint n;\nscanf(\"%d\",&n);\nreturn n;\n}\nint main(void){\n"
 -
 -cFooter = "return 0;}"
++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 ()
+ 
 -runFile :: ([Stm] -> IO()) -> ParseFun Stms -> FilePath -> IO ()
++runFile :: ([Func] -> [Stm] -> IO()) -> ParseFun Program -> FilePath -> IO ()
+ runFile e p f = readFile f >>= run e p
+ 
 -run :: ([Stm] -> IO()) -> ParseFun Stms -> String -> IO ()
++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
 -	Ok (Program s) -> do
 -		typeCheck s
 -		e s
++	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 pStms
 -		"-c":f:[] -> runFile (writeFile (f++".c") . compile)  pStms f
 -		f:[] -> runFile interpret pStms f
++		[] -> 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"
diff --combined Compile.hs
index 0e1cf22,2252fc5..eb70d0c
--- a/Compile.hs
+++ b/Compile.hs
@@@ -1,8 -1,15 +1,15 @@@
- module Compile (compileExp, compileStm) where
+ module Compile (compile,compileExp, compileStm) where
  
  import Abssyntax
  import Prelude hiding (lookup)
  
+ cHeader = "#include <stdio.h>\nint read(){\nint n;\nscanf(\"%d\",&n);\nreturn n;\n}\nint main(void){\n"
+ 
+ cFooter = "return 0;}"
+ 
 -compile :: [Stm] -> String
 -compile s = cHeader++concat (map compileStm s)++cFooter
++compile :: [Func] -> [Stm] -> String
++compile f s = cHeader++concat (map compileStm s)++cFooter
+ 
  compileExp :: Exp -> String
  compileExp (EBool True) = "1";
  compileExp (EBool False) = "0";
diff --combined Interpret.hs
index 0e39285,0728d51..5afcefb
--- a/Interpret.hs
+++ b/Interpret.hs
@@@ -1,14 -1,10 +1,14 @@@
- 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
@@@ -17,12 -13,12 +17,18 @@@
  	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
@@@ -48,16 -44,6 +54,16 @@@ eval EReadI = d
  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
@@@ -80,37 -66,37 +86,37 @@@ op ELt = \e e' -> VBool $ e <= e
  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
@@@ -128,13 -114,5 +134,13 @@@ execute (SDeclD t i) = execute $ SDecl 
  	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) })
diff --combined Interpreter.hs
index e41759d,694ce23..ae73abb
--- a/Interpreter.hs
+++ b/Interpreter.hs
@@@ -13,9 -13,8 +13,6 @@@ import Abssynta
  
  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
  
@@@ -25,34 -24,27 +22,32 @@@ myLLexer = myLexe
  
  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
@@@ -63,9 -55,9 +58,9 @@@
  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
  
  
  
diff --combined Typecheck.hs
index 5c70ccf,1b0baa0..a8c10e5
--- a/Typecheck.hs
+++ b/Typecheck.hs
@@@ -1,31 -1,33 +1,36 @@@
- 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
@@@ -47,37 -49,23 +52,37 @@@ typeCheckExp (ENeg e) = d
  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
@@@ -98,34 -86,10 +103,34 @@@ typeCheckStm (SDecl t i e) = d
  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