organized

.gitignore

@@ -0,0 +1,2 @@
+.vscode
+.idea

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

Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import Parser
+import Compiler
+
+main :: IO ()
+main = do
+    contents <- getContents
+    compileZorth $ parseZorth contents

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

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

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
+ghc Main.hs -o zorth && ./zorth > out.asm && nasm -f elf64 out.asm -o out.o  && ld out.o -o a.out && ./a.out

zorth.hs

@@ -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