Now you can assemble assembly code to .mif file

Right now we just start writing from memory cell 0,
it would be useful to be able to org to different cells
and start writing from that address instead.

Author: Enayaaa

Main.hs

@@ -10,24 +10,30 @@ import Data.Char
 import Data.Word
 import Data.Maybe
 
-{-
-NOOP
-ADD ACC, Mem[Addr]
-SUB ACC, Mem[Addr]
-NOT ACC
-AND ACC, Mem[Addr]
-CMP ACC, Mem[Addr]
-LB ACC, Mem[Addr]
-LBI ACC, Mem[Mem[Addr]]
-SB Mem[Addr], ACC
-SBI Mem[Mem[Addr]], ACC
-IN Mem[Addr], IO_BUS
-JA Addr
-J Offset
-JEQ Offset
-JNE Offset
-DS
--}
+help = "Usage:      ./Main [-h|--help] input_file\n\n"
+    ++ "Syntax cheatsheat: First column shows valid assembly operations.\n"
+    ++ "Addr ::= hex | bin | oct | naturalnumber\n"
+    ++ "Offset ::= int\n"
+    ++ "literal prefixes:  bin = `0b`, hex = `0x`, oct = `0o`\n"
+    ++ "Use `//` for line comments.\n"
+    ++ unlines (map ('\t':) [
+    "NOOP                       No Operation        Do Nothing",
+    "ADD ACC, M[Addr]           Add                 ACC = ACC + Memory[Addr]; Set C and Z flags",
+    "SUB ACC, M[Addr]           Subtract            ACC = ACC - Memory[Addr]; Set C and Z flags",
+    "NOT ACC                    Logical NOT         ACC = ACC’; Set Z flag",
+    "AND ACC, M[Addr]           Logical AND         ACC = ACC & Memory[Addr]; Set Z flag",
+    "CMP ACC, M[Addr]           Compare             if (ACC == Memory[Addr]): E flag=1 else: E flag=0",
+    "LB ACC, M[Addr]            Load Byte           ACC = Memory[Addr]",
+    "LBI ACC, M[M[Addr]]        Load Byte Index     ACC = Memory[Memory[Addr]]",
+    "SB M[Addr], ACC            Store Byte          Memory[Addr]=ACC",
+    "SBI M[M[Addr]], ACC        Store Byte Index    Memory[Memory[Addr]]=ACC",
+    "IN M[Addr], IO_BUS         Input               Memory[Addr] = Value at IO_BUS",
+    "JA Addr                    Jump Address        PC = Addr",
+    "J Offset                   Jump                PC = (PC+1) ± Offset",
+    "JEQ Offset                 Jump Equal          if (E flag == 1): PC = (PC+1) ± Offset",
+    "JNE Offset                 Jump Not Equal      if (E flag == 0): PC = (PC+1) ± Offset",
+    "DS                         Display             DS (display register) = ACC"
+    ])
 
 data Reg         = ACC               deriving Show
 data IOBus       = IOBus             deriving Show
@@ -42,7 +48,7 @@ instance Show AddrAddr where
     show (AddrAddr x) = "M[M["++show x++"]]"
 
 instance Show Offset where
-    show (Offset x) = "±"++show x
+    show (Offset x) = "+"++show x
 
 data Opcode = NOOP
             | ADD Reg Addr
@@ -83,8 +89,9 @@ opcodes = [
     ]
 
 upperLowerToken :: Parser String
-upperLowerToken = do xs <- some alphanum
-                     guard (all isUpper xs || all isLower xs)
+upperLowerToken = do xs <- some (alphanum <|> char '_')
+                     let rs = filter isAlpha xs
+                     guard (all isUpper rs || all isLower rs)
                      space
                      return xs
 
@@ -99,61 +106,88 @@ reg = do r <- upperLowerToken
             then return ACC
             else error "unknown reg"
 
-readHex :: String -> Int
-readHex = sum . zipWith (*) [1,16..] . reverse . ys
+-- | expects a base under 36?? and that the string only includes valid digits
+-- that are allowed in the base
+readBase :: Int -> String -> Int
+readBase base = sum . zipWith (\i d -> d*base^i) [0..] . reverse . ys
     where
         ys = map (\x -> if x `elem` ['0'..'9'] then
                             ord x - ord '0'
                         else
-                            ord x - ord 'a' + 10)
+                            ord (toLower x) - ord 'a' + 10)
 
---hex = do { string "0x"; xs <- some (sat (`elem` (['0'..'9']++['a'..'f']) . toLower)); return (readHex xs)}
---bin = do { string "0b"; nat }
+hex , bin, oct :: Parser Int
+hex = do string "0x"
+         xs <- some (sat (\x -> toLower x `elem` "0123456789abcdef"))
+         return (readBase 16 xs)
+bin = do string "0b"
+         xs <- some (sat (\x -> toLower x `elem` "01"))
+         return (readBase 2 xs)
+oct = do string "0o"
+         xs <- some (sat (\x -> toLower x `elem` "01234567"))
+         return (readBase 8 xs)
 
--- TODO: switch with addr, change addraddr to mememem
---mem = Addr . fromIntegral <$> nat
-       -- <|> Addr . fromIntegral <$> hex
+isWord8 :: Int -> Bool
+isWord8 n
+  | n > 0 = fromIntegral (minBound :: Word8) <= n
+            && n <= fromIntegral (maxBound :: Word8)
+  | otherwise = fromIntegral (minBound :: Word8) - 128 <= n
+                && n <= fromIntegral (maxBound :: Word8) - 128
 
 addr :: Parser Addr
-addr = do char 'M'
+addr = do string "M["
           space
-          char '['
-          space
-          n <- nat
+          n <- bin <|> hex <|> oct <|> nat
+          guard (isWord8 n)
           space
           char ']'
           space
           return (Addr . fromIntegral $ n)
 
 addraddr :: Parser AddrAddr
-addraddr = AddrAddr . fromIntegral <$> nat
+addraddr = do string "M[M["
+              space
+              n <- hex <|> bin <|> oct <|> nat
+              guard (isWord8 n)
+              space
+              string "]]"
+              space
+              return (AddrAddr . fromIntegral $ n)
+
+addrLiteral :: Parser Addr
+addrLiteral = Addr . fromIntegral <$> do {n <- hex <|> bin <|> oct <|> nat;
+                                         guard (isWord8 n);
+                                         return n}
 
 offset :: Parser Offset
-offset = Offset . fromIntegral <$> nat
+offset = Offset . fromIntegral <$> do { n <- int;
+                                        guard (isWord8 n);
+                                        return n }
 
 ioBus :: Parser IOBus
 ioBus = do b <- upperLowerToken
            if map toUpper b == "IO_BUS"
               then return IOBus
-              else error "unknown IO_Bus"
+              else error $ "unknown IO_Bus" ++ show b
 
 newline :: Parser Char
 newline = do { space; char '\n' }
+          <|> do { space; string "\r\n"; return '\n'}
 
 noop, add, sub, nott, andd, cmp, lb, lbi, sb, sbi, inn, ja, j, jeq, jne, ds :: Parser Opcode
 noop = return NOOP
-add  = do { r <- reg; space; char ','; space; ADD r <$> addr; }
-sub  = do { r <- reg; space; char ','; space; SUB r <$> addr; }
+add  = do { r <- reg      ; space ; char ',' ; space ; ADD r <$> addr     }
+sub  = do { r <- reg      ; space ; char ',' ; space ; SUB r <$> addr     }
 nott = NOT <$> reg
-andd = do { r <- reg; space; char ','; space; AND r <$> addr; }
-cmp  = do { r <- reg; space; char ','; space; CMP r <$> addr; }
-lb   = do { r <- reg; space; char ','; space; LB r <$> addr; }
-lbi  = do { r <- reg; space; char ','; space; LBI r <$> addraddr; }
-sb   = do { a <- addr; space; char ','; space; SB a <$> reg; }
-sbi  = do { a <- addraddr; space; char ','; SBI a <$> reg; }
-inn  = do { a <- addr; space; char ','; IN a <$> ioBus; }
-ja   = JA <$> addr
-j    = J <$> offset
+andd = do { r <- reg      ; space ; char ',' ; space ; AND r <$> addr     }
+cmp  = do { r <- reg      ; space ; char ',' ; space ; CMP r <$> addr     }
+lb   = do { r <- reg      ; space ; char ',' ; space ; LB r  <$> addr     }
+lbi  = do { r <- reg      ; space ; char ',' ; space ; LBI r <$> addraddr }
+sb   = do { a <- addr     ; space ; char ',' ; space ; SB a  <$> reg      }
+sbi  = do { a <- addraddr ; space ; char ',' ; space ; SBI a <$> reg      }
+inn  = do { a <- addr     ; space ; char ',' ; space ; IN a  <$> ioBus    }
+ja   = JA  <$> addrLiteral
+j    = J   <$> offset
 jeq  = JEQ <$> offset
 jne  = JNE <$> offset
 ds   = return DS
@@ -164,13 +198,13 @@ lineComment = do space
                  xs <- many (sat (/= '\n'))
                  return (c++xs)
 
+lineWithComment :: Parser (Maybe Opcode)
 lineWithComment = do x <- line
                      some newline <|> (do {lineComment; newline; return " "})
                      return (Just x)
                   <|> do {lineComment; newline; return Nothing}
                   <|> do {space; newline; return Nothing}
 
-
 line :: Parser Opcode
 line = do op <- opcode
           case map toUpper op of
@@ -190,16 +224,54 @@ line = do op <- opcode
             "JEQ"  -> jeq
             "JNE"  -> jne
             "DS"   -> ds
-            op -> error "hello"
+            op -> error $ "unknwn opcode  `"++ op ++ "`"
+
+toBin :: (Show a, Integral a) => Int -> a -> String
+toBin p 0 = replicate p '0'
+toBin p n = let xs = concatMap show $ reverse (helper n)
+            in  replicate (p - length xs) '0' ++ xs
+    where
+        helper 0 = []
+        helper n = let (q,r) = n `divMod` 2 in r : helper q
+
+assemble :: [Opcode] -> String
+assemble = unlines . (\xs -> xs ++ replicate (256 - length xs) (zeros 12)) . map helper
+    where
+        zeros n = replicate n '0'
+        helper x = case x of
+            NOOP                 -> "0000" ++ zeros 8
+            (ADD r (Addr a))     -> "0001" ++ toBin 8 a
+            (SUB r (Addr a))     -> "0010" ++ toBin 8 a
+            (NOT r)              -> "0011" ++ zeros 8
+            (AND r (Addr a))     -> "0100" ++ toBin 8 a
+            (CMP r (Addr a))     -> "0101" ++ toBin 8 a
+            (LB  r (Addr a))     -> "0110" ++ toBin 8 a
+            (LBI r (AddrAddr a)) -> "0111" ++ toBin 8 a
+            (SB  (Addr a) r)     -> "1000" ++ toBin 8 a
+            (SBI (AddrAddr a) r) -> "1001" ++ toBin 8 a
+            (IN  (Addr a) b)     -> "1010" ++ toBin 8 a
+            (JA  (Addr a))       -> "1011" ++ toBin 8 a
+            (J   (Offset o))     -> "1100" ++ toBin 8 o
+            (JEQ (Offset o))     -> "1101" ++ toBin 8 o
+            (JNE (Offset o))     -> "1110" ++ toBin 8 o
+            DS                   -> "1111" ++ zeros 8
 
+main :: IO ()
 main = do
     args <- getArgs
-    when (null args) (die "No input file provided.")
+    when (null args) (die "No input file provided. Use `-h` to see help page.")
+    when (head args `elem` ["-h", "--help"]) (do {putStr help; exitSuccess})
 
     contents <- readFile (head args)
-    --let line = head (lines contents)
-    print contents
-    print . catMaybes . fst . head $ parse (many lineWithComment) contents
-    print $ parse (many lineWithComment) contents
+    let [(res, unparsed)] = parse (many lineWithComment) contents
+        line = head (lines unparsed)
+        lineNumber = (+1) . fromJust $ elemIndex line (lines contents)
+    unless (null unparsed) (die $ "Invalid syntax at line "
+                                 ++ show lineNumber ++": \n"
+                                 ++ line ++ "\n\n"
+                                 ++ "Use `-h` to see help page.")
 
+    let parsed = catMaybes res
+    writeFile "memory.mif" (assemble parsed)
+    putStrLn "Wrote to memory.mif"
 

Parser.hs

@@ -126,6 +126,12 @@ nat :: Parser Int
 nat = do x <- some digitChar
          return (read x)
 
+int :: Parser Int
+int = do char '-'
+         n <- nat
+         return (-n)
+       <|> nat
+
 -- | Parse a string of spaces, tabs, and newlines
 space :: Parser String
 space = many (sat (\c -> c == '\t' || isSeparator c))