diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8cd0df3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.vscode +.idea \ No newline at end of file diff --git a/Compiler.hs b/Compiler.hs new file mode 100644 index 0000000..3f29695 --- /dev/null +++ b/Compiler.hs @@ -0,0 +1,94 @@ +module Compiler where + +import Parser +import Text.Printf (printf) +import Control.Monad (void) +import System.IO + +handleSymbol :: Handle -> ZorthExpr -> IO () + +handleSymbol h (ZorthASTInteger i) = hPutStrLn h $ " push "<>show i + +handleSymbol h (ZorthASTWord "+") = do + hPutStr h + " pop rbx\n\ + \ pop rax\n\ + \ add rax, rbx\n\ + \ push rax\n" + +handleSymbol h (ZorthASTWord "-") = do + hPutStr h + " pop rbx\n\ + \ pop rax\n\ + \ sub rax, rbx\n\ + \ push rax\n" + +handleSymbol h (ZorthASTWord "ret") = do + hPutStr h + " mov rax,60\n\ + \ mov rdi,0\n\ + \ syscall\n" + +handleSymbol h (ZorthASTWord "dup") = do + hPutStr h + " pop rax\n\ + \ push rax\n\ + \ push rax\n" + +handleSymbol h (ZorthASTWord "swap") = do + hPutStr h + " pop rax\n\ + \ pop rbx\n\ + \ push rax\n\ + \ push rbx\n" + +handleSymbol h (ZorthASTWord "drop") = do + hPutStr h " add rsp, 8\n" + +handleSymbol h (ZorthASTWord ".") = do + hPutStr h + " pop rbx\n\ + \ call print_number\n" + +forthPrelude :: Handle -> IO () +forthPrelude h = do + hPutStr h + "global _start\n\ + \print_number:\n\ + \ push rbp\n\ + \ mov rbp, rsp\n\ + \ sub rsp, 128 \n\ + \ mov rdx, -1 \n\ + \ jmp l2\n\ + \ add rsp, 28\n\ + \ pop rbp\n\ + \ ret\n\ + \l1:\n\ + \ dec rdx\n\ + \ imul rax, rbx, 1717986919\n\ + \ shr rax, 34\n\ + \ imul rcx, rax, 10\n\ + \ sub rbx, rcx\n\ + \ add rbx, '0'\n\ + \ mov qword[rbp+8*rdx], rbx\n\ + \\n\ + \ mov rbx, rax\n\ + \l2:\n\ + \ cmp rbx, 0\n\ + \ jne l1\n\ + \ mov qword[rbp-8], `\\n` \n\ + \ mov rax, 1\n\ + \ mov rdi, 1\n\ + \ lea rsi, [rbp+8*rdx]\n\ + \ neg rdx\n\ + \ imul rdx, 8\n\ + \ syscall\n\ + \ leave\n\ + \ ret\n\ + \_start:\n" + +compileZorth :: ZorthAST -> IO () +compileZorth [] = return () +compileZorth xs = do + forthPrelude stdout + foldr ((>>) . handleSymbol stdout) (return ()) xs diff --git a/Main b/Main new file mode 100755 index 0000000..e154fa2 Binary files /dev/null and b/Main differ diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..f9d6c80 --- /dev/null +++ b/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Parser +import Compiler + +main :: IO () +main = do + contents <- getContents + compileZorth $ parseZorth contents \ No newline at end of file diff --git a/Monpar.hs b/Monpar.hs new file mode 100644 index 0000000..0a40c86 --- /dev/null +++ b/Monpar.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE LambdaCase #-} +module Monpar where + +import qualified Control.Applicative as Ap +import Control.Applicative ((<|>), Alternative, many, some) +import Data.Char (isDigit, digitToInt) +import Control.Monad ( MonadPlus(mzero), void ) +import Text.Printf (printf) +newtype Parser a = Parser {runParser :: String -> [(a, String)]} + +instance Functor Parser where + fmap f p = Parser $ \inp -> [ (f x,xs) | (x,xs) <- runParser p inp ] + +instance Applicative Parser where + pure v = Parser $ \inp -> [(v,inp)] + d <*> e = d >>= (<$> e) + +instance Monad Parser where + return = pure + p >>= f = Parser $ \inp -> concat [runParser (f v) out | (v,out) <- runParser p inp] + +instance Alternative Parser where + empty = Parser $ const [] + p <|> q = Parser $ \inp -> runParser p inp ++ runParser q inp + many p = do { x <- p; xs <- many p; return $ x:xs } <|> return [] + some p = do + x <- p + xs <- many p + return $ x:xs + +instance MonadPlus Parser + +instance MonadFail Parser where + fail _ = mzero + +(<++) :: Parser a -> Parser a -> Parser a +p <++ q = Parser $ \inp -> let r1 = runParser p inp in + if null r1 then runParser q inp else r1 + +get :: Parser Char +get = Parser $ \case + [] -> [] + x:xs -> [(x,xs)] + + +look :: Parser Char +look = Parser $ \case + [] -> [] + x:xs -> [(x,x:xs)] + +sat :: (Char -> Bool) -> Parser Char +sat p = do + c <- get + if p c then return c else mzero + +char :: Char -> Parser Char +char c = sat (== c) + +string :: String -> Parser String +string "" = return "" +string (x:xs) = do + char x + string xs + return (x:xs) + +eof :: Parser () +eof = Parser $ \inp -> [((), inp) | null inp] + +option :: a -> Parser a -> Parser a +option x p = p <|> return x + +word :: Parser String +word = neWord <|> return "" + where + neWord = do + x <- sat (\x -> x /= '\n' && x /= ' ') + xs <- word + return $ x:xs \ No newline at end of file diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..5ab639d --- /dev/null +++ b/Parser.hs @@ -0,0 +1,55 @@ +module Parser where + +import Monpar +import Control.Applicative ((<|>), Alternative, many, some) +import Data.Char (isDigit, digitToInt) +import Control.Monad (MonadPlus(mzero), void) + +type ZorthAST = [ZorthExpr] + +data ZorthExpr = ZorthASTInteger Int + | ZorthASTWord String + | ZorthASTWordDecl [ZorthExpr] + deriving Show + +word1 :: Parser String +word1 = do + x <- sat (\x -> x /= '\n' && x /= ' ') + xs <- word + return $ x:xs + +nonsenseSymbol :: Parser Char +nonsenseSymbol = char ' ' <|> char '\n' + +skipNonsenseSymbols :: Parser [Char] +skipNonsenseSymbols = many nonsenseSymbol + +digit :: Parser Int +digit = digitToInt <$> sat isDigit + +pZorthUnsignedInteger :: Parser ZorthExpr +pZorthUnsignedInteger = ZorthASTInteger . foldr (\n t -> n + t*10) 0 . reverse <$> some digit + +pZorthSignedInteger :: Parser ZorthExpr +pZorthSignedInteger = do + char '-' + (ZorthASTInteger i) <- pZorthUnsignedInteger + return $ ZorthASTInteger $ negate i + +pZorthInteger :: Parser ZorthExpr +pZorthInteger = do + skipNonsenseSymbols + i <- pZorthSignedInteger <|> pZorthUnsignedInteger + eof <|> void nonsenseSymbol + return i + +pZorthWord :: Parser ZorthExpr +pZorthWord = do + skipNonsenseSymbols + ZorthASTWord <$> word1 + +pZorth :: Parser ZorthAST +pZorth = some (pZorthInteger <++ pZorthWord) + +parseZorth :: String -> ZorthAST +parseZorth = fst . head . runParser pZorth diff --git a/build.sh b/build.sh index fff431b..cd0abdf 100644 --- a/build.sh +++ b/build.sh @@ -1 +1 @@ -ghc zorth.hs -o zorth && ./zorth > out.asm && nasm -f elf64 out.asm -o out.o && ld out.o -o a.out && ./a.out \ No newline at end of file +ghc Main.hs -o zorth && ./zorth > out.asm && nasm -f elf64 out.asm -o out.o && ld out.o -o a.out && ./a.out \ No newline at end of file diff --git a/zorth.hs b/zorth.hs deleted file mode 100644 index 2042a50..0000000 --- a/zorth.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -import qualified Control.Applicative as Ap -import Control.Applicative ((<|>), Alternative, many, some) -import Data.Char (isDigit, digitToInt) -import Control.Monad -import Text.Printf (printf) -newtype Parser a = Parser {runParser :: String -> [(a, String)]} - -instance Functor Parser where - fmap f p = Parser $ \inp -> [ (f x,xs) | (x,xs) <- runParser p inp ] - -instance Applicative Parser where - pure v = Parser $ \inp -> [(v,inp)] - d <*> e = d >>= (<$> e) - -instance Monad Parser where - return = pure - p >>= f = Parser $ \inp -> concat [runParser (f v) out | (v,out) <- runParser p inp] - -instance Alternative Parser where - empty = Parser $ const [] - p <|> q = Parser $ \inp -> runParser p inp ++ runParser q inp - many p = do { x <- p; xs <- many p; return $ x:xs } <|> return [] - some p = do - x <- p - xs <- many p - return $ x:xs - -instance MonadPlus Parser - -instance MonadFail Parser where - fail _ = mzero - -(<++) :: Parser a -> Parser a -> Parser a -p <++ q = Parser $ \inp -> let r1 = runParser p inp in - if null r1 then runParser q inp else r1 - -get :: Parser Char -get = Parser $ \case - [] -> [] - x:xs -> [(x,xs)] - - -look :: Parser Char -look = Parser $ \case - [] -> [] - x:xs -> [(x,x:xs)] - -sat :: (Char -> Bool) -> Parser Char -sat p = do - c <- get - if p c then return c else mzero - -char :: Char -> Parser Char -char c = sat (== c) - -string :: String -> Parser String -string "" = return "" -string (x:xs) = do - char x - string xs - return (x:xs) - -eof :: Parser () -eof = Parser $ \inp -> if null inp then [((),inp)] else [] - - -data ZorthAST = ZorthASTInteger Int - | ZorthASTWord String - deriving Show -skipNonsenseSymbols :: Parser [Char] -skipNonsenseSymbols = many (char ' ' <|> char '\n') - -digit :: Parser Int -digit = digitToInt <$> sat isDigit - -option :: a -> Parser a -> Parser a -option x p = p <|> return x - -pZorthUnsignedInteger :: Parser ZorthAST -pZorthUnsignedInteger = ZorthASTInteger . foldr (\n t -> n + t*10) 0 . reverse <$> some digit - -pZorthSignedInteger :: Parser ZorthAST -pZorthSignedInteger = do - char '-' - (ZorthASTInteger i) <- pZorthUnsignedInteger - return $ ZorthASTInteger $ negate i - -pZorthInteger :: Parser ZorthAST -pZorthInteger = do - skipNonsenseSymbols - i <- pZorthSignedInteger <|> pZorthUnsignedInteger - eof <|> ((sat (\x -> x== ' ' || x == '\n')) >> return ()) - return i - -pZorthWord :: Parser ZorthAST -pZorthWord = do - skipNonsenseSymbols - ZorthASTWord <$> some (sat (\x -> x /= ' ' && x /= '\n')) - -pZorth :: Parser [ZorthAST] -pZorth = some (pZorthWord <|> pZorthInteger) - -parseZorth :: String -> [ZorthAST] -parseZorth = fst . head . runParser pZorth - -handleSymbol :: ZorthAST -> IO () -handleSymbol (ZorthASTInteger i) = void $ printf " push %d\n" i -handleSymbol (ZorthASTWord "+") = do - putStrLn " pop rbx" - putStrLn " pop rax" - putStrLn " add rax, rbx" - putStrLn " push rax" -handleSymbol (ZorthASTWord "-") = do - putStrLn " pop rbx" - putStrLn " pop rax" - putStrLn " sub rax, rbx" - putStrLn " push rax" -handleSymbol (ZorthASTWord "ret") = do - putStrLn " mov rax,60" - putStrLn " mov rdi,0" - putStrLn " syscall" -handleSymbol (ZorthASTWord "dup") = do - putStrLn " pop rax" - putStrLn " push rax" - putStrLn " push rax" -handleSymbol (ZorthASTWord "swap") = do - putStrLn " pop rax" - putStrLn " pop rbx" - putStrLn " push rax" - putStrLn " push rbx" -handleSymbol (ZorthASTWord "drop") = do - putStrLn " add rsp, 8" -handleSymbol (ZorthASTWord ".") = do - putStrLn " pop rbx" - putStrLn " call print_number" - -compileZorth :: [ZorthAST] -> IO () -compileZorth [] = return () -compileZorth xs = do - putStrLn "global _start" - putStrLn "print_number:" - putStrLn " push rbp" - putStrLn " mov rbp, rsp" - putStrLn " sub rsp, 128 " - putStrLn " mov rdx, -1 " - putStrLn " jmp l2" - putStrLn " add rsp, 28" - putStrLn " pop rbp" - putStrLn " ret" - putStrLn "l1:" - putStrLn " dec rdx" - putStrLn " imul rax, rbx, 1717986919" - putStrLn " shr rax, 34" - putStrLn " imul rcx, rax, 10" - putStrLn " sub rbx, rcx" - putStrLn " add rbx, '0'" - putStrLn " mov qword[rbp+8*rdx], rbx" - putStrLn "" - putStrLn " mov rbx, rax" - putStrLn "l2:" - putStrLn " cmp rbx, 0" - putStrLn " jne l1" - putStrLn " mov qword[rbp-8], `\\n` " - putStrLn " mov rax, 1" - putStrLn " mov rdi, 1" - putStrLn " lea rsi, [rbp+8*rdx]" - putStrLn " neg rdx" - putStrLn " imul rdx, 8" - putStrLn " syscall" - putStrLn " leave" - putStrLn " ret" - putStrLn "_start:" - foldr ((>>) . handleSymbol) (return ()) xs - -main :: IO () -main = do - contents <- getContents - compileZorth $ parseZorth contents \ No newline at end of file