summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore7
-rw-r--r--Makefile18
-rw-r--r--ast.hs148
-rw-r--r--codegen.hs238
-rw-r--r--ll/Makefile16
-rw-r--r--ll/ding.c30
-rw-r--r--ll/gen.hs57
-rw-r--r--ll/test.ll104
-rw-r--r--main.hs38
-rw-r--r--parser.hs252
-rw-r--r--pshow.hs18
-rw-r--r--test.nl18
12 files changed, 944 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..aea9637
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.hi
+*.o
+main
+
+ll/gen
+ll/test.s
+ll/test
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..cb0faab
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,18 @@
+GHC = ghc
+GHCFLAGS = -Wall -O3
+
+TARGET = main
+
+.PHONY: all clean remake
+
+all: $(TARGET)
+
+clean:
+ rm -f $(TARGET) *.o *.hi
+
+remake: clean
+ make all
+
+
+$(TARGET): *.hs
+ $(GHC) $(GHCFLAGS) $^ -o $@
diff --git a/ast.hs b/ast.hs
new file mode 100644
index 0000000..bd845df
--- /dev/null
+++ b/ast.hs
@@ -0,0 +1,148 @@
+module AST(
+ Name,
+ Program(..), Declaration(..), Block(..), Type(..), Literal(..),
+ BinaryOperator(..), UnaryOperator(..), Expression(..), Statement(..)) where
+
+import Data.List
+
+import PShow
+
+
+type Name = String
+
+data Program = Program [Declaration]
+ deriving (Show)
+
+data Declaration
+ = DecFunction {typeOf :: Type
+ ,nameOf :: Name
+ ,argumentsOf :: [(Type, Name)]
+ ,bodyOf :: Block}
+ | DecVariable {typeOf :: Type
+ ,nameOf :: Name
+ ,valueOf :: Maybe Expression}
+ | DecTypedef {typeOf :: Type
+ ,nameOf :: Name}
+ deriving (Show)
+
+data Block = Block [Statement]
+ deriving (Show)
+
+data Type = TypeInt Int
+ | TypeUInt Int
+ | TypeFloat
+ | TypeDouble
+ | TypePtr Type
+ | TypeName Name
+ deriving (Show, Eq)
+
+data Literal = LitInt Integer
+ | LitString String
+ | LitVar Name
+ | LitCall Name [Expression]
+ deriving (Show)
+
+data BinaryOperator
+ = Plus | Minus | Times | Divide | Modulo
+ | Equal | Unequal | Greater | Less | GEqual | LEqual
+ | BoolAnd | BoolOr
+ deriving (Show, Eq)
+
+data UnaryOperator
+ = Negate | Not | Invert | Dereference | Address
+ deriving (Show, Eq)
+
+data Expression
+ = ExLit Literal
+ | ExBinOp BinaryOperator Expression Expression
+ | ExUnOp UnaryOperator Expression
+ deriving (Show)
+
+data Statement
+ = StEmpty
+ | StBlock Block
+ | StExpr Expression
+ | StVarDeclaration Type Name (Maybe Expression)
+ | StAssignment Name Expression
+ | StIf Expression Statement Statement
+ | StWhile Expression Statement
+ | StReturn Expression
+ deriving (Show)
+
+
+indent :: Int -> String -> String
+indent sz str = intercalate "\n" $ map (prefix++) $ lines str
+ where prefix = replicate sz ' '
+
+
+instance PShow Program where
+ pshow (Program decls) = intercalate "\n" (map pshow decls)
+
+instance PShow Declaration where
+ pshow (DecFunction t n a b) =
+ concat [pshow t, " ", n, "(", intercalate ", " (map pshowArg a), ") ", pshow b]
+ where pshowArg (argt, argn) = concat [pshow argt, " ", argn]
+ pshow (DecVariable t n Nothing) =
+ concat [pshow t, " ", n, ";"]
+ pshow (DecVariable t n (Just e)) =
+ concat [pshow t, " ", n, " = ", pshow e, ";"]
+ pshow (DecTypedef t n) =
+ concat ["type ", n, " = ", pshow t, ";"]
+
+instance PShow Block where
+ pshow (Block []) = "{}"
+ pshow (Block stmts) = concat ["{\n", indent 4 $ intercalate "\n" (map pshow stmts), "\n}"]
+
+instance PShow Type where
+ pshow (TypeInt sz) = 'i' : pshow sz
+ pshow (TypeUInt sz) = 'u' : pshow sz
+ pshow TypeFloat = "float"
+ pshow TypeDouble = "double"
+ pshow (TypePtr t) = concat ["ptr(", pshow t, ")"]
+ pshow (TypeName n) = n
+
+instance PShow Literal where
+ pshow (LitInt i) = pshow i
+ pshow (LitString s) = pshow s
+ pshow (LitVar n) = n
+ pshow (LitCall n a) = concat [n, "(", intercalate ", " (map pshow a), ")"]
+
+instance PShow BinaryOperator where
+ pshow Plus = "+"
+ pshow Minus = "-"
+ pshow Times = "*"
+ pshow Divide = "/"
+ pshow Modulo = "%"
+ pshow Equal = "=="
+ pshow Unequal = "!="
+ pshow Greater = ">"
+ pshow Less = "<"
+ pshow GEqual = ">="
+ pshow LEqual = "<="
+ pshow BoolAnd = "&&"
+ pshow BoolOr = "||"
+
+instance PShow UnaryOperator where
+ pshow Negate = "-"
+ pshow Not = "!"
+ pshow Invert = "~"
+ pshow Dereference = "*"
+ pshow Address = "&"
+
+instance PShow Expression where
+ pshow (ExLit lit) = pshow lit
+ pshow (ExBinOp op a b) = concat [pshow a, " ", pshow op, " ", pshow b]
+ pshow (ExUnOp op a) = concat [pshow op, pshow a]
+
+instance PShow Statement where
+ pshow StEmpty = ";"
+ pshow (StBlock bl) = pshow bl
+ pshow (StExpr e) = pshow e ++ ";"
+ pshow (StVarDeclaration t n Nothing) = concat [pshow t, " ", n, ";"]
+ pshow (StVarDeclaration t n (Just e)) = concat [pshow t, " ", n, " = ", pshow e, ";"]
+ pshow (StAssignment n e) = concat [n, " = ", pshow e, ";"]
+ pshow (StIf c t StEmpty) = concat ["if (", pshow c, ") ", pshow t]
+ pshow (StIf c t@(StBlock _) e) = concat ["if (", pshow c, ") ", pshow t, " else ", pshow e]
+ pshow (StIf c t e) = concat ["if (", pshow c, ") ", pshow t, "\nelse ", pshow e]
+ pshow (StWhile c s) = concat ["while (", pshow c, ") ", pshow s]
+ pshow (StReturn e) = concat ["return ", pshow e, ";"]
diff --git a/codegen.hs b/codegen.hs
new file mode 100644
index 0000000..f2c35b4
--- /dev/null
+++ b/codegen.hs
@@ -0,0 +1,238 @@
+module Codegen(module Codegen, A.Module) where
+
+import qualified Data.Map.Strict as Map
+-- import qualified LLVM.General.AST.Type as A
+-- import qualified LLVM.General.AST.Global as A
+-- import qualified LLVM.General.AST.Constant as A.C
+-- import qualified LLVM.General.AST.Operand as A
+-- import qualified LLVM.General.AST.Name as A
+-- import qualified LLVM.General.AST.Instruction as A
+import qualified LLVM.General.AST as A
+
+import AST
+
+
+type Error a = Either String a
+
+
+codegen :: Program -- Program to compile
+ -> String -- Module name
+ -> String -- File name of source
+ -> Error A.Module
+codegen prog name fname = do
+ defs <- generateDefs (preprocess prog)
+ return $ A.defaultModule {
+ A.moduleName = name,
+ A.moduleSourceFileName = fname,
+ A.moduleDefinitions = defs
+ }
+
+preprocess :: Program -> Program
+preprocess prog@(Program decls) = mapProgram' filtered mapper
+ where
+ filtered = Program $ filter notTypedef decls
+ mapper = defaultPM' {typeHandler' = typeReplacer (findTypeRenames prog)}
+
+ notTypedef :: Declaration -> Bool
+ notTypedef (DecTypedef _ _) = False
+ notTypedef _ = True
+
+ typeReplacer :: Map.Map Name Type -> Type -> Type
+ typeReplacer m t@(TypeName n) = maybe t id $ Map.lookup n m
+ typeReplacer _ t = t
+
+ findTypeRenames :: Program -> Map.Map Name Type
+ findTypeRenames (Program d) = foldl go Map.empty d
+ where
+ go :: Map.Map Name Type -> Declaration -> Map.Map Name Type
+ go m (DecTypedef t n) = Map.insert n t m
+ go m _ = m
+
+
+generateDefs :: Program -> Error [A.Definition]
+generateDefs prog = do
+ checkUndefinedTypes prog
+ checkUndefinedVars prog
+ fail "TODO"
+ return []
+
+checkUndefinedTypes :: Program -> Error ()
+checkUndefinedTypes prog = fmap (const ()) $ mapProgram prog $ defaultPM {typeHandler = check}
+ where
+ check :: Type -> Error Type
+ check (TypeName n) = Left $ "Undefined type name '" ++ n ++ "'"
+ check t = Right t
+
+-- checkUndefinedVars :: Program -> Error ()
+-- checkUndefinedVars prog = do
+
+
+-- mapTypes' :: Program -> (Type -> Type) -> Program
+-- mapTypes' prog f = (\(Right res) -> res) $ mapTypes prog (return . f)
+
+-- mapTypes :: Program -> (Type -> Error Type) -> Error Program
+-- mapTypes (Program decls) f = Program <$> sequence (map goD decls)
+-- where
+-- handler :: Type -> Error Type
+-- handler (TypePtr t) = f t >>= f . TypePtr
+-- handler t = f t
+
+-- goD :: Declaration -> Error Declaration
+-- goD (DecFunction t n a b) = do
+-- rt <- handler t
+-- ra <- sequence $ map (\(at,an) -> (\art -> (art,an)) <$> handler at) a
+-- rb <- goB b
+-- return $ DecFunction rt n ra rb
+-- goD (DecVariable t n v) = (\rt -> DecVariable rt n v) <$> handler t
+-- goD (DecTypedef t n) = (\rt -> DecTypedef rt n) <$> handler t
+
+-- goB :: Block -> Error Block
+-- goB (Block stmts) = Block <$> sequence (map goS stmts)
+
+-- goS :: Statement -> Error Statement
+-- goS (StBlock bl) = StBlock <$> goB bl
+-- goS (StVarDeclaration t n e) = (\rt -> StVarDeclaration rt n e) <$> handler t
+-- goS (StIf c t e) = do
+-- rt <- goS t
+-- re <- goS e
+-- return $ StIf c rt re
+-- goS (StWhile c b) = StWhile c <$> goS b
+-- goS s = return s
+
+
+type MapperHandler a = a -> Error a
+
+data ProgramMapper = ProgramMapper
+ {declarationHandler :: MapperHandler Declaration
+ ,blockHandler :: MapperHandler Block
+ ,typeHandler :: MapperHandler Type
+ ,literalHandler :: MapperHandler Literal
+ ,binOpHandler :: MapperHandler BinaryOperator
+ ,unOpHandler :: MapperHandler UnaryOperator
+ ,expressionHandler :: MapperHandler Expression
+ ,statementHandler :: MapperHandler Statement
+ ,nameHandler :: MapperHandler Name}
+
+type MapperHandler' a = a -> a
+
+data ProgramMapper' = ProgramMapper'
+ {declarationHandler' :: MapperHandler' Declaration
+ ,blockHandler' :: MapperHandler' Block
+ ,typeHandler' :: MapperHandler' Type
+ ,literalHandler' :: MapperHandler' Literal
+ ,binOpHandler' :: MapperHandler' BinaryOperator
+ ,unOpHandler' :: MapperHandler' UnaryOperator
+ ,expressionHandler' :: MapperHandler' Expression
+ ,statementHandler' :: MapperHandler' Statement
+ ,nameHandler' :: MapperHandler' Name}
+
+defaultPM :: ProgramMapper
+defaultPM = ProgramMapper return return return return return return return return return
+
+defaultPM' :: ProgramMapper'
+defaultPM' = ProgramMapper' id id id id id id id id id
+
+mapProgram' :: Program -> ProgramMapper' -> Program
+mapProgram' prog mapper = (\(Right r) -> r) $ mapProgram prog $ ProgramMapper
+ {declarationHandler = return . declarationHandler' mapper
+ ,blockHandler = return . blockHandler' mapper
+ ,typeHandler = return . typeHandler' mapper
+ ,literalHandler = return . literalHandler' mapper
+ ,binOpHandler = return . binOpHandler' mapper
+ ,unOpHandler = return . unOpHandler' mapper
+ ,expressionHandler = return . expressionHandler' mapper
+ ,statementHandler = return . statementHandler' mapper
+ ,nameHandler = return . nameHandler' mapper}
+
+mapProgram :: Program -> ProgramMapper -> Error Program
+mapProgram prog mapper = goP prog
+ where
+ h_d = declarationHandler mapper
+ h_b = blockHandler mapper
+ h_t = typeHandler mapper
+ h_l = literalHandler mapper
+ h_bo = binOpHandler mapper
+ h_uo = unOpHandler mapper
+ h_e = expressionHandler mapper
+ h_s = statementHandler mapper
+ h_n = nameHandler mapper
+
+ goP :: Program -> Error Program
+ goP (Program decls) = Program <$> sequence (map (\d -> goD d >>= h_d) decls)
+
+ goD :: Declaration -> Error Declaration
+ goD (DecFunction t n a b) = do
+ rt <- goT t
+ rn <- goN n
+ ra <- sequence $ map (\(at,an) -> (,) <$> goT at <*> goN an) a
+ rb <- goB b
+ h_d $ DecFunction rt rn ra rb
+ goD (DecVariable t n mv) = do
+ rt <- goT t
+ rn <- goN n
+ rmv <- sequence $ fmap goE mv
+ h_d $ DecVariable rt rn rmv
+ goD (DecTypedef t n) = do
+ rt <- goT t
+ rn <- goN n
+ h_d $ DecTypedef rt rn
+
+ goT :: Type -> Error Type
+ goT (TypePtr t) = goT t >>= (h_t . TypePtr)
+ goT (TypeName n) = goN n >>= (h_t . TypeName)
+ goT t = h_t t
+
+ goN :: Name -> Error Name
+ goN = h_n
+
+ goB :: Block -> Error Block
+ goB (Block sts) = (Block <$> sequence (map goS sts)) >>= h_b
+
+ goE :: Expression -> Error Expression
+ goE (ExLit l) = goL l >>= (h_e . ExLit)
+ goE (ExBinOp bo e1 e2) = do
+ rbo <- goBO bo
+ re1 <- goE e1
+ re2 <- goE e2
+ h_e $ ExBinOp rbo re1 re2
+ goE (ExUnOp uo e) = do
+ ruo <- goUO uo
+ re <- goE e
+ h_e $ ExUnOp ruo re
+
+ goS :: Statement -> Error Statement
+ goS StEmpty = h_s StEmpty
+ goS (StBlock b) = goB b >>= (h_s . StBlock)
+ goS (StExpr e) = goE e >>= (h_s . StExpr)
+ goS (StVarDeclaration t n me) = do
+ rt <- goT t
+ rn <- goN n
+ rme <- sequence $ fmap goE me
+ h_s $ StVarDeclaration rt rn rme
+ goS (StAssignment n e) = do
+ rn <- goN n
+ re <- goE e
+ h_s $ StAssignment rn re
+ goS (StIf e s1 s2) = do
+ re <- goE e
+ rs1 <- goS s1
+ rs2 <- goS s2
+ h_s $ StIf re rs1 rs2
+ goS (StWhile e s) = do
+ re <- goE e
+ rs <- goS s
+ h_s $ StWhile re rs
+ goS (StReturn e) = goE e >>= (h_s . StReturn)
+
+ goL :: Literal -> Error Literal
+ goL (LitVar n) = goN n >>= (h_l . LitVar)
+ goL (LitCall n a) = do
+ rn <- goN n
+ ra <- sequence $ map goE a
+ h_l $ LitCall rn ra
+
+ goBO :: BinaryOperator -> Error BinaryOperator
+ goBO = h_bo
+
+ goUO :: UnaryOperator -> Error UnaryOperator
+ goUO = h_uo
diff --git a/ll/Makefile b/ll/Makefile
new file mode 100644
index 0000000..f19648f
--- /dev/null
+++ b/ll/Makefile
@@ -0,0 +1,16 @@
+.PHONY: all clean remake
+
+all: test
+
+clean:
+ rm test test.s
+
+remake: clean
+ make all
+
+
+test: test.s
+ clang -Wall -Wextra $< -o $@
+
+test.s: test.ll
+ llc -W $< -o $@
diff --git a/ll/ding.c b/ll/ding.c
new file mode 100644
index 0000000..b6b4bf2
--- /dev/null
+++ b/ll/ding.c
@@ -0,0 +1,30 @@
+#include <stdio.h>
+
+int mandeliter(double x,double y){
+ double a=x,b=y;
+ int n=0;
+ while(n<256){
+ double na=a*a-b*b+x;
+ double nb=2*a*b+y;
+ a=na;
+ b=nb;
+ if(a*a+b*b>4)break;
+ n++;
+ }
+ return n;
+}
+
+int main(void){
+ double x,y;
+ y=1.5;
+ while(y>=-1.5){
+ x=-2;
+ while(x<=1){
+ int n=mandeliter(x,y);
+ printf("%3d ",n);
+ x+=0.0625;
+ }
+ y-=0.125;
+ putchar('\n');
+ }
+}
diff --git a/ll/gen.hs b/ll/gen.hs
new file mode 100644
index 0000000..907a489
--- /dev/null
+++ b/ll/gen.hs
@@ -0,0 +1,57 @@
+import qualified LLVM.General.AST.Type as AST
+import qualified LLVM.General.AST.Global as AST
+import qualified LLVM.General.AST.Constant as AST.C
+import qualified LLVM.General.AST.Operand as AST
+import qualified LLVM.General.AST.Name as AST
+import qualified LLVM.General.AST.Instruction as AST
+import qualified LLVM.General.AST as AST
+import qualified LLVM.General as General
+import qualified LLVM.General.Context as General
+import qualified LLVM.General.Target as General
+import Control.Monad.Except
+import qualified Data.ByteString as BS
+import System.Exit
+
+
+bb1 :: AST.BasicBlock
+bb1 = AST.BasicBlock (AST.Name "bb1")
+ [AST.Name "s" AST.:= AST.Add False False
+ (AST.LocalReference AST.i32 (AST.Name "argc"))
+ (AST.ConstantOperand (AST.C.Int 32 1))
+ []]
+ (AST.Do $ AST.Ret (Just $ AST.LocalReference AST.i32 (AST.Name "s")) [])
+
+func :: AST.Global
+func = AST.functionDefaults {
+ AST.returnType = AST.i32,
+ AST.name = AST.Name "main",
+ AST.parameters =
+ ([AST.Parameter AST.i32 (AST.Name "argc") [],
+ AST.Parameter (AST.ptr (AST.ptr AST.i8)) (AST.Name "argv") []],
+ False),
+ AST.basicBlocks = [bb1]
+ }
+
+topmod :: AST.Module
+topmod = AST.defaultModule {AST.moduleDefinitions = [AST.GlobalDefinition func]}
+
+
+assert :: ExceptT String IO a -> IO a
+assert ex = do
+ e <- runExceptT ex
+ either die return e >> (return $ (\(Right r) -> r) e)
+
+main :: IO ()
+main = do
+ General.withContext $ \context -> do
+ assert $ General.withModuleFromAST context topmod $ \genmod -> do
+ llvmasm <- General.moduleLLVMAssembly genmod
+ putStr llvmasm
+ putStrLn ""
+ assert $ General.withHostTargetMachine $ \machine -> do
+ General.getTargetMachineTriple machine >>= putStrLn
+ putStrLn ""
+ assert (General.moduleTargetAssembly machine genmod)
+ >>= putStr
+ bs <- assert $ General.moduleObject machine genmod
+ BS.writeFile "output_gen.o" bs
diff --git a/ll/test.ll b/ll/test.ll
new file mode 100644
index 0000000..8da7408
--- /dev/null
+++ b/ll/test.ll
@@ -0,0 +1,104 @@
+declare i32 @printf(i8*, ...)
+declare void @putchar(i32)
+
+
+@maxiter = internal constant i32 32
+@lbound = internal constant double -2.0
+@rbound = internal constant double 1.0
+@tbound = internal constant double 1.5
+@bbound = internal constant double -1.5
+@hincr = internal constant double 0.03125
+@vincr = internal constant double 0.0625
+
+
+define internal i32 @mandeliter(double %x, double %y) {
+entry:
+ br label %loopbody
+
+loopbody:
+ %a = phi double [%x, %entry], [%na, %increment]
+ %b = phi double [%y, %entry], [%nb, %increment]
+ %n = phi i32 [0, %entry], [%nn, %increment]
+
+ %a2 = fmul double %a, %a
+ %b2 = fmul double %b, %b
+ %a2mb2 = fsub double %a2, %b2
+ %na = fadd double %a2mb2, %x
+
+ %ab = fmul double %a, %b
+ %ab2 = fadd double %ab, %ab
+ %nb = fadd double %ab2, %y
+
+ %norm = fadd double %a2, %b2
+ %cmp = fcmp ogt double %norm, 4.0
+ br i1 %cmp, label %afterloop, label %increment
+
+increment:
+ %nn = add i32 %n, 1
+ %maxiter = load i32, i32* @maxiter
+ %icmp = icmp slt i32 %nn, %maxiter
+ br i1 %icmp, label %loopbody, label %afterloop
+
+afterloop:
+ %retn = phi i32 [%n, %loopbody], [%nn, %increment]
+ ret i32 %retn
+}
+
+
+@num_formatstr = internal constant [4 x i8] c"%d \00"
+
+define internal void @printnum32(i32 %n) {
+entry:
+ %f = getelementptr [4 x i8], [4 x i8]* @num_formatstr, i64 0, i32 0
+ call i32(i8*, ...) @printf(i8* %f, i32 %n)
+ ret void
+}
+
+define internal void @printnum8(i8 %n) {
+entry:
+ %n32 = sext i8 %n to i32
+ tail call void @printnum32(i32 %n32)
+ ret void
+}
+
+
+@shadestr = internal constant [10 x i8] c" .,-:!%@#\00"
+
+
+define i32 @main() {
+entry:
+ %lbound = load double, double* @lbound
+ %rbound = load double, double* @rbound
+ %tbound = load double, double* @tbound
+ %bbound = load double, double* @bbound
+ %hincr = load double, double* @hincr
+ %vincr = load double, double* @vincr
+ br label %yloop
+
+yloop:
+ %y = phi double [%tbound, %entry], [%ny, %yloop2]
+ br label %xloop
+
+xloop:
+ %x = phi double [%lbound, %yloop], [%nx, %xloop]
+ %n = call i32 @mandeliter(double %x, double %y)
+ %nL = mul i32 %n, 8
+ %maxiter = load i32, i32* @maxiter
+ %nLdM = sdiv i32 %nL, %maxiter
+ %shadechrp = getelementptr [10 x i8], [10 x i8]* @shadestr, i64 0, i32 %nLdM
+ %shadechr = load i8, i8* %shadechrp
+ %shadeint = sext i8 %shadechr to i32
+ call void @putchar(i32 %shadeint)
+ %nx = fadd double %x, %hincr
+ %xcmp = fcmp ole double %nx, %rbound
+ br i1 %xcmp, label %xloop, label %yloop2
+
+yloop2:
+ %ny = fsub double %y, %vincr
+ call void @putchar(i32 10)
+ %ycmp = fcmp oge double %ny, %bbound
+ br i1 %ycmp, label %yloop, label %return
+
+return:
+ ret i32 0
+}
diff --git a/main.hs b/main.hs
new file mode 100644
index 0000000..e1b975a
--- /dev/null
+++ b/main.hs
@@ -0,0 +1,38 @@
+module Main where
+
+import Control.Monad
+import Data.Either
+import System.Environment
+import System.Exit
+
+import Codegen
+import Parser
+import PShow
+
+
+fromLeft :: Either a b -> a
+fromLeft (Left a) = a
+fromLeft (Right _) = error "Either is not a Left"
+
+fromRight :: Either a b -> b
+fromRight (Right b) = b
+fromRight (Left _) = error "Either is not a Right"
+
+dieShow :: (Show a) => a -> IO ()
+dieShow = die . show
+
+
+main :: IO ()
+main = do
+ args <- getArgs
+ when (length args /= 1) $ die "Pass NL file name as a command-line parameter"
+
+ let fname = args !! 0
+ parseResult <- (\file -> parseProgram file fname) <$> readFile fname
+
+ when (isLeft parseResult) $ dieShow $ fromLeft parseResult
+
+ let ast = fromRight parseResult
+ pprint ast
+
+ either die print $ codegen ast "Module" fname
diff --git a/parser.hs b/parser.hs
new file mode 100644
index 0000000..7359ccf
--- /dev/null
+++ b/parser.hs
@@ -0,0 +1,252 @@
+module Parser(parseProgram) where
+
+import Control.Monad
+import Data.Char
+import Data.Functor.Identity
+import Data.Maybe
+import qualified Data.Map.Strict as Map
+import Text.Parsec
+import qualified Text.Parsec.Expr as E
+
+import AST
+
+
+type Parser = Parsec String ()
+
+
+(<<) :: (Monad m) => m a -> m b -> m a
+(<<) = (<*)
+
+
+parseProgram :: String -> String -> Either ParseError Program
+parseProgram source fname = parse pProgram fname source
+
+-- parse' :: Parser a -> String -> Either ParseError a
+-- parse' p s = parse p "" s
+
+pProgram :: Parser Program
+pProgram = pWhiteComment >> (Program <$> many1 pDeclaration)
+
+pDeclaration :: Parser Declaration
+pDeclaration = pDecTypedef <|> do
+ t <- pType
+ n <- pName
+ pDecFunction' t n <|> pDecVariable' t n
+
+pDecTypedef :: Parser Declaration
+pDecTypedef = do
+ symbol "type"
+ n <- pName
+ symbol "="
+ t <- pType
+ symbol ";"
+ return $ DecTypedef t n
+
+pDecFunction' :: Type -> Name -> Parser Declaration
+pDecFunction' t n = do
+ symbol "("
+ a <- sepBy ((,) <$> pType <*> pName) (symbol ",")
+ symbol ")"
+ b <- pBlock
+ return $ DecFunction t n a b
+
+pDecVariable' :: Type -> Name -> Parser Declaration
+pDecVariable' t n = do
+ e <- (Just <$> (symbol "=" >> pExpression)) <|> return Nothing
+ symbol ";"
+ return $ DecVariable t n e
+
+pBlock :: Parser Block
+pBlock = do
+ symbol "{"
+ s <- many pStatement
+ symbol "}"
+ return $ Block s
+
+
+exprTable :: (E.OperatorTable String () Identity) Expression
+exprTable =
+ [[prefix "-" Negate,
+ prefix "!" Not,
+ prefix "~" Invert,
+ prefix "*" Dereference,
+ prefix "&" Address],
+ [binary "*" Times E.AssocLeft,
+ binary "/" Divide E.AssocLeft,
+ binary "%" Modulo E.AssocLeft],
+ [binary "+" Plus E.AssocLeft,
+ binary "-" Minus E.AssocLeft],
+ [binary ">" Greater E.AssocNone,
+ binary "<" Less E.AssocNone,
+ binary ">=" GEqual E.AssocNone,
+ binary "<=" LEqual E.AssocNone],
+ [binary "==" Equal E.AssocNone,
+ binary "!=" Unequal E.AssocNone],
+ [binary "&&" BoolAnd E.AssocLeft,
+ binary "||" BoolOr E.AssocLeft]]
+ where
+ binary name op assoc = E.Infix (ExBinOp op <$ symbol name) assoc
+ prefix name op = E.Prefix (ExUnOp op <$ symbol name)
+
+pExpression :: Parser Expression
+pExpression = E.buildExpressionParser exprTable pExLit
+
+pExLit :: Parser Expression
+pExLit = ExLit <$> pLiteral
+
+pLiteral :: Parser Literal
+pLiteral = (LitInt <$> pInteger) <|> (LitString <$> pString)
+ <|> try pLitCall <|> (LitVar <$> pName)
+
+pLitCall :: Parser Literal
+pLitCall = do
+ n <- pName
+ symbol "("
+ a <- sepBy pExpression (symbol ",")
+ symbol ")"
+ return $ LitCall n a
+
+
+pStatement :: Parser Statement
+pStatement = pStEmpty <|> pStIf <|> pStWhile <|> pStReturn <|> pStBlock
+ <|> try pStAssignment <|> pStVarDeclaration <|> pStExpr
+
+pStEmpty :: Parser Statement
+pStEmpty = symbol ";" >> return StEmpty
+
+pStBlock :: Parser Statement
+pStBlock = StBlock <$> pBlock
+
+pStVarDeclaration :: Parser Statement
+pStVarDeclaration = do
+ t <- pType
+ n <- pName
+ e <- optionMaybe (symbol "=" >> pExpression)
+ symbol ";"
+ return $ StVarDeclaration t n e
+
+pStExpr :: Parser Statement
+pStExpr = (StExpr <$> pExpression) << symbol ";"
+
+pStAssignment :: Parser Statement
+pStAssignment = do
+ n <- pName
+ symbol "="
+ e <- pExpression
+ symbol ";"
+ return $ StAssignment n e
+
+pStIf :: Parser Statement
+pStIf = do
+ symbol "if"
+ symbol "("
+ c <- pExpression
+ symbol ")"
+ t <- pStatement
+ e <- (symbol "else" >> pStatement) <|> return StEmpty
+ return $ StIf c t e
+
+pStWhile :: Parser Statement
+pStWhile = do
+ symbol "while"
+ symbol "("
+ c <- pExpression
+ symbol ")"
+ b <- pStatement
+ return $ StWhile c b
+
+pStReturn :: Parser Statement
+pStReturn = do
+ symbol "return"
+ e <- pExpression
+ symbol ";"
+ return $ StReturn e
+
+
+primitiveTypes :: Map.Map String Type
+primitiveTypes = Map.fromList
+ [("i8", TypeInt 8), ("i16", TypeInt 16), ("i32", TypeInt 32), ("i64", TypeInt 64),
+ ("u8", TypeUInt 8), ("u16", TypeUInt 16), ("u32", TypeUInt 32), ("u64", TypeUInt 64),
+ ("float", TypeFloat), ("double", TypeDouble)]
+
+findPrimType :: String -> Type
+findPrimType s = fromJust $ Map.lookup s primitiveTypes
+
+pType :: Parser Type
+pType = pPrimType <|> pPtrType <|> pTypeName
+
+pPrimType :: Parser Type
+pPrimType = findPrimType <$> choice (map symbol' $ Map.keys primitiveTypes)
+
+pPtrType :: Parser Type
+pPtrType = do
+ symbol "ptr"
+ symbol "("
+ t <- pType
+ symbol ")"
+ return $ TypePtr t
+
+pTypeName :: Parser Type
+pTypeName = TypeName <$> pName
+
+
+pName :: Parser Name
+pName = ((:) <$> pFirstChar <*> many pOtherChar) << pWhiteComment
+ where pFirstChar = satisfy (isLower .||. (=='_'))
+ pOtherChar = satisfy (isLower .||. isDigit .||. (=='_'))
+
+pInteger :: Parser Integer
+pInteger = (read <$> many1 (satisfy isDigit)) << pWhiteComment
+
+pString :: Parser String
+pString = do
+ void $ char '"'
+ s <- many (pEscape <|> anyChar)
+ symbol "\""
+ return s
+ where
+ pEscape :: Parser Char
+ pEscape = char '\\' >> (pEscapeN <|> pEscapeR <|> pEscapeT <|> pEscapeHex)
+
+ pEscapeN, pEscapeR, pEscapeT :: Parser Char
+ pEscapeN = '\n' <$ char 'n'
+ pEscapeR = '\r' <$ char 'r'
+ pEscapeT = '\t' <$ char 't'
+
+ pEscapeHex :: Parser Char
+ pEscapeHex = do
+ void $ char 'x'
+ c1 <- pHexChar
+ c2 <- pHexChar
+ return $ chr $ 16 * c1 + c2
+
+ pHexChar :: Parser Int
+ pHexChar = (liftM (\c -> ord c - ord '0') (satisfy isDigit))
+ <|> (liftM (\c -> ord c - ord 'a' + 10) (oneOf "abcdef"))
+ <|> (liftM (\c -> ord c - ord 'A' + 10) (oneOf "ABCDEF"))
+
+symbol :: String -> Parser ()
+symbol s = try (string s) >> pWhiteComment
+
+symbol' :: String -> Parser String
+symbol' s = try (string s) << pWhiteComment
+
+pWhiteComment :: Parser ()
+pWhiteComment = sepBy pWhitespace pComment >> return ()
+
+pWhitespace :: Parser ()
+pWhitespace = many (oneOf " \t\n") >> return ()
+
+pComment :: Parser ()
+pComment = pLineComment <|> pBlockComment
+
+pLineComment :: Parser ()
+pLineComment = try (string "//") >> manyTill anyChar (char '\n') >> return ()
+
+pBlockComment :: Parser ()
+pBlockComment = try (string "/*") >> manyTill anyChar (try (string "*/")) >> return ()
+
+
+infixr 2 .||.
+(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+f .||. g = \x -> f x || g x
diff --git a/pshow.hs b/pshow.hs
new file mode 100644
index 0000000..64fbab1
--- /dev/null
+++ b/pshow.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+module PShow(PShow(..), pprint) where
+
+
+class PShow a where
+ pshow :: a -> String
+
+
+pprint :: (PShow a) => a -> IO ()
+pprint = putStrLn . pshow
+
+
+instance PShow String where {pshow = show}
+instance PShow Int where {pshow = show}
+instance PShow Integer where {pshow = show}
+
+instance (PShow a, PShow b) => PShow (a, b) where
+ pshow (a, b) = "(" ++ pshow a ++ "," ++ pshow b ++ ")"
diff --git a/test.nl b/test.nl
new file mode 100644
index 0000000..99786fc
--- /dev/null
+++ b/test.nl
@@ -0,0 +1,18 @@
+type int = i32;
+type char = i8;
+
+int glob = 10;
+
+int main(int argc, ptr(char) argv) {
+ int kaas = glob + 2;
+ glob = 2 > 1 || 1 == 1 % 10;
+ while (glob < 20) {
+ if (kaas == 12) glob = glob + 3 / 2;
+ else glob = glob - 1;
+ if (glob < -10) return glob;
+ if (glob < -12) {
+ return glob;
+ } else {}
+ }
+ return kaas;
+}