1 module StackVM (StackVal(..), StackExp(..), Stack, Program, stackVM) where
3 -- Values that may appear in the stack. Such a value will also be
4 -- returned by the stackVM program execution function.
5 data StackVal = IVal Integer | BVal Bool | Void deriving Show
7 -- The various expressions our VM understands.
8 data StackExp = PushI Integer
16 type Stack = [StackVal]
17 type Program = [StackExp]
19 -- Execute the given program. Returns either an error message or the
20 -- value on top of the stack after execution.
21 stackVM :: Program -> Either String StackVal
24 errType :: String -> Either String a
25 errType op = Left $ "Encountered '" ++ op ++ "' opcode with ill-typed stack."
27 errUnderflow :: String -> Either String a
28 errUnderflow op = Left $ "Stack underflow with '" ++ op ++ "' opcode."
30 -- Execute a program against a given stack.
31 execute :: Stack -> Program -> Either String StackVal
32 execute [] [] = Right Void
33 execute (s:_) [] = Right s
35 execute s (PushI x : xs) = execute (IVal x : s) xs
36 execute s (PushB x : xs) = execute (BVal x : s) xs
38 execute (IVal s1 : IVal s2 : ss) (Add : xs) = execute (s':ss) xs
39 where s' = IVal (s1 + s2)
40 execute (_:_:_) (Add:_) = errType "Add"
41 execute _ (Add:_) = errUnderflow "Add"
43 execute (IVal s1:IVal s2:ss) (Mul : xs) = execute (s':ss) xs
44 where s' = IVal (s1 * s2)
45 execute (_:_:_) (Mul:_) = errType "Mul"
46 execute _ (Mul:_) = errUnderflow "Mul"
48 execute (BVal s1:BVal s2:ss) (And : xs) = execute (s':ss) xs
49 where s' = BVal (s1 && s2)
50 execute (_:_:_) (And:_) = errType "And"
51 execute _ (And:_) = errUnderflow "And"
53 execute (BVal s1 : BVal s2 : ss) (Or : xs) = execute (s':ss) xs
54 where s' = BVal (s1 || s2)
55 execute (_:_:_) (Or:_) = errType "Or"
56 execute _ (Or:_) = errUnderflow "Or"
58 test = stackVM [PushI 3, PushI 5, Add]