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

Add support for local labels

Browse Source
This commit is contained in:
Bartłomiej Przemysław Pluta
2021-11-15 14:05:18 +01:00
parent 5ad4114405
commit 18ddfa611d
8 changed files with 344 additions and 255 deletions
Download Patch File Download Diff File Expand all files Collapse all files

122
README.md
View File

@@ -124,28 +124,28 @@ call &pow
clr 2 clr 2
halt halt
pow: lda 1 ; base pow: lda 1 ; base
lda 0 ; exp lda 0 ; exp
push 1 ; acc push 1 ; acc
; | Stack: ; | Stack:
loop: ldl 1 ; if exp == 0 | exp .loop: ldl 1 ; if exp == 0 | exp
je &done ; then return | exp je &.done ; then return | exp
pop ; | pop ; |
; | ; |
ldl 2 ; Evaluate | acc ldl 2 ; Evaluate | acc
ldl 0 ; next power | acc base ldl 0 ; next power | acc base
mul ; | acc*base mul ; | acc*base
stl 2 ; | stl 2 ; |
; | ; |
ldl 1 ; Decrement exp | exp ldl 1 ; Decrement exp | exp
push 1 ; | exp 1 push 1 ; | exp 1
sub ; | exp-1 sub ; | exp-1
stl 1 ; | stl 1 ; |
jmp &loop ; | jmp &.loop ; |
done: ldl 2 ; | ... acc .done: ldl 2 ; | ... acc
ret ; | acc ret ; | acc
``` ```
The result of execution: The result of execution:
``` ```
@@ -161,26 +161,26 @@ call &pow
clr 2 clr 2
halt halt
pow: lda 1 ; base pow: lda 1 ; base
lda 0 ; exp lda 0 ; exp
ldl 1 ; push exp to top ldl 1 ; push exp to top
je &edge ; the edge case: if exp == 0 then return 1 je &.edge ; the edge case: if exp == 0 then return 1
pop ; pop exp pop ; pop exp
; | Stack: ; | Stack:
ldl 0 ; | base ldl 0 ; | base
ldl 1 ; | base exp ldl 1 ; | base exp
push 1 ; | base exp 1 push 1 ; | base exp 1
sub ; | base exp-1 sub ; | base exp-1
call &pow ; | base exp-1 base^(exp-1)] call &pow ; | base exp-1 base^(exp-1)]
clr 1 ; | base base^(exp-1) clr 1 ; | base base^(exp-1)
mul ; | base*base^(exp-1) mul ; | base*base^(exp-1)
ret ; | base*base^(exp-1) ret ; | base*base^(exp-1)
edge: pop .edge: pop
push 1 ; return 1 push 1 ; return 1
ret ret
``` ```
The result of execution: The result of execution:
``` ```
@@ -195,32 +195,32 @@ call &fibb
clr 1 clr 1
halt halt
fibb: lda 0 ; n | Stack: fibb: lda 0 ; n | Stack:
ldl 0 ; n == 0 -> return 1 | n ldl 0 ; n == 0 -> return 1 | n
je &done0 ; | n je &.done0 ; | n
pop ; | pop ; |
ldl 0 ; n == 1 -> return 1 | n ldl 0 ; n == 1 -> return 1 | n
push 1 ; | n 1 push 1 ; | n 1
sub ; | n-1 sub ; | n-1
je &done1 ; | n-1 je &.done1 ; | n-1
dup ; Evaluate fibb | n-1 n-1 dup ; Evaluate fibb | n-1 n-1
push 1 ; | n-1 n-1 1 push 1 ; | n-1 n-1 1
sub ; | n-1 n-2 sub ; | n-1 n-2
call &fibb ; | n-1 n-2 f(n-2) call &fibb ; | n-1 n-2 f(n-2)
clr 1 ; | n-1 f(n-2) clr 1 ; | n-1 f(n-2)
over ; | n-1 f(n-2) n-1 over ; | n-1 f(n-2) n-1
call &fibb ; | n-1 f(n-2) n-1 f(n-1) call &fibb ; | n-1 f(n-2) n-1 f(n-1)
clr 1 ; | n-1 f(n-2) f(n-1) clr 1 ; | n-1 f(n-2) f(n-1)
add ; | n-1 f(n-2)+f(n-1) add ; | n-1 f(n-2)+f(n-1)
ret ret
done1: pop .done1: pop
push 1 push 1
ret ret
done0: pop .done0: pop
push 1 push 1
ret ret
``` ```
The result of execution: The result of execution:
``` ```

34
app/Assembler/Emitter.hs
View File

@@ -2,27 +2,28 @@ module Assembler.Emitter where
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.Trans (lift) import Control.Monad.Trans (lift)
import Control.Monad.State (State, execState, get, put) import Control.Monad.State (State, evalState, get, put)
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Word (Word8) import Data.Word (Word8)
import qualified Data.Map as M import qualified Data.Map as M
import Assembler.Parser (AST(..)) import Assembler.Parser (AST(..), Scope(..))
data Bean = Byte Word8 data Bean = Byte Word8
| Reference String | Reference String
deriving (Show, Eq) deriving (Show, Eq)
data Context = Context { _beans :: [Bean] data Context = Context { _beans :: [Bean]
, _labels :: M.Map String Int , _labels :: M.Map String Int
, _currentLabel :: Maybe String
} deriving (Show, Eq) } deriving (Show, Eq)
type Emitter = AST -> ExceptT String (State Context) () type Emitter = AST -> ExceptT String (State Context) ()
empty :: Context empty :: Context
empty = Context { _beans = [], _labels = M.fromList [] } empty = Context { _beans = [], _labels = M.fromList [], _currentLabel = Nothing }
emitBean :: Bean -> ExceptT String (State Context) () emitBean :: Bean -> ExceptT String (State Context) ()
emitBean bean = lift $ do emitBean bean = lift $ do
@@ -35,16 +36,33 @@ emitByte byte = emitBean $ Byte $ byte
emitParam :: Emitter emitParam :: Emitter
emitParam (Param (Integer x)) = emitByte $ fromIntegral $ x emitParam (Param (Integer x)) = emitByte $ fromIntegral $ x
emitParam (Param (LabelRef l)) = emitBean $ Reference $ l 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)
emitParam _ = throwError "Number or label reference expected" emitParam _ = throwError "Number or label reference expected"
emitLabelDef :: Emitter emitLabelDef :: Emitter
emitLabelDef (LabelDef label) = do emitLabelDef (LabelDef Global label) = do
ctx <- lift get ctx <- lift get
let labels = _labels ctx let labels = _labels ctx
let current = length (_beans 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 } put ctx { _labels = M.insert label current labels, _currentLabel = Just label }
return ()
emitLabelDef (LabelDef Local label) = do
ctx <- lift get
let labels = _labels ctx
scope <- case _currentLabel ctx of
(Just s) -> return s
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")
put ctx { _labels = M.insert canonicalLabel current labels }
return () return ()
emitLabelDef _ = throwError "Label definition expected" emitLabelDef _ = throwError "Label definition expected"

25
app/Assembler/Parser.hs
View File

@@ -7,6 +7,7 @@ import qualified Assembler.Tokenizer as T (Token(..))
import VirtualMachine.VM (Op) import VirtualMachine.VM (Op)
import Util (explode) import Util (explode)
data Scope = Local | Global deriving (Eq, Show, Enum, Bounded)
data AST = Empty data AST = Empty
| Operator Op | Operator Op
@@ -14,8 +15,9 @@ data AST = Empty
| Identifier String | Identifier String
| Colon | Colon
| Ampersand | Ampersand
| LabelDef String | Dot
| LabelRef String | LabelDef Scope String
| LabelRef Scope String
| Param AST | Param AST
| Params [AST] | Params [AST]
| Instruction AST AST | Instruction AST AST
@@ -53,15 +55,24 @@ parseAmpersand :: Parser
parseAmpersand ((T.Ampersand):_) = Just $ ParseResult Ampersand 1 parseAmpersand ((T.Ampersand):_) = Just $ ParseResult Ampersand 1
parseAmpersand _ = Nothing parseAmpersand _ = Nothing
-- label_def := ID ':' -- '.'
parseDot :: Parser
parseDot ((T.Dot):_) = Just $ ParseResult Dot 1
parseDot _ = Nothing
-- label_def := '.'? ID ':'
parseLabelDef :: Parser parseLabelDef :: Parser
parseLabelDef = parseSeq [parseIdentifier, parseColon] combine parseLabelDef = parseSeq [parseOptionally parseDot, parseIdentifier, parseColon] combine
where combine = (\[(Identifier iden), _] -> LabelDef iden) where
combine [Dot, (Identifier iden), _] = LabelDef Local iden
combine [_, (Identifier iden), _] = LabelDef Global iden
-- label_ref := '&' ID -- label_ref := '&' ID
parseLabelRef :: Parser parseLabelRef :: Parser
parseLabelRef = parseSeq [parseAmpersand, parseIdentifier] combine parseLabelRef = parseSeq [parseAmpersand, parseOptionally parseDot, parseIdentifier] combine
where combine = (\[_, (Identifier iden)] -> LabelRef iden) where
combine [_, Dot, (Identifier iden)] = LabelRef Local iden
combine [_, _, (Identifier iden)] = LabelRef Global iden
-- param := INT | label_ref -- param := INT | label_ref
parseParam :: Parser parseParam :: Parser

2
app/Assembler/Tokenizer.hs
View File

@@ -14,6 +14,7 @@ data Token = Operator Op
| Identifier String | Identifier String
| Colon | Colon
| Ampersand | Ampersand
| Dot
| NewLine | NewLine
| WhiteSpace | WhiteSpace
| Comment String | Comment String
@@ -138,6 +139,7 @@ tokenize input = tokens >>= (\t -> Right $ filter tokenFilter t)
, tokenizeIdentifier , tokenizeIdentifier
, keywordTokenizer False ":" Colon , keywordTokenizer False ":" Colon
, keywordTokenizer False "&" Ampersand , keywordTokenizer False "&" Ampersand
, keywordTokenizer False "." Dot
, tokenizeChar , tokenizeChar
, tokenizeString , tokenizeString
] ]

144
test/Assembler/EmitterSpec.hs
View File

@@ -8,7 +8,7 @@ import Control.Monad.State (evalState, get)
import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Except (runExceptT)
import Assembler.Tokenizer (tokenize) import Assembler.Tokenizer (tokenize)
import Assembler.Parser (AST(..), parse) import Assembler.Parser (AST(..), Scope(..), parse)
import Assembler.Emitter as E import Assembler.Emitter as E
import VirtualMachine.VM (Op(..)) import VirtualMachine.VM (Op(..))
@@ -18,16 +18,75 @@ evalContext ctx ast emitter = flip evalState ctx $ runExceptT $ emitter ast >> l
spec :: Spec spec :: Spec
spec = do spec = do
describe "emitLabelDef" $ do describe "emitLabelDef" $ do
it "inserts label definition to the context" $ do it "inserts global label definition to the context" $ do
let ctx = E.empty let ctx = E.empty
let input = LabelDef "main" let input = LabelDef Global "main"
let expected = Right (ctx { _labels = M.fromList[("main", 0)] }) let expected = Right (ctx { _labels = M.fromList [("main", 0)], _currentLabel = Just "main" })
evalContext ctx input emitLabelDef `shouldBe` expected evalContext ctx input emitLabelDef `shouldBe` expected
it "does not allow to redefine label" $ do it "does not allow to redefine global label" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0)] } let ctx = E.empty { _labels = M.fromList [("main", 0)] }
let input = LabelDef "main" let input = LabelDef Global "main"
let expected = Left "Label 'main' is already defined" let expected = Left "Label 'main' is already defined"
evalContext ctx input emitLabelDef `shouldBe` expected evalContext ctx input emitLabelDef `shouldBe` expected
it "does not allow to redefine global label" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0)] }
let input = LabelDef Global "main"
let expected = Left "Label 'main' is already defined"
evalContext ctx input emitLabelDef `shouldBe` expected
it "inserts local label definition to the context" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0)], _currentLabel = Just "main" }
let input = LabelDef Local "foo"
let expected = Right (ctx { _labels = M.fromList [("main", 0), ("main.foo", 0)], _currentLabel = Just "main" })
evalContext ctx input emitLabelDef `shouldBe` expected
it "allows for the same local label in different global label scopes" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0)], _currentLabel = Just "program" }
let input = LabelDef Local "foo"
let expected = Right (ctx { _labels = M.fromList [("main", 0), ("main.foo", 0), ("program", 0), ("program.foo", 0)], _currentLabel = Just "program" })
evalContext ctx input emitLabelDef `shouldBe` expected
it "does not allow to redefine local label" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0), ("main.foo", 0)], _currentLabel = Just "main" }
let input = LabelDef Local "foo"
let expected = Left "Label 'foo' is already defined in the global label 'main' scope"
evalContext ctx input emitLabelDef `shouldBe` expected
it "does not allow to define local label outside global label scope" $ do
let ctx = E.empty
let input = LabelDef Local "foo"
let expected = Left "Local label ('.foo') can be defined only in the global label scope"
evalContext ctx input emitLabelDef `shouldBe` expected
describe "emitParam" $ do
it "emits byte for integer literal" $ do
let ctx = E.empty
let input = Param (Integer 4)
let expected = Right (ctx { _beans = [Byte 0x04] })
evalContext ctx input emitParam `shouldBe` expected
it "emits reference mark for global label reference" $ do
let ctx = E.empty
let input = Param (LabelRef Global "main")
let expected = Right (ctx { _beans = [Reference "main"] })
evalContext ctx input emitParam `shouldBe` expected
it "emits reference mark for local label reference" $ do
let ctx = E.empty { _labels = M.fromList [("main", 0)], _currentLabel = Just "main"}
let input = Param (LabelRef Local "foo")
let expected = Right (ctx { _beans = [Reference "main.foo"] })
evalContext ctx input emitParam `shouldBe` expected
it "does not allow to reference local label outside global label scope" $ do
let ctx = E.empty
let input = Param (LabelRef Local "foo")
let expected = Left "Local label ('.foo') reference is allowed only in the global label scope"
evalContext ctx input emitParam `shouldBe` expected
describe "emitInstr" $ do
it "emits byte for no-param instruction" $ do
let ctx = E.empty
let input = Instruction (Operator Halt) Empty
let expected = Right (ctx { _beans = [Byte 0x01] })
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 expected = Right (ctx { _beans = [Byte 0x02, Byte 0x0B, Reference "main"] })
evalContext ctx input emitInstr `shouldBe` expected
describe "resolveLabels" $ do describe "resolveLabels" $ do
it "replaces reference with actual byte number" $ do it "replaces reference with actual byte number" $ do
@@ -40,51 +99,46 @@ spec = do
let expected = Left "Label 'not_existing_label' is not defined" let expected = Left "Label 'not_existing_label' is not defined"
resolveLabels labels beans `shouldBe` expected resolveLabels labels beans `shouldBe` expected
describe "emitParam" $ do
it "emits byte for integer literal" $ do
let ctx = E.empty
let input = Param (Integer 4)
let expected = Right (ctx { _beans = [Byte 0x04] })
evalContext ctx input emitParam `shouldBe` expected
it "emits reference mark for label reference" $ do
let ctx = E.empty
let input = Param (LabelRef "main")
let expected = Right (ctx { _beans = [Reference "main"] })
evalContext ctx input emitParam `shouldBe` expected
describe "emitInstr" $ do
it "emits byte for no-param instruction" $ do
let ctx = E.empty
let input = Instruction (Operator Halt) Empty
let expected = Right (ctx { _beans = [Byte 0x01] })
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 "main"))])
let expected = Right (ctx { _beans = [Byte 0x02, Byte 0x0B, Reference "main"] })
evalContext ctx input emitInstr `shouldBe` expected
describe "emit" $ do describe "emit" $ do
it "label resolution works" $ do it "global label resolution works" $ do
let input = "main: \n\ let input = "main: \n\
\push 1\n\ \ push 1 \n\
\push 2\n\ \ push 2 \n\
\jmp &sum\n\ \ jmp &sum \n\
\\n\ \ sum: add \n\
\sum: add\n\ \ jmp &main "
\jmp &main"
let (Right tokens) = tokenize input let (Right tokens) = tokenize input
let (Right ast) = parse tokens let (Right ast) = parse tokens
let expected = [0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00] let expected = [0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00]
emit ast `shouldBe` Right expected emit ast `shouldBe` Right expected
it "local label resolution works" $ do
let input = " main: \n\
\ .loop: push 1 \n\
\ push 2 \n\
\ jmp &.sum \n\
\ .sum: add \n\
\ jmp &.loop \n\
\ foo: \n\
\ .loop: push 1 \n\
\ push 2 \n\
\ jmp &.sum \n\
\ .sum: add \n\
\ jmp &.loop "
let (Right tokens) = tokenize input
let (Right ast) = parse tokens
-- The differences: &.sum &.loop
-- vvvv vvvv
let expected = [ 0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00 -- 'main' scope
, 0x02, 0x01, 0x02, 0x02, 0x0e, 0x0f, 0x06, 0x0e, 0x09 -- 'foo' scope
]
emit ast `shouldBe` Right expected
it "raises error if label has not been defined" $ do it "raises error if label has not been defined" $ do
let input = "main: \n\ let input = " main: \n\
\push 1\n\ \ push 1 \n\
\push 2\n\ \ push 2 \n\
\jmp &sum\n\ \ jmp &sum \n\
\\n\ \ sum: add \n\
\sum: add\n\ \ jmp &program "
\jmp &program"
let (Right tokens) = tokenize input let (Right tokens) = tokenize input
let (Right ast) = parse tokens let (Right ast) = parse tokens
emit ast `shouldBe` Left "Label 'program' is not defined" emit ast `shouldBe` Left "Label 'program' is not defined"

104
test/Assembler/ParserSpec.hs
View File

@@ -58,26 +58,30 @@ spec = do
parseAmpersand [] `shouldBe` Nothing parseAmpersand [] `shouldBe` Nothing
describe "parseLabelDef" $ do describe "parseLabelDef" $ do
it "parses 'label:'" $ it "parses global label def" $
parseLabelDef [T.Identifier "label", T.Colon] `shouldBe` success (LabelDef "label") 2 parseLabelDef [T.Identifier "label", T.Colon] `shouldBe` success (LabelDef Global "label") 2
it "parses local label def" $
parseLabelDef [T.Dot, T.Identifier "label", T.Colon] `shouldBe` success (LabelDef Local "label") 3
it "requires label" $ it "requires label" $
parseLabelDef [T.Colon] `shouldBe` Nothing parseLabelDef [T.Colon] `shouldBe` Nothing
it "requires colon" $ it "requires colon" $
parseLabelDef [T.Identifier "label"] `shouldBe` Nothing parseLabelDef [T.Identifier "label"] `shouldBe` Nothing
it "supports non-truncated input" $ do it "supports non-truncated input" $ do
parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef "sum") 2 parseLabelDef [T.Identifier "sum", T.Colon, T.Operator Nop] `shouldBe` success (LabelDef Global "sum") 2
it "supports empty input" $ it "supports empty input" $
parseLabelDef [] `shouldBe` Nothing parseLabelDef [] `shouldBe` Nothing
describe "parseLabelRef" $ do describe "parseLabelRef" $ do
it "parses '&label'" $ it "parses global label ref" $
parseLabelRef [T.Ampersand, T.Identifier "label"] `shouldBe` success (LabelRef "label") 2 parseLabelRef [T.Ampersand, T.Identifier "label"] `shouldBe` success (LabelRef Global "label") 2
it "parses local label" $
parseLabelRef [T.Ampersand, T.Dot, T.Identifier "label"] `shouldBe` success (LabelRef Local "label") 3
it "requires label" $ it "requires label" $
parseLabelRef [T.Ampersand] `shouldBe` Nothing parseLabelRef [T.Ampersand] `shouldBe` Nothing
it "requires ampersand" $ it "requires ampersand" $
parseLabelRef [T.Identifier "label"] `shouldBe` Nothing parseLabelRef [T.Identifier "label"] `shouldBe` Nothing
it "supports non-truncated input" $ do it "supports non-truncated input" $ do
parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef "sum") 2 parseLabelRef [T.Ampersand, T.Identifier "sum", T.Operator Nop] `shouldBe` success (LabelRef Global "sum") 2
it "supports empty input" $ it "supports empty input" $
parseLabelRef [] `shouldBe` Nothing parseLabelRef [] `shouldBe` Nothing
@@ -88,7 +92,7 @@ spec = do
let expected = map (flip success 1 . Param . Integer) ints let expected = map (flip success 1 . Param . Integer) ints
map parseParam input `shouldBe` expected map parseParam input `shouldBe` expected
it "parses label references" $ do it "parses label references" $ do
let expected = success (Param (LabelRef "program")) 2 let expected = success (Param (LabelRef Global "program")) 2
parseParam [T.Ampersand, T.Identifier "program"] `shouldBe` expected parseParam [T.Ampersand, T.Identifier "program"] `shouldBe` expected
it "supports non-truncated input" $ do it "supports non-truncated input" $ do
let expected = success (Param (Integer 1)) 1 let expected = success (Param (Integer 1)) 1
@@ -118,7 +122,7 @@ spec = do
let expected = success (Instruction let expected = success (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef "program")) (Param (LabelRef Global "program"))
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
@@ -141,18 +145,18 @@ spec = do
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "parses operator with multiple param ref params" $ do it "parses operator with multiple param ref params" $ do
let input = [T.Operator Push let input = [T.Operator Push
, T.Ampersand, T.Identifier "program" , T.Ampersand, T.Dot, T.Identifier "program"
, T.Ampersand, T.Identifier "main" , T.Ampersand, T.Dot, T.Identifier "main"
, T.Ampersand, T.Identifier "foo" , T.Ampersand, T.Identifier "foo"
, T.Ampersand, T.Identifier "bar" , T.Ampersand, T.Dot, T.Identifier "bar"
] ]
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (LabelRef "program")), (Param (LabelRef Local "program")),
(Param (LabelRef "main")), (Param (LabelRef Local "main")),
(Param (LabelRef "foo")), (Param (LabelRef Global "foo")),
(Param (LabelRef "bar")) (Param (LabelRef Local "bar"))
]) ])
) (length input) ) (length input)
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
@@ -160,23 +164,23 @@ spec = do
let input = [T.Operator Push let input = [T.Operator Push
, T.Ampersand, T.Identifier "program" , T.Ampersand, T.Identifier "program"
, T.IntLiteral 4 , T.IntLiteral 4
, T.Ampersand, T.Identifier "main" , T.Ampersand, T.Dot, T.Identifier "main"
, T.Ampersand, T.Identifier "foo" , T.Ampersand, T.Identifier "foo"
, T.IntLiteral 10 , T.IntLiteral 10
, T.IntLiteral 11 , T.IntLiteral 11
, T.Ampersand, T.Identifier "bar" , T.Ampersand, T.Dot, T.Identifier "bar"
, T.IntLiteral 20 , T.IntLiteral 20
] ]
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (LabelRef "program")), (Param (LabelRef Global "program")),
(Param (Integer 4)), (Param (Integer 4)),
(Param (LabelRef "main")), (Param (LabelRef Local "main")),
(Param (LabelRef "foo")), (Param (LabelRef Global "foo")),
(Param (Integer 10)), (Param (Integer 10)),
(Param (Integer 11)), (Param (Integer 11)),
(Param (LabelRef "bar")), (Param (LabelRef Local "bar")),
(Param (Integer 20)) (Param (Integer 20))
]) ])
) (length input) ) (length input)
@@ -186,7 +190,7 @@ spec = do
, T.Ampersand, T.Identifier "program" , T.Ampersand, T.Identifier "program"
, T.IntLiteral 4 , T.IntLiteral 4
, T.Ampersand, T.Identifier "main" , T.Ampersand, T.Identifier "main"
, T.Ampersand, T.Identifier "foo" , T.Ampersand, T.Dot, T.Identifier "foo"
, T.IntLiteral 10 , T.IntLiteral 10
, T.IntLiteral 11 , T.IntLiteral 11
, T.Ampersand, T.Identifier "bar" , T.Ampersand, T.Identifier "bar"
@@ -197,29 +201,29 @@ spec = do
let expected = success (Instruction let expected = success (Instruction
(Operator Push) (Operator Push)
(Params [ (Params [
(Param (LabelRef "program")), (Param (LabelRef Global "program")),
(Param (Integer 4)), (Param (Integer 4)),
(Param (LabelRef "main")), (Param (LabelRef Global "main")),
(Param (LabelRef "foo")), (Param (LabelRef Local "foo")),
(Param (Integer 10)), (Param (Integer 10)),
(Param (Integer 11)), (Param (Integer 11)),
(Param (LabelRef "bar")), (Param (LabelRef Global "bar")),
(Param (Integer 20)) (Param (Integer 20))
]) ])
) 13 ) 14
parseInstr input `shouldBe` expected parseInstr input `shouldBe` expected
it "supports empty input" $ it "supports empty input" $
parseInstr [] `shouldBe` Nothing parseInstr [] `shouldBe` Nothing
describe "parseLine" $ do describe "parseLine" $ do
it "supports label definition and operator in the same line" $ do it "supports label definition and operator in the same line" $ do
let input = [T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program"] let input = [T.Dot, T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program"]
let expected = success (Line let expected = success (Line
(LabelDef "main") (LabelDef Local "main")
(Instruction (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef "program")) (Param (LabelRef Global "program"))
]) ])
) )
) (length input) ) (length input)
@@ -227,18 +231,18 @@ spec = do
it "supports line with just label definition" $ do it "supports line with just label definition" $ do
let input = [T.Identifier "main", T.Colon] let input = [T.Identifier "main", T.Colon]
let expected = success (Line let expected = success (Line
(LabelDef "main") (LabelDef Global "main")
Empty Empty
) (length input) ) (length input)
parseLine input `shouldBe` expected parseLine input `shouldBe` expected
it "supports line with just operator" $ do it "supports line with just operator" $ do
let input = [T.Operator Call, T.Ampersand, T.Identifier "program"] let input = [T.Operator Call, T.Ampersand, T.Dot, T.Identifier "program"]
let expected = success (Line let expected = success (Line
Empty Empty
(Instruction (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef "program")) (Param (LabelRef Local "program"))
]) ])
) )
) (length input) ) (length input)
@@ -246,11 +250,11 @@ spec = do
it "supports non-truncated input" $ do it "supports non-truncated input" $ do
let input = [T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program", T.Identifier "exit"] let input = [T.Identifier "main", T.Colon, T.Operator Call, T.Ampersand, T.Identifier "program", T.Identifier "exit"]
let expected = success (Line let expected = success (Line
(LabelDef "main") (LabelDef Global "main")
(Instruction (Instruction
(Operator Call) (Operator Call)
(Params [ (Params [
(Param (LabelRef "program")) (Param (LabelRef Global "program"))
]) ])
) )
) 5 ) 5
@@ -381,7 +385,7 @@ spec = do
, success (Integer 4) 1 , success (Integer 4) 1
, Nothing , Nothing
, Nothing , Nothing
, success (LabelDef "not me") 2 , success (LabelDef Local "not me") 2
, Nothing , Nothing
, success (Instruction (Operator Push) Empty) 1 , success (Instruction (Operator Push) Empty) 1
, Nothing , Nothing
@@ -402,7 +406,7 @@ spec = do
parseAny [] input `shouldBe` Nothing parseAny [] input `shouldBe` Nothing
it "supports empty input irrespective of wrapped parsers" $ do it "supports empty input irrespective of wrapped parsers" $ do
let parsers = map const [ success (Integer 4) 1 let parsers = map const [ success (Integer 4) 1
, success (LabelDef "not me") 2 , success (LabelDef Local "not me") 2
, success (Instruction (Operator Push) Empty) 1 , success (Instruction (Operator Push) Empty) 1
, Nothing , Nothing
, success Ampersand 1 , success Ampersand 1
@@ -450,7 +454,7 @@ spec = do
parseSeq pattern combiner input `shouldBe` Nothing parseSeq pattern combiner input `shouldBe` Nothing
it "supports empty input irrespective of wrapped parsers" $ do it "supports empty input irrespective of wrapped parsers" $ do
let pattern = map const [ success (Integer 4) 1 let pattern = map const [ success (Integer 4) 1
, success (LabelDef "not me") 2 , success (LabelDef Global "not me") 2
, success (Instruction (Operator Push) Empty) 1 , success (Instruction (Operator Push) Empty) 1
, success Ampersand 1 , success Ampersand 1
, success Colon 1 , success Colon 1
@@ -481,10 +485,10 @@ spec = do
it "parses line by line" $ do it "parses line by line" $ do
let input = "add1_2: push 1\npush 2\nadd" let input = "add1_2: push 1\npush 2\nadd"
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
-- Labels: Operations: Params: -- Labels: Operations: Params:
let expected = Program [ (Line (LabelDef "add1_2") (Instruction (Operator Push) (Params [Param $ Integer 1]))) 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 Push) (Params [Param $ Integer 2])))
, (Line Empty (Instruction (Operator Add) Empty)) , (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 it "rejects multiple instructions in single line" $ do
@@ -528,13 +532,13 @@ spec = do
\ sum: add\n\ \ sum: add\n\
\ ret" \ ret"
let (Right tokens) = T.tokenize input let (Right tokens) = T.tokenize input
-- Labels: Operations: Params: -- Labels: Operations: Params:
let expected = Program [ (Line (LabelDef "main") 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 7])))
, (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 4]))) , (Line Empty (Instruction (Operator Push) (Params [Param $ Integer 4])))
, (Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef "sum"]))) , (Line Empty (Instruction (Operator Call) (Params [Param $ LabelRef Global "sum"])))
, (Line Empty (Instruction (Operator Halt) Empty)) , (Line Empty (Instruction (Operator Halt) Empty))
, (Line (LabelDef "sum") (Instruction (Operator Add) Empty)) , (Line (LabelDef Global "sum") (Instruction (Operator Add) Empty))
, (Line Empty (Instruction (Operator Ret) Empty)) , (Line Empty (Instruction (Operator Ret) Empty))
] ]
parse tokens `shouldBe` (Right $ expected :: Either String AST) parse tokens `shouldBe` (Right $ expected :: Either String AST)

2
test/Assembler/TokenizerSpec.hs
View File

@@ -353,7 +353,7 @@ spec = do
it "treats 'someId1234' as 'someId1234' identifier instead of 'someId' identifier and 1234 int" $ it "treats 'someId1234' as 'someId1234' identifier instead of 'someId' identifier and 1234 int" $
tokenize "someId1234" `shouldBe` Right [Identifier "someId1234"] tokenize "someId1234" `shouldBe` Right [Identifier "someId1234"]
it "accepts 'main: NL" $ it "accepts 'main: NL" $
tokenize "main: \n" `shouldBe` Right [Identifier "main", Colon, NewLine] tokenize ".main: \n" `shouldBe` Right [Dot, Identifier "main", Colon, NewLine]
it "accepts 'call &sum NL" $ it "accepts 'call &sum NL" $
tokenize "call &sum \n" `shouldBe` Right [Operator Call, Ampersand, Identifier "sum", NewLine] tokenize "call &sum \n" `shouldBe` Right [Operator Call, Ampersand, Identifier "sum", NewLine]
it "rejects '4push'" $ it "rejects '4push'" $

160
test/VirtualMachineSpec.hs
View File

@@ -1055,13 +1055,13 @@ spec = do
\ clr 2 \n\ \ clr 2 \n\
\ halt \n\ \ halt \n\
\ \n\ \ \n\
\ sum: lda 0 \n\ \ sum: lda 0 \n\
\ lda 1 \n\ \ lda 1 \n\
\ add \n\ \ add \n\
\ ret \n\ \ ret \n\
\ \n\ \ \n\
\ prd: lda 0 \n\ \ prd: lda 0 \n\
\ lda 1 \n\ \ lda 1 \n\
\ mul \n\ \ mul \n\
\ ret " \ ret "
let expected = done [2*3+5] 14 (-01) let expected = done [2*3+5] 14 (-01)
@@ -1069,97 +1069,97 @@ spec = do
actual `shouldBe` expected actual `shouldBe` expected
it "example #2" $ do it "example #2" $ do
let input = " main: push 100 \n\ let input = " main: push 100 \n\
\ loop: push 1 \n\ \ .loop: push 1 \n\
\ sub \n\ \ sub \n\
\ jne &loop \n\ \ jne &.loop \n\
\ halt " \ halt "
let expected = done [0] 7 (-1) let expected = done [0] 7 (-1)
actual <- run input actual <- run input
actual `shouldBe` expected actual `shouldBe` expected
it "example #3: power - loop variant" $ do it "example #3: power - loop variant" $ do
let input = " push 3 \n\ let input = " push 3 \n\
\ push 6 \n\ \ push 6 \n\
\ call &pow \n\ \ call &pow \n\
\ clr 2 \n\ \ clr 2 \n\
\ halt \n\ \ halt \n\
\ pow: lda 1 \n\ \ pow: lda 1 \n\
\ lda 0 \n\ \ lda 0 \n\
\ push 1 \n\ \ push 1 \n\
\ loop: ldl 1 \n\ \ .loop: ldl 1 \n\
\ je &done \n\ \ je &.done \n\
\ pop \n\ \ pop \n\
\ ldl 2 \n\ \ ldl 2 \n\
\ ldl 0 \n\ \ ldl 0 \n\
\ mul \n\ \ mul \n\
\ stl 2 \n\ \ stl 2 \n\
\ ldl 1 \n\ \ ldl 1 \n\
\ push 1 \n\ \ push 1 \n\
\ sub \n\ \ sub \n\
\ stl 1 \n\ \ stl 1 \n\
\ jmp &loop \n\ \ jmp &.loop \n\
\ done: ldl 2 \n\ \ .done: ldl 2 \n\
\ ret " \ ret "
let expected = done [3 ^ (6 :: Int)] 8 (-1) let expected = done [3 ^ (6 :: Int)] 8 (-1)
actual <- run input actual <- run input
actual `shouldBe` expected actual `shouldBe` expected
it "example #4: power - recursive variant" $ do it "example #4: power - recursive variant" $ do
let input = " push 4 \n\ let input = " push 4 \n\
\ push 7 \n\ \ push 7 \n\
\ call &pow \n\ \ call &pow \n\
\ clr 2 \n\ \ clr 2 \n\
\ halt \n\ \ halt \n\
\ pow: lda 1 \n\ \ pow: lda 1 \n\
\ lda 0 \n\ \ lda 0 \n\
\ ldl 1 \n\ \ ldl 1 \n\
\ je &edge \n\ \ je &.edge \n\
\ pop \n\ \ pop \n\
\ ldl 0 \n\ \ ldl 0 \n\
\ ldl 1 \n\ \ ldl 1 \n\
\ push 1 \n\ \ push 1 \n\
\ sub \n\ \ sub \n\
\ call &pow \n\ \ call &pow \n\
\ clr 1 \n\ \ clr 1 \n\
\ mul \n\ \ mul \n\
\ ret \n\ \ ret \n\
\ edge: pop \n\ \ .edge: pop \n\
\ push 1 \n\ \ push 1 \n\
\ ret " \ ret "
let expected = done [4 ^ (7 :: Int)] 8 (-1) let expected = done [4 ^ (7 :: Int)] 8 (-1)
actual <- run input actual <- run input
actual `shouldBe` expected actual `shouldBe` expected
it "example #5: 11-th element of Fibonacci sequence - recursive variant" $ do it "example #5: 11-th element of Fibonacci sequence - recursive variant" $ do
let input = " push 11 \n\ let input = " push 11 \n\
\ call &fibb \n\ \ call &fibb \n\
\ clr 1 \n\ \ clr 1 \n\
\ halt \n\ \ halt \n\
\ fibb: lda 0 \n\ \ fibb: lda 0 \n\
\ ldl 0 \n\ \ ldl 0 \n\
\ je &done0 \n\ \ je &.done0 \n\
\ pop \n\ \ pop \n\
\ ldl 0 \n\ \ ldl 0 \n\
\ push 1 \n\ \ push 1 \n\
\ sub \n\ \ sub \n\
\ je &done1 \n\ \ je &.done1 \n\
\ dup \n\ \ dup \n\
\ push 1 \n\ \ push 1 \n\
\ sub \n\ \ sub \n\
\ call &fibb \n\ \ call &fibb \n\
\ clr 1 \n\ \ clr 1 \n\
\ over \n\ \ over \n\
\ call &fibb \n\ \ call &fibb \n\
\ clr 1 \n\ \ clr 1 \n\
\ add \n\ \ add \n\
\ ret \n\ \ ret \n\
\ done1: pop \n\ \ .done1: pop \n\
\ push 1 \n\ \ push 1 \n\
\ ret \n\ \ ret \n\
\ done0: pop \n\ \ .done0: pop \n\
\ push 1 \n\ \ push 1 \n\
\ ret " \ ret "
let expected = done [fibb 11] 6 (-1) let expected = done [fibb 11] 6 (-1)
actual <- run input actual <- run input
actual `shouldBe` expected actual `shouldBe` expected