Evaluator

2 files changed, 191 insertions, 1 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
new file mode 100644
index 0000000..9047469
--- /dev/null
+++ b/src/Eval.hs
@@ -0,0 +1,190 @@
+module Eval
+  ()
+  where
+import Syntax
+import Typecheck ()
+
+import Control.Monad.State.Lazy
+import Control.Monad.Except
+data Value = VInt Int
+            | VRecord  [(Idnt,Value)]
+            | VVariant Idnt Value
+            | VPtr Int
+            deriving(Eq,Show)
+false = VVariant "false" (VRecord [])
+true = VVariant "true" (VRecord [])
+type Variables = [(Idnt,Value)]
+type Heap = (Int,[(Int,Value)])
+
+data ProgramState= ProgramState Variables Heap
+
+type EvalMonad = ExceptT String (State ProgramState)
+
+assertInt :: Value -> EvalMonad Int
+assertInt (VInt i) = return i
+assertInt v = throwError $ "expected value to be int " ++ show v
+assertRec :: Value -> EvalMonad [(Idnt,Value)]
+assertRec (VRecord l) = return l
+assertRec v = throwError $ "expected value to be int " ++ show v
+assertVar :: Value -> EvalMonad (Idnt,Value)
+assertVar (VVariant label val) = return (label,val)
+assertVar v = throwError $ "expected value to be int " ++ show v
+assertPtr :: Value -> EvalMonad Int
+assertPtr (VPtr i) = return i
+assertPtr v = throwError $ "expected value to be ptr " ++ show v
+
+evalExpr :: Expr ->EvalMonad Value
+evalExpr (Var v)= do
+  (ProgramState vars _) <- get
+  case lookup v vars of
+    Just val -> return val
+    Nothing -> throwError $ "Variable" ++show v ++ "not defined"
+evalExpr (IntLit n) = return $ VInt n
+evalExpr (Record l) = do
+  fields <- mapM (\(idnt,expr) ->do
+                     val <- evalExpr expr
+                     return (idnt,val) ) l
+  return $ VRecord fields
+evalExpr (Variant _ idnt e) = do
+  v <- evalExpr e
+  return $ VVariant idnt v
+evalExpr (Add e1 e2) = do
+  v1 <- evalExpr e1
+  v2 <- evalExpr e2
+  i1 <- assertInt v1
+  i2 <- assertInt v2
+  return $ VInt $ i1 + i2
+
+evalExpr (Mult e1 e2) = do
+  v1 <- evalExpr e1
+  v2 <- evalExpr e2
+  i1 <- assertInt v1
+  i2 <- assertInt v2
+  return $ VInt $ i1 + i2
+evalExpr (Neg e) = do
+  v <- evalExpr e
+  i <- assertInt v
+  return $ VInt i
+evalExpr (Deref e) = do
+  v <- evalExpr e
+  ptrVal <-assertPtr v
+  (ProgramState _ (_,heap)) <- get
+  case lookup ptrVal heap of
+    Just val -> return val
+    Nothing -> throwError $ "invalid pointer" 
+evalExpr c@(Match e cases) = do
+  v <- evalExpr e
+  (label,value) <- assertVar v
+  case lookup label (map (\(a,b,c)-> (a,(b,c)) )cases) of
+    Just (bind,expr) -> do
+      st@(ProgramState vars heap) <- get
+      put $ ProgramState ((bind,value):vars) heap
+      ret <- evalExpr expr
+      put st
+      return ret
+    Nothing -> throwError $ "Unsupported label"++ show label ++ "in case" ++ show c
+evalExpr (Proj label e) = do
+  v <- evalExpr e
+  l <- assertRec v
+  case lookup label l of
+    Just v -> return v
+    Nothing -> throwError $ "Projection "++ show label ++ "on record" ++ show v
+  
+evalExpr (Annot e _) = evalExpr e
+
+changeDict ::Eq a=> a -> b -> [(a,b)] -> Maybe [(a,b)]
+changeDict _ _ []= Nothing
+changeDict var val ((a,b):xs) = if a==var then (Just $ (a,val):xs) else
+  do
+    ret <- changeDict var val xs
+    return $ (a,b):ret
+ensureTop :: (Show a, Eq a, Show b) => a -> [(a,b)] -> EvalMonad [(a,b)]
+ensureTop var [] = throwError $ "Expected variable " ++ show var ++ " at the end of lexical scope, instead got empty set of variables" 
+ensureTop var ((a,b):xs) = if a==var then return xs
+  else throwError $ "Expected variable " ++ show var ++ " at the end of lexical scope, instead got" ++ show b
+  
+ 
+  
+
+runCom :: Com -> EvalMonad ProgramState
+runCom Skip = do
+  get
+runCom (Seq c1 c2) =do
+  runCom c1
+  runCom c2
+runCom (If e1 c1 c2) = do
+  v1 <- evalExpr e1
+  if v1 == true  then runCom c1
+    else if v1 ==false then runCom c2
+         else throwError $ "Not boolean in if "++ show v1
+runCom c@(While e1 c1) = do
+  v1 <- evalExpr e1
+  if v1 == true  then do
+      runCom c1
+      runCom c
+    else if v1 ==false then runCom Skip
+         else throwError $ "Not boolean in if "++ show v1
+runCom (Asgn var expr) = do
+  val <- evalExpr expr
+  (ProgramState vars heap) <- get
+  case changeDict var val vars of
+    Just newVars -> let p = ProgramState newVars heap in
+      do
+        put p
+        return p
+    Nothing -> throwError $ "Assigning to not-declared variable " ++ show var
+runCom (Decl var expr com) = do
+  val <- evalExpr expr
+  (ProgramState vars heap) <- get
+  put $ ProgramState ((var,val):vars) heap
+  runCom com
+  --remove new variable
+  (ProgramState vars heap) <- get
+  vars' <- ensureTop var vars
+  put $ ProgramState vars' heap
+  get
+runCom (Alloc var expr com) = do
+  val <- evalExpr expr
+  (ProgramState vars (heapCnt,heap)) <- get
+  put $ ProgramState ((var,VPtr heapCnt):vars) (heapCnt+1,((heapCnt,val):heap))
+  runCom com
+  --remove new variable
+  (ProgramState vars heap) <- get
+  vars' <- ensureTop var vars
+  put $ ProgramState vars' heap
+  get
+runCom (Save var expr) = do
+  val <- evalExpr expr
+  ptr <- evalExpr (Var var)
+  ptrVal <- assertPtr ptr
+  (ProgramState vars (heapCnt,heap)) <- get
+  heap' <- case changeDict ptrVal val heap of
+    Nothing -> throwError $ "invalid pointer"
+    Just x -> return x
+  put $ ProgramState vars (heapCnt,heap')
+  get
+runCom (SMatch e cases) = do
+  v <- evalExpr e
+  (label,value) <- assertVar v
+  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
+      runCom com
+      (ProgramState vars heap) <- get
+      vars' <- ensureTop bind vars
+      put $ ProgramState vars' heap
+      get
+    Nothing -> throwError $ "Unsupported label"++ show label ++ "in case" ++ show c
+runCom (FunctionCall var fname arugments) = undefined --TODO
+
+  
+  
+  
+  
+  
+  
+
+  
+
+
diff --git a/src/Typecheck.hs b/src/Typecheck.hs
index 8f09627..7136e64 100644
--- a/src/Typecheck.hs
+++ b/src/Typecheck.hs
@@ -4,10 +4,10 @@ module Typecheck
  checkExpr,
  wellFormed,
  Environment,
+ bool
  )
   where
 import Syntax
---import Control.Monad
 import Control.Monad.Except
 type Environment = [(Idnt,Typ)]