summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ast.hs4
-rw-r--r--check.hs13
-rw-r--r--codegen.hs53
-rw-r--r--parser.hs41
-rw-r--r--test_string.nl9
5 files changed, 93 insertions, 27 deletions
diff --git a/ast.hs b/ast.hs
index f566335..8cecab6 100644
--- a/ast.hs
+++ b/ast.hs
@@ -20,6 +20,8 @@ data Declaration
,valueOf :: Maybe Expression}
| DecTypedef {typeOf :: Type
,nameOf :: Name}
+ | DecExtern {typeOf :: Type
+ ,nameOf :: Name}
deriving (Show)
data Block = Block [Statement]
@@ -102,6 +104,8 @@ instance PShow Declaration where
concat [pshow t, " ", n, " = ", pshow e, ";"]
pshow (DecTypedef t n) =
concat ["type ", n, " = ", pshow t, ";"]
+ pshow (DecExtern t n) =
+ concat ["extern ", pshow t, " ", n, ";"]
instance PShow Block where
pshow (Block []) = "{}"
diff --git a/check.hs b/check.hs
index a29f18b..b6a660b 100644
--- a/check.hs
+++ b/check.hs
@@ -64,13 +64,16 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls
functionTypes :: Map.Map Name (Type,[Type])
functionTypes = foldr (uncurry Map.insert) Map.empty pairs
where pairs = map ((,) <$> nameOf <*> getTypes) $ filter isFunctionDecl decls
+
getTypes (DecFunction rt _ args _) = (rt, map fst args)
+ getTypes (DecExtern (TypeFunc rt ats) _) = (rt, ats)
getTypes _ = undefined
isVarDecl (DecVariable {}) = True
isVarDecl _ = False
isFunctionDecl (DecFunction {}) = True
+ isFunctionDecl (DecExtern (TypeFunc {}) _) = True
isFunctionDecl _ = False
goD :: Map.Map Name Type -> Declaration -> Error Declaration
@@ -150,7 +153,7 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls
\(a,i) -> let argtype = fromJust (exTypeOf a)
in if canConvert argtype (snd ft !! i)
then return a
- else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (fst ft)
+ else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (snd ft !! i)
++ "' in call of function '" ++ pshow n ++ "'"
return $ ExLit (LitCall n rargs) (Just (fst ft))
goE names (ExBinOp bo e1 e2 _) = do
@@ -324,10 +327,18 @@ mapProgram prog mapper = goP prog
rt <- goT t
rn <- goN n
h_d $ DecTypedef rt rn
+ goD (DecExtern t n) = do
+ rt <- goT t
+ rn <- goN n
+ h_d $ DecExtern rt rn
goT :: MapperHandler Type
goT (TypePtr t) = goT t >>= (h_t . TypePtr)
goT (TypeName n) = goN n >>= (h_t . TypeName)
+ goT (TypeFunc t as) = do
+ rt <- goT t
+ ras <- mapM goT as
+ h_t $ TypeFunc rt ras
goT t = h_t t
goN :: MapperHandler Name
diff --git a/codegen.hs b/codegen.hs
index 1df87b4..b7af7a1 100644
--- a/codegen.hs
+++ b/codegen.hs
@@ -210,7 +210,25 @@ genGlobalVars (Program decs) = liftM (mapMaybe id) $ mapM gen decs
gen (DecFunction rt n a _) = do
setGlobalFunction n n (TypeFunc rt (map fst a))
return Nothing
- gen _ = return Nothing
+ gen (DecExtern t@(TypeFunc rt ats) n) = do
+ setGlobalFunction n n t
+ argnames <- sequence $ replicate (length ats) (getNewName "arg")
+ return $ Just $ A.GlobalDefinition $
+ A.functionDefaults {
+ A.G.returnType = toLLVMType rt,
+ A.G.name = A.Name n,
+ A.G.parameters = ([A.Parameter (toLLVMType at) (A.Name an) [] | (at,an) <- zip ats argnames], False),
+ A.G.basicBlocks = []
+ }
+ gen (DecExtern t n) = do
+ setGlobalVar n n t
+ return $ Just $ A.GlobalDefinition $
+ A.globalVariableDefaults {
+ A.G.name = A.Name n,
+ A.G.type' = toLLVMType t,
+ A.G.initializer = Nothing
+ }
+ gen (DecTypedef _ _) = return Nothing
genStringLiterals :: CGMonad [A.Definition]
genStringLiterals = liftM stringLiterals get >>= return . map gen
@@ -229,27 +247,44 @@ genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs
gen :: Declaration -> CGMonad (Maybe A.Definition)
gen dec@(DecFunction rettype name args body) = do
setCurrentFunction dec
- firstbb <- genBlock' body
+ state $ \s -> ((), s {
+ allBlocks = Map.empty,
+ variables = Map.empty
+ })
+ firstbb <- genFunctionBlock body args
cleanupTrampolines
blockmap <- liftM allBlocks get
let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap
bbs = fromJust (Map.lookup firstbb blockmap) : bbs'
- state $ \s -> ((), s {allBlocks = Map.empty})
return $ Just $ A.GlobalDefinition $ A.functionDefaults {
A.G.returnType = toLLVMType rettype,
A.G.name = A.Name name,
- A.G.parameters = ([A.Parameter (toLLVMType t) (A.Name n) [] | (t,n) <- args], False),
+ A.G.parameters = ([A.Parameter (toLLVMType t) (A.Name ("farg_"++n)) [] | (t,n) <- args], False),
A.G.basicBlocks = bbs
}
gen _ = return Nothing
-genBlock' :: Block -> CGMonad LLName
-genBlock' bl = do
+genFunctionBlock :: Block -> [(Type,Name)] -> CGMonad LLName
+genFunctionBlock bl args = do
+ firstbb <- newBlock
+ let prepArg :: (Type,Name) -> CGMonad ()
+ prepArg (t,n) = do
+ label <- addInstr $ A.Alloca (toLLVMType t) Nothing 0 []
+ void $ addInstr $ A.Store False (A.LocalReference (A.ptr (toLLVMType t)) (A.Name label))
+ (A.LocalReference (toLLVMType t) (A.Name ("farg_"++n)))
+ Nothing 0 []
+ setVar n label t
+ sequence_ $ map prepArg args
+
termbb <- newBlock
setTerminator $ A.Unreachable []
- genBlock bl termbb
+
+ bodybb <- genBlock bl termbb
+ changeBlock firstbb
+ setTerminator $ A.Br (A.Name bodybb) []
+ return firstbb
genBlock :: Block
-> LLName -- name of BasicBlock following this Block
@@ -378,8 +413,8 @@ genExpression (ExBinOp bo e1 e2 (Just t)) = do
return $ A.LocalReference (toLLVMType t) (A.Name label)
Equal -> do
sharedType <- commonTypeM (fromJust (exTypeOf e1)) (fromJust (exTypeOf e2))
- trace ("Shared type for Equal of " ++ pshow e1 ++ " and " ++ pshow e2 ++ " is: " ++ pshow sharedType)
- $ return ()
+ -- trace ("Shared type for Equal of " ++ pshow e1 ++ " and " ++ pshow e2 ++ " is: " ++ pshow sharedType)
+ -- $ return ()
e1op' <- castOperand e1op sharedType
e2op' <- castOperand e2op sharedType
label <- case sharedType of
diff --git a/parser.hs b/parser.hs
index 615f6e7..81cbbd3 100644
--- a/parser.hs
+++ b/parser.hs
@@ -28,7 +28,7 @@ pProgram :: Parser Program
pProgram = pWhiteComment >> (Program <$> many1 pDeclaration)
pDeclaration :: Parser Declaration
-pDeclaration = pDecTypedef <|> do
+pDeclaration = pDecTypedef <|> pDecExtern <|> do
t <- pTypeVoid <|> pType
n <- pName
if t == TypeVoid
@@ -44,6 +44,14 @@ pDecTypedef = do
symbol ";"
return $ DecTypedef t n
+pDecExtern :: Parser Declaration
+pDecExtern = do
+ symbol "extern"
+ t <- pType
+ n <- pName
+ symbol ";"
+ return $ DecExtern t n
+
pDecFunction' :: Type -> Name -> Parser Declaration
pDecFunction' t n = do
symbol "("
@@ -97,7 +105,7 @@ pExLit :: Parser Expression
pExLit = exLit_ <$> pLiteral
pLiteral :: Parser Literal
-pLiteral = (LitInt <$> pInteger) <|> (LitString <$> pString)
+pLiteral = (LitInt <$> pInteger) <|> (LitInt <$> pCharStr) <|> (LitString <$> pString)
<|> try pLitCall <|> (LitVar <$> pName)
pLitCall :: Parser Literal
@@ -224,23 +232,30 @@ pString = do
s <- many (pEscape <|> satisfy (/='"'))
symbol "\""
return s
- where
- pEscape :: Parser Char
- pEscape = char '\\' >> (pEscapeQuote <|> pEscapeN <|> pEscapeR <|> pEscapeT <|> pEscapeHex)
+pCharStr :: Parser Integer
+pCharStr = do
+ void $ char '\''
+ c <- pEscape <|> satisfy (/='\'')
+ symbol "'"
+ return $ fromIntegral (ord c)
+
+pEscape :: Parser Char
+pEscape = char '\\' >> (pEscapeQuote <|> pEscapeN <|> pEscapeR <|> pEscapeT <|> pEscapeHex)
+ where
pEscapeQuote, pEscapeN, pEscapeR, pEscapeT :: Parser Char
- pEscapeQuote = '"' <$ char '"'
+ pEscapeQuote = ('"' <$ char '"') <|> ('\'' <$ 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
-
+pEscapeHex :: Parser Char
+pEscapeHex = do
+ void $ char 'x'
+ c1 <- pHexChar
+ c2 <- pHexChar
+ return $ chr $ 16 * c1 + c2
+ where
pHexChar :: Parser Int
pHexChar = (liftM (\c -> ord c - ord '0') (satisfy isDigit))
<|> (liftM (\c -> ord c - ord 'a' + 10) (oneOf "abcdef"))
diff --git a/test_string.nl b/test_string.nl
index 37841a7..ccba9a1 100644
--- a/test_string.nl
+++ b/test_string.nl
@@ -2,15 +2,16 @@ type int = i32;
type char = i8;
type string = ptr(char);
-void func(string s) {
- int i = 1;
+extern func void(int) putchar;
+
+void f(char c) {
+ putchar(c);
return;
}
int main(int argc, ptr(string) argv) {
string s = "kaas";
ptr(i8) s2 = "kaas2";
- //func void(string) the_func = func;
- func(s);
+ f('x');
return 0;
}