Dev 1.4

Kroha.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           Kroha
-version:        1.3.2.0
+version:        1.3.3.0
 description:    Please see the README on GitHub at <https://github.com/vorotynsky/Kroha#readme>
 homepage:       https://github.com/vorotynsky/Kroha#readme
 bug-reports:    https://github.com/vorotynsky/Kroha/issues
@@ -25,6 +25,7 @@ source-repository head
 executable Kroha
   main-is: Main.hs
   other-modules:
+      Args
       Kroha
       Kroha.Backends.Common
       Kroha.Backends.Nasm
@@ -42,6 +43,7 @@ executable Kroha
       Kroha.Types
       Paths_Kroha
   hs-source-dirs:
+      app
       src
   ghc-options: -XTupleSections -XDeriveTraversable -XRankNTypes -XImplicitParams -XTypeFamilies
   build-depends:
@@ -51,6 +53,7 @@ executable Kroha
     , extra >=1.0 && <1.8
     , hashmap >=1.0.0 && <1.4
     , megaparsec >=8.0.0 && <=10.0.0
+    , optparse-applicative >=0.17.0.0 && <0.18.0.0
   default-language: Haskell2010
 
 test-suite Kroha-tests
@@ -73,7 +76,6 @@ test-suite Kroha-tests
       Kroha.Syntax.Statements
       Kroha.Syntax.Syntax
       Kroha.Types
-      Main
       Paths_Kroha
   hs-source-dirs:
       test
@@ -88,4 +90,5 @@ test-suite Kroha-tests
     , extra >=1.0 && <1.8
     , hashmap >=1.0.0 && <1.4
     , megaparsec >=8.0.0 && <=10.0.0
+    , optparse-applicative >=0.17.0.0 && <0.18.0.0
   default-language: Haskell2010

app/Args.hs

@@ -0,0 +1,46 @@
+module Args where
+
+import Options.Applicative
+
+import Kroha.Backends.Common
+import Kroha.Backends.Nasm
+
+data Output 
+    = StdOut
+    | File FilePath
+
+data Options = Options 
+    { backend :: Backend 
+    , files   :: [FilePath]
+    , output  :: Output }
+
+backends = [("nasm16", nasm 16), ("nasm32", nasm 32), ("nasm64", nasm 64)]
+
+toRight _ (Just x) = Right x
+toRight x Nothing  = Left x
+
+backendParser = option (eitherReader (\x -> toRight "Unknown backend" $ lookup x backends))
+    ( long "assembly" 
+    <> metavar "BACKEND" 
+    <> help "Specify backend"
+    <> value (nasm 64) )
+
+outputParser :: Parser FilePath
+outputParser = option str
+    ( long "output"
+    <> short 'o'
+    <> metavar "FILE" 
+    <> help "Place the output into <FILE>")
+
+optionsParser :: Parser Options
+optionsParser = Options
+    <$> backendParser
+    <*> some (argument str (metavar "FILES..."))
+    <*> (flag' StdOut (long "stdout") <|> fmap File outputParser <|> pure (File "./kroha.asm"))
+
+readOptions :: IO Options
+readOptions = execParser opts
+    where opts = info (optionsParser <**> helper) 
+                  ( fullDesc
+                  <> progDesc "Compiles programs written in Kroha"
+                  <> header "Kroha language" )

app/Main.hs

@@ -0,0 +1,29 @@
+module Main where
+
+import           Data.Either        (partitionEithers)
+import           Data.List          (intercalate)
+import           System.Environment (getArgs)
+import           System.Exit        (exitFailure)
+
+import           Args
+import           Kroha
+import           Kroha.Backends.Common
+
+write :: Output -> String -> IO ()
+write (StdOut   ) content = putStrLn content
+write (File path) content = writeFile path content
+
+process :: Backend -> [(String, String)] -> IO String
+process backend contents = 
+    do let (errors, results) = partitionEithers . fmap (uncurry $ kroha backend) $ contents
+       errors <- traverse putStrLn errors
+       if null errors then pure () else exitFailure
+       return $ intercalate "\n\n" results
+
+main :: IO ()
+main = do
+    options <- readOptions
+    contents <- mapM readFile (files options)
+    parsed <- process (backend options) (zip (files options) contents)
+    let result = "; build with Kroha\n; see: https://github.com/vorotynsky/Kroha \n\n" ++ parsed
+    write (output options) result

package.yaml

@@ -1,5 +1,5 @@
 name:                Kroha
-version:             1.3.2.0
+version:             1.3.3.0
 github:              "vorotynsky/Kroha"
 license:             GPL-3
 author:              "Vorotynsky Maxim"
@@ -32,10 +32,13 @@ dependencies:
 - extra >= 1.0 && < 1.8
 - comonad >= 5 && < 5.1
 - hashmap >= 1.0.0 && < 1.4
+- optparse-applicative >= 0.17.0.0 && < 0.18.0.0
 
 executables:
   Kroha:
-    source-dirs:      src
+    source-dirs:      
+    - app
+    - src
     main:             Main.hs
 
 tests:

src/Kroha.hs

@@ -4,8 +4,7 @@ import           Data.Bifunctor            (first)
 import           Data.Foldable             (toList)
 import           Data.HashMap              (fromList, lookup)
 
-import           Kroha.Backends.Common     (runBackend, typeConfig)
-import           Kroha.Backends.Nasm       (nasm)
+import           Kroha.Backends.Common     (Backend, runBackend, typeConfig)
 import           Kroha.Errors              (Result, showErrors)
 import           Kroha.Instructions        (instructions)
 import           Kroha.Parser.Declarations (parseProgram)
@@ -15,20 +14,20 @@ import           Kroha.Syntax.Declarations (NodeId, Program, genId, pzip, pzip3)
 import           Kroha.Types               (resolve, typeCastsTree)
 
 
-compile :: Program NodeId -> Result String
-compile program = do
-                  scopes  <- linkProgram program
-                  let tc   = typeConfig nasm
-                  casts   <- typeCastsTree tc scopes
-                  _       <- resolve tc (pzip program casts)
-                  let stackRanges = stack tc program
-                  let prepared = instructions (pzip3 stackRanges (fmap snd scopes) program)
-                  return (runBackend nasm prepared)
+compile :: Backend -> Program NodeId -> Result String
+compile backend program = 
+      do scopes  <- linkProgram program
+         let tc   = typeConfig backend
+         casts   <- typeCastsTree tc scopes
+         _       <- resolve tc (pzip program casts)
+         let stackRanges = stack tc program
+         let prepared = instructions (pzip3 stackRanges (fmap snd scopes) program)
+         return (runBackend backend prepared)
 
-kroha :: String -> String -> Either String String
-kroha name src =
+kroha :: Backend -> String -> String -> Either String String
+kroha backend name src =
       case parseProgram name src of
            Left err   -> Left err
-           Right parsed -> first (showErrors (`Data.HashMap.lookup` rangeTable)) $ compile prog
+           Right parsed -> first (showErrors (`Data.HashMap.lookup` rangeTable)) $ compile backend prog
               where prog = genId parsed
                     rangeTable = fromList $ toList $ pzip prog parsed

src/Kroha/Backends/Nasm.hs

@@ -31,7 +31,7 @@ nasmTypeG , nasmTypeL, untyped :: TypeName -> String
     where append x s = s ++ x
 
 
-target :: (TypeName -> String) -> Target -> String
+target :: (?bp :: RegisterName) => (TypeName -> String) -> Target -> String
 target tf (LiteralTarget (IntegerLiteral num)) = show num
 target tf (StackTarget (offset, s))            = (tf . size2type) s ++ "[bp - " ++ show (bytes offset) ++ "]"
 target tf (RegisterTarget reg)                 = reg
@@ -43,15 +43,15 @@ jump NotEquals = "jne"
 jump Less      = "jl"
 jump Greater   = "jg"
 
-nasm16I :: Instruction -> [String]
-nasm16I (Body _ _)                   = []
-nasm16I (Assembly asm)               = [asm]
-nasm16I (Label lbl)                  = [label lbl ++ ":"]
-nasm16I (Move l r)                   = ["mov " ++ target nasmTypeL l ++ ", " ++ target untyped r]
-nasm16I (CallI l args)               = (fmap (("push " ++) . target nasmTypeL) . reverse $ args) ++ ["call " ++ label l, "add sp, " ++ show ((length args) * 2)]
-nasm16I (Jump l Nothing)             = ["jmp " ++ label l]
-nasm16I (Jump lbl (Just (l, c, r)))  = ["cmp " ++ target nasmTypeL l ++ ", " ++ target untyped r, jump c ++ " " ++ label lbl]
-nasm16I (StackAlloc s)               = ["enter " ++ show (bytes s) ++ ", 0"]
+nasmI :: (?sp :: RegisterName, ?bp :: RegisterName) => Instruction -> [String]
+nasmI (Body _ _)                   = []
+nasmI (Assembly asm)               = [asm]
+nasmI (Label lbl)                  = [label lbl ++ ":"]
+nasmI (Move l r)                   = ["mov " ++ target nasmTypeL l ++ ", " ++ target untyped r]
+nasmI (CallI l args)               = (fmap (("push " ++) . target nasmTypeL) . reverse $ args) ++ ["call " ++ label l, "add " ++ ?sp ++ ", " ++ show ((length args) * 2)]
+nasmI (Jump l Nothing)             = ["jmp " ++ label l]
+nasmI (Jump lbl (Just (l, c, r)))  = ["cmp " ++ target nasmTypeL l ++ ", " ++ target untyped r, jump c ++ " " ++ label lbl]
+nasmI (StackAlloc s)               = ["enter " ++ show (bytes s) ++ ", 0"]
 
 nasmSection :: Section -> String -> String
 nasmSection section body = header <> body <> "\n\n"
@@ -69,17 +69,32 @@ litType :: Literal -> Result TypeId
 litType l@(IntegerLiteral x) | x >= 0   && x < 65536 = Right 2
                              | otherwise             = Left (BackendError (show l ++ " is not in [0; 65536)"))
 
+regsBase16 = zip ((\x -> fmap ((:) x . pure) "lhx") =<< "abcd") (cycle [0, 0, 1])
+regsBase32 = zip ((fmap (\x -> 'e':x:"x")) "abcd") (cycle [3])
+regsBase64 = zip ((fmap (\x -> 'r':x:"x")) "abcd") (cycle [4])
+
+regsSpec r = zip ['r':r, 'e':r, r, r++"l"] [4,3,1,0]
+regsInfo = concatMap regsSpec ["sp", "bp", "si", "di"]
+
+regsRf r = zip [r, r++"d", r++"w", r++"b"] [4, 3, 1, 0]
+regsR = concatMap regsRf $ fmap ((:) 'r' . show) [8..15]
+
 nasmTypes = TypeConfig
-    { types = (fmap . first) TypeName [("int8", 8), ("int16", 16), ("+literal+", 16)]
+    { types = (fmap . first) TypeName [("int8", 8), ("int16", 16), ("+literal+", 16), ("int32", 32), ("int64", 64)]
     , pointerType = 1
-    , registers = zip ((\x -> fmap ((:) x . pure) "lhx") =<< "abcd") (cycle [0, 0, 1])
-    , typeCasts = buildG (0, 3) [(0, 2), (1, 2)]
+    , registers = regsBase16 ++ regsBase32 ++ regsBase64 ++ regsInfo ++ regsR
+    , typeCasts = buildG (0, 5) [(0, 2), (1, 2), (3, 2), (4, 2)]
     , literalType = litType }
 
 size2type size = fromJust . lookup size . fmap (\(a, b) -> (b, a)) $ types nasmTypes
 
-nasm = Backend
-    { instruction = nasm16I
+nasmInstruction 16 = let ?bp =  "bp" in let ?sp =  "sp" in nasmI
+nasmInstruction 32 = let ?bp = "ebp" in let ?sp = "esp" in nasmI
+nasmInstruction 64 = let ?bp = "rbp" in let ?sp = "rsp" in nasmI
+
+
+nasm arch = Backend
+    { instruction = nasmInstruction arch
     , bodyWrap    = id
     , indent      = "  "
     , section     = nasmSection

test/Case.hs

@@ -9,6 +9,7 @@ import           Data.List.Extra     (trim)
 import           Data.Maybe          (fromJust, isJust)
 import           Data.Tuple.Extra    (both)
 import           Kroha               (kroha)
+import           Kroha.Backends.Nasm (nasm)
 import           Test.HUnit
 
 type TestName = String
@@ -53,7 +54,7 @@ testCase :: TestName -> Test
 testCase name = TestCase $ do
     text <- readFile $ toFile ".test.kr" name
     let (program, expected) = both trim $ extract text
-    let actual = trim . fromEither $ kroha name program
+    let actual = trim . fromEither $ kroha (nasm 16) name program
     assertProgram name expected actual
     where extract text = fromJust . join . find isJust . fmap (`splitBy` text) $ ["nasm", "errors"]