diff --git a/MVM.cabal b/MVM.cabal index f350a45..dd0d1f1 100644 --- a/MVM.cabal +++ b/MVM.cabal @@ -40,7 +40,8 @@ executable MVM base ^>=4.15.0.0, bytestring ^>=0.11.0.0, containers ^>=0.6.4.1, - mtl ^>=2.2.2 + mtl ^>=2.2.2, + transformers ^>=0.5.6.2 hs-source-dirs: app default-language: Haskell2010 @@ -57,6 +58,7 @@ test-suite spec bytestring ^>=0.11.0.0, containers ^>=0.6.4.1, mtl ^>=2.2.2, + transformers ^>=0.5.6.2, hspec ==2.* other-modules: Assembler.TokenizerSpec diff --git a/app/Main.hs b/app/Main.hs index 350c58b..84effda 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,10 +6,12 @@ import qualified VirtualMachine as VM import Assembler.Compiler (compile) +import Control.Monad.Trans.Except + run :: String -> IO () run input = case compile input of - (Right bytes) -> print $ VM.run VM.empty (B.pack bytes) + (Right bytes) -> runExceptT (VM.run VM.empty (B.pack bytes)) >>= print >> return () (Left err) -> putStrLn err main :: IO () diff --git a/app/VirtualMachine.hs b/app/VirtualMachine.hs index ee9f8ba..3241c5d 100644 --- a/app/VirtualMachine.hs +++ b/app/VirtualMachine.hs @@ -12,7 +12,10 @@ module VirtualMachine ( import Data.Word (Word8) import Data.Foldable (toList) -import Data.Char (toLower, toUpper) +import Data.Char (chr, toLower, toUpper) + +import Control.Monad.Trans (liftIO, lift) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT, except) import qualified Data.Map as M import qualified Data.Sequence as S @@ -49,6 +52,8 @@ data Op = Nop -- 0x00 | Jge -- 0x13 | Jle -- 0x14 | Ld -- 0x15 + | In -- 0x16 + | Out -- 0x17 deriving (Eq, Ord, Enum, Show, Read, Bounded) type Args = [Int] @@ -62,7 +67,7 @@ data Instruction = Simple { _op :: Op } | Complex { _op :: Op , _noParams :: Int - , _cAction :: VM -> Args -> Either String VM + , _cAction :: VM -> Args -> ExceptT String IO VM } data Command = Command { _instr :: Instruction @@ -88,24 +93,31 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\ , Simple { _op = Div, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y `div` x]) } , Simple { _op = Neg, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [-x]) } , Simple { _op = Not, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [if x /= 0 then 0 else 1]) } - , Complex { _op = Halt, _noParams = 0, _cAction = (\vm _ -> Right $ vm { _halt = True }) } - , Complex { _op = Jmp, _noParams = 1, _cAction = (\vm [x] -> Right $ vm { _pc = x}) } + , Complex { _op = Halt, _noParams = 0, _cAction = (\vm _ -> except $ Right $ vm { _halt = True }) } + , Complex { _op = Jmp, _noParams = 1, _cAction = (\vm [x] -> except $ Right $ vm { _pc = x}) } , Complex { _op = Je, _noParams = 1, _cAction = jumpIf (==) } , Complex { _op = Jne, _noParams = 1, _cAction = jumpIf (/=) } , Complex { _op = Jg, _noParams = 1, _cAction = jumpIf (>) } , Complex { _op = Jl, _noParams = 1, _cAction = jumpIf (<) } , Complex { _op = Jge, _noParams = 1, _cAction = jumpIf (>=) } , Complex { _op = Jle, _noParams = 1, _cAction = jumpIf (<=) } + , Complex { _op = Out, _noParams = 0, _cAction = output } ] -jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Either String VM -jumpIf _ _ [] = Left $ "Address expected" -jumpIf _ _ (_:_:_) = Left $ "Multiple parameters are not supported by jmp* instructions" -jumpIf predicate vm [addr] = Right $ vm { _pc = pc } +jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> ExceptT String IO VM +jumpIf _ _ [] = except $ Left $ "Address expected" +jumpIf _ _ (_:_:_) = except $ Left $ "Multiple parameters are not supported by jmp* instructions" +jumpIf predicate vm [addr] = except $ Right $ vm { _pc = pc } where (top:_) = toList . _stack $ vm pc = if top `predicate` 0 then addr else _pc vm + 1 +output :: VM -> Args -> ExceptT String IO VM +output vm _ = do + let char = map chr $ toList $ S.take 1 $ _stack vm + liftIO $ putStr char + return vm { _pc = _pc vm + 1, _stack = S.drop 1 $ _stack vm} + instructionByOp :: M.Map Op Instruction instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions @@ -133,18 +145,18 @@ parseCommand (opByte:xs) = do let params = map fromIntegral $ take paramsNumber xs :: [Int] return (Command instruction params, drop paramsNumber xs) -interpret :: [Command] -> VM -> Either String VM -interpret _ vm@(VM _ _ _ True) = Right $ vm +interpret :: [Command] -> VM -> ExceptT String IO VM +interpret _ vm@(VM _ _ _ True) = except $ Right $ vm interpret cmds vm = do vm' <- interpretCommand cmds vm interpret cmds vm' -interpretCommand :: [Command] -> VM -> Either String VM -interpretCommand [] _ = Left $ "Empty code" +interpretCommand :: [Command] -> VM -> ExceptT String IO VM +interpretCommand [] _ = except $ Left $ "Empty code" interpretCommand cmds vm@(VM pc _ _ _) - | pc >= length cmds = Right $ vm { _halt = True } + | pc >= length cmds = except $ Right $ vm { _halt = True } | otherwise = case instr of - (Simple _ _ _ _) -> interpretSimple vm cmd + (Simple _ _ _ _) -> except $ interpretSimple vm cmd (Complex _ _ _) -> interpretComplex vm cmd where cmd@(Command instr _) = cmds !! pc @@ -158,9 +170,9 @@ interpretSimple vm (Command (Simple _ _ noPops operation) args) = vm' }) interpretSimple _ _ = Left "Unknown operation" -interpretComplex :: VM -> Command -> Either String VM +interpretComplex :: VM -> Command -> ExceptT String IO VM interpretComplex vm (Command (Complex _ _ operation) args) = operation vm args -interpretComplex _ _ = Left "Unknown operation" +interpretComplex _ _ = except $ Left "Unknown operation" -run :: VM -> B.ByteString -> Either String VM -run vm code = parse code >>= flip interpret vm \ No newline at end of file +run :: VM -> B.ByteString -> ExceptT String IO VM +run vm code = return code >>= (except . parse) >>= flip interpret vm \ No newline at end of file