added cabal build system

app/Compiler.hs

@@ -0,0 +1,95 @@
+module Compiler where
+
+import Parser
+import Text.Printf (printf)
+import Control.Monad (void) 
+import System.Process
+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 :: Handle -> ZorthAST -> IO ()
+compileZorth h [] = return ()
+compileZorth h xs = do
+    forthPrelude h
+    foldr ((>>) . handleSymbol h) (return ()) xs

app/Main.hs

@@ -0,0 +1,14 @@
+module Main where
+
+import Parser
+import Compiler
+import System.Process
+import System.IO
+
+main :: IO ()
+main = do
+    contents <- getContents
+    withFile "out.asm" WriteMode (\f -> compileZorth f $ parseZorth contents)
+    readProcess "nasm" ["-f", "elf64", "out.asm", "-o", "out.o"] ""
+    readProcess "ld" ["out.o", "-o", "a.out"] ""
+    return ()

app/Monpar.hs

@@ -0,0 +1,81 @@
+{-# 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
+
+manyTill :: Parser a -> Parser b -> Parser [a]
+manyTill p q = (q >> return []) <++ do { x <- p; xs <- manyTill p q; return $ x:xs } 

app/Parser.hs

@@ -0,0 +1,65 @@
+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 (String,ZorthAST)
+               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
+
+pZorthWordDecl :: Parser ZorthExpr
+pZorthWordDecl = do
+    ZorthASTWord ":" <- pZorthWord
+    ZorthASTWord name <- pZorthWord
+    xs <- manyTill pZorthExpr (do { ZorthASTWord ";" <- pZorthWord; return () })
+    return $ ZorthASTWordDecl (name,xs)
+
+pZorthExpr :: Parser ZorthExpr
+pZorthExpr = pZorthWordDecl <++ pZorthInteger <++ pZorthWord
+
+pZorth :: Parser ZorthAST 
+pZorth = some pZorthExpr 
+
+parseZorth :: String -> ZorthAST
+parseZorth = fst . head . runParser pZorth