module Language.Scheme.Core
(
evalLisp
, evalLisp'
, evalString
, evalAndPrint
, apply
, continueEval
, runIOThrows
, runIOThrowsREPL
, nullEnvWithImport
, primitiveBindings
, r5rsEnv
, r5rsEnv'
, r7rsEnv
, r7rsEnv'
, r7rsTimeEnv
, version
, findFileOrLib
, getDataFileFullPath
, replaceAtIndex
, registerExtensions
, showBanner
, showLispError
, substr
, updateList
, updateVector
, updateByteVector
, meval
) where
import qualified Paths_husk_scheme as PHS (getDataFileName, version)
#ifdef UseFfi
import qualified Language.Scheme.FFI
#endif
import Language.Scheme.Environments
import Language.Scheme.Libraries
import qualified Language.Scheme.Macro
import Language.Scheme.Parser
import Language.Scheme.Primitives
import Language.Scheme.Types
import Language.Scheme.Util
import Language.Scheme.Variables
import Control.Monad.Error
import Data.Array
import qualified Data.ByteString as BS
import qualified Data.Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Version as DV
import Data.Word
import qualified System.Exit
import qualified System.Info as SysInfo
version :: String
version = DV.showVersion PHS.version
showBanner :: IO ()
showBanner = do
putStrLn " _ _ __ _ "
putStrLn " | | | | \\\\\\ | | "
putStrLn " | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ "
putStrLn " | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "
putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ "
putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| "
putStrLn " "
putStrLn " http://justinethier.github.io/husk-scheme "
putStrLn " (c) 2010-2014 Justin Ethier "
putStrLn $ " Version " ++ (DV.showVersion PHS.version) ++ " "
putStrLn " "
getHuskFeatures :: IO [LispVal]
getHuskFeatures = do
return [ Atom "r7rs"
, Atom "husk"
, Atom $ "husk-" ++ (DV.showVersion PHS.version)
, Atom SysInfo.arch
, Atom SysInfo.os
, Atom "full-unicode"
, Atom "complex"
, Atom "ratios"
]
getDataFileFullPath :: String -> IO String
getDataFileFullPath = PHS.getDataFileName
findFileOrLib :: String -> ErrorT LispError IO String
findFileOrLib filename = do
fileAsLib <- liftIO $ getDataFileFullPath $ "lib/" ++ filename
exists <- fileExists [String filename]
existsLib <- fileExists [String fileAsLib]
case (exists, existsLib) of
(Bool False, Bool True) -> return fileAsLib
_ -> return filename
libraryExists :: [LispVal] -> IOThrowsError LispVal
libraryExists [p@(Pointer _ _)] = do
p' <- recDerefPtrs p
libraryExists [p']
libraryExists [(String filename)] = do
fileAsLib <- liftIO $ getDataFileFullPath $ "lib/" ++ filename
Bool exists <- fileExists [String filename]
Bool existsLib <- fileExists [String fileAsLib]
return $ Bool $ exists || existsLib
libraryExists _ = return $ Bool False
registerExtensions :: Env -> (FilePath -> IO FilePath) -> IO ()
registerExtensions env getDataFileName = do
_ <- registerSRFI env getDataFileName 1
_ <- registerSRFI env getDataFileName 2
return ()
registerSRFI :: Env -> (FilePath -> IO FilePath) -> Integer -> IO ()
registerSRFI env getDataFileName num = do
filename <- getDataFileName $ "lib/srfi/srfi-" ++ show num ++ ".scm"
_ <- evalString env $ "(register-extension '(srfi " ++ show num ++ ") \"" ++
(escapeBackslashes filename) ++ "\")"
return ()
showLispError :: LispError -> IO String
showLispError (TypeMismatch str p@(Pointer _ e)) = do
lv' <- evalLisp' e p
case lv' of
Left _ -> showLispError $ TypeMismatch str $ Atom $ show p
Right val -> showLispError $ TypeMismatch str val
showLispError (BadSpecialForm str p@(Pointer _ e)) = do
lv' <- evalLisp' e p
case lv' of
Left _ -> showLispError $ BadSpecialForm str $ Atom $ show p
Right val -> showLispError $ BadSpecialForm str val
showLispError err = return $ show err
runIOThrowsREPL :: IOThrowsError String -> IO String
runIOThrowsREPL action = do
runState <- runErrorT action
case runState of
Left err -> showLispError err
Right val -> return val
runIOThrows :: IOThrowsError String -> IO (Maybe String)
runIOThrows action = do
runState <- runErrorT action
case runState of
Left err -> do
disp <- showLispError err
return $ Just disp
Right _ -> return Nothing
evalString :: Env -> String -> IO String
evalString env expr = do
runIOThrowsREPL $ liftM show $ liftThrows (readExpr expr) >>= evalLisp env
evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr = evalString env expr >>= putStrLn
evalLisp :: Env -> LispVal -> IOThrowsError LispVal
evalLisp env lisp = do
v <- meval env (makeNullContinuation env) lisp
safeRecDerefPtrs [] v
evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' env lisp = runErrorT (evalLisp 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 apply >>= (func env cont)
continueEval :: Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
continueEval _
(Continuation
cEnv
(Just (HaskellBody func funcArgs))
(Just nCont@(Continuation {}))
_)
val
xargs = do
let args = case funcArgs of
Nothing -> xargs
_ -> funcArgs
func cEnv nCont val args
continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) dynWind) val extraArgs = do
case cBody of
[] -> do
case cCont of
Continuation {contClosure = nEnv} ->
continueEval nEnv cCont val extraArgs
_ -> return val
(lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) dynWind) lv
continueEval _ (Continuation cEnv Nothing (Just cCont) _) val xargs = continueEval cEnv cCont val xargs
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 Nothing
eval env cont val@(String _) = continueEval env cont val Nothing
eval env cont val@(Char _) = continueEval env cont val Nothing
eval env cont val@(Complex _) = continueEval env cont val Nothing
eval env cont val@(Float _) = continueEval env cont val Nothing
eval env cont val@(Rational _) = continueEval env cont val Nothing
eval env cont val@(Number _) = continueEval env cont val Nothing
eval env cont val@(Bool _) = continueEval env cont val Nothing
eval env cont val@(HashTable _) = continueEval env cont val Nothing
eval env cont val@(Vector _) = continueEval env cont val Nothing
eval env cont val@(ByteVector _) = continueEval env cont val Nothing
eval env cont val@(LispEnv _) = continueEval env cont val Nothing
eval env cont val@(Pointer _ _) = continueEval env cont val Nothing
eval env cont (Atom a) = do
v <- getVar env a
let val = case v of
#ifdef UsePointers
List _ -> Pointer a env
DottedList _ _ -> Pointer a env
String _ -> Pointer a env
Vector _ -> Pointer a env
ByteVector _ -> Pointer a env
HashTable _ -> Pointer a env
#endif
_ -> v
continueEval env cont val Nothing
eval env cont (List [Atom "quote", val]) = continueEval env cont val Nothing
eval env cont args@(List [Atom "expand" , _body]) = do
bound <- liftIO $ isRecBound env "expand"
if bound
then prepareApply env cont args
else do
value <- Language.Scheme.Macro.expand env False _body apply
continueEval env cont value Nothing
eval env cont args@(List (Atom "let-syntax" : List _bindings : _body)) = do
bound <- liftIO $ isRecBound env "let-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) apply
case expanded of
List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing) (Nil "") Nothing
e -> continueEval bodyEnv cont e Nothing
eval env cont args@(List (Atom "letrec-syntax" : List _bindings : _body)) = do
bound <- liftIO $ isRecBound env "letrec-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) apply
case expanded of
List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing) (Nil "") Nothing
e -> continueEval bodyEnv cont e Nothing
eval env cont (List [Atom "define-syntax",
Atom newKeyword,
Atom keyword]) = do
bound <- getNamespacedVar' env macroNamespace keyword
case bound of
Just m -> do
_ <- defineNamespacedVar env macroNamespace newKeyword m
continueEval env cont (Nil "") Nothing
Nothing -> throwError $ TypeMismatch "macro" $ Atom keyword
eval env cont args@(List [Atom "define-syntax", Atom keyword,
(List [Atom "er-macro-transformer",
(List (Atom "lambda" : List fparams : fbody))])]) = do
bound <- liftIO $ isRecBound env "define-syntax"
if bound
then prepareApply env cont args
else do
_ <- validateFuncParams fparams (Just 3)
f <- makeNormalFunc env fparams fbody
_ <- defineNamespacedVar env macroNamespace keyword $ SyntaxExplicitRenaming f
continueEval env cont (Nil "") Nothing
eval env cont args@(List [Atom "define-syntax", Atom keyword,
(List (Atom "syntax-rules" : Atom ellipsis : (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 ellipsis identifiers rules
continueEval env cont (Nil "") Nothing
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 "") Nothing
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 "") Nothing
_ -> 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 _ = do
value <- setVar e var result
continueEval e c value Nothing
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 (Just 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 _ = do
value <- defineVar e var result
continueEval e c value Nothing
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
_ <- validateFuncParams fparams Nothing
ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody
result <- (makeNormalFunc env fparams ebody >>= defineVar env var)
continueEval env cont result Nothing
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
_ <- validateFuncParams (fparams ++ [varargs]) Nothing
ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody
result <- (makeVarargs varargs env fparams ebody >>= defineVar env var)
continueEval env cont result Nothing
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
_ <- validateFuncParams fparams Nothing
ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody
result <- makeNormalFunc env fparams ebody
continueEval env cont result Nothing
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
_ <- validateFuncParams (fparams ++ [varargs]) Nothing
ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody
result <- makeVarargs varargs env fparams ebody
continueEval env cont result Nothing
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
ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody
result <- makeVarargs varargs env [] ebody
continueEval env cont result Nothing
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 cpsChar) character
where
cpsChar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsChar e c chr _ = do
meval e (makeCPSWArgs e c cpsStr [chr]) i
cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsStr e c idx (Just [chr]) = do
value <- getVar env var
derefValue <- derefPtr value
meval e (makeCPSWArgs e c cpsSubStr [idx, chr]) derefValue
cpsStr _ _ _ _ = throwError $ InternalError "Unexpected case in cpsStr"
cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSubStr e c str (Just [idx, chr]) = do
value <- substr (str, chr, idx) >>= updateObject e var
continueEval e c value Nothing
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 (Just 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 do
value <- getVar env var
continueEval env (makeCPS env cont cpsObj) value Nothing
where
cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj e c obj@(Pointer _ _) x = do
o <- derefPtr obj
cpsObj e c o x
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)]) = do
value <- updateObject e var (List (obj : ls))
continueEval e c value Nothing
cpsSet e c obj (Just [DottedList (_ : ls) l]) = do
value <- updateObject e var (DottedList (obj : ls) l)
continueEval e c value Nothing
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 (Just 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 do
value <- getVar env var
derefValue <- derefPtr value
continueEval env (makeCPS env cont cpsObj) derefValue Nothing
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
updateCdr e c obj l = do
l' <- recDerefPtrs l
obj' <- recDerefPtrs obj
value <- (cons [l', obj']) >>= updateObject e var
continueEval e c value Nothing
cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet e c obj (Just [List (l : _)]) = updateCdr e c obj l
cpsSet e c obj (Just [DottedList (l : _) _]) = updateCdr e c obj l
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 do
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 (Just 2) args
eval env cont args@(List [Atom "list-set!", Atom var, i, object]) = do
bound <- liftIO $ isRecBound env "list-set!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont $ createObjSetCPS var object updateList) i
eval env cont args@(List [Atom "list-set!" , nonvar , _ , _]) = do
bound <- liftIO $ isRecBound env "list-set!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "list-set!" : args)) = do
bound <- liftIO $ isRecBound env "list-set!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs (Just 3) 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 $ createObjSetCPS var object updateVector) i
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 (Just 3) args
eval env cont args@(List [Atom "bytevector-u8-set!", Atom var, i, object]) = do
bound <- liftIO $ isRecBound env "bytevector-u8-set!"
if bound
then prepareApply env cont args
else meval env (makeCPS env cont $ createObjSetCPS var object updateByteVector) i
eval env cont args@(List [Atom "bytevector-u8-set!" , nonvar , _ , _]) = do
bound <- liftIO $ isRecBound env "bytevector-u8-set!"
if bound
then prepareApply env cont args
else throwError $ TypeMismatch "variable" nonvar
eval env cont fargs@(List (Atom "bytevector-u8-set!" : args)) = do
bound <- liftIO $ isRecBound env "bytevector-u8-set!"
if bound
then prepareApply env cont fargs
else throwError $ NumArgs (Just 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]) = do
v <- getVar e var
derefVar <- derefPtr v
meval e (makeCPSWArgs e c cpsEvalH [key, value]) derefVar
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
updateObject 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 (Just 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 _ = do
value <- getVar e var
derefValue <- derefPtr value
meval e (makeCPSWArgs e c cpsEvalH $ [key]) derefValue
cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH e c h (Just [key]) = do
case h of
HashTable ht -> do
updateObject 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 (Just 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
replaceAtIndex :: forall a. Int -> a -> [a] -> [a]
replaceAtIndex n item ls = a ++ (item:b) where (a, (_:b)) = splitAt n ls
updateList :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateList (List list) (Number idx) obj = do
return $ List $ replaceAtIndex (fromInteger idx) obj list
updateList ptr@(Pointer _ _) i obj = do
list <- derefPtr ptr
updateList list i obj
updateList l _ _ = throwError $ TypeMismatch "list" l
updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)]
updateVector ptr@(Pointer _ _) i obj = do
vec <- derefPtr ptr
updateVector vec i obj
updateVector v _ _ = throwError $ TypeMismatch "vector" v
updateByteVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateByteVector (ByteVector vec) (Number idx) obj =
case obj of
Number byte -> do
let (h, t) = BS.splitAt (fromInteger idx) vec
return $ ByteVector $ BS.concat [h, BS.pack [fromInteger byte :: Word8], BS.tail t]
badType -> throwError $ TypeMismatch "byte" badType
updateByteVector ptr@(Pointer _ _) i obj = do
vec <- derefPtr ptr
updateByteVector vec i obj
updateByteVector v _ _ = throwError $ TypeMismatch "bytevector" v
createObjSetCPS :: String
-> LispVal
-> (LispVal -> LispVal -> LispVal -> ErrorT LispError IO LispVal)
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
createObjSetCPS var object updateFnc = cpsIndex
where
cpsUpdateStruct :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUpdateStruct e c struct (Just [idx, obj]) = do
value <- updateFnc struct idx obj >>= updateObject e var
continueEval e c value Nothing
cpsUpdateStruct _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateStruct"
cpsGetVar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsGetVar e c obj (Just [idx]) = (meval e (makeCPSWArgs e c cpsUpdateStruct [idx, obj]) =<< getVar e var)
cpsGetVar _ _ _ _ = throwError $ InternalError "Invalid argument to cpsGetVar"
cpsIndex :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsIndex e c idx _ = meval e (makeCPSWArgs e c cpsGetVar [idx]) object
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 args' = do
let args = case args' of
Just as -> as
Nothing -> []
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
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 a) = throwError $ Default $ "Unexpected error in function application (1) " ++ show a
cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)"
prepareApply _ _ _ = throwError $ Default "Unexpected error in prepareApply"
apply :: LispVal
-> LispVal
-> [LispVal]
-> IOThrowsError LispVal
apply _ cont@(Continuation env _ _ 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 = do
case (toInteger $ length args) of
0 -> throwError $ NumArgs (Just 1) []
1 -> continueEval e c (head args) Nothing
_ ->
continueEval e cont (head args) (Just $ tail args)
apply cont (IOFunc func) args = do
result <- func args
case cont of
Continuation cEnv _ _ _ -> continueEval cEnv cont result Nothing
_ -> return result
apply cont (CustFunc func) args = do
List dargs <- recDerefPtrs $ List args
result <- func dargs
case cont of
Continuation cEnv _ _ _ -> continueEval cEnv cont result Nothing
_ -> 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 Nothing
_ -> return result
apply cont (Func aparams avarargs abody aclosure) args =
if num aparams /= num args && isNothing avarargs
then throwError $ NumArgs (Just (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 null cBody
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) cwcDynWind) (Nil "") Nothing
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 && isNothing avarargs
then throwError $ NumArgs (Just (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 "") (Just [])
bindVarArgs arg env = case arg of
Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)]
Nothing -> return env
apply _ func args = do
List [func'] <- recDerefPtrs $ List [func]
List args' <- recDerefPtrs $ List 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)
nullEnvWithImport :: IO Env
nullEnvWithImport = nullEnv >>=
(flip extendEnv [
((varNamespace, "%import"), EvalFunc evalfuncImport),
((varNamespace, "hash-table-ref"), IOFunc $ wrapHashTbl hashTblRef)])
r5rsEnv :: IO Env
r5rsEnv = do
env <- r5rsEnv'
_ <- evalLisp' env $ List [Atom "%bootstrap-import"]
return env
r5rsEnv' :: IO Env
r5rsEnv' = do
env <- primitiveBindings
stdlib <- PHS.getDataFileName "lib/stdlib.scm"
srfi55 <- PHS.getDataFileName "lib/srfi/srfi-55.scm"
features <- getHuskFeatures
_ <- evalString env $ "(define *features* '" ++ show (List features) ++ ")"
_ <- evalString env $ "(load \"" ++ (escapeBackslashes stdlib) ++ "\")"
_ <- evalString env $ "(load \"" ++ (escapeBackslashes srfi55) ++ "\")"
registerExtensions env PHS.getDataFileName
#ifdef UseLibraries
metalib <- PHS.getDataFileName "lib/modules.scm"
metaEnv <- nullEnvWithParent env
_ <- evalString metaEnv $ "(load \"" ++ (escapeBackslashes metalib) ++ "\")"
_ <- evalLisp' env $ List [Atom "define", Atom "*meta-env*", LispEnv metaEnv]
_ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme"]], List [Atom "make-module", Bool False, LispEnv env , List [Atom "quote", List []]]]
timeEnv <- liftIO $ r7rsTimeEnv
_ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "time", Atom "posix"]], List [Atom "make-module", Bool False, LispEnv timeEnv, List [Atom "quote", List []]]]
_ <- evalLisp' metaEnv $ List [
Atom "define",
Atom "library-exists?",
List [Atom "quote",
IOFunc libraryExists]]
#endif
return env
r7rsEnv :: IO Env
r7rsEnv = do
env <- r7rsEnv'
_ <- evalLisp' env $ List [Atom "%bootstrap-import"]
return env
r7rsEnv' :: IO Env
r7rsEnv' = do
env <- primitiveBindings --baseBindings
features <- getHuskFeatures
_ <- evalString env $ "(define *features* '" ++ show (List features) ++ ")"
cxr <- PHS.getDataFileName "lib/cxr.scm"
_ <- evalString env $ "(load \"" ++ (escapeBackslashes cxr) ++ "\")"
core <- PHS.getDataFileName "lib/core.scm"
_ <- evalString env $ "(load \"" ++ (escapeBackslashes core) ++ "\")"
#ifdef UseLibraries
metalib <- PHS.getDataFileName "lib/modules.scm"
metaEnv <- nullEnvWithParent env
_ <- evalString metaEnv $ "(load \"" ++ (escapeBackslashes metalib) ++ "\")"
_ <- evalLisp' env $ List [Atom "define", Atom "*meta-env*", LispEnv metaEnv]
_ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme"]], List [Atom "make-module", Bool False, LispEnv env , List [Atom "quote", List []]]]
timeEnv <- liftIO $ r7rsTimeEnv
_ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "time", Atom "posix"]], List [Atom "make-module", Bool False, LispEnv timeEnv, List [Atom "quote", List []]]]
_ <- evalLisp' metaEnv $ List [
Atom "define",
Atom "library-exists?",
List [Atom "quote",
IOFunc libraryExists]]
#endif
return env
r7rsTimeEnv :: IO Env
r7rsTimeEnv = do
nullEnv >>=
(flip extendEnv
[ ((varNamespace, "current-second"), IOFunc currentTimestamp)])
evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind,
evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues,
evalfuncMakeEnv, evalfuncNullEnv, evalfuncUseParentEnv, evalfuncExit,
evalfuncInteractionEnv, evalfuncImport :: [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 _ ) _ _ = apply (Continuation e (Just (HaskellBody cpsAfter Nothing))
(Just (Continuation ce cc cnc
Nothing))
(Just [DynamicWinders beforeFunc afterFunc]))
thunkFunc []
cpsThunk _ _ _ _ = throwError $ Default "Unexpected error in cpsThunk during (dynamic-wind)"
cpsAfter _ c value _ = do
let cpsRetVals :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsRetVals e cc _ xargs = continueEval e cc value xargs
apply (makeCPS env c cpsRetVals) afterFunc []
evalfuncDynamicWind (_ : args) = throwError $ NumArgs (Just 3) args
evalfuncDynamicWind _ = throwError $ NumArgs (Just 3) []
evalfuncExit args@(cont : rest) = do
_ <- unchain cont
case rest of
[Bool False] -> evalfuncExitFail args
_ -> evalfuncExitSuccess args
where
unchain c@(Continuation _ _ cn _) = do
case cn of
(Just c'@(Continuation {})) -> do
_ <- execAfters c
unchain c'
_ -> execAfters c
unchain _ = return []
execAfters (Continuation e _ _ (Just dynamicWinders)) = do
mapM (\ (DynamicWinders _ afterFunc) ->
apply (makeNullContinuation e) afterFunc [])
dynamicWinders
execAfters _ = return []
evalfuncExit args = throwError $ InternalError $ "Invalid arguments to exit: " ++ show args
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 _ _ _ _) value (Just xargs) = apply c consumer (value : xargs)
cpsEval _ c value _ = apply c consumer [value]
evalfuncCallWValues (_ : args) = throwError $ NumArgs (Just 2) args
evalfuncCallWValues _ = throwError $ NumArgs (Just 2) []
evalfuncApply (cont@(Continuation {}) : func : args) = do
let aRev = reverse args
if null args
then throwError $ NumArgs (Just 2) args
else applyArgs $ head aRev
where
applyArgs aRev = do
case aRev of
List aLastElems -> do
apply cont func $ (init args) ++ aLastElems
Pointer _ _ -> do
derefPtr aRev >>= applyArgs
other -> throwError $ TypeMismatch "List" other
evalfuncApply (_ : args) = throwError $ NumArgs (Just 2) args
evalfuncApply _ = throwError $ NumArgs (Just 2) []
evalfuncMakeEnv (cont@(Continuation env _ _ _) : _) = do
e <- liftIO nullEnv
continueEval env cont (LispEnv e) Nothing
evalfuncMakeEnv _ = throwError $ NumArgs (Just 1) []
evalfuncNullEnv [cont@(Continuation env _ _ _), Number _] = do
nilEnv <- liftIO primitiveBindings
continueEval env cont (LispEnv nilEnv) Nothing
evalfuncNullEnv (_ : args) = throwError $ NumArgs (Just 1) args
evalfuncNullEnv _ = throwError $ NumArgs (Just 1) []
evalfuncInteractionEnv (cont@(Continuation env _ _ _) : _) = do
continueEval env cont (LispEnv env) Nothing
evalfuncInteractionEnv _ = throwError $ InternalError ""
evalfuncUseParentEnv ((Continuation env a b c) : _) = do
let parEnv = fromMaybe env (parentEnv env)
continueEval parEnv (Continuation parEnv a b c) (LispEnv parEnv) Nothing
evalfuncUseParentEnv _ = throwError $ InternalError ""
evalfuncImport [
cont@(Continuation env a b c),
toEnv,
LispEnv fromEnv,
imports,
_] = do
LispEnv toEnv' <-
case toEnv of
LispEnv _ -> return toEnv
Bool False -> do
case parentEnv env of
Just env' -> return $ LispEnv env'
Nothing -> throwError $ InternalError "import into empty env"
_ -> throwError $ InternalError ""
case imports of
List [Bool False] -> do
exportAll toEnv'
Bool False -> do
exportAll toEnv'
p@(Pointer _ _) -> do
List i <- derefPtr p
result <- moduleImport toEnv' fromEnv i
continueEval env cont result Nothing
List i -> do
result <- moduleImport toEnv' fromEnv i
continueEval env cont result Nothing
_ -> throwError $ InternalError ""
where
exportAll toEnv' = do
newEnv <- liftIO $ importEnv toEnv' fromEnv
continueEval
env
(Continuation env a b c)
(LispEnv newEnv)
Nothing
evalfuncImport ((Continuation {} ) : cs) = do
throwError $ TypeMismatch "import fields" $ List cs
evalfuncImport _ = throwError $ InternalError ""
bootstrapImport :: [LispVal] -> ErrorT LispError IO LispVal
bootstrapImport [cont@(Continuation env _ _ _)] = do
LispEnv me <- getVar env "*meta-env*"
ri <- getNamespacedVar me macroNamespace "repl-import"
renv <- defineNamespacedVar env macroNamespace "import" ri
continueEval env cont renv Nothing
bootstrapImport _ = throwError $ InternalError ""
evalfuncLoad (cont : p@(Pointer _ _) : lvs) = do
lv <- derefPtr p
evalfuncLoad (cont : lv : lvs)
evalfuncLoad [(Continuation _ a b c), String filename, LispEnv env] = do
evalfuncLoad [Continuation env a b c, String filename]
evalfuncLoad [cont@(Continuation env _ _ _), String filename] = do
filename' <- findFileOrLib filename
results <- load filename' >>= mapM (meval env (makeNullContinuation env))
if not (null results)
then do result <- return . last $ results
continueEval env cont result Nothing
else return $ Nil ""
evalfuncLoad (_ : args) = throwError $ NumArgs (Just 1) args
evalfuncLoad _ = throwError $ NumArgs (Just 1) []
evalfuncEval [cont@(Continuation env _ _ _), val] = do
v <- derefPtr val
meval env cont v
evalfuncEval [cont@(Continuation {}), val, LispEnv env] = do
v <- derefPtr val
meval env cont v
evalfuncEval (_ : args) = throwError $ NumArgs (Just 1) args
evalfuncEval _ = throwError $ NumArgs (Just 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 Nothing
_ -> return result
Func _ (Just _) _ _ -> apply cont func [cont]
Func aparams _ _ _ ->
if toInteger (length aparams) == 1
then apply cont func [cont]
else throwError $ NumArgs (Just (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 (Just (toInteger $ length aparams)) [cont]
other -> throwError $ TypeMismatch "procedure" other
evalfuncCallCC (_ : args) = throwError $ NumArgs (Just 1) args
evalfuncCallCC _ = throwError $ NumArgs (Just 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)
, ("exit", evalfuncExit)
, ("eval", evalfuncEval)
, ("load", evalfuncLoad)
, ("null-environment", evalfuncNullEnv)
, ("current-environment", evalfuncInteractionEnv)
, ("interaction-environment", evalfuncInteractionEnv)
, ("make-environment", evalfuncMakeEnv)
#ifdef UseFfi
, ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI)
#endif
#ifdef UseLibraries
, ("%import", evalfuncImport)
, ("%bootstrap-import", bootstrapImport)
#endif
, ("%husk-switch-to-parent-environment", evalfuncUseParentEnv)
, ("exit-fail", evalfuncExitFail)
, ("exit-success", evalfuncExitSuccess)
]