hw5/StackVM.hs

   1 module StackVM (StackVal(..), StackExp(..), Stack, Program, stackVM) where
   2
   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
   6
   7 -- The various expressions our VM understands.
   8 data StackExp = PushI Integer
   9               | PushB Bool
  10               | Add
  11               | Mul
  12               | And
  13               | Or
  14                 deriving Show
  15
  16 type Stack   = [StackVal]
  17 type Program = [StackExp]
  18
  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
  22 stackVM = execute []
  23
  24 errType :: String -> Either String a
  25 errType op = Left $ "Encountered '" ++ op ++ "' opcode with ill-typed stack."
  26
  27 errUnderflow :: String -> Either String a
  28 errUnderflow op = Left $ "Stack underflow with '" ++ op ++ "' opcode."
  29
  30 -- Execute a program against a given stack.
  31 execute :: Stack -> Program -> Either String StackVal
  32 execute [] []                               = Right Void
  33 execute (s:_) []                            = Right s
  34
  35 execute s (PushI x : xs)                    = execute (IVal x : s) xs
  36 execute s (PushB x : xs)                    = execute (BVal x : s) xs
  37
  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"
  42
  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"
  47
  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"
  52
  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"
  57
  58 test = stackVM [PushI 3, PushI 5, Add]