module Language.Scheme.Compiler where
import qualified Language.Scheme.Macro
import Language.Scheme.Numerical
import Language.Scheme.Parser
import Language.Scheme.Primitives
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Error
import qualified Data.Array
import Data.Complex
import qualified Data.List
import Data.Ratio
import System.IO
import Debug.Trace
data CompOpts = CompileOptions {
coptsThisFunc :: String,
coptsThisFuncUseValue :: Bool,
coptsThisFuncUseArgs :: Bool,
coptsNextFunc :: Maybe String
}
defaultCompileOptions :: String -> CompOpts
defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing
createAstFunc :: CompOpts -> [HaskAST] -> HaskAST
createAstFunc (CompileOptions thisFunc useVal useArgs _) body = do
let val = case useVal of
True -> "value"
_ -> "_"
args = case useArgs of
True -> "(Just args)"
_ -> "_"
AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") body
createAstCont :: CompOpts -> String -> String -> HaskAST
createAstCont (CompileOptions _ _ _ (Just nextFunc)) var indentation = do
AstValue $ indentation ++ " continueEval env (makeCPS env cont " ++ nextFunc ++ ") " ++ var
createAstCont (CompileOptions _ _ _ Nothing) var indentation = do
AstValue $ indentation ++ " continueEval env cont " ++ var
data HaskAST = AstAssignM String HaskAST
| AstFunction {astfName :: String,
astfArgs :: String,
astfCode :: [HaskAST]
}
| AstValue String
| AstContinuation {astcNext :: String,
astcArgs :: String
}
showValAST :: HaskAST -> String
showValAST (AstAssignM var val) = " " ++ var ++ " <- " ++ show val
showValAST (AstFunction name args code) = do
let header = "\n" ++ name ++ args ++ " = do "
let body = unwords . map (\x -> "\n" ++ x ) $ map showValAST code
header ++ body
showValAST (AstValue v) = v
showValAST (AstContinuation nextFunc args) = " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " " ++ args ++ ") $ Nil \"\""
instance Show HaskAST where show = showValAST
joinL ls sep = concat $ Data.List.intersperse sep ls
astToHaskellStr :: LispVal -> String
astToHaskellStr (String s) = "String " ++ show s
astToHaskellStr (Char c) = "Char " ++ show c
astToHaskellStr (Atom a) = "Atom " ++ show a
astToHaskellStr (Number n) = "Number (" ++ show n ++ ")"
astToHaskellStr (Complex c) = "Complex $ (" ++ (show $ realPart c) ++ ") :+ (" ++ (show $ imagPart c) ++ ")"
astToHaskellStr (Rational r) = "Rational $ (" ++ (show $ numerator r) ++ ") % (" ++ (show $ denominator r) ++ ")"
astToHaskellStr (Float f) = "Float (" ++ show f ++ ")"
astToHaskellStr (Bool True) = "Bool True"
astToHaskellStr (Bool False) = "Bool False"
astToHaskellStr (Vector v) = do
let ls = Data.Array.elems v
size = (length ls) 1
"Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map astToHaskellStr ls) "," ++ "])"
astToHaskellStr (List ls) = "List [" ++ joinL (map astToHaskellStr ls) "," ++ "]"
astToHaskellStr (DottedList ls l) =
"DottedList [" ++ joinL (map astToHaskellStr ls) "," ++ "] $ " ++ astToHaskellStr l
header :: [String]
header = [
"module Main where "
, "import Language.Scheme.Core "
, "import Language.Scheme.Numerical "
, "import Language.Scheme.Primitives "
, "import Language.Scheme.Types -- Scheme data types "
, "import Language.Scheme.Variables -- Scheme variable operations "
, "import Control.Monad.Error "
, "import Data.Array "
, "import Data.Complex "
, "import Data.Ratio "
, "import System.IO "
, " "
, ""
, "--makeNormalFunc :: Env -> [LispVal] -> String -> IOThrowsError LispVal "
, "makeHFunc ::"
, " (Monad m) =>"
, " Maybe String "
, " -> Env "
, " -> [String] "
, " -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) "
, "-- -> String "
, " -> m LispVal"
, "makeHFunc varargs env fparams fbody = return $ HFunc fparams varargs fbody env --(map showVal fparams) varargs fbody env"
, "makeNormalHFunc :: (Monad m) =>"
, " Env"
, " -> [String]"
, " -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)"
, " -> m LispVal"
, "makeNormalHFunc = makeHFunc Nothing"
, "makeHVarargs :: (Monad m) => LispVal "
, " -> Env"
, " -> [String]"
, " -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)"
, " -> m LispVal"
, "makeHVarargs = makeHFunc . Just . showVal"
, "main :: IO () "
, "main = do "
, " env <- primitiveBindings "
, " (runIOThrows $ liftM show $ run env (makeNullContinuation env) (Nil \"\") Nothing) >>= putStr "
, " "]
compileLisp :: Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp env filename entryPoint exitPoint = load filename >>= compileBlock entryPoint exitPoint env []
compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST]
compileBlock symThisFunc symLastFunc env result code@[c] = do
compiled <- mcompile env c $ CompileOptions symThisFunc False False symLastFunc
return $ result ++ compiled
compileBlock symThisFunc symLastFunc env result code@(c:cs) = do
Atom symNextFunc <- _gensym "f"
compiled <- mcompile env c $ CompileOptions symThisFunc False False (Just symNextFunc)
compileBlock symNextFunc symLastFunc env (result ++ compiled) cs
compileBlock _ _ _ result [] = return result
compileScalar :: String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar val copts = do
f <- return $ AstAssignM "x1" $ AstValue val
c <- return $ createAstCont copts "x1" ""
return [createAstFunc copts [f, c]]
compileLambdaList :: [LispVal] -> IOThrowsError String
compileLambdaList l = do
serialized <- mapM serialize l
return $ "[" ++ concat (Data.List.intersperse "," serialized) ++ "]"
where serialize (Atom a) = return $ (show a)
compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile _ (Nil n) copts = compileScalar (" return $ Nil " ++ (show n)) copts
compile _ (String s) copts = compileScalar (" return $ String " ++ (show s)) copts
compile _ (Char c) copts = compileScalar (" return $ Char " ++ (show c)) copts
compile _ (Complex c) copts = compileScalar (" return $ Complex $ (" ++ (show $ realPart c) ++ ") :+ (" ++ (show $ imagPart c) ++ ")") copts
compile _ (Float f) copts = compileScalar (" return $ Float (" ++ (show f) ++ ")") copts
compile _ (Rational r) copts = compileScalar (" return $ Rational $ (" ++ (show $ numerator r) ++ ") % (" ++ (show $ denominator r) ++ ")") copts
compile _ (Number n) copts = compileScalar (" return $ Number (" ++ (show n) ++ ")") copts
compile _ (Bool b) copts = compileScalar (" return $ Bool " ++ (show b)) copts
compile _ v@(Vector _) copts = compileScalar (" return $ " ++ astToHaskellStr v) copts
compile _ (Atom a) copts = compileScalar (" getVar env \"" ++ a ++ "\"") copts
compile _ (List [Atom "quote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts
compile _ (List [Atom "quasiquote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts
compile env args@(List (Atom "let-syntax" : List _bindings : _body)) copts = do
bodyEnv <- liftIO $ extendEnv env []
_ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False _bindings
expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body
case expanded of
List e -> compile bodyEnv (List $ Atom "begin" : e) copts
e -> compile bodyEnv e copts
compile env args@(List (Atom "letrec-syntax" : List _bindings : _body)) copts = do
bodyEnv <- liftIO $ extendEnv env []
_ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False _bindings
expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body
case expanded of
List e -> compile bodyEnv (List $ Atom "begin" : e) copts
e -> compile bodyEnv e copts
compile env args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) copts = do
_ <- defineNamespacedVar env macroNamespace keyword $ Syntax (Just env) Nothing False identifiers rules
compileScalar (" return $ Nil \"\"") copts
compile env args@(List [Atom "if", predic, conseq]) copts =
compile env (List [Atom "if", predic, conseq, Nil ""]) copts
compile env args@(List [Atom "if", predic, conseq, alt]) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symPredicate <- _gensym "ifPredic"
Atom symCheckPredicate <- _gensym "compiledIfPredicate"
Atom symConsequence <- _gensym "compiledConsequence"
Atom symAlternate <- _gensym "compiledAlternative"
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"if\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do " ++ symPredicate ++ " env (makeCPS env cont " ++ symCheckPredicate ++ ") (Nil \"\") [] "
]
compPredicate <- compileExpr env predic symPredicate Nothing
compConsequence <- compileExpr env conseq symConsequence nextFunc
compAlternate <- compileExpr env alt symAlternate nextFunc
compCheckPredicate <- return $ AstFunction symCheckPredicate " env cont result _ " [
AstValue $ " case result of ",
AstValue $ " Bool False -> " ++ symAlternate ++ " env cont (Nil \"\") [] ",
AstValue $ " _ -> " ++ symConsequence ++ " env cont (Nil \"\") [] "]
return $ [createAstFunc copts f] ++ compPredicate ++ [compCheckPredicate] ++ compConsequence ++ compAlternate
compile env args@(List [Atom "set!", Atom var, form]) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symDefine <- _gensym "setFunc"
Atom symMakeDefine <- _gensym "setFuncMakeSet"
_ <- defineVar env var form
entryPt <- compileSpecialFormEntryPoint "set!" symDefine copts
compDefine <- compileExpr env form symDefine $ Just symMakeDefine
compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [
AstValue $ " _ <- setVar env \"" ++ var ++ "\" result",
createAstCont copts "result" ""]
return $ [entryPt] ++ compDefine ++ [compMakeDefine]
compile env (List [Atom "set!", nonvar, _]) copts = do
f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\" $ String \"" ++ (show nonvar) ++ "\"") copts
return [f]
compile env (List (Atom "set!" : args)) copts = do
f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts
return [f]
compile env args@(List [Atom "define", Atom var, form]) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symDefine <- _gensym "defineFuncDefine"
Atom symMakeDefine <- _gensym "defineFuncMakeDef"
_ <- defineVar env var form
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do " ++ symDefine ++ " env cont (Nil \"\") []" ]
compDefine <- compileExpr env form symDefine $ Just symMakeDefine
compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [
AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result",
createAstCont copts "result" ""]
return $ [createAstFunc copts f] ++ compDefine ++ [compMakeDefine]
compile env args@(List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symCallfunc <- _gensym "defineFuncEntryPt"
compiledParams <- compileLambdaList fparams
compiledBody <- compileBlock symCallfunc Nothing env [] fbody
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do result <- makeNormalHFunc env (" ++ compiledParams ++ ") " ++ symCallfunc,
AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ",
createAstCont copts "result" " "
]
return $ [createAstFunc copts f] ++ compiledBody
compile env args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symCallfunc <- _gensym "defineFuncEntryPt"
compiledParams <- compileLambdaList fparams
compiledBody <- compileBlock symCallfunc Nothing env [] fbody
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do result <- makeHVarargs (" ++ astToHaskellStr varargs ++ ") env (" ++ compiledParams ++ ") " ++ symCallfunc,
AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ",
createAstCont copts "result" " "
]
return $ [createAstFunc copts f] ++ compiledBody
compile env args@(List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symCallfunc <- _gensym "lambdaFuncEntryPt"
compiledParams <- compileLambdaList fparams
compiledBody <- compileBlock symCallfunc Nothing env [] fbody
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"lambda\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do result <- makeNormalHFunc env (" ++ compiledParams ++ ") " ++ symCallfunc,
createAstCont copts "result" " "
]
return $ [createAstFunc copts f] ++ compiledBody
compile env args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symCallfunc <- _gensym "lambdaFuncEntryPt"
compiledParams <- compileLambdaList fparams
compiledBody <- compileBlock symCallfunc Nothing env [] fbody
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"lambda\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do result <- makeHVarargs (" ++ astToHaskellStr varargs ++ ") env (" ++ compiledParams ++ ") " ++ symCallfunc,
createAstCont copts "result" " "
]
return $ [createAstFunc copts f] ++ compiledBody
compile env args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do
Atom symCallfunc <- _gensym "lambdaFuncEntryPt"
compiledBody <- compileBlock symCallfunc Nothing env [] fbody
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"lambda\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else do result <- makeHVarargs (" ++ astToHaskellStr varargs ++ ") env [] " ++ symCallfunc,
createAstCont copts "result" " "
]
return $ [createAstFunc copts f] ++ compiledBody
compile env args@(List [Atom "string-set!", Atom var, i, character]) copts = do
Atom symDefine <- _gensym "stringSetFunc"
Atom symMakeDefine <- _gensym "stringSetFuncMakeSet"
entryPt <- compileSpecialFormEntryPoint "string-set!" symDefine copts
compDefine <- compileExpr env i symDefine $ Just symMakeDefine
compMakeDefine <- return $ AstFunction symMakeDefine " env cont idx _ " [
AstValue $ " tmp <- getVar env \"" ++ var ++ "\"",
AstValue $ " result <- substr (tmp, (" ++ astToHaskellStr(character) ++ "), idx)",
AstValue $ " _ <- setVar env \"" ++ var ++ "\" result",
createAstCont copts "result" ""]
return $ [entryPt] ++ compDefine ++ [compMakeDefine]
compile env args@(List [Atom "set-car!", Atom var, argObj]) copts = do
Atom symGetVar <- _gensym "setCarGetVar"
Atom symCompiledObj <- _gensym "setCarCompiledObj"
Atom symObj <- _gensym "setCarObj"
Atom symDoSet <- _gensym "setCarDoSet"
let finalContinuation = case copts of
(CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPS e c " ++ nextFunc ++ ")\n"
_ -> "continueEval e c\n"
entryPt <- compileSpecialFormEntryPoint "set-car!" symGetVar copts
compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [
AstValue $ " result <- getVar env \"" ++ var ++ "\"",
AstValue $ " " ++ symObj ++ " env cont result Nothing "]
compiledObj <- compileExpr env argObj symCompiledObj Nothing
compObj <- return $ AstValue $ "" ++
symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" ++
symObj ++ " e c obj@(List (_ : _)) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
symObj ++ " e c obj@(DottedList _ _) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
symObj ++ " _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"
compDoSet <- return $ AstValue $ "" ++
symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
symDoSet ++ " e c obj (Just [List (_ : ls)]) = setVar e \"" ++ var ++ "\" (List (obj : ls)) >>= " ++ finalContinuation ++
symDoSet ++ " e c obj (Just [DottedList (_ : ls) l]) = setVar e \"" ++ var ++ "\" (DottedList (obj : ls) l) >>= " ++ finalContinuation ++
symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"
return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj
compile env args@(List [Atom "set-cdr!", Atom var, argObj]) copts = do
Atom symGetVar <- _gensym "setCdrGetVar"
Atom symCompiledObj <- _gensym "setCdrCompiledObj"
Atom symObj <- _gensym "setCdrObj"
Atom symDoSet <- _gensym "setCdrDoSet"
let finalContinuation = case copts of
(CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPS e c " ++ nextFunc ++ ")\n"
_ -> "continueEval e c\n"
entryPt <- compileSpecialFormEntryPoint "set-car!" symGetVar copts
compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [
AstValue $ " result <- getVar env \"" ++ var ++ "\"",
AstValue $ " " ++ symObj ++ " env cont result Nothing "]
compiledObj <- compileExpr env argObj symCompiledObj Nothing
compObj <- return $ AstValue $ "" ++
symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" ++
symObj ++ " e c obj@(List (_ : _)) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
symObj ++ " e c obj@(DottedList _ _) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
symObj ++ " _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"
compDoSet <- return $ AstValue $ "" ++
symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
symDoSet ++ " e c obj (Just [List (l : _)]) = setVar e \"" ++ var ++ "\" (DottedList [l] obj) >>= " ++ finalContinuation ++
symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = setVar e \"" ++ var ++ "\" (DottedList [l] obj) >>= " ++ finalContinuation ++
symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"
return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj
compile env args@(List [Atom "vector-set!", Atom var, i, object]) copts = do
Atom symCompiledIdx <- _gensym "vectorSetIdx"
Atom symCompiledObj <- _gensym "vectorSetObj"
Atom symUpdateVec <- _gensym "vectorSetUpdate"
Atom symIdxWrapper <- _gensym "vectorSetIdxWrapper"
entryPt <- compileSpecialFormEntryPoint "vector-set!" symCompiledIdx copts
compiledIdx <- compileExpr env i symCompiledIdx (Just symIdxWrapper)
compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [
AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]
compiledObj <- compileExpr env object symCompiledObj Nothing
compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [
AstValue $ " vec <- getVar env \"" ++ var ++ "\"",
AstValue $ " result <- updateVector vec idx obj >>= setVar env \"" ++ var ++ "\"",
createAstCont copts "result" ""]
return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj
compile env args@(List (_ : _)) copts = mfunc env args compileApply copts
compile _ badForm _ = throwError $ BadSpecialForm "Unrecognized special form" badForm
mcompile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile env lisp copts = mfunc env lisp compile copts
mfunc :: Env -> LispVal -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]) -> CompOpts -> IOThrowsError [HaskAST]
mfunc env lisp func copts = do
transformed <- Language.Scheme.Macro.macroEval env lisp
func env transformed copts
compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST
compileSpecialFormEntryPoint formName formSym copts = do
compileSpecialForm formName ("do " ++ formSym ++ " env cont (Nil \"\") []") copts
compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST
compileSpecialForm formName formCode copts = do
f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"" ++ formName ++ "\"",
AstValue $ " if bound ",
AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ",
AstValue $ " else " ++ formCode]
return $ createAstFunc copts f
compileExpr :: Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr env expr symThisFunc fForNextExpr = do
mcompile env expr (CompileOptions symThisFunc False False fForNextExpr)
compileApply :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compileApply env args@(List (func : params)) copts@(CompileOptions coptsThis _ _ coptsNext) = do
Atom stubFunc <- _gensym "applyStubF"
Atom wrapperFunc <- _gensym "applyWrapper"
Atom nextFunc <- _gensym "applyNextF"
c <- return $ AstFunction coptsThis " env cont _ _ " [AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ wrapperFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""]
wrapper <- return $ AstFunction wrapperFunc " env cont value _ " [AstValue $ " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " [value]) $ Nil \"\""]
_comp <- mcompile env func $ CompileOptions stubFunc False False Nothing
rest <- compileArgs nextFunc False params
return $ [c, wrapper ] ++ _comp ++ rest
where
compileArgs :: String -> Bool -> [LispVal] -> IOThrowsError [HaskAST]
compileArgs thisFunc thisFuncUseValue args = do
case args of
[] -> do
case coptsNext of
Nothing -> return $ [
AstFunction thisFunc
" env cont (Nil _) (Just (a:as)) " [AstValue " apply cont a as "],
AstFunction thisFunc
" env cont value (Just (a:as)) " [AstValue " apply cont a $ as ++ [value] "]]
Just fnextExpr -> return $ [
AstFunction thisFunc
" env cont (Nil _) (Just (a:as)) " [AstValue $ " apply (makeCPS env cont " ++ fnextExpr ++ ") a as "],
AstFunction thisFunc
" env cont value (Just (a:as)) " [AstValue $ " apply (makeCPS env cont " ++ fnextExpr ++ ") a $ as ++ [value] "]]
(a:as) -> do
Atom stubFunc <- _gensym "applyFirstArg"
Atom nextFunc <- _gensym "applyNextArg"
_comp <- mcompile env a $ CompileOptions stubFunc False False Nothing
f <- if thisFuncUseValue
then return $ AstValue $ thisFunc ++ " env cont value (Just args) = do "
else return $ AstValue $ thisFunc ++ " env cont _ (Just args) = do "
c <- if thisFuncUseValue
then return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env cont " ++ nextFunc ++ " $ args ++ [value]) " ++ stubFunc ++ ") $ Nil\"\""
else return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env cont " ++ nextFunc ++ " args) " ++ stubFunc ++ ") $ Nil\"\""
rest <- compileArgs nextFunc True as
return $ [ f, c] ++ _comp ++ rest