diff --git a/src/Nand2Tetris/VM.hs b/src/Nand2Tetris/VM.hs index 30a0d34..4114656 100644 --- a/src/Nand2Tetris/VM.hs +++ b/src/Nand2Tetris/VM.hs @@ -4,6 +4,7 @@ module Nand2Tetris.VM ( VMInstruction(..), + BranchingCmd(..), ArithmeticCmd(..), AccessType(..), Segment(..), @@ -24,7 +25,7 @@ import qualified Data.Text as T import Nand2Tetris.Error (Error) import Nand2Tetris.Hack (HackInstruction (A, C), Imm (Imm, Label), - Jump (JEq, JGt, JLt, JNone, Jmp), + Jump (JEq, JGt, JLt, JNe, JNone, Jmp), Reg (RegA, RegD, RegM), Source (S0, SDAndM, SDOrM, SDPlusA, SDPlusM, SMMinusD, SNeg, SNeg1, SNot, SReg, SRegMinus1, SRegPlus1), canonicalRepresentation) @@ -38,6 +39,13 @@ import qualified Text.Megaparsec.Char.Lexer as L data VMInstruction = VMArithmetic ArithmeticCmd | VMMemAccess AccessType Segment + | VMBranching BranchingCmd + deriving (Show, Eq) + +data BranchingCmd = + BLabel T.Text + | BGoto T.Text + | BIfGoto T.Text deriving (Show, Eq) data ArithmeticCmd = @@ -97,6 +105,9 @@ instrAnnotation (VMMemAccess accessType segment) = SStatic label -> "static " <> label SPointer i -> "pointer " <> (T.pack . show $ i) STemp i -> "temp " <> (T.pack . show $ i) +instrAnnotation (VMBranching (BLabel label)) = "label " <> label +instrAnnotation (VMBranching (BGoto label)) = "goto " <> label +instrAnnotation (VMBranching (BIfGoto label)) = "if-goto " <> label type Parser = Parsec Error T.Text @@ -110,9 +121,17 @@ parseInstructions = many (sp *> parseInstruction <* sp) <* eof parseInstruction :: Parser VMInstruction parseInstruction = try parseMemAccess <|> - parseArithmetic + try parseArithmetic <|> + parseBranching where + parseBranching :: Parser VMInstruction + parseBranching = VMBranching <$> + choice [ string "label" *> space1 *> (BLabel <$> parseId), + string "goto" *> space1 *> (BGoto <$> parseId), + string "if-goto" *> space1 *> (BIfGoto <$> parseId) + ] + parseMemAccess :: Parser VMInstruction parseMemAccess = VMMemAccess <$> parseAccessType <*> @@ -252,6 +271,16 @@ compileInstruction instr = do compileInstruction' (VMArithmetic ACAnd) = return $ binopSequence SDAndM compileInstruction' (VMArithmetic ACOr) = return $ binopSequence SDOrM compileInstruction' (VMArithmetic ACNot) = return $ unopSequence (SNot RegM) + compileInstruction' (VMBranching (BLabel label)) = return [ALabel label] + compileInstruction' (VMBranching (BGoto label)) = + return [ Code (A (Label label)), + Code (C [] S0 Jmp) + ] + compileInstruction' (VMBranching (BIfGoto label)) = + return [ Code (A (Label "SP")), + Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), + Code (C [] (SReg RegM) JNe) + ] compileConditional jumpType = do let sub = binopSequence SMMinusD diff --git a/test/Test/Nand2Tetris/VM.hs b/test/Test/Nand2Tetris/VM.hs index ec11b83..d29ae4f 100644 --- a/test/Test/Nand2Tetris/VM.hs +++ b/test/Test/Nand2Tetris/VM.hs @@ -12,8 +12,9 @@ import Nand2Tetris.Hack (HackInstruction (..), Imm (..), Jump (..), import Nand2Tetris.VM (AccessType (ACPop, ACPush), AnnotatedAsmLine (..), ArithmeticCmd (ACAdd, ACAnd, ACEq, ACGt, ACLt, ACNeg, ACNot, ACOr, ACSub), + BranchingCmd (..), Segment (SArgument, SConstant, SLocal, SPointer, SStatic, STemp, SThat, SThis), - VMInstruction (VMArithmetic, VMMemAccess), + VMInstruction (VMArithmetic, VMBranching, VMMemAccess), compileInstruction, parseInstruction, runCompilerDef) import Text.Megaparsec (runParser) @@ -25,6 +26,8 @@ spec = do describe "compile push instruction" compilePushInstructionSpec describe "compile pop instruction" compilePopInstructionSpec describe "compile arithmetic instrucitons" compileArithInstructionSpec + describe "compile branching instrucitons" compileBranchingInstructionSpec + parseInstructionSpec :: Spec parseInstructionSpec = do @@ -85,6 +88,14 @@ parseInstructionSpec = do it "Parses instruction: not" $ doParse "not" `shouldBe` Right (VMArithmetic ACNot) + it "Parses instruction: label foo" $ + doParse "label foo" `shouldBe` Right (VMBranching (BLabel "foo")) + + it "Parses instruction: goto foo" $ + doParse "goto foo" `shouldBe` Right (VMBranching (BGoto "foo")) + + it "Parses instruction: if-goto foo" $ + doParse "if-goto foo" `shouldBe` Right (VMBranching (BIfGoto "foo")) where doParse = runParser parseInstruction "" @@ -228,13 +239,13 @@ compilePopInstructionSpec = do Code (C [RegD] (SReg RegA) JNone), Code (A (Label reg)), Code (C [RegD] SDPlusM JNone), - Code (A (Label "R15")), + Code (A (Imm 15)), Code (C [RegM] (SReg RegD) JNone), Code (A (Label "SP")), Code (C [RegA] (SReg RegM) JNone), Code (C [RegD] (SReg RegM) JNone), - Code (A (Label "R15")), + Code (A (Imm 15)), Code (C [RegA] (SReg RegM) JNone), Code (C [RegM] (SReg RegD) JNone) ] @@ -298,3 +309,25 @@ compileArithInstructionSpec = do Code (C [RegM] (SNeg RegM) JNone) ] +compileBranchingInstructionSpec :: Spec +compileBranchingInstructionSpec = do + it "label foo" $ do + let compiled = runCompilerDef $ compileInstruction (VMBranching (BLabel "foo")) + head compiled `shouldBe` (Comment "label foo") + tail compiled `shouldBe` [(ALabel "foo")] + + it "goto foo" $ do + let compiled = runCompilerDef $ compileInstruction (VMBranching (BGoto "foo")) + head compiled `shouldBe` (Comment "goto foo") + tail compiled `shouldBe` [ Code (A (Label "foo")), + Code (C [] S0 Jmp) + ] + + it "if-goto foo" $ do + let compiled = runCompilerDef $ compileInstruction (VMBranching (BIfGoto "foo")) + head compiled `shouldBe` (Comment "if-goto foo") + tail compiled `shouldBe` [ Code (A (Label "SP")), + Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), + Code (C [] (SReg RegM) JNe) + ] +