bartek/mvm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactor code

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-18 17:20:27 +01:00
parent c656b8ca4e
commit 2c56582460
15 changed files with 454 additions and 659 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
README.md
View File

@@ -28,10 +28,9 @@ List of available instructions:
| ``0x16`` | ``IN`` | Read input from stdin |
| ``0x17`` | ``OUT`` | Put top stack value to stdout as char |
| ``0x18`` | ``CLR x`` | Wipe out ``x`` values before the top value from the stack |
| ``0x19`` | ``ROLL`` | Rotate the stack/stack frame |
| ``0x1A`` | ``OVER`` | Duplicate and push the second value from the top |
| ``0x1B`` | ``LDL x`` | Lift the ``x`` from the _fp_ variable to the top of the stack |
| ``0x1C`` | ``STL x`` | Store the top stack value under the ``x`` from the _fp_ variable |
| ``0x19`` | ``OVER`` | Duplicate and push the second value from the top |
| ``0x1A`` | ``LDL x`` | Lift the ``x`` from the _fp_ variable to the top of the stack |
| ``0x1B`` | ``STL x`` | Store the top stack value under the ``x`` from the _fp_ variable |
## Example
### Example 1

2
app/Assembler/Compiler.hs
View File

@@ -7,4 +7,4 @@ import Assembler.Parser (parse)
import Assembler.Emitter (emit)
compile :: String -> Either String [Word8]
compile input = return input >>= tokenize >>= parse >>= emit
compile input = tokenize input >>= parse >>= emit

19
app/Assembler/Emitter.hs
View File

@@ -23,7 +23,7 @@ data Context = Context { _beans :: [Bean]
type Emitter = AST -> ExceptT String (State Context) ()
empty :: Context
empty = Context { _beans = [], _labels = M.fromList [], _currentLabel = Nothing }
empty = Context { _beans = [], _labels = M.empty, _currentLabel = Nothing }
emitBean :: Bean -> ExceptT String (State Context) ()
emitBean bean = lift $ do
@@ -32,17 +32,17 @@ emitBean bean = lift $ do
return ()
emitByte :: Word8 -> ExceptT String (State Context) ()
emitByte byte = emitBean $ Byte $ byte
emitByte byte = emitBean $ Byte byte
emitParam :: Emitter
emitParam (Param (Integer x)) = emitByte $ fromIntegral $ x
emitParam (Param (LabelRef Global l)) = emitBean $ Reference $ l
emitParam (Param (Integer x)) = emitByte $ fromIntegral x
emitParam (Param (LabelRef Global l)) = emitBean $ Reference l
emitParam (Param (LabelRef Local l)) = do
ctx <- lift get
scope <- case _currentLabel ctx of
(Just s) -> return s
Nothing -> throwError $ "Local label ('." ++ l ++ "') reference is allowed only in the global label scope"
emitBean $ Reference $ (scope ++ "." ++ l)
emitBean $ Reference (scope ++ "." ++ l)
emitParam _ = throwError "Number or label reference expected"
emitLabelDef :: Emitter
@@ -50,7 +50,7 @@ emitLabelDef (LabelDef Global label) = do
ctx <- lift get
let labels = _labels ctx
let current = length (_beans ctx)
when (label `M.member` labels) (throwError $ "Label '" ++ (label) ++ "' is already defined")
when (label `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined")
put ctx { _labels = M.insert label current labels, _currentLabel = Just label }
return ()
emitLabelDef (LabelDef Local label) = do
@@ -61,7 +61,7 @@ emitLabelDef (LabelDef Local label) = do
Nothing -> throwError $ "Local label ('." ++ label ++ "') can be defined only in the global label scope"
let canonicalLabel = scope ++ "." ++ label
let current = length (_beans ctx)
when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ (label) ++ "' is already defined in the global label '" ++ scope ++ "' scope")
when (canonicalLabel `M.member` labels) (throwError $ "Label '" ++ label ++ "' is already defined in the global label '" ++ scope ++ "' scope")
put ctx { _labels = M.insert canonicalLabel current labels }
return ()
emitLabelDef _ = throwError "Label definition expected"
@@ -71,7 +71,6 @@ emitInstr (Instruction (Operator op) Empty) = emitByte $ fromIntegral . fromEnum
emitInstr (Instruction (Operator op) (Params params)) = do
emitByte $ fromIntegral $ fromEnum op
mapM_ emitParam params
return ()
emitInstr _ = throwError "Instruction expected"
emitLine :: Emitter
@@ -81,13 +80,13 @@ emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr >> ret
emitLine _ = throwError "Line of code expected"
emitProgram :: Emitter
emitProgram (Program progLines) = mapM emitLine progLines >> return ()
emitProgram (Program progLines) = mapM_ emitLine progLines
emitProgram _ = throwError "Program code expected"
resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean]
resolveLabels labels beans = sequence $ foldr folder [] beans
where
folder b acc = (resolveLabel labels b) : acc
folder b acc = resolveLabel labels b : acc
resolveLabel :: M.Map String Int -> Bean -> Either String Bean
resolveLabel _ b@(Byte _) = Right b

33
app/Assembler/Parser.hs
View File

@@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Assembler.Parser where
import Data.List (intercalate)
@@ -43,36 +44,36 @@ parseInt _ = Nothing
-- ID := [alnum, '_']+
parseIdentifier :: Parser
parseIdentifier ((T.Identifier iden):_) = Just $ ParseResult (Identifier iden) 1
parseIdentifier _ = Nothing
parseIdentifier _ = Nothing
-- ':'
parseColon :: Parser
parseColon ((T.Colon):_) = Just $ ParseResult Colon 1
parseColon _ = Nothing
parseColon (T.Colon:_) = Just $ ParseResult Colon 1
parseColon _ = Nothing
-- '&'
parseAmpersand :: Parser
parseAmpersand ((T.Ampersand):_) = Just $ ParseResult Ampersand 1
parseAmpersand _ = Nothing
parseAmpersand (T.Ampersand:_) = Just $ ParseResult Ampersand 1
parseAmpersand _ = Nothing
-- '.'
parseDot :: Parser
parseDot ((T.Dot):_) = Just $ ParseResult Dot 1
parseDot _ = Nothing
parseDot (T.Dot:_) = Just $ ParseResult Dot 1
parseDot _ = Nothing
-- label_def := '.'? ID ':'
parseLabelDef :: Parser
parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine
where
combine [Dot, (Identifier iden), _] = LabelDef Local iden
combine [_, (Identifier iden), _] = LabelDef Global iden
combine [Dot, Identifier iden, _] = LabelDef Local iden
combine [_, Identifier iden, _] = LabelDef Global iden
-- label_ref := '&' ID
parseLabelRef :: Parser
parseLabelRef = parseSeq [parseAmpersand, parseOptionally parseDot, parseIdentifier] combine
where
combine [_, Dot, (Identifier iden)] = LabelRef Local iden
combine [_, _, (Identifier iden)] = LabelRef Global iden
combine [_, Dot, Identifier iden] = LabelRef Local iden
combine [_, _, Identifier iden] = LabelRef Global iden
-- param := INT | label_ref
parseParam :: Parser
@@ -117,7 +118,7 @@ parseMany parser combiner tokens = if null asts
parseGreedy :: Parser -> [T.Token] -> [ParseResult]
parseGreedy parser tokens = case parser tokens of
(Just r@(ParseResult _ consumed)) -> r : parseGreedy parser (drop consumed tokens)
Nothing -> []
Nothing -> []
-- a | b | c
parseAlt :: [Parser] -> (AST -> AST) -> Parser
@@ -137,7 +138,7 @@ parseSeq parsers combiner tokens = do
results <- parseAll parsers tokens
let consumed = sum $ map (\(ParseResult _ c) -> c) results
let asts = map (\(ParseResult a _) -> a) results
if (length asts) == (length parsers)
if length asts == length parsers
then return $ ParseResult (combiner asts) consumed
else Nothing
@@ -147,7 +148,7 @@ parseAll [] _ = Just []
parseAll (p:ps) tokens = do
(ParseResult ast consumed) <- p tokens
rest <- parseAll ps (drop consumed tokens)
return $ (ParseResult ast consumed) : rest
return $ ParseResult ast consumed : rest
-- 'Nothing' if not consumed tokens exist
assertConsumed :: Parser -> Parser
@@ -162,8 +163,8 @@ parse :: [T.Token] -> Either String AST
parse tokens = do
let codeLines = explode (==T.NewLine) tokens
let results = map (assertConsumed parseLine) codeLines
let errors = filter ((==Nothing) . snd) $ zipWith (,) codeLines $ results
let errorMsg = "Parse error(s):\n" ++ (intercalate "\n" $ map (show . fst) errors)
let errors = filter ((==Nothing) . snd) $ zip codeLines results
let errorMsg = "Parse error(s):\n" ++ intercalate "\n" (map (show . fst) errors)
case sequenceA results of
(Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r
Nothing -> Left errorMsg

43
app/Assembler/Tokenizer.hs
View File

@@ -38,27 +38,24 @@ keywordTokenizer cs kwd token input
matches = and zipped && len == length zipped
operatorTokenizer :: Op -> Tokenizer
operatorTokenizer op input = keywordTokenizer False (toLowerCase . show $ op) (Operator op) input
operatorTokenizer op = keywordTokenizer False (toLowerCase . show $ op) (Operator op)
tokenizeOperators :: Tokenizer
tokenizeOperators = anyTokenizer $ map operatorTokenizer ops
where
ops = sortBy cmp [Nop ..]
cmp x y = (length . show) y `compare` (length . show) x
tokenizeOperators = anyTokenizer $ map operatorTokenizer $ sortBy cmp [Nop ..]
where cmp x y = (length . show) y `compare` (length . show) x
tokenizeIdentifier :: Tokenizer
tokenizeIdentifier [] = Nothing
tokenizeIdentifier input@(x:_) = if null identifier || (not . isAlpha) x
then Nothing
else Just $ TokenizeResult (Identifier identifier) (length identifier)
where
identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input
where identifier = takeWhile (or . sequenceA [isAlphaNum, (=='_')]) input
tokenizeWhitespace :: Tokenizer
tokenizeWhitespace [] = Nothing
tokenizeWhitespace (x:_)
| isSpace x = Just $ TokenizeResult WhiteSpace 1
| otherwise = Nothing
| otherwise = Nothing
tokenizeDecimal :: Tokenizer
tokenizeDecimal [] = Nothing
@@ -71,15 +68,11 @@ tokenizeDecimal input = if null numberStr
numberStr = takeWhile isDigit input
tokenizeHex :: Tokenizer
tokenizeHex [] = Nothing
tokenizeHex input = if isPrefix && len > 0
then Just $ TokenizeResult (IntLiteral number) (len + 2)
else Nothing
where
isPrefix = take 2 input == "0x"
number = read . ("0x"++) $ numberStr
len = length numberStr
numberStr = takeWhile isHexDigit (drop 2 input)
tokenizeHex ('0':'x':input) = if null input
then Nothing
else Just $ TokenizeResult (IntLiteral $ read $ "0x" ++ numberStr) (length numberStr + 2)
where numberStr = takeWhile isHexDigit input
tokenizeHex _ = Nothing
tokenizeChar :: Tokenizer
tokenizeChar ('\'':'\\':x:'\'':_) = controlChar x >>= (\s -> return $ TokenizeResult (IntLiteral s) 4)
@@ -100,13 +93,9 @@ tokenizeString ('"':xs) = do
tokenizeString _ = Nothing
tokenizeComment :: Tokenizer
tokenizeComment [] = Nothing
tokenizeComment (x:xs) = if x == ';'
then Just $ TokenizeResult (Comment comment) (len + 1)
else Nothing
where
len = length comment
comment = takeWhile (/='\n') xs
tokenizeComment (';':xs) = Just $ TokenizeResult (Comment comment) (length comment + 1)
where comment = takeWhile (/='\n') xs
tokenizeComment _ = Nothing
type SeparatorPredicate = Char -> Bool
sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer
@@ -115,7 +104,7 @@ sepTokenizer predicate tokenizer input = do
result@(TokenizeResult _ consumed) <- tokenizer input
let next = drop consumed input
if null next || (predicate . head $ next)
then return $ result
then return result
else Nothing
anyTokenizer :: [Tokenizer] -> Tokenizer
@@ -124,7 +113,7 @@ anyTokenizer tokenizers input = getFirst . mconcat . map First $ sequenceA token
tokenize :: String -> Either String [Token]
tokenize [] = Right []
tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t)
tokenize input = tokens >>= (Right . filter tokenFilter)
where
tokens = case tokenizers input of
(Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest)
@@ -145,6 +134,6 @@ tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t)
]
tokenFilter :: Token -> Bool
tokenFilter (WhiteSpace) = False
tokenFilter WhiteSpace = False
tokenFilter (Comment _) = False
tokenFilter _ = True

6
app/Main.hs
View File

@@ -1,8 +1,8 @@
module Main where
import System.Environment
import System.Environment (getArgs)
import Runner (run, runDebug)
import Runner (run)
main :: IO ()
main = do
@@ -11,5 +11,5 @@ main = do
result <- run input
case result of
(Right vm) -> do
putStrLn $ "\n\nDone:\n" ++ (show vm)
putStrLn $ "\nDone\n" ++ show vm
(Left err) -> putStrLn $ "\n\nError:\n" ++ err

2
app/Runner.hs
View File

@@ -16,4 +16,4 @@ runDebug :: String -> IO (Either String VM)
runDebug = exec empty { _debug = True }
exec :: VM -> String -> IO (Either String VM)
exec vm input = runExceptT $ return input >>= (except . compile) >>= (liftIO . VM.run vm . B.pack) >>= except >>= return
exec vm input = runExceptT $ (except . compile) input >>= (liftIO . VM.run vm . B.pack) >>= except

7
app/Util.hs
View File

@@ -9,7 +9,6 @@ module Util (
) where
import Prelude hiding (head)
import Data.List hiding (head)
import Data.Word (Word8)
import Data.Char (chr, toLower)
import Numeric (showHex)
@@ -19,10 +18,10 @@ toLowerCase :: String -> String
toLowerCase = map toLower
bytesStr :: Int -> [Word8] -> String
bytesStr sparse = insertAtN '\n' (sparse*3) . intercalate " " . map byteStr
bytesStr sparse = insertAtN '\n' (sparse*3) . unwords . map byteStr
byteStr :: Word8 -> String
byteStr = pad '0' 2 . (flip showHex) "" . (fromIntegral :: Word8 -> Integer)
byteStr = pad '0' 2 . flip showHex "" . (fromIntegral :: Word8 -> Integer)
insertAtN :: a -> Int -> [a] -> [a]
insertAtN c n xs = insertAtN' n xs
@@ -40,7 +39,7 @@ head (x:_) = Just x
unescape :: String -> Maybe String
unescape ('\\':x:xs) = do
cc <- fmap chr $ controlChar x
cc <- chr <$> controlChar x
rest <- unescape xs
return $ cc : rest
unescape (x:xs) = unescape xs >>= (\rest -> return $ x : rest)

202
app/VirtualMachine/Instruction.hs
View File

@@ -1,46 +1,45 @@
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module VirtualMachine.Instruction where
import Data.Char (chr, ord)
import Data.Word (Word8)
import System.IO (stdin, hGetChar)
import Control.Monad (unless)
import Control.Monad (void)
import Control.Monad.Except (throwError)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as M
import qualified Data.Sequence as S
import VirtualMachine.VM (Op(..), Machine, push, pop, forward, getAt, getPc, getFp, getStackSize, setAt, setPc, setFp, setHalt)
import VirtualMachine.VM (Op(..), Computation, push, pop, forward, getPc, getFp, getStackSize, setPc, setFp, setHalt, frameAt, updateFrameAt)
type Params = [Int]
type Pops = [Int]
type Pushes = S.Seq Int
data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes }
| Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> ExceptT String Machine () }
data Instruction = Simple { _op :: Op, _noParams :: Int, _noPops :: Int, _sAction :: Params -> Pops -> Pushes }
| Complex { _op :: Op, _noParams :: Int, _noPops :: Int, _cAction :: Params -> Pops -> Computation () }
instance Show Instruction where
show (Simple op noParams noPops _) = (show op) ++ "(S," ++ (show noParams) ++ "," ++ (show noPops) ++ ")"
show (Complex op noParams noPops _) = (show op) ++ "(C," ++ (show noParams) ++ "," ++ (show noPops) ++ ")"
show (Simple op noParams noPops _) = show op ++ "(S," ++ show noParams ++ "," ++ show noPops ++ ")"
show (Complex op noParams noPops _) = show op ++ "(C," ++ show noParams ++ "," ++ show noPops ++ ")"
data Unit = Instr { _instr :: Instruction }
| Byte { _byte :: Word8 }
deriving (Show)
instructions :: [Instruction]
instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\_ _ -> S.empty) }
, Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = (\params _ -> S.fromList params) }
, Simple { _op = Pop, _noParams = 0, _noPops = 1, _sAction = (\_ _ -> S.empty) }
, Simple { _op = Dup, _noParams = 0, _noPops = 1, _sAction = (\_ [x] -> S.fromList [x, x]) }
, Simple { _op = Swap, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y, x]) }
, Simple { _op = Add, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y + x]) }
, Simple { _op = Sub, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y - x]) }
, Simple { _op = Mul, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y * x]) }
, 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]) }
, Simple { _op = Over, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y, x, y]) }
instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = \_ _ -> S.empty }
, Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = \params _ -> S.fromList params }
, Simple { _op = Pop, _noParams = 0, _noPops = 1, _sAction = \_ _ -> S.empty }
, Simple { _op = Dup, _noParams = 0, _noPops = 1, _sAction = \_ [x] -> S.fromList [x, x] }
, Simple { _op = Swap, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y, x] }
, Simple { _op = Add, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y + x] }
, Simple { _op = Sub, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y - x] }
, Simple { _op = Mul, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y * x] }
, 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] }
, Simple { _op = Over, _noParams = 0, _noPops = 2, _sAction = \_ [x, y] -> S.fromList [y, x, y] }
, Complex { _op = Halt, _noParams = 0, _noPops = 0, _cAction = halt }
, Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call }
, Complex { _op = Ret, _noParams = 0, _noPops = 0, _cAction = ret }
@@ -51,11 +50,10 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
, Complex { _op = Jl, _noParams = 1, _noPops = 1, _cAction = jumpIf (<) }
, Complex { _op = Jge, _noParams = 1, _noPops = 1, _cAction = jumpIf (>=) }
, Complex { _op = Jle, _noParams = 1, _noPops = 1, _cAction = jumpIf (<=) }
, Complex { _op = Lda, _noParams = 1, _noPops = 0, _cAction = load }
, Complex { _op = Lda, _noParams = 1, _noPops = 0, _cAction = loadArg }
, Complex { _op = In, _noParams = 0, _noPops = 0, _cAction = input }
, Complex { _op = Out, _noParams = 0, _noPops = 1, _cAction = output }
, Complex { _op = Clr, _noParams = 1, _noPops = 0, _cAction = clear }
, Complex { _op = Roll, _noParams = 0, _noPops = 0, _cAction = roll }
, Complex { _op = Ldl, _noParams = 1, _noPops = 0, _cAction = loadLocal }
, Complex { _op = Stl, _noParams = 1, _noPops = 1, _cAction = storeLocal }
]
@@ -63,133 +61,57 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
instructionByOp :: M.Map Op Instruction
instructionByOp = M.fromList $ map (\i -> (_op i, i)) instructions
halt :: Params -> Pops -> ExceptT String Machine ()
halt _ _ = lift $ do
setHalt True
return ()
halt :: Params -> Pops -> Computation ()
halt _ _ = setHalt True
call :: Params -> Pops -> ExceptT String Machine ()
call (addr:_) _ = lift $ do
call :: Params -> Pops -> Computation ()
call (addr:_) _ = do
fp <- getFp
fp' <- getStackSize
retAddr <- getPc >>= return . (+2)
retAddr <- (+2) <$> getPc
push [retAddr, fp]
setPc addr
setFp fp'
return ()
call [] _ = throwError "Address excepted"
ret :: Params -> Pops -> ExceptT String Machine ()
ret :: Params -> Pops -> Computation ()
ret _ _ = do
fp <- lift getFp
stackSize <- lift getStackSize
fp' <- getAt (stackSize - fp - 1) "Cannot determine previous frame pointer (fp)"
retAddr <- getAt (stackSize - fp - 2) "Cannot determine return address"
if stackSize - fp == 2
then lift $ do
_ <- pop $ stackSize - fp
return ()
else lift $ do
retVal <- pop 1
_ <- pop $ stackSize - fp - 1
push retVal
return ()
lift $ setFp fp'
lift $ setPc retAddr
return ()
jump :: Params -> Pops -> ExceptT String Machine ()
jump (addr:_) _ = lift $ do
setPc addr
return ()
jump [] _ = throwError "Address expected"
jumpIf :: (Int -> Int -> Bool) -> Params -> Pops -> ExceptT String Machine ()
jumpIf p (addr:_) (top:_) = lift $ do
pc <- getPc
push [top]
setPc $ if top `p` 0 then addr else pc + 2
return ()
jumpIf _ [] _ = throwError "Address expected"
jumpIf _ _ [] = throwError "Empty stack - nothing to compare"
input :: Params -> Pops -> ExceptT String Machine ()
input _ _ = lift $ do
c <- liftIO $ hGetChar stdin
push [ord c]
forward 1
return()
output :: Params -> Pops -> ExceptT String Machine ()
output _ (char:_) = lift $ do
liftIO $ putStr $ [chr char]
forward 1
return ()
output _ [] = throwError $ "Empty stack - nothing to output"
load :: Params -> Pops -> ExceptT String Machine ()
load (index:_) _ = do
fp <- lift getFp
stackSize <- lift getStackSize
val <- getAt (stackSize - fp + index) ("Index " ++ (show index) ++ " out of stack bounds")
lift $ push [val]
lift $ forward 2
return ()
load [] _ = throwError "Local parameter index expected"
niy :: Op -> Params -> Pops -> ExceptT String Machine ()
niy op _ _ = do
pc <- lift getPc
throwError $ "Instruction '" ++ (show op) ++ "' ("++ (show $ pc) ++") is not implemented yet"
clear :: Params -> Pops -> ExceptT String Machine ()
clear (count:_) _ = lift $ do
top <- pop 1
_ <- pop count
push top
forward 2
return ()
clear [] _ = throwError "Number of elements to be cleaned expected"
roll :: Params -> Pops -> ExceptT String Machine ()
roll _ _ = lift $ do
fp <- getFp
stackSize <- getStackSize
let offset = if fp == -1 then 0 else (fp + 2)
substack <- pop $ stackSize - offset
if null substack
then return ()
else do
let (x:xs) = substack
push $ xs ++ [x]
return ()
forward 1
return ()
loadLocal :: Params -> Pops -> ExceptT String Machine ()
loadLocal (index:_) _ = do
fp <- lift getFp
unless (fp > -1) (throwError "No active stack frame to load local variable")
stackSize <- lift getStackSize
val <- getAt (stackSize - fp - 3 - index) $ "No stack value on the active frame under the index: " ++ (show index)
lift $ push [val]
lift $ forward 2
return ()
loadLocal [] _ = throwError "Local variable index expected"
fp' <- frameAt 0 id "frame pointer (fp)"
retAddr <- frameAt 1 id "return address"
storeLocal :: Params -> Pops -> ExceptT String Machine ()
storeLocal (index:_) (val:_) = do
fp <- lift getFp
unless (fp > -1) (throwError "No active stack frame to store local variable")
stackSize <- lift getStackSize
lift $ setAt (stackSize - fp - 3 - index) val
lift $ forward 2
return ()
storeLocal [] _ = throwError "Local variable index expected"
storeLocal _ [] = throwError "Empty stack - nothing to store"
if stackSize - fp == 2
then void $ pop (stackSize - fp)
else pop 1 >>= \retVal -> pop (stackSize - fp - 1) >> push retVal
setFp fp'
setPc retAddr
jump :: Params -> Pops -> Computation ()
jump (addr:_) _ = setPc addr
jumpIf :: (Int -> Int -> Bool) -> Params -> Pops -> Computation ()
jumpIf p (addr:_) (top:_) = push [top] >> getPc >>= (\pc -> return $ if top `p` 0 then addr else pc + 2) >>= setPc
input :: Params -> Pops -> Computation ()
input _ _ = liftIO getChar >>= \c -> push [ord c] >> forward 1
output :: Params -> Pops -> Computation ()
output _ (char:_) = liftIO (putStr [chr char]) >> forward 1
loadArg :: Params -> Pops -> Computation ()
loadArg (index:_) _ = frameAt index (\x -> -x - 1) "call argument" >>= \val -> push [val] >> forward 2
clear :: Params -> Pops -> Computation ()
clear (count:_) _ = pop 1 >>= \top -> pop count >> push top >> forward 2
loadLocal :: Params -> Pops -> Computation ()
loadLocal (index:_) _ = frameAt index (+2) "local variable" >>= \val -> push [val] >> forward 2
storeLocal :: Params -> Pops -> Computation ()
storeLocal (index:_) (val:_) = updateFrameAt (index + 2) val >> forward 2
niy :: Op -> Params -> Pops -> Computation ()
niy op _ _ = getPc >>= \pc -> throwError $ "Instruction '" ++ show op ++ "' ("++ show pc ++") is not implemented yet"

66
app/VirtualMachine/Interpreter.hs
View File

@@ -4,15 +4,14 @@ import Data.Word (Word8)
import Data.List (intercalate)
import Control.Monad (when, unless)
import Control.Monad.Trans.State (get, evalStateT)
import Control.Monad.Trans.Except (ExceptT, except, runExceptT)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.State (evalStateT)
import Control.Monad.Trans.Except (except, runExceptT)
import Control.Monad.Except (throwError)
import Control.Monad.State (liftIO)
import qualified Data.Map as M
import qualified Data.ByteString as B
import VirtualMachine.VM (VM(..), Op, Machine, pop, pushS, forward, getPc, isHalted, isDebug)
import VirtualMachine.VM (VM(..), Op, Computation, get, pop, pushS, forward, getPc, isHalted, isDebug)
import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp)
@@ -24,7 +23,7 @@ parseInstr (opCode:rest) = do
Nothing -> Left "Unknown instruction"
let noParams = _noParams instr
let params = map fromIntegral $ take noParams rest :: [Word8]
unless (length params == noParams) (Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'")
unless (length params == noParams) (Left $ "Expected " ++ show noParams ++ " parameter(s), got " ++ show (length params) ++ " for operator '" ++ show op ++ "'")
return (instr, params)
parseInstr [] = Left "Unexpected end of the file"
@@ -37,68 +36,61 @@ parse code = do
rest <- parse (drop (noParams + 1) code)
return $ [Instr instr] ++ paramBytes ++ rest
interpret :: [Unit] -> ExceptT String Machine ()
interpret units = do
halted <- lift isHalted
if halted
then return ()
else do
interpretUnit units
interpret units
interpret :: [Unit] -> Computation ()
interpret units = isHalted >>= \halted -> unless halted $ interpretUnit units >> interpret units
interpretUnit :: [Unit] -> ExceptT String Machine ()
interpretUnit :: [Unit] -> Computation ()
interpretUnit [] = throwError "Nothing to interpret"
interpretUnit units = do
pc <- lift getPc
pc <- getPc
let progSize = length units
unless (pc < progSize) (throwError $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")")
unless (pc < progSize) (throwError $ "PC (=" ++ show pc ++ ") exceeds program size (=" ++ show progSize ++ ")")
case units !! pc of
(Instr instr) -> dispatchInstr units instr
(Byte _) -> throwError $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction"
(Byte _) -> throwError $ "PC (=" ++ show pc ++ ") currently points to the data byte rather than instruction"
dispatchInstr :: [Unit] -> Instruction -> ExceptT String Machine ()
dispatchInstr :: [Unit] -> Instruction -> Computation ()
dispatchInstr units instr = do
debug <- lift isDebug
debug <- isDebug
when debug $ lift $ do
when debug $ do
vm <- get
pc <- getPc
let noParams = _noParams instr
let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units
liftIO $ putStrLn $ show vm
liftIO $ putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params
let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) units
liftIO $ print vm
liftIO $ putStrLn $ show pc ++ ": " ++ show (_op instr) ++ " " ++ params
case instr of
Simple {} -> interpretSimple units instr
Complex {} -> interpretComplex units instr
interpretSimple :: [Unit] -> Instruction -> ExceptT String Machine ()
interpretSimple :: [Unit] -> Instruction -> Computation ()
interpretSimple units instr = do
pc <- lift getPc
pc <- getPc
let noParams = _noParams instr
let noPops = _noPops instr
let paramBytes = take noParams $ drop (pc + 1) $ units
let paramBytes = take noParams $ drop (pc + 1) units
let params = map (fromIntegral . _byte) paramBytes
let action = _sAction instr
pops <- lift $ pop noPops
unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops))
pops <- pop noPops
unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ show noPops ++ " elements, got " ++ show (length pops))
let pushes = action params pops
lift $ pushS pushes
lift $ forward $ noParams + 1
return ()
pushS pushes
forward $ noParams + 1
interpretComplex :: [Unit] -> Instruction -> ExceptT String Machine ()
interpretComplex :: [Unit] -> Instruction -> Computation ()
interpretComplex units instr = do
pc <- lift getPc
pc <- getPc
let noParams = _noParams instr
let noPops = _noPops instr
let paramBytes = take noParams $ drop (pc + 1) $ units
let paramBytes = take noParams $ drop (pc + 1) units
let params = map (fromIntegral . _byte) paramBytes
let action = _cAction instr
pops <- lift $ pop noPops
unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ (show noPops) ++ " elements, got " ++ (show $ length pops))
pops <- pop noPops
unless (length pops == noPops) (throwError $ "Attempt to pop from empty stack: tried to pop " ++ show noPops ++ " elements, got " ++ show (length pops))
action params pops
run :: VM -> B.ByteString -> IO (Either String VM)
run vm input = evalStateT (runExceptT machine) vm
where machine = (return input) >>= (return .B.unpack) >>= (except . parse) >>= interpret >> (lift get)
where machine = (except . parse . B.unpack) input >>= interpret >> get

109
app/VirtualMachine/VM.hs
View File

@@ -3,11 +3,13 @@ module VirtualMachine.VM where
import Text.Printf (printf)
import Data.Foldable (toList)
import Control.Monad.Trans (lift)
import Control.Monad.State (get, put)
import Control.Monad.Except (throwError)
import Control.Monad.Trans.State (StateT)
import Control.Monad.Trans.Except (ExceptT)
import qualified Data.Sequence as S
import qualified Control.Monad.State as ST (get, put)
import Data.Functor ((<&>))
import Control.Monad (unless)
data VM = VM { _pc :: Int
@@ -45,14 +47,15 @@ data Op = Nop -- 0x00
| In -- 0x16
| Out -- 0x17
| Clr -- 0x18
| Roll -- 0x19
| Over -- 0x1A
| Ldl -- 0x1B
| Stl -- 0x1C
| Over -- 0x19
| Ldl -- 0x1A
| Stl -- 0x1B
deriving (Eq, Ord, Enum, Show, Read, Bounded)
type Machine = StateT VM IO
type Computation = ExceptT String Machine
empty :: VM
empty = VM { _pc = 0
, _fp = -1
@@ -63,69 +66,71 @@ empty = VM { _pc = 0
-------------------------------------------------------------------------------
getPc :: Machine Int
getPc = get >>= (return . _pc)
get :: Computation VM
get = lift ST.get
getFp :: Machine Int
getFp = get >>= (return . _fp)
put :: VM -> Computation ()
put x = lift $ ST.put x
isHalted :: Machine Bool
isHalted = get >>= (return . _halt)
getPc :: Computation Int
getPc = get <&> _pc
isDebug :: Machine Bool
isDebug = get >>= (return . _debug)
getFp :: Computation Int
getFp = get <&> _fp
getAt :: Int -> String -> ExceptT String Machine Int
getAt index err = do
vm <- lift $ get
let stack = _stack vm
case (stack S.!? index) of
isHalted :: Computation Bool
isHalted = get <&> _halt
isDebug :: Computation Bool
isDebug = get <&> _debug
stackAt :: Int -> String -> Computation Int
stackAt index err = get >>= \vm -> case _stack vm S.!? index of
(Just i) -> return i
Nothing -> throwError err
frameAt :: Int -> (Int -> Int) -> String -> Computation Int
frameAt index t name = do
vm <- get
fp <- getFp
unless (fp > -1) (throwError "No active stack frame")
stackSize <- getStackSize
case _stack vm S.!? (stackSize - fp - 1 - t index) of
(Just i) -> return i
Nothing -> throwError err
Nothing -> throwError $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds"
setAt :: Int -> Int -> Machine ()
setAt index val = do
updateFrameAt :: Int -> Int -> Computation ()
updateFrameAt index value = do
vm <- get
let stack = _stack vm
let stack' = S.update index val stack
put vm { _stack = stack' }
fp <- getFp
unless (fp > -1) (throwError "No active stack frame")
stackSize <- getStackSize
put vm { _stack = S.update (stackSize - fp - 1 - index) value $ _stack vm }
getStackSize :: Machine Int
getStackSize = get >>= (return . length . _stack)
getStackSize :: Computation Int
getStackSize = get <&> (length . _stack)
setPc :: Int -> Machine ()
setPc pc = do
vm <- get
put vm { _pc = pc }
setPc :: Int -> Computation ()
setPc pc = get >>= \vm -> put vm { _pc = pc }
setFp :: Int -> Machine ()
setFp fp = do
vm <- get
put vm { _fp = fp }
setFp :: Int -> Computation ()
setFp fp = get >>= \vm -> put vm { _fp = fp }
setHalt :: Bool -> Machine ()
setHalt halt = do
vm <- get
put vm { _halt = halt }
setHalt :: Bool -> Computation ()
setHalt halt = get >>= \vm -> put vm { _halt = halt }
pop :: Int -> Machine [Int]
pop :: Int -> Computation [Int]
pop count = do
vm <- get
let stack = _stack vm
put vm { _stack = S.drop count $ stack }
return $ toList $ S.take count $ stack
put vm { _stack = S.drop count stack }
return $ toList $ S.take count stack
push :: [Int] -> Machine ()
push :: [Int] -> Computation ()
push = pushS . S.fromList
pushS :: S.Seq Int -> Machine ()
pushS numbers = do
vm <- get
put vm { _stack = numbers <> _stack vm }
return ()
pushS :: S.Seq Int -> Computation ()
pushS numbers = get >>= \vm -> put vm { _stack = numbers <> _stack vm }
forward :: Int -> Machine ()
forward offset = do
vm <- get
put vm { _pc = _pc vm + offset }
return ()
forward :: Int -> Computation ()
forward offset = get >>= \vm -> put vm { _pc = _pc vm + offset }

2
test/Assembler/EmitterSpec.hs
View File

@@ -84,7 +84,7 @@ spec = do
evalContext ctx input emitInstr `shouldBe` expected
it "emits bytes for 2-param instruction" $ do
let ctx = E.empty
let input = Instruction (Operator Push) (Params [(Param (Integer 11)), (Param (LabelRef Global "main"))])
let input = Instruction (Operator Push) (Params [Param (Integer 11), Param (LabelRef Global "main")])
let expected = Right (ctx { _beans = [Byte 0x02, Byte 0x0B, Reference "main"] })
evalContext ctx input emitInstr `shouldBe` expected

115
test/Assembler/ParserSpec.hs
View File

@@ -17,8 +17,7 @@ spec = do
let input = map ((:[]) . T.Operator) ops
let expected = map (flip success 1 . Operator) ops
map parseOperator input `shouldBe` expected
it "supports non-truncated input" $ do
parseOperator [T.Operator Call, T.Ampersand, T.Identifier "label"] `shouldBe` success (Operator Call) 1
it "supports non-truncated input" $ parseOperator [T.Operator Call, T.Ampersand, T.Identifier "label"] `shouldBe` success (Operator Call) 1
it "supports empty input" $
parseOperator [] `shouldBe` Nothing
@@ -28,32 +27,28 @@ spec = do
let input = map ((:[]) . T.IntLiteral) ints
let expected = map (flip success 1 . Integer) ints
map parseInt input `shouldBe` expected
it "supports non-truncated input" $ do
parseInt [T.IntLiteral 4, T.Colon] `shouldBe` success (Integer 4) 1
it "supports non-truncated input" $ parseInt [T.IntLiteral 4, T.Colon] `shouldBe` success (Integer 4) 1
it "supports empty input" $
parseInt [] `shouldBe` Nothing
describe "parseIdentifier" $ do
it "accepts identifier tokens" $
parseIdentifier [T.Identifier "someId"] `shouldBe` success (Identifier "someId") 1
it "supports non-truncated input" $ do
parseIdentifier [T.Identifier "label", T.Colon] `shouldBe` success (Identifier "label") 1
it "supports non-truncated input" $ parseIdentifier [T.Identifier "label", T.Colon] `shouldBe` success (Identifier "label") 1
it "supports empty input" $
parseIdentifier [] `shouldBe` Nothing
describe "parseColon" $ do
it "accepts colon tokens" $
parseColon [T.Colon] `shouldBe` success Colon 1
it "supports non-truncated input" $ do
parseColon [T.Colon, T.Operator Add] `shouldBe` success Colon 1
it "supports non-truncated input" $ parseColon [T.Colon, T.Operator Add] `shouldBe` success Colon 1
it "supports empty input" $
parseColon [] `shouldBe` Nothing
describe "parseAmpersand" $ do
it "accepts colon tokens" $
parseAmpersand [T.Ampersand] `shouldBe` success Ampersand 1
it "supports non-truncated input" $ do
parseAmpersand [T.Ampersand, T.Identifier "label"] `shouldBe` success Ampersand 1
it "supports non-truncated input" $ parseAmpersand [T.Ampersand, T.Identifier "label"] `shouldBe` success Ampersand 1
it "supports empty input" $
parseAmpersand [] `shouldBe` Nothing
@@ -66,8 +61,7 @@ spec = do
parseLabelDef [T.Colon] `shouldBe` Nothing
it "requires colon" $
parseLabelDef [T.Identifier "label"] `shouldBe` Nothing
it "supports non-truncated input" $ do
parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2
it "supports non-truncated input" $ parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2
it "supports empty input" $
parseLabelDef [] `shouldBe` Nothing
@@ -80,8 +74,7 @@ spec = do
parseLabelRef [T.Ampersand] `shouldBe` Nothing
it "requires ampersand" $
parseLabelRef [T.Identifier "label"] `shouldBe` Nothing
it "supports non-truncated input" $ do
parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2
it "supports non-truncated input" $ parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2
it "supports empty input" $
parseLabelRef [] `shouldBe` Nothing
@@ -113,7 +106,7 @@ spec = do
let expected = success (Instruction
(Operator Push)
(Params [
(Param (Integer 4))
Param (Integer 4)
])
) (length input)
parseInstr input `shouldBe` expected
@@ -122,7 +115,7 @@ spec = do
let expected = success (Instruction
(Operator Call)
(Params [
(Param (LabelRef Global "program"))
Param (LabelRef Global "program")
])
) (length input)
parseInstr input `shouldBe` expected
@@ -136,10 +129,10 @@ spec = do
let expected = success (Instruction
(Operator Push)
(Params [
(Param (Integer 1)),
(Param (Integer 4)),
(Param (Integer 2)),
(Param (Integer 0))
Param (Integer 1),
Param (Integer 4),
Param (Integer 2),
Param (Integer 0)
])
) (length input)
parseInstr input `shouldBe` expected
@@ -153,10 +146,10 @@ spec = do
let expected = success (Instruction
(Operator Push)
(Params [
(Param (LabelRef Local "program")),
(Param (LabelRef Local "main")),
(Param (LabelRef Global "foo")),
(Param (LabelRef Local "bar"))
Param (LabelRef Local "program"),
Param (LabelRef Local "main"),
Param (LabelRef Global "foo"),
Param (LabelRef Local "bar")
])
) (length input)
parseInstr input `shouldBe` expected
@@ -174,14 +167,14 @@ spec = do
let expected = success (Instruction
(Operator Push)
(Params [
(Param (LabelRef Global "program")),
(Param (Integer 4)),
(Param (LabelRef Local "main")),
(Param (LabelRef Global "foo")),
(Param (Integer 10)),
(Param (Integer 11)),
(Param (LabelRef Local "bar")),
(Param (Integer 20))
Param (LabelRef Global "program"),
Param (Integer 4),
Param (LabelRef Local "main"),
Param (LabelRef Global "foo"),
Param (Integer 10),
Param (Integer 11),
Param (LabelRef Local "bar"),
Param (Integer 20)
])
) (length input)
parseInstr input `shouldBe` expected
@@ -201,14 +194,14 @@ spec = do
let expected = success (Instruction
(Operator Push)
(Params [
(Param (LabelRef Global "program")),
(Param (Integer 4)),
(Param (LabelRef Global "main")),
(Param (LabelRef Local "foo")),
(Param (Integer 10)),
(Param (Integer 11)),
(Param (LabelRef Global "bar")),
(Param (Integer 20))
Param (LabelRef Global "program"),
Param (Integer 4),
Param (LabelRef Global "main"),
Param (LabelRef Local "foo"),
Param (Integer 10),
Param (Integer 11),
Param (LabelRef Global "bar"),
Param (Integer 20)
])
) 14
parseInstr input `shouldBe` expected
@@ -223,7 +216,7 @@ spec = do
(Instruction
(Operator Call)
(Params [
(Param (LabelRef Global "program"))
Param (LabelRef Global "program")
])
)
) (length input)
@@ -242,7 +235,7 @@ spec = do
(Instruction
(Operator Call)
(Params [
(Param (LabelRef Local "program"))
Param (LabelRef Local "program")
])
)
) (length input)
@@ -254,7 +247,7 @@ spec = do
(Instruction
(Operator Call)
(Params [
(Param (LabelRef Global "program"))
Param (LabelRef Global "program")
])
)
) 5
@@ -264,17 +257,17 @@ spec = do
describe "mapAST" $ do
it "returns mapped AST if wrapped parser succeeded" $ do
let astMapper ast = Param ast
let astMapper = Param
let parser = const $ success Colon 1
let input = [T.StringLiteral "Some not important input"]
mapAST parser astMapper input `shouldBe` success (Param Colon) 1
it "results Nothing when wrapped parser failed" $ do
let astMapper ast = Param ast
let astMapper = Param
let parser = const Nothing
let input = [T.StringLiteral "Some not important input"]
mapAST parser astMapper input `shouldBe` Nothing
it "supports empty input irrespective of wrapped parser" $ do
let astMapper ast = Param ast
let astMapper = Param
let parser = const $ success Colon 1
let input = []
mapAST parser astMapper input `shouldBe` Nothing
@@ -285,11 +278,11 @@ spec = do
let input = [T.StringLiteral "Some not important input"]
parseOptionally parser input `shouldBe` success Ampersand 1
it "returns Empty if wrapped parser failed" $ do
let parser = const $ Nothing
let parser = const Nothing
let input = [T.StringLiteral "Some not important input"]
parseOptionally parser input `shouldBe` success Empty 0
it "supports empty input irrespective of wrapped parser" $ do
let parser = const $ Nothing
let parser = const Nothing
let input = []
parseOptionally parser input `shouldBe` success Empty 0
@@ -398,7 +391,7 @@ spec = do
let input = [T.StringLiteral "some not important input"]
parseAny parsers input `shouldBe` success (Integer 4) 1
it "returns Nothing if no one of the parsers matches the input" $ do
let parsers = map const (take 4 $ repeat $ Nothing)
let parsers = replicate 4 (const Nothing)
let input = [T.StringLiteral "some not important input"]
parseAny parsers input `shouldBe` Nothing
it "always returns Nothing if no parsers are defined" $ do
@@ -486,11 +479,11 @@ spec = do
let input = "add1_2: push 1\npush 2\nadd"
let (Right tokens) = T.tokenize input
-- Labels: Operations: Params:
let expected = Program [ (Line (LabelDef Global "add1_2") (Instruction (Operator Push) (Params [Param $ Integer 1])))
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 2])))
, (Line Empty (Instruction (Operator Add) Empty))
let expected = Program [ Line (LabelDef Global "add1_2") (Instruction (Operator Push) (Params [Param $ Integer 1]))
, Line Empty (Instruction (Operator Push) (Params [Param $ Integer 2]))
, Line Empty (Instruction (Operator Add) Empty)
]
parse tokens `shouldBe` (Right $ expected :: Either String AST)
parse tokens `shouldBe` (Right expected :: Either String AST)
it "rejects multiple instructions in single line" $ do
let input = "push 1 add"
let (Right tokens) = T.tokenize input
@@ -533,12 +526,12 @@ spec = do
\ ret"
let (Right tokens) = T.tokenize input
-- Labels: Operations: Params:
let expected = Program [ (Line (LabelDef Global "main") Empty)
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 7])))
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 4])))
, (Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"])))
, (Line Empty (Instruction (Operator Halt) Empty))
, (Line (LabelDef Global "sum") (Instruction (Operator Add) Empty))
, (Line Empty (Instruction (Operator Ret) Empty))
let expected = Program [ Line (LabelDef Global "main") Empty
, Line Empty (Instruction (Operator Push) (Params [Param $ Integer 7]))
, Line Empty (Instruction (Operator Push) (Params [Param $ Integer 4]))
, Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"]))
, Line Empty (Instruction (Operator Halt) Empty)
, Line (LabelDef Global "sum") (Instruction (Operator Add) Empty)
, Line Empty (Instruction (Operator Ret) Empty)
]
parse tokens `shouldBe` (Right $ expected :: Either String AST)
parse tokens `shouldBe` (Right expected :: Either String AST)

56
test/Assembler/TokenizerSpec.hs
View File

@@ -80,8 +80,8 @@ spec = do
it "parses CR" $
tokenizeWhitespace "\r" `shouldBe` success WhiteSpace 1
it "rejects non-whitespace chars" $ do
let input = map (\x -> [x]) $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
let expected = take (length input) . repeat $ Nothing
let input = map (: []) $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
let expected = replicate (length input) Nothing
map tokenizeWhitespace input `shouldBe` expected
it "supports empty input" $
tokenizeIdentifier "" `shouldBe` Nothing
@@ -95,7 +95,7 @@ spec = do
it "does not support negative numbers" $ do
let nums = [-1, -2 .. -65535] :: [Integer]
let input = map show nums
let expected = take (length nums) . repeat $ Nothing
let expected = replicate (length nums) Nothing
map tokenizeDecimal input `shouldBe` expected
it "rejects other input" $
tokenizeDecimal "some unsupported input" `shouldBe` Nothing
@@ -105,13 +105,13 @@ spec = do
describe "tokenizeHex" $ do
it "parses numbers from 0x0 to 0xFFFF" $ do
let nums = [0 .. 0xFFFF]
let input = map (("0x"++) . (flip showHex "")) nums
let expected = map (\n -> success (IntLiteral n) (length . ("0x"++) . (flip showHex "") $ n)) nums
let input = map (("0x"++) . flip showHex "") nums
let expected = map (\n -> success (IntLiteral n) (length . ("0x"++) . flip showHex "" $ n)) nums
map tokenizeHex input `shouldBe` expected
it "does not support negative numbers" $ do
let nums = [0 .. 0xFFFF] :: [Integer]
let input = map (("-0x"++) . (flip showHex "")) nums
let expected = take (length nums) . repeat $ Nothing
let input = map (("-0x"++) . flip showHex "") nums
let expected = replicate (length nums) Nothing
map tokenizeHex input `shouldBe` expected
it "accepts left-padded number" $
tokenizeHex "0x0010" `shouldBe` success (IntLiteral 16) 6
@@ -186,8 +186,7 @@ spec = do
let len = length str + 2
let input = "\"" ++ str ++ "\""
tokenizeString input `shouldBe` success (StringLiteral str) len
it "supports escape sequences literals" $ do
pendingWith "We need probably to fix tokenizeString since the following test fails"
it "supports escape sequences literals" $ pendingWith "We need probably to fix tokenizeString since the following test fails"
-- TODO:
-- let str = "\\n\\t\\v\\b\\r\\f\\a\\\\\\\"\\0"
-- let len = length str + 2
@@ -261,7 +260,7 @@ spec = do
, Nothing
, Nothing
]
let t = map (\x -> (\_ -> x)) values
let t = map const values
anyTokenizer t "some not important input" `shouldBe` success Ampersand 1
it "returns the token of the first matching subtokenizer" $ do
let values = [ Nothing
@@ -279,7 +278,7 @@ spec = do
, success Colon 1
, Nothing
]
let t = map (\x -> (\_ -> x)) values
let t = map const values
anyTokenizer t "some not important input" `shouldBe` success (IntLiteral 4) 1
it "returns Nothing if no one of the tokenizers matches the input" $ do
let values = [ Nothing
@@ -288,7 +287,7 @@ spec = do
, Nothing
, Nothing
]
let t = map (\x -> (\_ -> x)) values
let t = map const values
anyTokenizer t "some not important input" `shouldBe` Nothing
it "always returns Nothing if no tokenizers are defined" $
anyTokenizer [] "some not important input" `shouldBe` Nothing
@@ -299,31 +298,30 @@ spec = do
, success (IntLiteral 3) 1
, success (Operator Push) 4
]
let t = map (\x -> (\_ -> x)) values
let t = map const values
anyTokenizer t input `shouldBe` Nothing
describe "tokenFilter" $ do
it "filters out whitespaces and comments" $ do
let tokens = [ Operator Push
describe "tokenFilter" $ it "filters out whitespaces and comments" $ do
let tokens = [ Operator Push
, IntLiteral 4
, Comment "here is the identifier"
, Identifier "someId"
, WhiteSpace
, Colon
, WhiteSpace
, Ampersand
, NewLine
, WhiteSpace
, Comment "some comment"
]
let expected = [ Operator Push
, IntLiteral 4
, Comment "here is the identifier"
, Identifier "someId"
, WhiteSpace
, Colon
, WhiteSpace
, Ampersand
, NewLine
, WhiteSpace
, Comment "some comment"
]
let expected = [ Operator Push
, IntLiteral 4
, Identifier "someId"
, Colon
, Ampersand
, NewLine
]
filter tokenFilter tokens `shouldBe` expected
filter tokenFilter tokens `shouldBe` expected
describe "tokenize" $ do
it "treats 'pop' as a operator instead of identifier" $

118
test/VirtualMachineSpec.hs
View File

@@ -741,14 +741,14 @@ spec = do
let vm = empty { _stack = S.fromList [], _fp = 0 }
let input = " ret \n\
\ halt "
let expected = Left "Cannot determine previous frame pointer (fp)"
let expected = Left "Cannot determine frame pointer (fp) - index 0 out of frame bounds"
actual <- exec vm input
actual `shouldBe` expected
it "raises error if there is no return address on the stack (stack size is 1)" $ do
let vm = empty { _stack = S.fromList [-1], _fp = 0 }
let input = " ret \n\
\ halt "
let expected = Left "Cannot determine return address"
let expected = Left "Cannot determine return address - index 1 out of frame bounds"
actual <- exec vm input
actual `shouldBe` expected
@@ -790,7 +790,7 @@ spec = do
it "raises error if stack is empty" $ do
let input = " lda 0 \n\
\ halt "
let expected = Left "Index 0 out of stack bounds"
let expected = Left "Cannot determine call argument - index 0 out of frame bounds"
let vm = empty { _stack = S.fromList [], _fp = 0 }
actual <- exec vm input
actual `shouldBe` expected
@@ -798,14 +798,14 @@ spec = do
let vm = empty { _stack = S.fromList [-1], _fp = 0 }
let input = " lda 0 \n\
\ halt "
let expected = Left "Index 0 out of stack bounds"
let expected = Left "Cannot determine call argument - index 0 out of frame bounds"
actual <- exec vm input
actual `shouldBe` expected
it "raises error if stack contains only previous fp and return address" $ do
let vm = empty { _stack = S.fromList [2, -1], _fp = 0 }
let input = " lda 0 \n\
\ halt "
let expected = Left "Index 0 out of stack bounds"
let expected = Left "Cannot determine call argument - index 0 out of frame bounds"
actual <- exec vm input
actual `shouldBe` expected
it "loads the first (0) argument if stack contains only previous fp, return address and single argument" $ do
@@ -819,7 +819,7 @@ spec = do
let vm = empty { _stack = S.fromList [2, -1, 3], _fp = 1 }
let input = " lda 1 \n\
\ halt "
let expected = Left "Index 1 out of stack bounds"
let expected = Left "Cannot determine call argument - index 1 out of frame bounds"
actual <- exec vm input
actual `shouldBe` expected
it "loads the 11th argument if it exists" $ do
@@ -863,108 +863,6 @@ spec = do
actual <- run input
actual `shouldBe` expected
describe "roll" $ do
it "supports stack with 5 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ push 8 \n\
\ roll \n\
\ halt "
let expected = done [7, 6, 5, 4, 8] 11 (-1)
actual <- run input
actual `shouldBe` expected
it "supports stack with 4 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ roll \n\
\ halt "
let expected = done [6, 5, 4, 7] 9 (-1)
actual <- run input
actual `shouldBe` expected
it "supports stack with 3 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ roll \n\
\ halt "
let expected = done [5, 4, 6] 7 (-1)
actual <- run input
actual `shouldBe` expected
it "supports stack with 2 elements" $ do
let input = " push 4 \n\
\ push 5 \n\
\ roll \n\
\ halt "
let expected = done [4, 5] 5 (-1)
actual <- run input
actual `shouldBe` expected
it "supports singleton stack" $ do
let input = " push 4 \n\
\ roll \n\
\ halt "
let expected = done [4] 3 (-1)
actual <- run input
actual `shouldBe` expected
it "supports empty stack" $ do
let input = " roll \n\
\ halt "
let expected = done [] 1 (-1)
actual <- run input
actual `shouldBe` expected
it "can be composed" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ push 8 \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ halt "
let expected = done [5, 4, 8, 7, 6] 13 (-1)
actual <- run input
actual `shouldBe` expected
it "does not change the stack order when rolling number equals the stack size" $ do
let input = " push 4 \n\
\ push 5 \n\
\ push 6 \n\
\ push 7 \n\
\ push 8 \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ roll \n\
\ halt "
let expected = done [8, 7, 6, 5, 4] 15 (-1)
actual <- run input
actual `shouldBe` expected
it "works in the context of current frame" $ do
let input = " push 1 \n\
\ push 2 \n\
\ push 3 \n\
\ call &foo \n\
\ foo: push 10 \n\
\ push 20 \n\
\ push 30 \n\
\ call &bar \n\
\ bar: push 70 \n\
\ push 80 \n\
\ push 90 \n\
\ roll \n\
\ halt "
let expected = done [80, 70, 90, 16, 3, 30, 20, 10, 8, -1, 3, 2, 1] 23 8
-- ├────────┤ ├────────┤ ├─────┤
-- │ │ │ │ └─────┴── there are no 'roll' instructions under the root so the data is in the correct order
-- │ │ └────────┴────────────────── as above - no 'roll' instruction under the 'foo' function
-- └────────┴───────────────────────────────────── the 'roll' instruction is called under the 'bar' function, so the numbers are rolled
actual <- run input
actual `shouldBe` expected
describe "over" $ do
it "pushes the second value from the top" $ do
let input = " push 1 \n\
@@ -1017,7 +915,7 @@ spec = do
\ push 3 \n\
\ ldl 0 \n\
\ halt "
let expected = Left "No active stack frame to load local variable"
let expected = Left "No active stack frame"
actual <- run input
actual `shouldBe` expected
@@ -1040,7 +938,7 @@ spec = do
\ push 3 \n\
\ stl 0 \n\
\ halt "
let expected = Left "No active stack frame to store local variable"
let expected = Left "No active stack frame"
actual <- run input
actual `shouldBe` expected