124 lines
3.3 KiB
Haskell
124 lines
3.3 KiB
Haskell
module Compiler where
|
|
|
|
import Parser
|
|
import Text.Printf (printf)
|
|
import Control.Monad (void)
|
|
import System.Process
|
|
import System.IO
|
|
import Control.Monad.Trans.State
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import qualified Data.Map as M
|
|
|
|
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"
|
|
|
|
type Environment = M.Map String ZorthAST
|
|
|
|
handleSymbol :: Handle -> ZorthExpr -> StateT Environment IO ()
|
|
|
|
handleSymbol h (ZorthASTInteger i) =
|
|
do
|
|
liftIO $ hPutStrLn h $ " push "<>show i
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord "+") = do
|
|
liftIO $ hPutStr h
|
|
" pop rbx\n\
|
|
\ pop rax\n\
|
|
\ add rax, rbx\n\
|
|
\ push rax\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord "-") = do
|
|
liftIO $ hPutStr h
|
|
" pop rbx\n\
|
|
\ pop rax\n\
|
|
\ sub rax, rbx\n\
|
|
\ push rax\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord "ret") = do
|
|
liftIO $ hPutStr h
|
|
" mov rax,60\n\
|
|
\ mov rdi,0\n\
|
|
\ syscall\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord "dup") = do
|
|
liftIO $ hPutStr h
|
|
" pop rax\n\
|
|
\ push rax\n\
|
|
\ push rax\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord "swap") = do
|
|
liftIO $ hPutStr h
|
|
" pop rax\n\
|
|
\ pop rbx\n\
|
|
\ push rax\n\
|
|
\ push rbx\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord "drop") = do
|
|
liftIO $ hPutStr h " add rsp, 8\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord ".") = do
|
|
liftIO $ hPutStr h
|
|
" pop rbx\n\
|
|
\ call print_number\n"
|
|
return ()
|
|
|
|
handleSymbol h (ZorthASTWord w) = do
|
|
state <- get
|
|
liftIO $ compileZorthAST h (state M.! w) state -- parent env to child and discard
|
|
return ()
|
|
|
|
handleSymbol _ (ZorthASTWordDecl (name,ast)) = do
|
|
state <- get
|
|
put $ M.insert name ast state
|
|
return ()
|
|
|
|
compileZorthAST :: Handle -> ZorthAST -> Environment -> IO ()
|
|
compileZorthAST h ast state = runStateT (foldl (\m x -> m >> handleSymbol h x) (return ()) ast) state >> return ()
|
|
|
|
compileZorth :: Handle -> ZorthAST -> IO ()
|
|
compileZorth _ [] = return ()
|
|
compileZorth h xs = do
|
|
forthPrelude h
|
|
compileZorthAST h xs M.empty
|
|
|