1 files changed, 58 insertions, 0 deletions
diff --git a/lec05/StackVM.hs b/lec05/StackVM.hs
new file mode 100644
index 0000000..5b2591a
--- /dev/null
+++ b/lec05/StackVM.hs
@@ -0,0 +1,58 @@
+module StackVM (StackVal(..), StackExp(..), Stack, Program, stackVM) where
+
+-- Values that may appear in the stack. Such a value will also be
+-- returned by the stackVM program execution function.
+data StackVal = IVal Integer | BVal Bool | Void deriving Show
+
+-- The various expressions our VM understands.
+data StackExp = PushI Integer
+              | PushB Bool
+              | Add
+              | Mul
+              | And
+              | Or
+                deriving Show
+
+type Stack   = [StackVal]
+type Program = [StackExp]
+
+-- Execute the given program. Returns either an error message or the
+-- value on top of the stack after execution.
+stackVM :: Program -> Either String StackVal
+stackVM = execute []
+
+errType :: String -> Either String a
+errType op = Left $ "Encountered '" ++ op ++ "' opcode with ill-typed stack."
+
+errUnderflow :: String -> Either String a
+errUnderflow op = Left $ "Stack underflow with '" ++ op ++ "' opcode."
+
+-- Execute a program against a given stack.
+execute :: Stack -> Program -> Either String StackVal
+execute [] []                               = Right Void
+execute (s:_) []                            = Right s
+
+execute s (PushI x : xs)                    = execute (IVal x : s) xs
+execute s (PushB x : xs)                    = execute (BVal x : s) xs
+
+execute (IVal s1 : IVal s2 : ss) (Add : xs) = execute (s':ss) xs
+    where s' = IVal (s1 + s2)
+execute (_:_:_) (Add:_)                     = errType "Add"
+execute _ (Add:_)                           = errUnderflow "Add"
+
+execute (IVal s1:IVal s2:ss) (Mul : xs)     = execute (s':ss) xs
+    where s' = IVal (s1 * s2)
+execute (_:_:_) (Mul:_)                     = errType "Mul"
+execute _ (Mul:_)                           = errUnderflow "Mul"
+
+execute (BVal s1:BVal s2:ss) (And : xs)     = execute (s':ss) xs
+    where s' = BVal (s1 && s2)
+execute (_:_:_) (And:_)                     = errType "And"
+execute _ (And:_)                           = errUnderflow "And"
+
+execute (BVal s1 : BVal s2 : ss) (Or : xs)  = execute (s':ss) xs
+    where s' = BVal (s1 || s2)
+execute (_:_:_) (Or:_)                      = errType "Or"
+execute _ (Or:_)                            = errUnderflow "Or"
+
+test = stackVM [PushI 3, PushI 5, Add]