diff --git a/app/VirtualMachine/Instruction.hs b/app/VirtualMachine/Instruction.hs index 6c53865..3acb38f 100644 --- a/app/VirtualMachine/Instruction.hs +++ b/app/VirtualMachine/Instruction.hs @@ -5,7 +5,7 @@ import Data.Word (Word8) import System.IO (stdin, hGetChar) import Control.Monad.Except (throwError) import Control.Monad.Trans (lift, liftIO) -import Control.Monad.Trans.Except (ExceptT, except) +import Control.Monad.Trans.Except (ExceptT) import qualified Data.Map as M import qualified Data.Sequence as S @@ -39,6 +39,7 @@ 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]) } + , 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 } @@ -53,6 +54,7 @@ instructions = [ Simple { _op = Nop, _noParams = 0, _noPops = 0, _sAction = (\ , 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 } ] instructionByOp :: M.Map Op Instruction @@ -125,7 +127,7 @@ output _ (char:_) = lift $ do liftIO $ putStr $ [chr char] forward 1 return () -output _ [] = except $ Left $ "Empty stack - nothing to output" +output _ [] = throwError $ "Empty stack - nothing to output" load :: Params -> Pops -> ExceptT String Machine () load (index:_) _ = do @@ -149,4 +151,19 @@ clear (count:_) _ = lift $ do push top forward 2 return () -clear [] _ = except $ Left "Number of elements to be cleaned expected" \ No newline at end of file +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 () \ No newline at end of file diff --git a/app/VirtualMachine/VM.hs b/app/VirtualMachine/VM.hs index 811a3b7..8cd9791 100644 --- a/app/VirtualMachine/VM.hs +++ b/app/VirtualMachine/VM.hs @@ -41,6 +41,8 @@ data Op = Nop -- 0x00 | In -- 0x16 | Out -- 0x17 | Clr -- 0x18 + | Roll -- 0x19 + | Over -- 0x20 deriving (Eq, Ord, Enum, Show, Read, Bounded) type Machine = StateT VM IO diff --git a/test/VirtualMachineSpec.hs b/test/VirtualMachineSpec.hs index f7047fb..5eee52b 100644 --- a/test/VirtualMachineSpec.hs +++ b/test/VirtualMachineSpec.hs @@ -826,6 +826,141 @@ 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\ + \ push 2 \n\ + \ over \n\ + \ halt " + let expected = done [1, 2, 1] 5 (-1) + actual <- run input + actual `shouldBe` expected + it "can be used multiple times" $ do + let input = " push 1 \n\ + \ push 2 \n\ + \ over \n\ + \ over \n\ + \ over \n\ + \ halt " + let expected = done [1, 2, 1, 2, 1] 7 (-1) + actual <- run input + actual `shouldBe` expected + it "raises error if empty stack" $ do + let input = " over \n\ + \ halt " + let expected = Left "Attempt to pop from empty stack: tried to pop 2 elements, got 0" + actual <- run input + actual `shouldBe` expected + it "raises error if stack is not big enough" $ do + let input = " push 5 \n\ + \ over \n\ + \ halt " + let expected = Left "Attempt to pop from empty stack: tried to pop 2 elements, got 1" + actual <- run input + actual `shouldBe` expected + describe "examples" $ do it "example #1" $ do let input = " main: push 2 \n\