Calling external functions!

- Call extern-declared functions
- Parse 'c'har literals
- Correctly make function arguments into local variables
- Fix error message in check.hs (new line 153)

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;
 }