vmtranslator: compile branching commands

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

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)
+                             ]
+