Permalink
Browse files

Compile foreign calls

  • Loading branch information...
1 parent 168706f commit 3812df83c9b12ba8fb4acd8b7243de700ea80d7f Edwin Brady committed Sep 3, 2012
Showing with 43 additions and 16 deletions.
  1. +5 −1 iif/testvm.iif
  2. +5 −3 src/IRTS/CodegenC.hs
  3. +29 −12 src/IRTS/LParser.hs
  4. +4 −0 src/IRTS/Simplified.hs
View
@@ -23,6 +23,10 @@ fun intToNat(x) = case x of {
| _ => S (intToNat (x - 1))
}
+fun sin(x) = foreign C Float "sin" (Float x)
+
fun main() = let val = natToInt(plus(intToNat(fact(6)), S(S(O)))) in
- %WriteString("Answer: " ++ %IntString(val))
+ let sval = sin(1.0) in
+ %WriteString("Answer: " ++ %IntString(val)
+ ++ " " ++ %FloatString(sval))
View
@@ -26,7 +26,8 @@ codegenC :: [(Name, LDecl)] ->
DbgLevel ->
IO ()
codegenC defs out exec incs libs dbg
- = do let tagged = addTags defs
+ = do -- print defs
+ let tagged = addTags defs
let ctxtIn = addAlist tagged emptyContext
let checked = checkDefs ctxtIn tagged
case checked of
@@ -47,6 +48,7 @@ codegenC defs out exec incs libs dbg
" " ++ tmpn ++
" `idris --link` `idris --include` " ++ libs ++
" -lidris_rts -o " ++ out
+-- putStrLn cout
exit <- system gcc
when (exit /= ExitSuccess) $
putStrLn ("FAILURE: " ++ gcc)
@@ -56,7 +58,7 @@ codegenC defs out exec incs libs dbg
headers [] = "#include <idris_rts.h>\n\n"
headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs
-debug DEBUG = "#define IDRIS_DEBUG\n\n"
+debug TRACE = "#define IDRIS_DEBUG\n\n"
debug _ = ""
gccDbg DEBUG = "-g"
@@ -136,7 +138,7 @@ bcc i (OP l fn args) = indent i ++ creg l ++ " = " ++ doOp fn args ++ ";\n"
bcc i (FOREIGNCALL l LANG_C rty fn args)
= indent i ++ creg l ++ " = " ++
c_irts rty (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
- where fcall (t, arg) = irts_c t (creg l)
+ where fcall (t, arg) = irts_c t (creg arg)
-- bcc i _ = indent i ++ "// not done yet\n"
c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"
View
@@ -46,7 +46,7 @@ lchar = lexeme.char
fovm :: FilePath -> IO ()
fovm f = do defs <- parseFOVM f
- codegenC defs "a.out" True [] "" DEBUG
+ codegenC defs "a.out" True ["math.h"] "" TRACE
parseFOVM :: FilePath -> IO [(Name, LDecl)]
parseFOVM fname = do -- putStrLn $ "Reading " ++ fname
@@ -144,20 +144,37 @@ pCase = do reserved "case"; e <- pLExp; reserved "of"
return (LCase e alts)
pCast :: LParser LExp
-pCast = do reserved "FloatString"; e <- pLExp; return (LOp LFloatStr [e])
- <|> do reserved "StringFloat"; e <- pLExp; return (LOp LStrFloat [e])
- <|> do reserved "FloatInt"; e <- pLExp; return (LOp LFloatInt [e])
- <|> do reserved "IntFloat"; e <- pLExp; return (LOp LIntFloat [e])
- <|> do reserved "StringInt"; e <- pLExp; return (LOp LStrInt [e])
- <|> do reserved "IntString"; e <- pLExp; return (LOp LIntStr [e])
+pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
+ return (LOp LFloatStr [e])
+ <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'
+ return (LOp LStrFloat [e])
+ <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'
+ return (LOp LFloatInt [e])
+ <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'
+ return (LOp LIntFloat [e])
+ <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'
+ return (LOp LStrInt [e])
+ <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
+ return (LOp LIntStr [e])
pPrim :: LParser LExp
-pPrim = do reserved "StrEq"; e <- pLExp; e' <- pLExp; return (LOp LStrEq [e, e'])
- <|> do reserved "StrLt"; e <- pLExp; e' <- pLExp; return (LOp LStrLt [e, e'])
- <|> do reserved "StrLen"; e <- pLExp; return (LOp LStrLen [e])
+pPrim = do reserved "StrEq"; lchar '(';
+ e <- pLExp; lchar ',';
+ e' <- pLExp; lchar ')';
+ return (LOp LStrEq [e, e'])
+ <|> do reserved "StrLt"; lchar '('
+ e <- pLExp; lchar ','; e' <- pLExp;
+ lchar ')'
+ return (LOp LStrLt [e, e'])
+ <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';
+ return (LOp LStrLen [e])
<|> do reserved "ReadString"; return (LOp LReadStr [])
- <|> do reserved "WriteString"; e <- pLExp; return (LOp LPrintStr [e])
- <|> do reserved "WriteInt"; e <- pLExp; return (LOp LPrintNum [e])
+ <|> do reserved "WriteString"; lchar '(';
+ e <- pLExp; lchar ')'
+ return (LOp LPrintStr [e])
+ <|> do reserved "WriteInt"; lchar '(';
+ e <- pLExp; lchar ')';
+ return (LOp LPrintNum [e])
pAlt :: LParser LAlt
pAlt = try (do x <- iName []
View
@@ -130,6 +130,10 @@ scopecheck ctxt env tm = sc env tm where
" has arity " ++ show ar
[_] -> return $ SApp tc f args'
[] -> fail $ "Codegen error: No such variable " ++ show f
+ sc env (SForeign l ty f args)
+ = do args' <- mapM (\ (t, a) -> do a' <- scVar env a
+ return (t, a')) args
+ return $ SForeign l ty f args'
sc env (SCon tag f args)
= do args' <- mapM (scVar env) args
case lookupCtxt Nothing f ctxt of

0 comments on commit 3812df8

Please sign in to comment.