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

Add support for clr instruction

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-09 21:25:48 +01:00
parent 71ec09c326
commit ae2ff96cb7
3 changed files with 18 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
README.md
View File

@@ -24,4 +24,7 @@ List of available instructions:
| ``0x12`` | ``JL x`` | Jump to ``x`` **if** top element ``< 0 `` | | ``0x12`` | ``JL x`` | Jump to ``x`` **if** top element ``< 0 `` |
| ``0x13`` | ``JGE x`` | Jump to ``x`` **if** top element ``>= 0`` | | ``0x13`` | ``JGE x`` | Jump to ``x`` **if** top element ``>= 0`` |
| ``0x14`` | ``JLE x`` | Jump to ``x`` **if** top element ``<= 0`` | | ``0x14`` | ``JLE x`` | Jump to ``x`` **if** top element ``<= 0`` |
| ``0x15`` | ``LD x`` | Push local variable to stack | | ``0x15`` | ``LD x`` | Push local variable to stack |
| ``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 |

16
app/VirtualMachine/Instruction.hs
View File

@@ -51,6 +51,7 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\
, Complex { _op = Ld, _noParams = 1, _noPops = 0, _cAction = load } , Complex { _op = Ld, _noParams = 1, _noPops = 0, _cAction = load }
, Complex { _op = In, _noParams = 0, _noPops = 0, _cAction = niy In } , Complex { _op = In, _noParams = 0, _noPops = 0, _cAction = niy In }
, Complex { _op = Out, _noParams = 0, _noPops = 1, _cAction = output } , Complex { _op = Out, _noParams = 0, _noPops = 1, _cAction = output }
, Complex { _op = Clr, _noParams = 1, _noPops = 0, _cAction = clear }
] ]
instructionByOp :: M.Map Op Instruction instructionByOp :: M.Map Op Instruction
@@ -92,7 +93,7 @@ ret vm _ _ = do
return vm { _fp = fp', _pc = retAddr, _stack = stack' } return vm { _fp = fp', _pc = retAddr, _stack = stack' }
jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM
jumpIf predicate vm (addr:_) (top:_) = except $ Right $ vm { _pc = pc } jumpIf predicate vm (addr:_) (top:_) = except $ return $ vm { _pc = pc }
where pc = if top `predicate` 0 then addr else _pc vm + 2 where pc = if top `predicate` 0 then addr else _pc vm + 2
jumpIf _ _ [] _ = except $ Left "Address expected" jumpIf _ _ [] _ = except $ Left "Address expected"
jumpIf _ _ _ [] = except $ Left "Empty stack - nothing to compare" jumpIf _ _ _ [] = except $ Left "Empty stack - nothing to compare"
@@ -112,7 +113,16 @@ load vm (index:_) _ = do
val <- except $ evalState (runExceptT (getAt (stackSize - fp + index) ("Index " ++ (show index) ++ "out of stack bounds") )) vm val <- except $ evalState (runExceptT (getAt (stackSize - fp + index) ("Index " ++ (show index) ++ "out of stack bounds") )) vm
return $ execState (push [val] >> forward 2) vm return $ execState (push [val] >> forward 2) vm
load _ [] _ = except $ Left $ "Empty stack - nothing to lift" load _ [] _ = except $ Left $ "Local parameter index expected"
niy :: Op -> VM -> Params -> Pops -> ExceptT String IO VM niy :: Op -> VM -> Params -> Pops -> ExceptT String IO VM
niy op vm _ _ = except $ Left $ "Instruction '" ++ (show op) ++ "' ("++ (show $ _pc vm) ++") is not implemented yet" niy op vm _ _ = except $ Left $ "Instruction '" ++ (show op) ++ "' ("++ (show $ _pc vm) ++") is not implemented yet"
clear :: VM -> Params -> Pops -> ExceptT String IO VM
clear vm (count:_) _ = except $ return $ flip execState vm $ do
top <- pop 1
_ <- pop count
push top
forward 2
return ()
clear _ [] _ = except $ Left "Number of elements to be cleaned expected"

1
app/VirtualMachine/VM.hs
View File

@@ -37,6 +37,7 @@ data Op = Nop -- 0x00
| Ld -- 0x15 | Ld -- 0x15
| In -- 0x16 | In -- 0x16
| Out -- 0x17 | Out -- 0x17
| Clr -- 0x18
deriving (Eq, Ord, Enum, Show, Read, Bounded) deriving (Eq, Ord, Enum, Show, Read, Bounded)
empty :: VM empty :: VM