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

Resolve compilation warnings

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-08 10:36:22 +01:00
parent 919cddd814
commit 42b2eb5e41
6 changed files with 80 additions and 84 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
app/Assembler/Parser.hs
View File

@@ -38,7 +38,7 @@ parseInt _ = Nothing
-- ID := [alnum, '_']+ -- ID := [alnum, '_']+
parseIdentifier :: Parser parseIdentifier :: Parser
parseIdentifier ((T.Identifier id):_) = Just $ ParseResult (Identifier id) 1 parseIdentifier ((T.Identifier iden):_) = Just $ ParseResult (Identifier iden) 1
parseIdentifier _ = Nothing parseIdentifier _ = Nothing
-- ':' -- ':'
@@ -54,12 +54,12 @@ parseAmpersand _ = Nothing
-- label_def := ID ':' -- label_def := ID ':'
parseLabelDef :: Parser parseLabelDef :: Parser
parseLabelDef = parseSeq [parseIdentifier, parseColon] combine parseLabelDef = parseSeq [parseIdentifier, parseColon] combine
where combine = (\[(Identifier id), _] -> LabelDef id) where combine = (\[(Identifier iden), _] -> LabelDef iden)
-- label_ref := '&' ID -- label_ref := '&' ID
parseLabelRef :: Parser parseLabelRef :: Parser
parseLabelRef = parseSeq [parseAmpersand, parseIdentifier] combine parseLabelRef = parseSeq [parseAmpersand, parseIdentifier] combine
where combine = (\[_, (Identifier id)] -> LabelRef id) where combine = (\[_, (Identifier iden)] -> LabelRef iden)
-- param := INT | label_ref -- param := INT | label_ref
parseParam :: Parser parseParam :: Parser
@@ -103,7 +103,7 @@ parseMany parser combiner tokens = if null asts
-- a a a a a a a... -- a a a a a a a...
parseGreedy :: Parser -> [T.Token] -> [ParseResult] parseGreedy :: Parser -> [T.Token] -> [ParseResult]
parseGreedy parser tokens = case parser tokens of parseGreedy parser tokens = case parser tokens of
(Just r@(ParseResult ast consumed)) -> r : parseGreedy parser (drop consumed tokens) (Just r@(ParseResult _ consumed)) -> r : parseGreedy parser (drop consumed tokens)
Nothing -> [] Nothing -> []
-- a | b | c -- a | b | c
@@ -147,9 +147,9 @@ assertConsumed parser tokens = do
parse :: [T.Token] -> Either String AST parse :: [T.Token] -> Either String AST
parse tokens = do parse tokens = do
let lines = U.explode (==T.NewLine) tokens let codeLines = U.explode (==T.NewLine) tokens
let results = map (assertConsumed parseLine) lines let results = map (assertConsumed parseLine) codeLines
let errors = filter ((==Nothing) . snd) $ zipWith (,) lines $ results let errors = filter ((==Nothing) . snd) $ zipWith (,) codeLines $ results
let errorMsg = "Parse error(s):\n" ++ (List.intercalate "\n" $ map (show . fst) errors) let errorMsg = "Parse error(s):\n" ++ (List.intercalate "\n" $ map (show . fst) errors)
case sequenceA results of case sequenceA results of
(Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r (Just r) -> return $ Program $ map (\(ParseResult ast _) -> ast) r

26
app/Assembler/Tokenizer.hs
View File

@@ -90,10 +90,10 @@ tokenizeString ('"':xs) = do
return $ TokenizeResult (StringLiteral unescaped) (length string + 2) return $ TokenizeResult (StringLiteral unescaped) (length string + 2)
where where
extractString [] = Nothing extractString [] = Nothing
extractString (x:xs) extractString (y:ys)
| x == '"' = Just [] | y == '"' = Just []
| x == '\n' = Nothing | y == '\n' = Nothing
| otherwise = extractString xs >>= (\r -> return $ x : r) | otherwise = extractString ys >>= (\r -> return $ y : r)
tokenizeString _ = Nothing tokenizeString _ = Nothing
tokenizeComment :: Tokenizer tokenizeComment :: Tokenizer
@@ -108,12 +108,12 @@ tokenizeComment (x:xs) = if x == ';'
type SeparatorPredicate = Char -> Bool type SeparatorPredicate = Char -> Bool
sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer sepTokenizer :: SeparatorPredicate -> Tokenizer -> Tokenizer
sepTokenizer _ _ [] = Nothing sepTokenizer _ _ [] = Nothing
sepTokenizer pred tokenizer input = do sepTokenizer predicate tokenizer input = do
result@(TokenizeResult token consumed) <- tokenizer input result@(TokenizeResult _ consumed) <- tokenizer input
let next = drop consumed input let next = drop consumed input
let (isSep, _) = if null next let (isSep, _) = if null next
then (True, 0) then (True, 0)
else if pred . head $ next else if predicate . head $ next
then (True, 1) then (True, 1)
else (False, 0) else (False, 0)
if isSep if isSep
@@ -131,13 +131,6 @@ tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t)
tokens = case tokenizers input of tokens = case tokenizers input of
(Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest) (Just (TokenizeResult token chars)) -> tokenize (drop chars input) >>= (\rest -> return $ token : rest)
Nothing -> Left $ "Unknown token: " ++ take 20 input Nothing -> Left $ "Unknown token: " ++ take 20 input
tokenFilter :: Token -> Bool
tokenFilter (WhiteSpace) = False
tokenFilter (Comment _) = False
tokenFilter _ = True
tokenizers :: Tokenizer
tokenizers = anyTokenizer tokenizers = anyTokenizer
[ keywordTokenizer False "\n" NewLine [ keywordTokenizer False "\n" NewLine
, tokenizeWhitespace , tokenizeWhitespace
@@ -151,3 +144,8 @@ tokenizers = anyTokenizer
, tokenizeChar , tokenizeChar
, tokenizeString , tokenizeString
] ]
tokenFilter :: Token -> Bool
tokenFilter (WhiteSpace) = False
tokenFilter (Comment _) = False
tokenFilter _ = True

10
app/Util.hs
View File

@@ -21,14 +21,14 @@ bytesStr :: Int -> [Word8] -> String
bytesStr sparse = insertAtN '\n' (sparse*3) . intercalate " " . map byteStr bytesStr sparse = insertAtN '\n' (sparse*3) . intercalate " " . map byteStr
byteStr :: Word8 -> String byteStr :: Word8 -> String
byteStr = pad '0' 2 . (flip showHex) "" . fromIntegral byteStr = pad '0' 2 . (flip showHex) "" . (fromIntegral :: Word8 -> Integer)
insertAtN :: a -> Int -> [a] -> [a] insertAtN :: a -> Int -> [a] -> [a]
insertAtN c n xs = insertAtN' n xs insertAtN c n xs = insertAtN' n xs
where where
insertAtN' 0 xs = c : insertAtN' n xs insertAtN' 0 ys = c : insertAtN' n ys
insertAtN' _ [] = [] insertAtN' _ [] = []
insertAtN' m (x:xs) = x : insertAtN' (m-1) xs insertAtN' m (y:ys) = y : insertAtN' (m-1) ys
pad :: Char -> Int -> String -> String pad :: Char -> Int -> String -> String
pad char width string = replicate (width - length string) char ++ string pad char width string = replicate (width - length string) char ++ string
@@ -61,8 +61,8 @@ controlChar x = case x of
_ -> Nothing _ -> Nothing
explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]] explode :: (Foldable f) => (a -> Bool) -> f a -> [[a]]
explode pred xs = filter (not . null) $ foldr split [[]] xs explode predicate xs = filter (not . null) $ foldr split [[]] xs
where where
split y (ys:yss) split y (ys:yss)
| pred y = []:ys:yss | predicate y = []:ys:yss
| otherwise = (y:ys):yss | otherwise = (y:ys):yss

92
app/VirtualMachine.hs
View File

@@ -19,10 +19,10 @@ import qualified Data.ByteString as B
import qualified Util as U import qualified Util as U
data VM = VM { pc :: Int data VM = VM { _pc :: Int
, fp :: Int , _fp :: Int
, stack :: S.Seq Int , _stack :: S.Seq Int
, halt :: Bool , _halt :: Bool
} deriving (Show, Eq) } deriving (Show, Eq)
data Op = Nop -- 0x00 data Op = Nop -- 0x00
@@ -53,57 +53,57 @@ type Args = [Int]
type Pops = [Int] type Pops = [Int]
type Pushes = S.Seq Int type Pushes = S.Seq Int
data Instruction = Simple { op :: Op data Instruction = Simple { _op :: Op
, noParams :: Int , _noParams :: Int
, noPops :: Int , _noPops :: Int
, sAction :: Args -> Pops -> Pushes , _sAction :: Args -> Pops -> Pushes
} }
| Complex { op :: Op | Complex { _op :: Op
, noParams :: Int , _noParams :: Int
, cAction :: VM -> Args -> Either String VM , _cAction :: VM -> Args -> Either String VM
} }
data Command = Command { instr :: Instruction data Command = Command { _instr :: Instruction
, args :: [Int] , _args :: [Int]
} }
empty :: VM empty :: VM
empty = VM { pc = 0 empty = VM { _pc = 0
, fp = -1 , _fp = -1
, stack = S.empty , _stack = S.empty
, halt = False , _halt = False
} }
instructions :: [Instruction] instructions :: [Instruction]
instructions = [ Simple { op = Nop, noParams = 0, noPops = 0, sAction = (\_ _ -> S.empty) } instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\_ _ -> S.empty) }
, Simple { op = Push, noParams = 1, noPops = 0, sAction = (\args _ -> S.fromList args) } , Simple { _op = Push, _noParams = 1, _noPops = 0, _sAction = (\params _ -> S.fromList params) }
, Simple { op = Pop, noParams = 0, noPops = 1, sAction = (\_ _ -> S.empty) } , 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = Halt, _noParams = 0, _cAction = (\vm _ -> Right $ vm { _halt = True }) }
, Complex { op = Jmp, noParams = 1, cAction = (\vm [x] -> Right $ vm { pc = x}) } , Complex { _op = Jmp, _noParams = 1, _cAction = (\vm [x] -> Right $ vm { _pc = x}) }
, Complex { op = Je, noParams = 1, cAction = jumpIf (==) } , Complex { _op = Je, _noParams = 1, _cAction = jumpIf (==) }
, Complex { op = Jne, noParams = 1, cAction = jumpIf (/=) } , Complex { _op = Jne, _noParams = 1, _cAction = jumpIf (/=) }
, Complex { op = Jg, noParams = 1, cAction = jumpIf (>) } , Complex { _op = Jg, _noParams = 1, _cAction = jumpIf (>) }
, Complex { op = Jl, noParams = 1, cAction = jumpIf (<) } , Complex { _op = Jl, _noParams = 1, _cAction = jumpIf (<) }
, Complex { op = Jge, noParams = 1, cAction = jumpIf (>=) } , Complex { _op = Jge, _noParams = 1, _cAction = jumpIf (>=) }
, Complex { op = Jle, noParams = 1, cAction = jumpIf (<=) } , Complex { _op = Jle, _noParams = 1, _cAction = jumpIf (<=) }
] ]
jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Either String VM jumpIf :: (Int -> Int -> Bool) -> VM -> Args -> Either String VM
jumpIf predicate vm [addr] = Right $ vm { pc = pc' } jumpIf predicate vm [addr] = Right $ vm { _pc = pc }
where where
(top:_) = toList . stack $ vm (top:_) = toList . _stack $ vm
pc' = if top `predicate` 0 then addr else pc vm + 1 pc = if top `predicate` 0 then addr else _pc vm + 1
instructionByOp :: Map.Map Op Instruction instructionByOp :: Map.Map Op Instruction
instructionByOp = Map.fromList $ map (\i -> (op i, i)) instructions instructionByOp = Map.fromList $ map (\i -> (_op i, i)) instructions
toOp :: String -> Op toOp :: String -> Op
toOp = read . capitalize toOp = read . capitalize
@@ -125,7 +125,7 @@ parseCommand [] = Nothing
parseCommand (opByte:xs) = do parseCommand (opByte:xs) = do
let op = toEnum . fromIntegral $ opByte :: Op let op = toEnum . fromIntegral $ opByte :: Op
instruction <- Map.lookup op instructionByOp instruction <- Map.lookup op instructionByOp
let paramsNumber = noParams instruction let paramsNumber = _noParams instruction
let params = map fromIntegral $ take paramsNumber xs :: [Int] let params = map fromIntegral $ take paramsNumber xs :: [Int]
return (Command instruction params, drop paramsNumber xs) return (Command instruction params, drop paramsNumber xs)
@@ -138,19 +138,19 @@ interpret cmds vm = do
interpretCommand :: [Command] -> VM -> Either String VM interpretCommand :: [Command] -> VM -> Either String VM
interpretCommand [] _ = Left $ "Empty code" interpretCommand [] _ = Left $ "Empty code"
interpretCommand cmds vm@(VM pc _ _ _) interpretCommand cmds vm@(VM pc _ _ _)
| pc >= length cmds = Right $ vm { halt = True } | pc >= length cmds = Right $ vm { _halt = True }
| otherwise = case instr of | otherwise = case instr of
(Simple _ _ _ _) -> interpretSimple vm cmd (Simple _ _ _ _) -> interpretSimple vm cmd
(Complex _ _ _) -> interpretComplex vm cmd (Complex _ _ _) -> interpretComplex vm cmd
where cmd@(Command instr _) = cmds !! pc where cmd@(Command instr _) = cmds !! pc
interpretSimple :: VM -> Command -> Either String VM interpretSimple :: VM -> Command -> Either String VM
interpretSimple vm (Command (Simple op _ noPops operation) args) = vm' interpretSimple vm (Command (Simple _ _ noPops operation) args) = vm'
where where
pops = toList . S.take noPops . stack $ vm pops = toList . S.take noPops . _stack $ vm
stack' = Right $ operation args pops stack' = Right $ operation args pops
vm' = stack' >>= (\s -> Right $ vm { pc = pc vm + 1 vm' = stack' >>= (\s -> Right $ vm { _pc = _pc vm + 1
, stack = s <> (S.drop noPops . stack) vm , _stack = s <> (S.drop noPops . _stack) vm
}) })
interpretSimple _ _ = Left "Unknown operation" interpretSimple _ _ = Left "Unknown operation"

1
test/Assembler/ParserSpec.hs
View File

@@ -1,7 +1,6 @@
module Assembler.ParserSpec where module Assembler.ParserSpec where
import Test.Hspec import Test.Hspec
import Test.Hspec.QuickCheck
import qualified Assembler.Tokenizer as T import qualified Assembler.Tokenizer as T
import Assembler.Parser import Assembler.Parser

1
test/Assembler/TokenizerSpec.hs
View File

@@ -1,7 +1,6 @@
module Assembler.TokenizerSpec where module Assembler.TokenizerSpec where
import Test.Hspec import Test.Hspec
import Test.Hspec.QuickCheck
import Numeric (showHex) import Numeric (showHex)
import Data.Char (ord) import Data.Char (ord)