module Language.Scheme.Compiler where
import qualified Language.Scheme.Macro
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 qualified Data.Map
import Data.Ratio
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 _) funcBody = do
let val = case useVal of
True -> "value"
_ -> "_"
args = case useArgs of
True -> "(Just args)"
_ -> "_"
AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") funcBody
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 fheader = "\n" ++ name ++ args ++ " = do "
let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code
fheader ++ fbody
showValAST (AstValue v) = v
showValAST (AstContinuation nextFunc args) = " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " " ++ args ++ ") $ Nil \"\""
instance Show HaskAST where show = showValAST
joinL :: forall a. [[a]] -> [a] -> [a]
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 (HashTable ht) = do
let ls = Data.Map.toList ht
conv (a, b) = "(" ++ astToHaskellStr a ++ "," ++ astToHaskellStr b ++ ")"
"HashTable $ Data.Map.fromList $ [" ++ joinL (map conv ls) "," ++ "]"
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, headerModule, headerImports :: [String]
headerModule = ["module Main where "]
headerImports = [
"Language.Scheme.Core "
, "Language.Scheme.Numerical "
, "Language.Scheme.Primitives "
, "Language.Scheme.Types -- Scheme data types "
, "Language.Scheme.Variables -- Scheme variable operations "
, "Control.Monad.Error "
, "Data.Array "
, "Data.Complex "
, " qualified Data.Map "
, "Data.Ratio "
, "System.IO "]
header = [
" "
, "main :: IO () "
, "main = do "
, " env <- primitiveBindings "
, " result <- (runIOThrows $ liftM show $ run env (makeNullContinuation env) (Nil \"\") Nothing) "
, " case result of "
, " Just errMsg -> putStrLn errMsg "
, " _ -> return () "
, " "]
initializeCompiler :: Env -> IOThrowsError [HaskAST]
initializeCompiler env = do
_ <- defineNamespacedVar env "internal" "imports" $ List []
return []
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 [c] = do
compiled <- mcompile env c $ CompileOptions symThisFunc False False symLastFunc
return $ result ++ compiled
compileBlock symThisFunc symLastFunc env result (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)
serialize a = throwError $ Default $ "invalid parameter to lambda list: " ++ 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 _ ht@(HashTable _) copts = compileScalar (" return $ " ++ astToHaskellStr ht) 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 (List [Atom "expand", _body]) copts = do
val <- Language.Scheme.Macro.expand env False _body
compileScalar (" return $ " ++ astToHaskellStr val) copts
compile env (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 (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 (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 (List [Atom "if", predic, conseq]) copts =
compile env (List [Atom "if", predic, conseq, Nil ""]) copts
compile env (List [Atom "if", predic, conseq, alt]) copts@(CompileOptions _ _ _ 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 (List [Atom "set!", Atom var, form]) copts@(CompileOptions _ _ _ _) = 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 _ (List [Atom "set!", nonvar, _]) copts = do
f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\" $ String \"" ++ (show nonvar) ++ "\"") copts
return [f]
compile _ (List (Atom "set!" : args)) copts = do
f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts
return [f]
compile env (List [Atom "define", Atom var, form]) copts@(CompileOptions _ _ _ _) = 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 (List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions _ _ _ _) = 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 (List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions _ _ _ _) = 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 (List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions _ _ _ _) = 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 (List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions _ _ _ _) = 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 (List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions _ _ _ _) = 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 (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 (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 (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 : _)]) = (liftThrows $ cons [l, obj]) >>= setVar e \"" ++ var ++ "\" >>= " ++ finalContinuation ++
symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = (liftThrows $ cons [l, obj]) >>= setVar e \"" ++ var ++ "\" >>= " ++ finalContinuation ++
symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"
return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj
compile env (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 (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) copts = do
Atom symCompiledIdx <- _gensym "hashTableSetIdx"
Atom symCompiledObj <- _gensym "hashTableSetObj"
Atom symUpdateVec <- _gensym "hashTableSetUpdate"
Atom symIdxWrapper <- _gensym "hashTableSetIdxWrapper"
entryPt <- compileSpecialFormEntryPoint "hash-table-set!" symCompiledIdx copts
compiledIdx <- compileExpr env rkey symCompiledIdx (Just symIdxWrapper)
compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [
AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]
compiledObj <- compileExpr env rvalue symCompiledObj Nothing
compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [rkey]) " [
AstValue $ " HashTable ht <- getVar env \"" ++ var ++ "\"",
AstValue $ " result <- setVar env \"" ++ var ++ "\" (HashTable $ Data.Map.insert rkey obj ht) ",
createAstCont copts "result" ""]
return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj
compile env (List [Atom "hash-table-delete!", Atom var, rkey]) copts = do
Atom symCompiledIdx <- _gensym "hashTableDeleteIdx"
Atom symDoDelete <- _gensym "hashTableDelete"
entryPt <- compileSpecialFormEntryPoint "hash-table-delete!" symCompiledIdx copts
compiledIdx <- compileExpr env rkey symCompiledIdx (Just symDoDelete)
compiledUpdate <- return $ AstFunction symDoDelete " env cont rkey _ " [
AstValue $ " HashTable ht <- getVar env \"" ++ var ++ "\"",
AstValue $ " result <- setVar env \"" ++ var ++ "\" (HashTable $ Data.Map.delete rkey ht) ",
createAstCont copts "result" ""]
return $ [entryPt, compiledUpdate] ++ compiledIdx
compile env (List [Atom "load-ffi",
String moduleName,
String externalFuncName,
String internalFuncName]) copts = do
List l <- getNamespacedVar env "internal" "imports"
_ <- if not ((String moduleName) `elem` l)
then setNamespacedVar env "internal" "imports" $ List $ l ++ [String moduleName]
else return $ String ""
return [createAstFunc copts [
AstValue $ " result <- defineVar env \"" ++
internalFuncName ++ "\" $ IOFunc " ++
moduleName ++ "." ++ externalFuncName,
createAstCont copts "result" ""]]
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 (List (func : fparams)) (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 fparams
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