module Language.Scheme.Core
(
evalLisp
, evalString
, evalAndPrint
, primitiveBindings
, apply
, continueEval
, showBanner
, substr
, updateVector
, version
) where
import qualified Language.Scheme.FFI
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 Data.Array
import qualified Data.Map
import qualified System.Exit
import System.IO
version :: String
version = "3.5.3.1"
showBanner :: IO ()
showBanner = do
putStrLn " _ _ __ _ "
putStrLn " | | | | \\\\\\ | | "
putStrLn " | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ "
putStrLn " | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "
putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ "
putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| "
putStrLn " "
putStrLn " http://justinethier.github.com/husk-scheme "
putStrLn " (c) 2010-2012 Justin Ethier "
putStrLn $ " Version " ++ version ++ " "
putStrLn " "
evalString :: Env -> String -> IO String
evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= meval env (makeNullContinuation env)
evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr = evalString env expr >>= putStrLn
evalLisp :: Env -> LispVal -> IOThrowsError LispVal
evalLisp env lisp = meval env (makeNullContinuation env) lisp
meval, mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval env cont lisp = mfunc env cont lisp eval
mprepareApply env cont lisp = mfunc env cont lisp prepareApply
mfunc :: Env -> LispVal -> LispVal -> (Env -> LispVal -> LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
mfunc env cont lisp func = do
Language.Scheme.Macro.macroEval env lisp >>= (func env cont)
continueEval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
continueEval _
(Continuation cEnv (Just (HaskellBody func funcArgs))
(Just (Continuation cce cnc ccc _ cdynwind))
xargs _)
val = func cEnv (Continuation cce cnc ccc xargs cdynwind) val funcArgs
continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) extraArgs dynWind) val = do
case cBody of
[] -> do
case cCont of
Continuation nEnv ncCont nnCont _ nDynWind ->
continueEval nEnv (Continuation nEnv ncCont nnCont extraArgs nDynWind) val
_ -> return (val)
[lv] -> meval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind) lv
(lv : lvs) -> meval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) lv
continueEval _ (Continuation cEnv Nothing (Just cCont) _ _) val = continueEval cEnv cCont val
continueEval _ (Continuation _ Nothing Nothing _ _) val = return val
continueEval _ _ _ = throwError $ Default "Internal error in continueEval"
eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval env cont val@(Nil _) = continueEval env cont val
eval env cont val@(String _) = continueEval env cont val
eval env cont val@(Char _) = continueEval env cont val
eval env cont val@(Complex _) = continueEval env cont val
eval env cont val@(Float _) = continueEval env cont val
eval env cont val@(Rational _) = continueEval env cont val
eval env cont val@(Number _) = continueEval env cont val
eval env cont val@(Bool _) = continueEval env cont val
eval env cont val@(HashTable _) = continueEval env cont val
eval env cont val@(Vector _) = do
continueEval env cont val
eval env cont (Atom a) = continueEval env cont =<< getVar env a
eval env cont (List [Atom "quote", val]) = continueEval env cont val
eval envi cont (List [Atom "quasiquote", value]) = cpsUnquote envi cont value Nothing
where cpsUnquote :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquote e c val _ = do
case val of
List [Atom "unquote", vval] -> meval e c vval
List (_ : _) -> doCpsUnquoteList e c val
DottedList xs x -> do
doCpsUnquoteList e (makeCPSWArgs e c cpsUnquotePair $ [x] ) $ List xs
Vector vec -> do
let len = length (elems vec)
if len > 0
then doCpsUnquoteList e (makeCPS e c cpsUnquoteVector) $ List $ elems vec
else continueEval e c $ Vector $ listArray (0, 1) []
_ -> meval e c (List [Atom "quote", val])
cpsUnquotePair :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquotePair e c (List rxs) (Just [rx]) = do
cpsUnquote e (makeCPSWArgs e c cpsUnquotePairFinish $ [List rxs]) rx Nothing
cpsUnquotePair _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePair"
cpsUnquotePairFinish :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquotePairFinish e c rx (Just [List rxs]) = do
case rx of
List [] -> continueEval e c $ List rxs
List rxlst -> continueEval e c $ List $ rxs ++ rxlst
DottedList rxlst rxlast -> continueEval e c $ DottedList (rxs ++ rxlst) rxlast
_ -> continueEval e c $ DottedList rxs rx
cpsUnquotePairFinish _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePairFinish"
cpsUnquoteVector :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquoteVector e c (List vList) _ = continueEval e c (Vector $ listArray (0, (length vList 1)) vList)
cpsUnquoteVector _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteVector"
doCpsUnquoteList :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
doCpsUnquoteList e c (List (x : xs)) = cpsUnquoteList e c x $ Just ([List xs, List []])
doCpsUnquoteList _ _ _ = throwError $ InternalError "Unexpected parameters to doCpsUnquoteList"
cpsUnquoteList :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquoteList e c val (Just ([List unEvaled, List acc])) = do
case val of
List [Atom "unquote-splicing", vvar] -> do
meval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) vvar
_ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing
cpsUnquoteList _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteList"
cpsUnquoteSplicing :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquoteSplicing e c val (Just ([List unEvaled, List acc])) = do
case val of
List v -> case unEvaled of
[] -> continueEval e c $ List $ acc ++ v
_ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ v ])
_ -> throwError $ TypeMismatch "proper list" val
cpsUnquoteSplicing _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteSplicing"
cpsUnquoteFld :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUnquoteFld e c val (Just ([List unEvaled, List acc])) = do
case unEvaled of
[] -> continueEval e c $ List $ acc ++ [val]
_ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ [val] ])
cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld"
eval env cont args@(List (Atom "let-syntax" : List _bindings : _body)) = do
bound <- liftIO $ isRecBound env "define-syntax"
if bound
then prepareApply env cont args
else 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 -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil ""
e -> continueEval bodyEnv cont e
eval env cont args@(List (Atom "letrec-syntax" : List _bindings : _body)) = do
bound <- liftIO $ isRecBound env "define-syntax"
if bound
then prepareApply env cont args
else 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 -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil ""
e -> continueEval bodyEnv cont e
eval env cont args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) = do
bound <- liftIO $ isRecBound env "define-syntax"
if bound
then prepareApply env cont args
else do
_ <- defineNamespacedVar env macroNamespace keyword $ Syntax (Just env) Nothing False identifiers rules
continueEval env cont $ Nil ""
eval env cont args@(List [Atom "if", predic, conseq, alt]) = do
bound <- liftIO $ isRecBound env "if"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cps) predic
where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps e c result _ =
case (result) of
Bool False -> meval e c alt
_ -> meval e c conseq
eval env cont args@(List [Atom "if", predic, conseq]) = do
bound <- liftIO $ isRecBound env "if"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsResult) predic
where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult e c result _ =
case result of
Bool False -> continueEval e c $ Nil ""
_ -> meval e c conseq
eval env cont args@(List [Atom "set!", Atom var, form]) = do
bound <- liftIO $ isRecBound env "set!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsResult) form
where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult e c result _ = setVar e var result >>= continueEval e c
eval env cont args@(List [Atom "set!", nonvar, _]) = do
bound <- liftIO $ isRecBound env "set!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "set!" : args)) = do
bound <- liftIO $ isRecBound env "set!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 2 args
eval env cont args@(List [Atom "define", Atom var, form]) = do
bound <- liftIO $ isRecBound env "define"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsResult) form
where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult e c result _ = defineVar e var result >>= continueEval e c
eval env cont args@(List (Atom "define" : List (Atom var : fparams) : fbody )) = do
bound <- liftIO $ isRecBound env "define"
if bound
then prepareApply env cont args
else do result <- (makeNormalFunc env fparams fbody >>= defineVar env var)
continueEval env cont result
eval env cont args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do
bound <- liftIO $ isRecBound env "define"
if bound
then prepareApply env cont args
else do result <- (makeVarargs varargs env fparams fbody >>= defineVar env var)
continueEval env cont result
eval env cont args@(List (Atom "lambda" : List fparams : fbody)) = do
bound <- liftIO $ isRecBound env "lambda"
if bound
then prepareApply env cont args
else do result <- makeNormalFunc env fparams fbody
continueEval env cont result
eval env cont args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) = do
bound <- liftIO $ isRecBound env "lambda"
if bound
then prepareApply env cont args
else do result <- makeVarargs varargs env fparams fbody
continueEval env cont result
eval env cont args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) = do
bound <- liftIO $ isRecBound env "lambda"
if bound
then prepareApply env cont args
else do result <- makeVarargs varargs env [] fbody
continueEval env cont result
eval env cont args@(List [Atom "string-set!", Atom var, i, character]) = do
bound <- liftIO $ isRecBound env "string-set!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsStr) i
where
cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsStr e c idx _ = (meval e (makeCPSWArgs e c cpsSubStr $ [idx]) =<< getVar e var)
cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSubStr e c str (Just [idx]) =
substr (str, character, idx) >>= setVar e var >>= continueEval e c
cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr"
eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do
bound <- liftIO $ isRecBound env "string-set!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "string-set!" : args)) = do
bound <- liftIO $ isRecBound env "string-set!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 3 args
eval env cont args@(List [Atom "set-car!", Atom var, argObj]) = do
bound <- liftIO $ isRecBound env "set-car!"
if bound
then prepareApply env cont args
else continueEval env (makeCPS env cont cpsObj) =<< getVar env var
where
cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj _ _ obj@(List []) _ = throwError $ TypeMismatch "pair" obj
cpsObj e c obj@(List (_ : _)) _ = meval e (makeCPSWArgs e c cpsSet $ [obj]) argObj
cpsObj e c obj@(DottedList _ _) _ = meval e (makeCPSWArgs e c cpsSet $ [obj]) argObj
cpsObj _ _ obj _ = throwError $ TypeMismatch "pair" obj
cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet e c obj (Just [List (_ : ls)]) = setVar e var (List (obj : ls)) >>= continueEval e c
cpsSet e c obj (Just [DottedList (_ : ls) l]) = setVar e var (DottedList (obj : ls) l) >>= continueEval e c
cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet"
eval env cont args@(List [Atom "set-car!" , nonvar , _ ]) = do
bound <- liftIO $ isRecBound env "set-car!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "set-car!" : args)) = do
bound <- liftIO $ isRecBound env "set-car!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 2 args
eval env cont args@(List [Atom "set-cdr!", Atom var, argObj]) = do
bound <- liftIO $ isRecBound env "set-cdr!"
if bound
then prepareApply env cont args
else continueEval env (makeCPS env cont cpsObj) =<< getVar env var
where
cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj _ _ pair@(List []) _ = throwError $ TypeMismatch "pair" pair
cpsObj e c pair@(List (_ : _)) _ = meval e (makeCPSWArgs e c cpsSet $ [pair]) argObj
cpsObj e c pair@(DottedList _ _) _ = meval e (makeCPSWArgs e c cpsSet $ [pair]) argObj
cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair
cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet e c obj (Just [List (l : _)]) = setVar e var (DottedList [l] obj) >>= continueEval e c
cpsSet e c obj (Just [DottedList (l : _) _]) = setVar e var (DottedList [l] obj) >>= continueEval e c
cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet"
eval env cont args@(List [Atom "set-cdr!" , nonvar , _ ]) = do
bound <- liftIO $ isRecBound env "set-cdr!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "set-cdr!" : args)) = do
bound <- liftIO $ isRecBound env "set-cdr!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 2 args
eval env cont args@(List [Atom "vector-set!", Atom var, i, object]) = do
bound <- liftIO $ isRecBound env "vector-set!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsObj) i
where
cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj e c idx _ = meval e (makeCPSWArgs e c cpsVec $ [idx]) object
cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsVec e c obj (Just [idx]) = (meval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) =<< getVar e var)
cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec"
cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUpdateVec e c vec (Just [idx, obj]) =
updateVector vec idx obj >>= setVar e var >>= continueEval e c
cpsUpdateVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateVec"
eval env cont args@(List [Atom "vector-set!" , nonvar , _ , _]) = do
bound <- liftIO $ isRecBound env "vector-set!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "vector-set!" : args)) = do
bound <- liftIO $ isRecBound env "vector-set!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 3 args
eval env cont args@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do
bound <- liftIO $ isRecBound env "hash-table-set!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsValue) rkey
where
cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsValue e c key _ = meval e (makeCPSWArgs e c cpsH $ [key]) rvalue
cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsH e c value (Just [key]) = (meval e (makeCPSWArgs e c cpsEvalH $ [key, value]) =<< getVar e var)
cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH"
cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH e c h (Just [key, value]) = do
case h of
HashTable ht -> do
setVar env var (HashTable $ Data.Map.insert key value ht) >>= meval e c
other -> throwError $ TypeMismatch "hash-table" other
cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH"
eval env cont args@(List [Atom "hash-table-set!" , nonvar , _ , _]) = do
bound <- liftIO $ isRecBound env "hash-table-set!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "hash-table-set!" : args)) = do
bound <- liftIO $ isRecBound env "hash-table-set!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 3 args
eval env cont args@(List [Atom "hash-table-delete!", Atom var, rkey]) = do
bound <- liftIO $ isRecBound env "hash-table-delete!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont cpsH) rkey
where
cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsH e c key _ = (meval e (makeCPSWArgs e c cpsEvalH $ [key]) =<< getVar e var)
cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH e c h (Just [key]) = do
case h of
HashTable ht -> do
setVar env var (HashTable $ Data.Map.delete key ht) >>= meval e c
other -> throwError $ TypeMismatch "hash-table" other
cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH"
eval env cont args@(List [Atom "hash-table-delete!" , nonvar , _]) = do
bound <- liftIO $ isRecBound env "hash-table-delete!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do
bound <- liftIO $ isRecBound env "hash-table-delete!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs 2 args
eval env cont args@(List (_ : _)) = mprepareApply env cont args
eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
substr :: (LispVal, LispVal, LispVal) -> IOThrowsError LispVal
substr (String str, Char char, Number ii) = do
return $ String $ (take (fromInteger ii) . drop 0) str ++
[char] ++
(take (length str) . drop (fromInteger ii + 1)) str
substr (String _, Char _, n) = throwError $ TypeMismatch "number" n
substr (String _, c, _) = throwError $ TypeMismatch "character" c
substr (s, _, _) = throwError $ TypeMismatch "string" s
updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)]
updateVector v _ _ = throwError $ TypeMismatch "vector" v
prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply env cont (List (function : functionArgs)) = do
eval env (makeCPSWArgs env cont cpsPrepArgs $ functionArgs) function
where cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsPrepArgs e c func (Just args) =
case (args) of
[] -> apply c func []
[a] -> meval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []]) a
(a : as) -> meval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a
cpsPrepArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (1)"
cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) =
case argsRemaining of
[] -> apply c func (argsEvaled ++ [evaledArg])
[a] -> meval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []]) a
(a : as) -> meval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a
cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)"
cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)"
prepareApply _ _ _ = throwError $ Default "Unexpected error in prepareApply"
makeFunc ::
(Monad m) =>
Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env
makeNormalFunc :: (Monad m) => Env
-> [LispVal]
-> [LispVal]
-> m LispVal
makeNormalFunc = makeFunc Nothing
makeVarargs :: (Monad m) => LispVal -> Env
-> [LispVal]
-> [LispVal]
-> m LispVal
makeVarargs = makeFunc . Just . showVal
apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply _ cont@(Continuation env ccont ncont _ ndynwind) args = do
case ndynwind of
Just ([DynamicWinders beforeFunc _]) -> apply (makeCPS env cont cpsApply) beforeFunc []
_ -> doApply env cont
where
cpsApply :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsApply e c _ _ = doApply e c
doApply e c =
case (toInteger $ length args) of
0 -> throwError $ NumArgs 1 []
1 -> continueEval e c $ head args
_ ->
continueEval e (Continuation env ccont ncont (Just $ tail args) ndynwind) $ head args
apply cont (IOFunc func) args = do
result <- func args
case cont of
Continuation cEnv _ _ _ _ -> continueEval cEnv cont result
_ -> return result
apply cont (EvalFunc func) args = do
func (cont : args)
apply cont (PrimitiveFunc func) args = do
result <- liftThrows $ func args
case cont of
Continuation cEnv _ _ _ _ -> continueEval cEnv cont result
_ -> return result
apply cont (Func aparams avarargs abody aclosure) args =
if num aparams /= num args && avarargs == Nothing
then throwError $ NumArgs (num aparams) args
else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody)
where remainingArgs = drop (length aparams) args
num = toInteger . length
evalBody evBody env = case cont of
Continuation _ (Just (SchemeBody cBody)) (Just cCont) _ cDynWind -> if length cBody == 0
then continueWCont env (evBody) cCont cDynWind
else continueWCont env (evBody) cont cDynWind
Continuation _ _ _ _ cDynWind -> continueWCont env (evBody) cont cDynWind
_ -> continueWCont env (evBody) cont Nothing
continueWCont cwcEnv cwcBody cwcCont cwcDynWind =
continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) Nothing cwcDynWind) $ Nil ""
bindVarArgs arg env = case arg of
Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)]
Nothing -> return env
apply cont (HFunc aparams avarargs abody aclosure) args =
if num aparams /= num args && avarargs == Nothing
then throwError $ NumArgs (num aparams) args
else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody)
where remainingArgs = drop (length aparams) args
num = toInteger . length
evalBody evBody env = evBody env cont (Nil "") Nothing
bindVarArgs arg env = case arg of
Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)]
Nothing -> return env
apply _ func args = throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : args)
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives
++ map (domakeFunc EvalFunc) evalFunctions
++ map (domakeFunc PrimitiveFunc) primitives)
where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func)
evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal
evalfuncDynamicWind [cont@(Continuation env _ _ _ _), beforeFunc, thunkFunc, afterFunc] = do
apply (makeCPS env cont cpsThunk) beforeFunc []
where
cpsThunk, cpsAfter :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsThunk e (Continuation ce cc cnc ca _ ) _ _ = apply (Continuation e (Just (HaskellBody cpsAfter Nothing))
(Just (Continuation ce cc cnc ca
Nothing))
Nothing
(Just ([DynamicWinders beforeFunc afterFunc])))
thunkFunc []
cpsThunk _ _ _ _ = throwError $ Default "Unexpected error in cpsThunk during (dynamic-wind)"
cpsAfter _ c _ _ = apply c afterFunc []
evalfuncDynamicWind (_ : args) = throwError $ NumArgs 3 args
evalfuncDynamicWind _ = throwError $ NumArgs 3 []
evalfuncCallWValues [cont@(Continuation env _ _ _ _), producer, consumer] = do
apply (makeCPS env cont cpsEval) producer []
where
cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEval _ c@(Continuation _ _ _ (Just xargs) _) value _ = apply c consumer (value : xargs)
cpsEval _ c value _ = apply c consumer [value]
evalfuncCallWValues (_ : args) = throwError $ NumArgs 2 args
evalfuncCallWValues _ = throwError $ NumArgs 2 []
evalfuncApply [cont@(Continuation _ _ _ _ _), func, List args] = apply cont func args
evalfuncApply (_ : args) = throwError $ NumArgs 2 args
evalfuncApply _ = throwError $ NumArgs 2 []
evalfuncLoad [cont@(Continuation env _ _ _ _), String filename] = do
results <- load filename >>= mapM (evaluate env (makeNullContinuation env))
if not (null results)
then do result <- return . last $ results
continueEval env cont result
else return $ Nil ""
where evaluate env2 cont2 val2 = meval env2 cont2 val2
evalfuncLoad (_ : args) = throwError $ NumArgs 1 args
evalfuncLoad _ = throwError $ NumArgs 1 []
evalfuncEval [cont@(Continuation env _ _ _ _), val] = meval env cont val
evalfuncEval (_ : args) = throwError $ NumArgs 1 args
evalfuncEval _ = throwError $ NumArgs 1 []
evalfuncCallCC [cont@(Continuation _ _ _ _ _), func] = do
case func of
Continuation _ _ _ _ _ -> apply cont func [cont]
PrimitiveFunc f -> do
result <- liftThrows $ f [cont]
case cont of
Continuation cEnv _ _ _ _ -> continueEval cEnv cont result
_ -> return result
Func _ (Just _) _ _ -> apply cont func [cont]
Func aparams _ _ _ ->
if (toInteger $ length aparams) == 1
then apply cont func [cont]
else throwError $ NumArgs (toInteger $ length aparams) [cont]
HFunc _ (Just _) _ _ -> apply cont func [cont]
HFunc aparams _ _ _ ->
if (toInteger $ length aparams) == 1
then apply cont func [cont]
else throwError $ NumArgs (toInteger $ length aparams) [cont]
other -> throwError $ TypeMismatch "procedure" other
evalfuncCallCC (_ : args) = throwError $ NumArgs 1 args
evalfuncCallCC _ = throwError $ NumArgs 1 []
evalfuncExitFail _ = do
_ <- liftIO $ System.Exit.exitFailure
return $ Nil ""
evalfuncExitSuccess _ = do
_ <- liftIO $ System.Exit.exitSuccess
return $ Nil ""
evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)]
evalFunctions = [ ("apply", evalfuncApply)
, ("call-with-current-continuation", evalfuncCallCC)
, ("call-with-values", evalfuncCallWValues)
, ("dynamic-wind", evalfuncDynamicWind)
, ("eval", evalfuncEval)
, ("load", evalfuncLoad)
, ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI)
, ("exit-fail", evalfuncExitFail)
, ("exit-success", evalfuncExitSuccess)
]
ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("open-input-file", makePort ReadMode),
("open-output-file", makePort WriteMode),
("close-input-port", closePort),
("close-output-port", closePort),
("input-port?", isInputPort),
("output-port?", isOutputPort),
("current-input-port", currentInputPort),
("current-output-port", currentOutputPort),
("read", readProc),
("read-char", readCharProc hGetChar),
("peek-char", readCharProc hLookAhead),
("write", writeProc (\ port obj -> hPrint port obj)),
("write-char", writeCharProc),
("display", writeProc (\ port obj -> case obj of
String str -> hPutStr port str
_ -> hPutStr port $ show obj)),
("read-contents", readContents),
("read-all", readAll),
("gensym", gensym)]
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numAdd),
("-", numSub),
("*", numMul),
("/", numDiv),
("modulo", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem),
("round", numRound),
("floor", numFloor),
("ceiling", numCeiling),
("truncate", numTruncate),
("numerator", numNumerator),
("denominator", numDenominator),
("exp", numExp),
("log", numLog),
("sin", numSin),
("cos", numCos),
("tan", numTan),
("asin", numAsin),
("acos", numAcos),
("atan", numAtan),
("sqrt", numSqrt),
("expt", numExpt),
("make-rectangular", numMakeRectangular),
("make-polar", numMakePolar),
("real-part", numRealPart ),
("imag-part", numImagPart),
("magnitude", numMagnitude),
("angle", numAngle ),
("exact->inexact", numExact2Inexact),
("inexact->exact", numInexact2Exact),
("number->string", num2String),
("=", numBoolBinopEq),
(">", numBoolBinopGt),
(">=", numBoolBinopGte),
("<", numBoolBinopLt),
("<=", numBoolBinopLte),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
("string-ci=?", stringCIEquals),
("string-ci<?", stringCIBoolBinop (<)),
("string-ci>?", stringCIBoolBinop (>)),
("string-ci<=?", stringCIBoolBinop (<=)),
("string-ci>=?", stringCIBoolBinop (>=)),
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv),
("equal?", equal),
("pair?", isDottedList),
("procedure?", isProcedure),
("number?", isNumber),
("complex?", isComplex),
("real?", isReal),
("rational?", isRational),
("integer?", isInteger),
("list?", unaryOp isList),
("null?", isNull),
("eof-object?", isEOFObject),
("symbol?", isSymbol),
("symbol->string", symbol2String),
("string->symbol", string2Symbol),
("char?", isChar),
("vector?", unaryOp isVector),
("make-vector", makeVector),
("vector", buildVector),
("vector-length", vectorLength),
("vector-ref", vectorRef),
("vector->list", vectorToList),
("list->vector", listToVector),
("make-hash-table", hashTblMake),
("hash-table?", isHashTbl),
("hash-table-exists?", hashTblExists),
("hash-table-ref", hashTblRef),
("hash-table-size", hashTblSize),
("hash-table->alist", hashTbl2List),
("hash-table-keys", hashTblKeys),
("hash-table-values", hashTblValues),
("hash-table-copy", hashTblCopy),
("string?", isString),
("string", buildString),
("make-string", makeString),
("string-length", stringLength),
("string-ref", stringRef),
("substring", substring),
("string-append", stringAppend),
("string->number", stringToNumber),
("string->list", stringToList),
("list->string", listToString),
("string-copy", stringCopy),
("boolean?", isBoolean)]