husk-scheme 3.15 → 3.15.1
raw patch · 19 files changed
+364/−206 lines, 19 files
Files
- AUTHORS +2/−0
- ChangeLog.markdown +14/−0
- hs-src/Compiler/huskc.hs +16/−18
- hs-src/Interpreter/shell.hs +32/−11
- hs-src/Language/Scheme/Compiler.hs +64/−62
- hs-src/Language/Scheme/Compiler/Libraries.hs +68/−25
- hs-src/Language/Scheme/Compiler/Types.hs +3/−1
- hs-src/Language/Scheme/Core.hs +25/−17
- hs-src/Language/Scheme/Environments.hs +3/−5
- hs-src/Language/Scheme/Libraries.hs +1/−3
- hs-src/Language/Scheme/Macro.hs +15/−10
- hs-src/Language/Scheme/Macro/ExplicitRenaming.hs +22/−9
- hs-src/Language/Scheme/Numerical.hs +14/−5
- hs-src/Language/Scheme/Parser.hs +29/−10
- hs-src/Language/Scheme/Primitives.hs +24/−14
- hs-src/Language/Scheme/Types.hs +1/−2
- hs-src/Language/Scheme/Util.hs +12/−1
- hs-src/Language/Scheme/Variables.hs +18/−12
- husk-scheme.cabal +1/−1
AUTHORS view
@@ -7,6 +7,8 @@ Arseniy <https://github.com/Rotsor> Eli Barzilay <eli@barzilay.org> Ricardo Lanziano <ricardo.lanziano@gmail.com>+ SaitoAtsushi <https://github.com/SaitoAtsushi>+ sw2wolf <https://github.com/sw2wolf> References: Write Yourself a Scheme in 48 Hours <http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours>
ChangeLog.markdown view
@@ -1,3 +1,17 @@+v3.15.1+--------++This is a small bug fix release:++- Preserve macro hygiene when using code that contains explicit renaming macros contained within syntax-rules macros. Previously, the syntax-rules system would not pass renamed variables across to the ER system. So an identifier could be renamed by syntax-rules but the ER macro would then have no knowledge of the rename and would be unable to use `rename` to make the identifier hygienic. For example, the code:++ (let ((unquote 'foo)) `(,'bar))++ Should evaluate to `((unquote (quote bar)))`.++- Added support for multi-line input to `huski`.+- Fixed GHC compiler warnings when building with `-Wall`.+ v3.15 --------
hs-src/Compiler/huskc.hs view
@@ -21,7 +21,7 @@ import System.Console.GetOpt import System.FilePath (dropExtension) import System.Environment-import System.Exit (ExitCode (..), exitWith, exitFailure)+import System.Exit (ExitCode (..), exitWith) import System.IO main :: IO ()@@ -29,7 +29,7 @@ -- Read command line args and process options args <- getArgs- let (actions, nonOpts, msgs) = getOpt Permute options args+ let (actions, nonOpts, _) = getOpt Permute options args opts <- foldl (>>=) (return defaultOptions) actions let Options {optOutput = output, optLibs = lib, optDynamic = dynamic, optCustomOptions = extra, optSchemeRev = langrev} = opts @@ -39,10 +39,10 @@ let inFile = nonOpts !! 0 outHaskell = (dropExtension inFile) ++ ".hs" outExec = case output of- Just inFile -> inFile+ Just inFile' -> inFile' Nothing -> dropExtension inFile extraOpts = case extra of- Just args -> args+ Just args' -> args' Nothing -> "" -- TODO: pass language revision process inFile outHaskell outExec lib dynamic extraOpts langrev@@ -84,18 +84,14 @@ Option [] ["debug"] (NoArg showDebug) "show debug information", Option [] ["nolibs"] (NoArg getNoLibs) "a DEBUG option to use interpreted libraries instead of compiling them" ]--writeRxRSVersion arg opt = return opt { optSchemeRev = arg }---- |Determine executable file to write. --- This version just takes a name from the command line option-writeExec arg opt = return opt { optOutput = Just arg }--getNoLibs opt = return opt { optLibs = False }--getDynamic opt = return opt { optDynamic = True }--getExtraArgs arg opt = return opt { optCustomOptions = Just arg }+ where+ writeRxRSVersion arg opt = return opt { optSchemeRev = arg }+ -- |Determine executable file to write. + -- This version just takes a name from the command line option+ writeExec arg opt = return opt { optOutput = Just arg }+ getNoLibs opt = return opt { optLibs = False }+ getDynamic opt = return opt { optDynamic = True }+ getExtraArgs arg opt = return opt { optCustomOptions = Just arg } -- TODO: would nice to have this as well as a 'real' usage printout, perhaps via --help @@ -161,6 +157,7 @@ compileSchemeFile env stdlib srfi55 filename outHaskell langrev = do let conv :: LispVal -> String conv (String s) = s+ conv l = show l compileLibraries = case stdlib of Just _ -> True _ -> False@@ -168,7 +165,7 @@ -- TODO: clean this up later --moduleFile <- liftIO $ getDataFileName "lib/modules.scm" - (String nextFunc, libsC, libSrfi55C, libModules) <- case (stdlib, langrev) of+ (String nextFunc, libsC, libSrfi55C, _) <- case (stdlib, langrev) of (Just stdlib', "5") -> do -- TODO: it is only temporary to compile the standard library each time. It should be -- precompiled and just added during the ghc compilation@@ -190,7 +187,7 @@ outH <- liftIO $ openFile outHaskell WriteMode _ <- liftIO $ writeList outH headerComment _ <- liftIO $ writeList outH headerModule- _ <- liftIO $ writeList outH $ map (\mod -> "import " ++ mod ++ " ") $ headerImports ++ moreHeaderImports+ _ <- liftIO $ writeList outH $ map (\modl -> "import " ++ modl ++ " ") $ headerImports ++ moreHeaderImports filepath <- liftIO $ getDataFileName "" _ <- liftIO $ writeList outH $ header filepath compileLibraries langrev _ <- liftIO $ case compileLibraries of@@ -223,6 +220,7 @@ ExitSuccess -> return () -- |Helper function to write a list of abstract Haskell code to file+writeList :: Handle -> [String] -> IO () writeList outH (l : ls) = do hPutStrLn outH l writeList outH ls
hs-src/Interpreter/shell.hs view
@@ -12,27 +12,25 @@ -} module Main where-import Paths_husk_scheme import qualified Language.Scheme.Core as LSC -- Scheme Interpreter import Language.Scheme.Types -- Scheme data types-import qualified Language.Scheme.Util as LSU (strip)+import qualified Language.Scheme.Util as LSU (countAllLetters, strip) import qualified Language.Scheme.Variables as LSV -- Scheme variable operations import Control.Monad.Error import qualified Data.Char as DC import qualified Data.List as DL-import System.Cmd (system) import System.Console.GetOpt import qualified System.Console.Haskeline as HL import qualified System.Console.Haskeline.Completion as HLC import System.Environment-import System.Exit (ExitCode (..), exitWith, exitFailure)+import System.Exit (ExitCode (..), exitWith) import System.IO main :: IO () main = do args <- getArgs - let (actions, nonOpts, msgs) = getOpt Permute options args+ let (actions, nonOpts, _) = getOpt Permute options args opts <- foldl (>>=) (return defaultOptions) actions let Options {optSchemeRev = schemeRev} = opts @@ -60,8 +58,8 @@ Option ['r'] ["revision"] (ReqArg writeRxRSVersion "Scheme") "scheme RxRS version", Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information" ]--writeRxRSVersion arg opt = return opt { optSchemeRev = arg }+ where+ writeRxRSVersion arg opt = return opt { optSchemeRev = arg } showHelp :: Options -> IO Options showHelp _ = do@@ -94,6 +92,7 @@ runOne "7" args = runOneWenv LSC.r7rsEnv args runOne _ args = runOneWenv LSC.r5rsEnv args +runOneWenv :: IO Env -> [String] -> IO () runOneWenv initEnv args = do env <- initEnv >>= flip LSV.extendEnv [((LSV.varNamespace, "args"),@@ -124,10 +123,11 @@ runReplWenv env runReplWenv :: Env -> IO ()-runReplWenv env = do- let settings = HL.Settings (completeScheme env) Nothing True- HL.runInputT settings (loop env)+runReplWenv env' = do+ let settings = HL.Settings (completeScheme env') Nothing True+ HL.runInputT settings (loop env') where+ -- Main REPL loop loop :: Env -> HL.InputT IO () loop env = do minput <- HL.getInputLine "huski> "@@ -138,13 +138,34 @@ "quit" -> return () "" -> loop env -- ignore inputs of just whitespace input -> do- result <- liftIO (LSC.evalString env input)+ inputLines <- getMultiLine [input]+ let input' = unlines inputLines+ result <- liftIO (LSC.evalString env input') if (length result) > 0 then do HL.outputStrLn result loop env else loop env + -- Read another input line, if necessary+ getMultiLine previous = do+ if test previous+ then do+ mb_input <- HL.getInputLine ""+ case mb_input of+ Nothing -> return previous+ Just input -> getMultiLine $ previous ++ [input]+ else return previous++ -- Check if we need another input line+ -- This just does a bare minimum, and could be more robust+ test ls = do+ let cOpen = LSU.countAllLetters '(' ls+ cClose = LSU.countAllLetters ')' ls+ cOpen > cClose+ -- |Auto-complete using scheme symbols+completeScheme :: Env -> (String, String) + -> IO (String, [HLC.Completion]) completeScheme env (lnL, lnR) = do complete $ reverse $ readAtom lnL where
hs-src/Language/Scheme/Compiler.hs view
@@ -52,21 +52,15 @@ import Language.Scheme.Compiler.Libraries as LSCL import Language.Scheme.Compiler.Types import qualified Language.Scheme.Core as LSC - (apply, evalLisp, evalString, findFileOrLib, meval, nullEnvWithImport, - primitiveBindings, r5rsEnv, version) + (apply, evalLisp, findFileOrLib) import qualified Language.Scheme.Macro import Language.Scheme.Primitives import Language.Scheme.Types-import qualified Language.Scheme.Util (escapeBackslashes) import Language.Scheme.Variables import Control.Monad.Error-import qualified Data.Array-import qualified Data.ByteString as BS import Data.Complex import qualified Data.List-import qualified Data.Map import Data.Ratio-import Data.Word -- import Debug.Trace -- |Perform one-time initialization of the compiler's environment@@ -132,14 +126,14 @@ _ <- defineVar env v $ Number 0 -- For now, actual value does not matter defineLambdaVars env vs defineLambdaVars env (_ : vs) = defineLambdaVars env vs-defineLambdaVars env [] = return $ Nil ""+defineLambdaVars _ [] = return $ Nil "" -- |Find all variables defined at "this" level and load their symbols into -- the environment. This allows the compiler validation to work even -- though a variable is used in a sub-form before it is defined further -- on down in the program defineTopLevelVars :: Env -> [LispVal] -> IOThrowsError LispVal-defineTopLevelVars env (List [Atom "define", Atom var, form] : ls) = do+defineTopLevelVars env (List [Atom "define", Atom var, _] : ls) = do _ <- defineTopLevelVar env var defineTopLevelVars env ls defineTopLevelVars env ((List (Atom "define" : List (Atom var : _) : _)) : ls) = do@@ -151,6 +145,7 @@ defineTopLevelVars env (_ : ls) = defineTopLevelVars env ls defineTopLevelVars _ _ = return nullLisp +defineTopLevelVar :: Env -> String -> IOThrowsError LispVal defineTopLevelVar env var = do defineVar env var $ Number 0 -- Actual value not loaded at the moment @@ -160,8 +155,8 @@ compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST] -- Experimenting with r7rs library support compile env - ast@(List (Atom "import" : mods)) - copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (List (Atom "import" : mods)) + copts@(CompileOptions _ _ _ _) = do LispEnv meta <- getVar env "*meta-env*" LSCL.importAll env meta @@ -226,14 +221,14 @@ -- A non-standard way to rebind a macro to another keyword compile env - ast@(List [Atom "define-syntax", + (List [Atom "define-syntax", Atom newKeyword, Atom keyword]) copts = do bound <- getNamespacedVar' env macroNamespace keyword case bound of Just m -> do- defineNamespacedVar env macroNamespace newKeyword m+ _ <- defineNamespacedVar env macroNamespace newKeyword m compFunc <- return $ [ AstValue $ " bound <- getNamespacedVar' env macroNamespace \"" ++ keyword ++ "\"",@@ -328,7 +323,7 @@ compConsequence ++ compAlternate) compile env ast@(List [Atom "set!", Atom var, form]) copts@(CompileOptions _ _ _ _) = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symDefine <- _gensym "setFunc" Atom symMakeDefine <- _gensym "setFuncMakeSet" @@ -343,18 +338,18 @@ return $ [entryPt] ++ compDefine ++ [compMakeDefine]) compile env ast@(List [Atom "set!", nonvar, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "set!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts -- Cheesy to use a string, but fine for now... return [f]) compile env ast@(List [Atom "define", Atom var, form]) copts@(CompileOptions _ _ _ _) = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symDefine <- _gensym "defineFuncDefine" Atom symMakeDefine <- _gensym "defineFuncMakeDef" @@ -364,7 +359,7 @@ -- WORKAROUND #1 -- Special case to support require-extension- case form of+ _ <- case form of List [Atom "current-environment"] -> defineVar env var $ LispEnv env _ -> return $ Nil "" @@ -383,7 +378,7 @@ compile env ast@(List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions _ _ _ _) = do _ <- validateFuncParams fparams Nothing- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do bodyEnv <- liftIO $ extendEnv env [] -- bind lambda params in the extended env _ <- defineLambdaVars bodyEnv (Atom var : fparams)@@ -410,7 +405,7 @@ ast@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions _ _ _ _) = do _ <- validateFuncParams (fparams ++ [varargs]) Nothing- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do bodyEnv <- liftIO $ extendEnv env [] -- bind lambda params in the extended env _ <- defineLambdaVars bodyEnv $ (Atom var : fparams) ++ [varargs]@@ -434,7 +429,7 @@ compile env ast@(List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions _ _ _ _) = do _ <- validateFuncParams fparams Nothing- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams @@ -455,7 +450,7 @@ compile env ast@(List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions _ _ _ _) = do _ <- validateFuncParams (fparams ++ [varargs]) Nothing- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams @@ -474,7 +469,7 @@ compile env ast@(List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions _ _ _ _) = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" bodyEnv <- liftIO $ extendEnv env []@@ -491,7 +486,7 @@ return $ [createAstFunc copts f] ++ compiledBody) compile env ast@(List [Atom "string-set!", Atom var, i, character]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symDefine <- _gensym "stringSetFunc" Atom symMakeDefine <- _gensym "stringSetFuncMakeSet" Atom symChr <- _gensym "stringSetChar"@@ -512,18 +507,18 @@ return $ [entryPt, compDefine, compMakeDefine] ++ compI ++ compChr) compile env ast@(List [Atom "string-set!", nonvar, _, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "string-set!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "string-set!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "string-set!" ("throwError $ NumArgs 3 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "set-car!", Atom var, argObj]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symGetVar <- _gensym "setCarGetVar" Atom symCompiledObj <- _gensym "setCarCompiledObj" Atom symObj <- _gensym "setCarObj"@@ -574,18 +569,18 @@ return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj) compile env ast@(List [Atom "set-car!", nonvar, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "set-car!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "set-car!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "set-car!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "set-cdr!", Atom var, argObj]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symGetVar <- _gensym "setCdrGetVar" Atom symCompiledObj <- _gensym "setCdrCompiledObj" Atom symObj <- _gensym "setCdrObj"@@ -643,18 +638,18 @@ return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj) compile env ast@(List [Atom "set-cdr!", nonvar, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "set-cdr!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "set-cdr!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "set-cdr!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "list-set!", Atom var, i, object]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCompiledIdx <- _gensym "listSetIdx" Atom symCompiledObj <- _gensym "listSetObj" Atom symUpdateVec <- _gensym "listSetUpdate"@@ -676,18 +671,18 @@ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj) compile env ast@(List [Atom "list-set!", nonvar, _, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "list-set!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "list-set!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "list-set!" ("throwError $ NumArgs 3 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "vector-set!", Atom var, i, object]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCompiledIdx <- _gensym "vectorSetIdx" Atom symCompiledObj <- _gensym "vectorSetObj" Atom symUpdateVec <- _gensym "vectorSetUpdate"@@ -709,19 +704,19 @@ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj) compile env ast@(List [Atom "vector-set!", nonvar, _, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "vector-set!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "vector-set!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "vector-set!" ("throwError $ NumArgs 3 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "bytevector-u8-set!", Atom var, i, object]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCompiledIdx <- _gensym "bytevectorSetIdx" Atom symCompiledObj <- _gensym "bytevectorSetObj" Atom symUpdateVec <- _gensym "bytevectorSetUpdate"@@ -743,18 +738,18 @@ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj) compile env ast@(List [Atom "bytevector-u8-set!", nonvar, _, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "bytevector-u8-set!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "bytevector-u8-set!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "bytevector-u8-set!" ("throwError $ NumArgs 3 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCompiledIdx <- _gensym "hashTableSetIdx" Atom symCompiledObj <- _gensym "hashTableSetObj" Atom symUpdateVec <- _gensym "hashTableSetUpdate"@@ -778,18 +773,18 @@ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj) compile env ast@(List [Atom "hash-table-set!", nonvar, _, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "hash-table-set!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "hash-table-set!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "hash-table-set!" ("throwError $ NumArgs 3 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List [Atom "hash-table-delete!", Atom var, rkey]) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do Atom symCompiledIdx <- _gensym "hashTableDeleteIdx" Atom symDoDelete <- _gensym "hashTableDelete" @@ -808,18 +803,18 @@ return $ [entryPt, compiledUpdate] ++ compiledIdx) compile env ast@(List [Atom "hash-table-delete!", nonvar, _]) copts = do - compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "hash-table-delete!" ("throwError $ TypeMismatch \"variable\"" ++ " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "hash-table-delete!" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do f <- compileSpecialForm "hash-table-delete!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts return [f]) compile env ast@(List (Atom "%import" : args)) copts = do- compileSpecialFormBody env ast copts (\ nextFunc -> do+ compileSpecialFormBody env ast copts (\ _ -> do throwError $ NotImplemented $ "%import, with args: " ++ show args) compile env (List [a@(Atom "husk-interpreter?")]) copts = do@@ -931,7 +926,7 @@ -> IOThrowsError [HaskAST] -- ^ Code generated by the continuation, along with the code -- added to divert vars to the compiled program-divertVars env expanded copts@(CompileOptions tfnc uvar uargs nfnc) func = do+divertVars env expanded copts@(CompileOptions _ uvar uargs nfnc) func = do vars <- Language.Scheme.Macro.getDivertedVars env case vars of [] -> func env expanded copts@@ -945,8 +940,8 @@ -- divert them into the env at runtime compileDivertedVars :: String -> Env -> [LispVal] -> CompOpts -> IOThrowsError HaskAST compileDivertedVars - formNext env vars - copts@(CompileOptions thisFunc useVal useArgs nextFunc) = do+ formNext _ vars + copts@(CompileOptions _ useVal useArgs _) = do let val = case useVal of True -> "value" _ -> "Nil \"\""@@ -956,6 +951,7 @@ comp (List [Atom renamed, Atom orig]) = do [AstValue $ " v <- getVar env \"" ++ orig ++ "\"", AstValue $ " _ <- defineVar env \"" ++ renamed ++ "\" v"]+ comp _ = [] cvars = map comp vars f = (concat cvars) ++ [AstValue $ " " ++ formNext ++ " env cont (" ++ val ++ ") " ++ args]@@ -968,21 +964,27 @@ -- | Helper function for compiling a special form compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST-compileSpecialForm formName formCode copts = do+compileSpecialForm _ formCode copts = do f <- return $ [ AstValue $ " " ++ formCode] return $ createAstFunc copts f -- |A wrapper for each special form that allows the form variable -- (EG: "if") to be redefined at compile time+compileSpecialFormBody :: Env+ -> LispVal+ -> CompOpts+ -> (Maybe String -> ErrorT LispError IO [HaskAST])+ -> ErrorT LispError IO [HaskAST] compileSpecialFormBody env - ast@(List (Atom fnc : args)) + ast@(List (Atom fnc : _)) copts@(CompileOptions _ _ _ nextFunc) spForm = do isDefined <- liftIO $ isRecBound env fnc case isDefined of True -> mfunc env ast compileApply copts False -> spForm nextFunc+compileSpecialFormBody _ _ _ _ = throwError $ InternalError "compileSpecialFormBody" -- | Compile an intermediate expression (such as an arg to if) and -- call into the next continuation with it's value@@ -1044,10 +1046,10 @@ vars i pack [] strs vars _ = (strs, vars)- let (paramStrs, vars) = pack args [] [] 0+ let (paramStrs, vars) = pack args [] [] (0::Int) _compileFuncLitArgs func vars $ "[" ++ joinL paramStrs "," ++ "]" - _compileFuncLitArgs func vars args = do+ _compileFuncLitArgs fnc vars args = do Atom stubFunc <- _gensym "applyStubF" Atom nextFunc <- _gensym "applyNextF" @@ -1055,7 +1057,7 @@ AstFunction coptsThis " env cont _ _ " [ AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ nextFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] - _comp <- mcompile env func $ CompileOptions stubFunc False False Nothing+ _comp <- mcompile env fnc $ CompileOptions stubFunc False False Nothing -- Haskell variables must be used to retrieve each atom from the env let varLines = @@ -1076,7 +1078,7 @@ return $ [c] ++ _comp ++ rest -- |Compile function and args as a chain of continuations- compileAllArgs func = do+ compileAllArgs func' = do Atom stubFunc <- _gensym "applyStubF" Atom wrapperFunc <- _gensym "applyWrapper" Atom nextFunc <- _gensym "applyNextF"@@ -1090,7 +1092,7 @@ AstFunction wrapperFunc " env cont value _ " [ AstValue $ " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " [value]) $ Nil \"\""]- _comp <- mcompile env func $ CompileOptions stubFunc False False Nothing+ _comp <- mcompile env func' $ CompileOptions stubFunc False False Nothing rest <- case fparams of [] -> do@@ -1129,13 +1131,13 @@ then return $ AstValue $ thisFunc ++ " env cont value (Just args) = do " else return $ AstValue $ thisFunc ++ " env cont _ (Just args) = do " c <- do- let nextCont = case (lastArg, coptsNext) of+ let nextCont' = case (lastArg, coptsNext) of (True, Just fnextExpr) -> "(makeCPS env cont " ++ fnextExpr ++ ")" _ -> "cont" if thisFuncUseValue- then return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env " ++ nextCont ++ " " +++ then return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env " ++ nextCont' ++ " " ++ nextFunc ++ " $ args ++ [value]) " ++ stubFunc ++ ") $ Nil\"\"" - else return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env " ++ nextCont ++ " " +++ else return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env " ++ nextCont' ++ " " ++ nextFunc ++ " args) " ++ stubFunc ++ ") $ Nil\"\"" rest <- case lastArg of@@ -1166,7 +1168,7 @@ -- _collectLiterals :: [LispVal] -> [LispVal] -> Bool -> (Maybe [LispVal]) _collectLiterals (List _ : _) _ _ = Nothing-_collectLiterals (Atom a : as) _ False = Nothing+_collectLiterals (Atom _ : _) _ False = Nothing _collectLiterals (a : as) nfs varFlag = _collectLiterals as (a : nfs) varFlag _collectLiterals [] nfs _ = Just $ reverse nfs
hs-src/Language/Scheme/Compiler/Libraries.hs view
@@ -39,10 +39,10 @@ -> IOThrowsError [HaskAST] -- ^ Compiled code importAll env metaEnv [m] lopts - copts@(CompileOptions thisFunc _ _ lastFunc) = do+ copts@(CompileOptions _ _ _ _) = do _importAll env metaEnv m lopts copts importAll env metaEnv (m : ms) lopts- copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (CompileOptions thisFunc _ _ lastFunc) = do Atom nextFunc <- _gensym "importAll" c <- _importAll env metaEnv m lopts $ CompileOptions thisFunc False False (Just nextFunc)@@ -54,6 +54,12 @@ return $ c ++ rest ++ stub importAll _ _ [] _ _ = return [] +_importAll :: Env+ -> Env+ -> LispVal+ -> CompLibOpts+ -> CompOpts+ -> ErrorT LispError IO [HaskAST] _importAll env metaEnv m lopts copts = do -- Resolve import resolved <- LSC.evalLisp metaEnv $ @@ -66,8 +72,15 @@ err -> throwError $ TypeMismatch "module/import" err -- |Import a single module+importModule :: Env+ -> Env+ -> LispVal+ -> [LispVal]+ -> CompLibOpts+ -> CompOpts+ -> ErrorT LispError IO [HaskAST] importModule env metaEnv moduleName imports lopts - copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (CompileOptions thisFunc _ _ lastFunc) = do Atom symImport <- _gensym "importFnc" -- Load module@@ -138,14 +151,14 @@ -> IOThrowsError [HaskAST] -- ^ Compiled code, or an empty list if the module was already compiled -- and loaded into memory-loadModule metaEnv name lopts copts@(CompileOptions thisFunc _ _ lastFunc) = do+loadModule metaEnv name lopts copts@(CompileOptions _ _ _ _) = do -- Get the module definition, or load it from file if necessary- mod' <- eval metaEnv $ List [Atom "find-module", List [Atom "quote", name]]- case mod' of+ _mod' <- eval metaEnv $ List [Atom "find-module", List [Atom "quote", name]]+ case _mod' of Bool False -> return [] -- Even possible to reach this line? _ -> do- mod <- recDerefPtrs mod'- modEnv <- LSC.evalLisp metaEnv $ List [Atom "module-env", mod]+ _mod <- recDerefPtrs _mod'+ modEnv <- LSC.evalLisp metaEnv $ List [Atom "module-env", _mod] case modEnv of Bool False -> do {-------------------------------------------@@ -175,9 +188,9 @@ -- Create new env for module, per eval-module newEnv <- liftIO $ LSC.nullEnvWithImport -- compile the module code, again per eval-module- result <- compileModule newEnv metaEnv name mod lopts $+ result <- compileModule newEnv metaEnv name _mod lopts $ CompileOptions symStartLoadNewEnv False False (Just symEndLoadNewEnv)- modWEnv <- eval metaEnv $ List (Atom "module-env-set!" : mod' : [LispEnv newEnv]) + modWEnv <- eval metaEnv $ List (Atom "module-env-set!" : _mod' : [LispEnv newEnv]) -- Above does not update *modules* correctly, so we del/add below _ <- eval metaEnv $ List [Atom "delete-module!", List [Atom "quote", name]] _ <- eval metaEnv $ List [Atom "add-module!", List [Atom "quote", name], modWEnv]@@ -187,19 +200,26 @@ [createAstFunc (CompileOptions symEndLoadNewEnv False False Nothing) [AstValue " return $ Nil \"\""]] ++ result- _ -> return [] --mod+ _ -> return [] --_mod -- |Compile the given module, using metadata loaded into memory. -- This code is based off of eval-module from the meta language.-compileModule env metaEnv name mod lopts - copts@(CompileOptions thisFunc _ _ lastFunc) = do+compileModule :: Env+ -> Env+ -> LispVal+ -> LispVal+ -> CompLibOpts+ -> CompOpts+ -> ErrorT LispError IO [HaskAST]+compileModule env metaEnv name _mod lopts + (CompileOptions thisFunc _ _ lastFunc) = do -- TODO: set mod meta-data to avoid cyclic references -- see modules.scm for how this is done by the interpreter Atom afterImportsFnc <- _gensym "modAfterImport"- Atom afterDirFunc <- _gensym "modAfterDir"+ --Atom afterDirFunc <- _gensym "modAfterDir" metaData <- LSC.evalLisp metaEnv $ - List [Atom "module-meta-data", List [Atom "quote", mod]]+ List [Atom "module-meta-data", List [Atom "quote", _mod]] moduleImports <- cmpSubMod env metaEnv metaData lopts $ CompileOptions thisFunc False False (Just afterImportsFnc)@@ -230,7 +250,7 @@ -- -- TODO: ideally stubs would not be necessary, -- should refactor out at some point---createFunctionStub :: String -> HaskAST+createFunctionStub :: String -> Maybe String -> HaskAST createFunctionStub thisFunc nextFunc = do createAstFunc (CompileOptions thisFunc True False Nothing) [createAstCont (CompileOptions "" True False nextFunc) @@ -238,6 +258,12 @@ -- |Compile sub-modules. That is, modules that are imported by -- another module in the (define-library) definition+cmpSubMod :: Env+ -> Env+ -> LispVal+ -> CompLibOpts+ -> CompOpts+ -> ErrorT LispError IO [HaskAST] cmpSubMod env metaEnv (List ((List (Atom "import-immutable" : modules)) : ls)) lopts copts = do -- Punt on this for now, although the meta-lang does the same thing@@ -245,7 +271,7 @@ (List ((List (Atom "import" : modules)) : ls)) lopts copts cmpSubMod env metaEnv (List ((List (Atom "import" : modules)) : ls)) lopts- copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (CompileOptions thisFunc _ _ lastFunc) = do Atom nextFunc <- _gensym "cmpSubMod" code <- importAll env metaEnv modules lopts $ CompileOptions thisFunc False False (Just nextFunc)@@ -261,9 +287,16 @@ return [createFunctionStub thisFunc lastFunc] -- |Compile module directives (expressions) in a module definition+cmpModExpr :: Env+ -> Env+ -> LispVal+ -> LispVal+ -> CompLibOpts+ -> CompOpts+ -> ErrorT LispError IO [HaskAST] cmpModExpr env metaEnv name (List ((List (Atom "include" : files)) : ls)) lopts@(CompileLibraryOptions _ compileLisp)- copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (CompileOptions thisFunc _ _ lastFunc) = do dir <- LSC.evalLisp metaEnv $ List [Atom "module-name-prefix", List [Atom "quote", name]] -- TODO: this pattern is common with the one below in "begin", @@ -282,6 +315,7 @@ let path = dir ++ filename path' <- LSC.findFileOrLib path compileLisp env path' entry exit+ compileInc _ _ _ _ = throwError $ InternalError "" cmpModExpr env metaEnv name (List ((List (Atom "include-ci" : code)) : ls)) lopts copts = do -- NOTE: per r7rs, ci should insert a fold-case directive. But husk does@@ -293,11 +327,11 @@ (List ((List (Atom "begin" : code)) : ls)) lopts copts cmpModExpr env metaEnv name- (List ((List (Atom "begin" : code)) : ls)) + (List ((List (Atom "begin" : code')) : ls)) lopts@(CompileLibraryOptions compileBlock _)- copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (CompileOptions thisFunc _ _ lastFunc) = do Atom nextFunc <- _gensym "cmpSubModNext"- code <- compileBlock thisFunc (Just nextFunc) env [] code+ code <- compileBlock thisFunc (Just nextFunc) env [] code' rest <- cmpModExpr env metaEnv name (List ls) lopts $ CompileOptions nextFunc False False lastFunc stub <- case rest of @@ -306,16 +340,25 @@ return $ code ++ rest ++ stub cmpModExpr env metaEnv name (List (_ : ls)) lopts copts = cmpModExpr env metaEnv name (List ls) lopts copts-cmpModExpr _ _ _ _ _ copts@(CompileOptions thisFunc _ _ lastFunc) =+cmpModExpr _ _ _ _ _ (CompileOptions thisFunc _ _ lastFunc) = return [createFunctionStub thisFunc lastFunc] -- |Include one or more files for compilation -- TODO: this pattern is used elsewhere (IE, importAll). could be generalized-includeAll env dir [file] include lopts- copts@(CompileOptions thisFunc _ _ lastFunc) = do+includeAll :: forall t t1 t2 t3.+ t+ -> t3+ -> [t2]+ -> (t3+ -> t2 -> String -> Maybe String -> ErrorT LispError IO [HaskAST])+ -> t1+ -> CompOpts+ -> ErrorT LispError IO [HaskAST]+includeAll _ dir [file] include _ --lopts+ (CompileOptions thisFunc _ _ lastFunc) = do include dir file thisFunc lastFunc includeAll env dir (f : fs) include lopts- copts@(CompileOptions thisFunc _ _ lastFunc) = do+ (CompileOptions thisFunc _ _ lastFunc) = do Atom nextFunc <- _gensym "includeAll" c <- include dir f thisFunc (Just nextFunc) rest <- includeAll env dir fs include lopts $
hs-src/Language/Scheme/Compiler/Types.hs view
@@ -13,7 +13,7 @@ module Language.Scheme.Compiler.Types ( -- * Data types- CompOpts (CompileOptions)+ CompOpts (..) , CompLibOpts (..) , defaultCompileOptions , HaskAST (..)@@ -77,6 +77,7 @@ } -- |Runtime reference to module data structure+moduleRuntimeVar :: [Char] moduleRuntimeVar = " modules " -- |Create code for a function@@ -165,6 +166,7 @@ ast2Str (List ls) = "List [" ++ joinL (map ast2Str ls) "," ++ "]" ast2Str (DottedList ls l) = "DottedList [" ++ joinL (map ast2Str ls) "," ++ "] $ " ++ ast2Str l+ast2Str l = show l -- Error? -- |Convert a list of abstract syntax trees to a list of strings asts2Str :: [LispVal] -> String
hs-src/Language/Scheme/Core.hs view
@@ -53,7 +53,6 @@ import Language.Scheme.Environments import Language.Scheme.Libraries import qualified Language.Scheme.Macro-import Language.Scheme.Numerical import Language.Scheme.Parser import Language.Scheme.Primitives import Language.Scheme.Types@@ -62,17 +61,15 @@ import Control.Monad.Error import Data.Array import qualified Data.ByteString as BS-import qualified Data.Char import qualified Data.Map import Data.Word import qualified System.Exit-import System.IO import qualified System.Info as SysInfo -- import Debug.Trace -- |husk version number version :: String-version = "3.15"+version = "3.15.1" -- |A utility function to display the husk console banner showBanner :: IO ()@@ -118,6 +115,7 @@ -- libraries. If the file is not found in the current directory but exists -- as a husk library, return the full path to the file in the library. -- Otherwise just return the given filename.+findFileOrLib :: [Char] -> ErrorT LispError IO String findFileOrLib filename = do fileAsLib <- liftIO $ getDataFileFullPath $ "lib/" ++ filename exists <- fileExists [String filename]@@ -410,12 +408,14 @@ e -> continueEval bodyEnv cont e -- A non-standard way to rebind a macro to another keyword-eval env cont args@(List [Atom "define-syntax", - Atom newKeyword,- Atom keyword]) = do+eval env cont (List [Atom "define-syntax", + Atom newKeyword,+ Atom keyword]) = do bound <- getNamespacedVar' env macroNamespace keyword case bound of- Just m -> defineNamespacedVar env macroNamespace newKeyword m+ Just m -> do+ _ <- defineNamespacedVar env macroNamespace newKeyword m+ continueEval env cont $ Nil "" Nothing -> throwError $ TypeMismatch "macro" $ Atom keyword eval env cont args@(List [Atom "define-syntax", Atom keyword,@@ -582,6 +582,7 @@ 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]) =@@ -835,6 +836,7 @@ -- |Replace a list element, by index. Taken from: -- http://stackoverflow.com/questions/10133361/haskell-replace-element-in-list+replaceAtIndex :: forall a. Int -> a -> [a] -> [a] replaceAtIndex n item ls = a ++ (item:b) where (a, (_:b)) = splitAt n ls -- |A helper function for /(list-set!)/@@ -1216,7 +1218,7 @@ case aRev of List aLastElems -> do apply cont func $ (init args) ++ aLastElems- Pointer pVar pEnv -> do+ Pointer _ _ -> do derefPtr aRev >>= applyArgs other -> throwError $ TypeMismatch "List" other evalfuncApply (_ : args) = throwError $ NumArgs (Just 2) args -- Skip over continuation argument@@ -1226,15 +1228,17 @@ evalfuncMakeEnv (cont@(Continuation env _ _ _ _) : _) = do e <- liftIO $ nullEnv continueEval env cont $ LispEnv e+evalfuncMakeEnv _ = throwError $ NumArgs (Just 1) [] -evalfuncNullEnv [cont@(Continuation env _ _ _ _), Number version] = do- nullEnv <- liftIO $ primitiveBindings- continueEval env cont $ LispEnv nullEnv+evalfuncNullEnv [cont@(Continuation env _ _ _ _), Number _] = do+ nilEnv <- liftIO $ primitiveBindings+ continueEval env cont $ LispEnv nilEnv evalfuncNullEnv (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument evalfuncNullEnv _ = throwError $ NumArgs (Just 1) [] evalfuncInteractionEnv (cont@(Continuation env _ _ _ _) : _) = do continueEval env cont $ LispEnv env+evalfuncInteractionEnv _ = throwError $ InternalError "" evalfuncImport [ cont@(Continuation env a b c d), @@ -1244,13 +1248,14 @@ _] = do LispEnv toEnv' <- case toEnv of- LispEnv e -> return toEnv+ LispEnv _ -> return toEnv Bool False -> do -- A hack to load imports into the main env, which -- in modules.scm is the parent env case parentEnv env of- Just env -> return $ LispEnv env+ Just env' -> return $ LispEnv env' Nothing -> throwError $ InternalError "import into empty env"+ _ -> throwError $ InternalError "" case imports of List [Bool False] -> do -- Export everything exportAll toEnv'@@ -1264,6 +1269,7 @@ List i -> do result <- moduleImport toEnv' fromEnv i continueEval env cont result+ _ -> throwError $ InternalError "" where exportAll toEnv' = do newEnv <- liftIO $ importEnv toEnv' fromEnv@@ -1273,22 +1279,24 @@ (LispEnv newEnv) -- This is just for debugging purposes:-evalfuncImport args@(cont@(Continuation env _ _ _ _ ) : cs) = do+evalfuncImport ((Continuation _ _ _ _ _ ) : cs) = do throwError $ TypeMismatch "import fields" $ List cs+evalfuncImport _ = throwError $ InternalError "" -- |Load import into the main environment+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-+bootstrapImport _ = throwError $ InternalError "" evalfuncLoad (cont : p@(Pointer _ _) : lvs) = do lv <- derefPtr p evalfuncLoad (cont : lv : lvs) -evalfuncLoad [cont@(Continuation _ a b c d), String filename, LispEnv env] = do+evalfuncLoad [(Continuation _ a b c d), String filename, LispEnv env] = do evalfuncLoad [Continuation env a b c d, String filename] evalfuncLoad [cont@(Continuation env _ _ _ _), String filename] = do
hs-src/Language/Scheme/Environments.hs view
@@ -19,14 +19,12 @@ import Language.Scheme.Numerical import Language.Scheme.Primitives import Language.Scheme.Types-import Language.Scheme.Util import Language.Scheme.Variables import Control.Monad.Error import qualified Data.Char import System.IO -{- I/O primitives-Primitive functions that execute within the IO monad -}+-- |Primitive functions that execute within the IO monad ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] ioPrimitives = [("open-input-file", makePort openFile ReadMode), ("open-binary-input-file", makePort openBinaryFile ReadMode),@@ -160,9 +158,9 @@ exportsFromEnv' [LispEnv env] = do result <- liftIO $ exportsFromEnv env return $ List result-exportsFromEnv' err = return $ List []+exportsFromEnv' _ = return $ List [] -{- "Pure" primitive functions -}+-- | Pure primitive functions primitives :: [(String, [LispVal] -> ThrowsError LispVal)] primitives = [("+", numAdd), ("-", numSub),
hs-src/Language/Scheme/Libraries.hs view
@@ -17,9 +17,7 @@ findModuleFile , moduleImport ) where-import qualified Paths_husk_scheme as PHS (getDataFileName) import Language.Scheme.Types-import Language.Scheme.Util import Language.Scheme.Variables import Control.Monad.Error @@ -70,7 +68,7 @@ moduleImport to from (DottedList [Atom iRenamed] (Atom iOrig) : is) = do _ <- divertBinding to from iOrig iRenamed moduleImport to from is-moduleImport to from [] = do+moduleImport to _ [] = do return $ LispEnv to moduleImport _ _ err = do throwError $ Default $ "Unexpected argument to moduleImport: " ++ show err
hs-src/Language/Scheme/Macro.hs view
@@ -128,13 +128,17 @@ - begins with the keyword for the macro." - -}-macroEval env lisp@(List (Atom x : _)) apply = do+macroEval env lisp@(List (Atom _ : _)) apply = do -- Keep track of diverted variables _ <- clearDivertedVars env _macroEval env lisp apply macroEval env lisp apply = _macroEval env lisp apply -- |Do the actual work for the 'macroEval' wrapper func+_macroEval :: Env+ -> LispVal+ -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)+ -> ErrorT LispError IO LispVal _macroEval env lisp@(List (Atom x : _)) apply = do -- Note: If there is a procedure of the same name it will be shadowed by the macro. var <- getNamespacedVar' env macroNamespace x@@ -143,7 +147,7 @@ -- Explicit Renaming Just (SyntaxExplicitRenaming transformer@(Func _ _ _ _)) -> do renameEnv <- liftIO $ nullEnv -- Local environment used just for this- expanded <- explicitRenamingTransform env renameEnv + expanded <- explicitRenamingTransform env renameEnv renameEnv lisp transformer apply _macroEval env expanded apply @@ -166,6 +170,7 @@ _macroEval env expanded apply -- Useful debug to see all exp's: -- macroEval env (trace ("exp = " ++ show expanded) expanded)+ Just _ -> throwError $ InternalError "_macroEval" Nothing -> return lisp -- No macro to process, just return code as it is...@@ -212,7 +217,7 @@ -- Determine if the next element in a list matches 0-to-n times due to an ellipsis macroElementMatchesMany :: LispVal -> String -> Bool-macroElementMatchesMany args@(List (_ : ps)) ellipsisSym = do+macroElementMatchesMany (List (_ : ps)) ellipsisSym = do if not (null ps) then (head ps) == (Atom ellipsisSym) else False@@ -318,7 +323,7 @@ Move past it, but keep the same input. -} then do case ps of- [Atom esym] -> return $ Bool True -- An otherwise empty list, so just let the caller know match is done+ [Atom _] -> return $ Bool True -- An otherwise empty list, so just let the caller know match is done _ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags esym else return $ Bool False -- There was a match@@ -449,7 +454,7 @@ checkLocal _ _ _ _ _ _ _ _ (Float pattern) (Float input) _ _ = return $ Bool $ pattern == input checkLocal _ _ _ _ _ _ _ _ (String pattern) (String input) _ _ = return $ Bool $ pattern == input checkLocal _ _ _ _ _ _ _ _ (Char pattern) (Char input) _ _ = return $ Bool $ pattern == input-checkLocal defEnv outerEnv _ localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags esym = do+checkLocal defEnv outerEnv _ localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags _ = do -- TODO: --@@ -792,7 +797,7 @@ renameEnvClosure <- liftIO $ copyEnv renameEnv _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax (Just useEnv) (Just renameEnvClosure) True "..." identifiers rules return $ Nil "" -- Sentinal value-walkExpandedAtom _ useEnv _ renameEnv _ _ True _ (List _)+walkExpandedAtom _ useEnv _ _ _ _ True _ (List _) "define-syntax" ([Atom keyword, (List [Atom "er-macro-transformer", @@ -912,7 +917,7 @@ erRenameEnv <- liftIO $ nullEnv -- Local environment used just for this -- Different than the syntax-rules rename env (??) expanded <- explicitRenamingTransform - useEnv erRenameEnv (List (Atom a : ts)) transformer apply+ useEnv erRenameEnv renameEnv (List (Atom a : ts)) transformer apply walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List result) expanded apply @@ -1009,7 +1014,7 @@ l <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True (List []) d apply cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False (List $ result ++ [DottedList ls l]) (List ts) apply -cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList (List result) (List (Atom a : ts)) apply = do+cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ (List result) (List (Atom a : ts)) apply = do expanded <- recExpandAtom cleanupEnv $ Atom a cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False (List $ result ++ [expanded]) (List ts) apply @@ -1224,7 +1229,7 @@ -- TODO: I think the outerEnv should be accessed by the walker, and not within rewrite as is done below... Nil input -> do v <- getVar outerEnv input return v- List v -> do+ List _ -> do if ellipsisLevel > 0 then -- Take all elements, instead of one-at-a-time return $ appendNil (Matches.getData var ellipsisIndex) @@ -1301,7 +1306,7 @@ -- transform is an atom - if it is a list then there is no way this case can be reached. -- So... we do not need to worry about pattern variables here. No need to port that code -- from the above case.-transformRule defEnv outerEnv divertEnv localEnv renameEnv _ dim identifiers esym _ _ _ (Atom transform) = do+transformRule defEnv outerEnv divertEnv localEnv renameEnv _ dim identifiers _ _ _ _ (Atom transform) = do Bool isIdent <- findAtom (Atom transform) identifiers isPattVar <- liftIO $ isRecBound localEnv transform if isPattVar && not isIdent
hs-src/Language/Scheme/Macro/ExplicitRenaming.hs view
@@ -28,25 +28,29 @@ import Language.Scheme.Variables import Language.Scheme.Primitives (_gensym) import Control.Monad.Error+-- import Debug.Trace -- |Handle an explicit renaming macro explicitRenamingTransform :: Env -- ^Environment where macro was used -> Env -- ^Temporary environment to store renamed variables+ -> Env -- ^Environment containing any variables renamed by syntax-rules -> LispVal -- ^Form to transform -> LispVal -- ^Macro transformer -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Eval func -> IOThrowsError LispVal-explicitRenamingTransform useEnv renameEnv lisp +explicitRenamingTransform useEnv renameEnv srRenameEnv lisp transformer@(Func _ _ _ defEnv) apply = do let continuation = makeNullContinuation useEnv result <- apply continuation transformer [lisp, - IOFunc $ exRename useEnv renameEnv defEnv, + IOFunc $ exRename useEnv renameEnv srRenameEnv defEnv, IOFunc $ exCompare useEnv renameEnv defEnv] recDerefPtrs result+explicitRenamingTransform _ _ _ _ _ _ = + throwError $ InternalError "explicitRenamingTransform" -- |The explicit renaming "rename" function --@@ -68,10 +72,15 @@ -- the sense of eqv?. It is an error if the renaming -- procedure is called after the transformation -- procedure has returned.-exRename :: Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal-exRename useEnv renameEnv defEnv [Atom a] = do- isDef <- liftIO $ isRecBound defEnv a- if isDef+exRename :: Env -> Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal+exRename useEnv _ srRenameEnv defEnv [Atom a] = do+ isSynRulesRenamed <- liftIO $ isRecBound srRenameEnv a++ if isSynRulesRenamed -- already renamed by syntax-rules, so just return it+ then getVar srRenameEnv a+ else do+ isDef <- liftIO $ isRecBound defEnv a+ if isDef then do -- NOTE: useEnv/'r' is used to store renamed variables due@@ -96,11 +105,15 @@ return $ Atom renamed else return $ Atom a-exRename _ _ _ form = throwError $ Default $ "Unable to rename: " ++ show form+exRename _ _ _ _ form = throwError $ Default $ "Unable to rename: " ++ show form -- |The explicit renaming "compare" function-exCompare :: Env -> Env -> Env -> [LispVal] -> IOThrowsError LispVal-exCompare useEnv renameEnv defEnv values@[a, b] = do+exCompare :: Env -- ^ Environment of use+ -> Env -- ^ Environment with renames+ -> Env -- ^ Environment of definition+ -> [LispVal] -- ^ Values to compare+ -> IOThrowsError LispVal+exCompare _ _ _ [a, b] = do return $ Bool $ eqVal a b exCompare _ _ _ form = throwError $ Default $ "Unable to compare: " ++ show form
hs-src/Language/Scheme/Numerical.hs view
@@ -176,6 +176,9 @@ -- |Compare a series of numbers using a given numeric comparison -- function and an array of lisp values+numBoolBinopCompare :: (LispVal+ -> LispVal -> Either LispError LispVal)+ -> LispVal -> [LispVal] -> Either LispError LispVal numBoolBinopCompare cmp n1 (n2 : ns) = do List [n1', n2'] <- numCast [n1, n2] result <- cmp n1' n2'@@ -529,14 +532,17 @@ num2String badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Determine if the given value is not a number isNumNaN :: [LispVal] -> ThrowsError LispVal isNumNaN ([Float n]) = return $ Bool $ isNaN n isNumNaN _ = return $ Bool False +-- | Determine if number is infinite isNumInfinite :: [LispVal] -> ThrowsError LispVal isNumInfinite ([Float n]) = return $ Bool $ isInfinite n isNumInfinite _ = return $ Bool False +-- | Determine if number is not infinite isNumFinite :: [LispVal] -> ThrowsError LispVal isNumFinite ([Number _]) = return $ Bool True isNumFinite ([Float n]) = return $ Bool $ not $ isInfinite n@@ -544,6 +550,7 @@ isNumFinite ([Rational _]) = return $ Bool True isNumFinite _ = return $ Bool False +-- | Determine if number is exact isNumExact :: [LispVal] -> ThrowsError LispVal isNumExact ([Number _]) = return $ Bool True isNumExact ([Float _]) = return $ Bool False@@ -551,11 +558,12 @@ isNumExact ([Rational _]) = return $ Bool True isNumExact _ = return $ Bool False +-- | Determine if number is inexact isNumInexact :: [LispVal] -> ThrowsError LispVal-isNumInexact n@([Number _]) = return $ Bool False-isNumInexact n@([Float _]) = return $ Bool True-isNumInexact n@([Complex _]) = return $ Bool True-isNumInexact n@([Rational _]) = return $ Bool False+isNumInexact ([Number _]) = return $ Bool False+isNumInexact ([Float _]) = return $ Bool True+isNumInexact ([Complex _]) = return $ Bool True+isNumInexact ([Rational _]) = return $ Bool False isNumInexact _ = return $ Bool False -- |Predicate to determine if given value is a number@@ -610,7 +618,8 @@ -- |A utility function to determine if given value is a floating point -- number representing an whole number (integer). isFloatAnInteger :: LispVal -> Bool-isFloatAnInteger (Float n) = (floor n) == (ceiling n)+isFloatAnInteger (Float n) = + ((floor n) :: Integer) == ((ceiling n) :: Integer) isFloatAnInteger _ = False -- - end Numeric operations section ---
hs-src/Language/Scheme/Parser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {- | Module : Language.Scheme.Parser@@ -56,8 +57,11 @@ import Numeric import Text.ParserCombinators.Parsec hiding (spaces) import Text.Parsec.Language---import Text.Parsec.Prim (ParsecT) import qualified Text.Parsec.Token as P+#if __GLASGOW_HASKELL__ >= 702+import Data.Functor.Identity (Identity)+import Text.Parsec.Prim (ParsecT)+#endif -- This was added by pull request #63 as part of a series of fixes -- to get husk to build on ghc 7.2.2@@ -81,25 +85,39 @@ , P.caseSensitive = True } ---lexer :: P.GenTokenParser String () Identity+#if __GLASGOW_HASKELL__ >= 702+lexer :: P.GenTokenParser String () Data.Functor.Identity.Identity+#endif lexer = P.makeTokenParser lispDef ---dot :: ParsecT String () Identity String+#if __GLASGOW_HASKELL__ >= 702+dot :: ParsecT String () Identity String+#endif dot = P.dot lexer ---parens :: ParsecT String () Identity a -> ParsecT String () Identity a+#if __GLASGOW_HASKELL__ >= 702+parens :: ParsecT String () Identity a -> ParsecT String () Identity a+#endif parens = P.parens lexer +#if __GLASGOW_HASKELL__ >= 702+brackets :: ParsecT String () Identity a -> ParsecT String () Identity a+#endif brackets = P.brackets lexer ---identifier :: ParsecT String () Identity String+#if __GLASGOW_HASKELL__ >= 702+identifier :: ParsecT String () Identity String+#endif identifier = P.identifier lexer --- TODO: typedef. starting point was: whiteSpace :: CharParser ()---whiteSpace :: ParsecT String () Identity ()+#if __GLASGOW_HASKELL__ >= 702+whiteSpace :: ParsecT String () Identity ()+#endif whiteSpace = P.whiteSpace lexer ---lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a+#if __GLASGOW_HASKELL__ >= 702+lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a+#endif lexeme = P.lexeme lexer -- |Match a special character@@ -141,7 +159,7 @@ "return" -> return $ Char '\n' "tab" -> return $ Char '\t' _ -> case (c : r) of- [c] -> return $ Char c+ [ch] -> return $ Char ch ('x' : hexs) -> do rv <- parseHexScalar hexs return $ Char rv@@ -303,6 +321,7 @@ _ -> return c -- |Parse a hexidecimal scalar+parseHexScalar :: Monad m => String -> m Char parseHexScalar num = do let ns = Numeric.readHex num case ns of@@ -330,7 +349,7 @@ return $ ByteVector $ BS.pack $ map conv ns where conv (Number n) = fromInteger n :: Word8- conv n = 0 :: Word8+ conv _ = 0 :: Word8 -- |Parse a hash table. The table is either empty or is made up of -- an alist (associative list)
hs-src/Language/Scheme/Primitives.hs view
@@ -170,6 +170,7 @@ #if __GLASGOW_HASKELL__ < 702 try' = try #else+try' :: IO a -> IO (Either IOError a) try' = tryIOError #endif @@ -250,6 +251,7 @@ isBinaryPort _ = return $ Bool False -- | Determine if a file handle is in text mode+isTextPort' :: Handle -> IO Bool isTextPort' port = do textEncoding <- hGetEncoding port case textEncoding of@@ -386,6 +388,8 @@ {- writeProc :: --forall a (m :: * -> *). (MonadIO m, MonadError LispError m) => (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -}+writeProc :: (Handle -> LispVal -> IO a)+ -> [LispVal] -> ErrorT LispError IO LispVal writeProc func [obj] = do dobj <- recDerefPtrs obj -- Last opportunity to do this before writing writeProc func [dobj, Port stdout]@@ -693,7 +697,7 @@ -- Returns: Vector -- buildVector :: [LispVal] -> ThrowsError LispVal-buildVector lst@(o : os) = do+buildVector lst@(_ : _) = do return $ Vector $ (listArray (0, length lst - 1)) lst buildVector badArgList = throwError $ NumArgs (Just 1) badArgList @@ -790,7 +794,7 @@ return $ ByteVector $ BS.pack $ map conv bs where conv (Number n) = fromInteger n :: Word8- conv n = 0 :: Word8+ conv _ = 0 :: Word8 byteVectorCopy :: [LispVal] -> IOThrowsError LispVal @@ -835,13 +839,10 @@ -- byteVectorAppend :: [LispVal] -> IOThrowsError LispVal byteVectorAppend bs = do- let acc = BS.pack []- conv :: LispVal -> IOThrowsError BSU.ByteString- conv p@(Pointer _ _) = do- bs <- derefPtr p- conv bs- conv (ByteVector bs) = return bs- conv x = return BS.empty+ let conv :: LispVal -> IOThrowsError BSU.ByteString+ conv p@(Pointer _ _) = derefPtr p >>= conv+ conv (ByteVector bvs) = return bvs+ conv _ = return BS.empty bs' <- mapM conv bs return $ ByteVector $ BS.concat bs' -- TODO: error handling@@ -1499,6 +1500,7 @@ charUpper :: [LispVal] -> ThrowsError LispVal charUpper [Char c] = return $ Char $ toUpper c charUpper [notChar] = throwError $ TypeMismatch "char" notChar+charUpper args = throwError $ NumArgs (Just 1) args -- | Convert a character to lowercase --@@ -1511,6 +1513,7 @@ charLower :: [LispVal] -> ThrowsError LispVal charLower [Char c] = return $ Char $ toLower c charLower [notChar] = throwError $ TypeMismatch "char" notChar+charLower args = throwError $ NumArgs (Just 1) args charDigitValue :: [LispVal] -> ThrowsError LispVal charDigitValue [Char c] = do@@ -1521,6 +1524,7 @@ then return $ Number $ toInteger $ digitToInt c else return $ Bool False charDigitValue [notChar] = throwError $ TypeMismatch "char" notChar+charDigitValue args = throwError $ NumArgs (Just 1) args -- | Convert from a charater to an integer --@@ -1533,6 +1537,7 @@ char2Int :: [LispVal] -> ThrowsError LispVal char2Int [Char c] = return $ Number $ toInteger $ ord c char2Int [notChar] = throwError $ TypeMismatch "char" notChar+char2Int args = throwError $ NumArgs (Just 1) args -- | Convert from an integer to a character --@@ -1545,10 +1550,11 @@ int2Char :: [LispVal] -> ThrowsError LispVal int2Char [Number n] = return $ Char $ chr $ fromInteger n int2Char [notInt] = throwError $ TypeMismatch "integer" notInt+int2Char args = throwError $ NumArgs (Just 1) args -- |Determine if given character satisfies the given predicate charPredicate :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal-charPredicate pred ([Char c]) = return $ Bool $ pred c +charPredicate cpred ([Char c]) = return $ Bool $ cpred c charPredicate _ _ = return $ Bool False -- | Determine if the given value is a character@@ -1588,12 +1594,14 @@ isBoolean ([Bool _]) = return $ Bool True isBoolean _ = return $ Bool False +isBooleanEq :: Monad m => [LispVal] -> m LispVal isBooleanEq (Bool a : Bool b : bs) | a == b = isBooleanEq (Bool b : bs) | otherwise = return $ Bool False isBooleanEq [Bool _] = return $ Bool True isBooleanEq _ = return $ Bool False +isSymbolEq :: Monad m => [LispVal] -> m LispVal isSymbolEq (Atom a : Atom b : bs) | a == b = isSymbolEq (Atom b : bs) | otherwise = return $ Bool False@@ -1616,17 +1624,17 @@ boolBinop unpacker op args = if length args < 2 then throwError $ NumArgs (Just 2) args else do- result <- cmp op (head args) (tail args)+ result <- cmp (head args) (tail args) return $ Bool result where - cmp op b1 (b2 : bs) = do+ cmp b1 (b2 : bs) = do b1' <- unpacker b1 b2' <- unpacker b2 let result = op b1' b2' if result- then cmp op b2 bs+ then cmp b2 bs else return False- cmp _ _ _ = return True+ cmp _ _ = return True -- |Perform the given function against a single LispVal argument@@ -1648,6 +1656,8 @@ liftThrows $ boolBinop unpackStr fnc dargs -- |Perform boolBinop against two char arguments+charBoolBinop :: (Char -> Char -> Bool)+ -> [LispVal] -> ThrowsError LispVal charBoolBinop = boolBinop unpackChar -- |Perform boolBinop against two boolean arguments
hs-src/Language/Scheme/Types.hs view
@@ -105,7 +105,6 @@ import qualified Data.Map -- import Data.Maybe import Data.Ratio-import Data.Word import System.IO import Text.ParserCombinators.Parsec hiding (spaces) @@ -548,7 +547,7 @@ "Duplicate lambda parameter " ++ d _ -> return True where- filterArgs (Atom a) = True+ filterArgs (Atom _) = True filterArgs _ = False dupe (a : b : rest)
hs-src/Language/Scheme/Util.hs view
@@ -11,7 +11,9 @@ -} module Language.Scheme.Util- ( escapeBackslashes+ ( countAllLetters+ , countLetters+ , escapeBackslashes , strip ) where @@ -28,3 +30,12 @@ strip :: String -> String strip s = dropWhile ws $ reverse $ dropWhile ws $ reverse s where ws = (`elem` [' ', '\n', '\t', '\r'])++-- |Count occurences of a letter in a list of strings+countAllLetters :: Char -> [String] -> Int+countAllLetters c strs = sum $ map (countLetters c) strs++-- |Count occurences of a letter in a string+countLetters :: Char -> String -> Int+countLetters c str = length $ filter (== c) str+
hs-src/Language/Scheme/Variables.hs view
@@ -355,7 +355,7 @@ -- variable name could refer to 2 different variables in -- different environments. case value of- Pointer p env -> do+ Pointer p _ -> do if p == var then return value else next@@ -387,6 +387,12 @@ -- |Do the actual "set" operation, with NO pointer operations. -- Only call this if you know what you are doing!+_setNamespacedVarDirect+ :: Env -- ^ Environment + -> Char -- ^ Namespace+ -> String -- ^ Variable+ -> LispVal -- ^ Value+ -> IOThrowsError LispVal -- ^ Value _setNamespacedVarDirect envRef namespace var valueToStore = do @@ -420,11 +426,11 @@ -- The first pointer now becomes the old var, -- so its pointers list should become ps- movePointers pEnv namespace pVar ps+ _ <- movePointers pEnv namespace pVar ps -- Each ps needs to be updated to point to pVar -- instead of var- pointToNewVar pEnv namespace pVar ps+ _ <- pointToNewVar pEnv namespace pVar ps -- Set first pointer to existing value of var existingValue <- getNamespacedVar envRef namespace var@@ -439,9 +445,9 @@ -- |Move the given pointers (ptr) to the list of -- pointers for variable (var) movePointers :: Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal- movePointers envRef namespace var ptrs = do- env <- liftIO $ readIORef $ pointers envRef- case Data.Map.lookup (getVarName namespace var) env of+ movePointers envRef' namespace' var' ptrs = do+ env <- liftIO $ readIORef $ pointers envRef'+ case Data.Map.lookup (getVarName namespace' var') env of Just ps' -> do -- Append ptrs to existing list of pointers to var ps <- liftIO $ readIORef ps'@@ -450,15 +456,15 @@ Nothing -> do -- var does not have any pointers; create new list valueRef <- liftIO $ newIORef ptrs- liftIO $ writeIORef (pointers envRef) (Data.Map.insert (getVarName namespace var) valueRef env)+ liftIO $ writeIORef (pointers envRef') (Data.Map.insert (getVarName namespace var') valueRef env) return $ Nil "" -- |Update each pointer's source to point to pVar- pointToNewVar pEnv namespace pVar (Pointer v e : ps) = do- _ <- _setNamespacedVarDirect e namespace v (Pointer pVar pEnv)- pointToNewVar pEnv namespace pVar ps- pointToNewVar pEnv namespace pVar [] = return $ Nil ""- pointToNewVar pEnv namespace pVar _ = throwError $ InternalError "pointToNewVar"+ pointToNewVar pEnv namespace' pVar' (Pointer v e : ps) = do+ _ <- _setNamespacedVarDirect e namespace' v (Pointer pVar' pEnv)+ pointToNewVar pEnv namespace' pVar' ps+ pointToNewVar _ _ _ [] = return $ Nil ""+ pointToNewVar _ _ _ _ = throwError $ InternalError "pointToNewVar" -- |A wrapper for updateNamespaceObject that uses the variable namespace. updateObject :: Env -> String -> LispVal -> IOThrowsError LispVal
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.15+Version: 3.15.1 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>