diff options
| -rw-r--r-- | .gitignore | 7 | ||||
| -rw-r--r-- | Makefile | 18 | ||||
| -rw-r--r-- | ast.hs | 148 | ||||
| -rw-r--r-- | codegen.hs | 238 | ||||
| -rw-r--r-- | ll/Makefile | 16 | ||||
| -rw-r--r-- | ll/ding.c | 30 | ||||
| -rw-r--r-- | ll/gen.hs | 57 | ||||
| -rw-r--r-- | ll/test.ll | 104 | ||||
| -rw-r--r-- | main.hs | 38 | ||||
| -rw-r--r-- | parser.hs | 252 | ||||
| -rw-r--r-- | pshow.hs | 18 | ||||
| -rw-r--r-- | test.nl | 18 |
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 $@ @@ -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 +} @@ -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 ++ ")" @@ -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; +} |