husk-scheme 3.17.1 → 3.18
raw patch · 22 files changed
+267/−130 lines, 22 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Scheme.Primitives: data Unpacker
+ Language.Scheme.Types: instance Eq Env
Files
- AUTHORS +1/−0
- ChangeLog.markdown +19/−0
- README.markdown +28/−21
- hs-src/Compiler/huskc.hs +1/−1
- hs-src/Interpreter/shell.hs +1/−1
- hs-src/Language/Scheme/Compiler.hs +16/−6
- hs-src/Language/Scheme/Compiler/Libraries.hs +5/−5
- hs-src/Language/Scheme/Compiler/Types.hs +3/−2
- hs-src/Language/Scheme/Core.hs +26/−4
- hs-src/Language/Scheme/Libraries.hs +4/−4
- hs-src/Language/Scheme/Macro.hs +71/−49
- hs-src/Language/Scheme/Macro/ExplicitRenaming.hs +2/−2
- hs-src/Language/Scheme/Macro/Matches.hs +5/−5
- hs-src/Language/Scheme/Primitives.hs +5/−5
- hs-src/Language/Scheme/Types.hs +8/−4
- hs-src/Language/Scheme/Variables.hs +10/−6
- husk-scheme.cabal +1/−1
- lib/core.scm +3/−2
- lib/scheme/base.sld +10/−10
- lib/scheme/process-context.sld +3/−2
- lib/srfi/28.sld +7/−0
- lib/srfi/srfi-28.scm +38/−0
AUTHORS view
@@ -11,6 +11,7 @@ sw2wolf <https://github.com/sw2wolf> Satoshi Egi <egi@egison.org> Douglas Huff <https://github.com/jrmithdobbs>+ Bastian Holst <https://github.com/bholst> 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,22 @@+v3.18+--------++New Features:++- Added `exit` from R<sup>7</sup>RS.+- Added support for [SRFI 28 - Basic Format Strings](http://srfi.schemers.org/srfi-28/srfi-28.html).++Bug Fixes:++- Fixed bugs with `syntax-rules` where:+ - A literal identifier may not have been matched in a sub-macro if macro hygiene renamed the input.+ - The environment of macro definition may be overwritten during expansion of a `syntax-rules` macro contained in another macro. This could cause macros defined in a library - but not exported from the library - to incorrectly fail to expand because they are not in scope.+- `for-each` no longer throws an error when an empty list is received.+- In compiled code, the `let-syntax` and `letrec-syntax` forms are now available to `eval` at runtime.+- Added several missing I/O functions to the export list of the `(scheme base)` library.+- bholst added `Unpacker` to the exports from `Language.Scheme.Primitives`, as it is required by `unpackEquals`.+- bholst fixed many comments in the Haddock documentation.+ v3.17.1 --------
README.markdown view
@@ -1,6 +1,6 @@ [<img src="https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png" alt="husk-scheme">](http://justinethier.github.com/husk-scheme) -Husk is a dialect of Scheme written in Haskell that implements a superset of the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/) and a large portion of the R<sup>7</sup>RS-small language. Advanced features are provided including continuations, hygienic macros, libraries, and a full numeric tower.+Husk is a dialect of Scheme written in Haskell that implements a superset of the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/) and a large portion of the [R<sup>7</sup>RS-small](r7rs.org) language. Advanced features are provided including continuations, hygienic macros, libraries, and a full numeric tower. Husk may be used as either a stand-alone interpreter or as an extension language within a larger Haskell application. By closely following the R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS Schemes. Husk is mature enough for use in production applications, however it is not optimized for performance-critical applications. @@ -10,37 +10,44 @@ Installation -------------The [Glasgow Haskell Compiler](http://www.haskell.org/ghc/) (GHC) is required to build, install, and run Husk. All recent versions of GHC are supported, including 7.0, 7.2, 7.4, and 7.6. The easiest way to get GHC is via the [Haskell Platform](http://hackage.haskell.org/platform/). -Husk may be installed using [cabal](http://www.haskell.org/cabal/):+1. <b>Prerequisites</b>: You will need the [Haskell Platform](http://hackage.haskell.org/platform/) if you don't already have a recent copy installed. - cabal update- cabal install husk-scheme+2. <b>Install Husk</b> using [cabal](http://www.haskell.org/cabal/): -Before running Husk you may also need to add the cabal executable directory to your path. On Linux this is `~/.cabal/bin`. Now you are ready to start up the interpreter:+ cabal update+ cabal install husk-scheme - justin@my-pc$ huski- _ _ __ _ - | | | | \\\ | | - | |__ _ _ ___| | __ \\\ ___ ___| |__ ___ _ __ ___ ___ - | '_ \| | | / __| |/ / //\\\ / __|/ __| '_ \ / _ \ '_ ` _ \ / _ \ - | | | | |_| \__ \ < /// \\\ \__ \ (__| | | | __/ | | | | | __/ - |_| |_|\__,_|___/_|\_\ /// \\\ |___/\___|_| |_|\___|_| |_| |_|\___| +3. <b>Adjust your PATH</b>: Before running Husk you may also need to add the cabal executable directory to your path. On Linux this is `~/.cabal/bin`. ++4. Now you are ready to start up the interpreter:++ justin@my-pc$ huski+ _ _ __ _ + | | | | \\\ | | + | |__ _ _ ___| | __ \\\ ___ ___| |__ ___ _ __ ___ ___ + | '_ \| | | / __| |/ / //\\\ / __|/ __| '_ \ / _ \ '_ ` _ \ / _ \ + | | | | |_| \__ \ < /// \\\ \__ \ (__| | | | __/ | | | | | __/ + |_| |_|\__,_|___/_|\_\ /// \\\ |___/\___|_| |_|\___|_| |_| |_|\___| - http://justinethier.github.com/husk-scheme - (c) 2010-2012 Justin Ethier - Version 3.6.2 + http://justinethier.github.com/husk-scheme + (c) 2010-2014 Justin Ethier + Version 3.18 - huski> (define (hello) 'world)- (lambda () ...)- huski> (hello)- world+ huski> (define (hello) 'world)+ (lambda () ...)+ huski> (hello)+ world Husk has been tested on Windows, Linux, and FreeBSD. Documentation --------------The online [user manual](http://justinethier.github.io/husk-scheme/manual/index.html) provides an overview of the Scheme language as implemented by Husk, instructions for using the Haskell API, an alphabetical index of Scheme functions, and more.+The online [user manual](http://justinethier.github.io/husk-scheme/manual/index.html) provides an overview of the Scheme language as implemented by Husk, including:++ - A [getting started](http://justinethier.github.io/husk-scheme/manual/getting-started.html) guide.+ - [Instructions](http://justinethier.github.io/husk-scheme/manual/haskell-interface.html) for using the [Haskell API](http://hackage.haskell.org/package/husk-scheme) + - An alphabetical listing of the [Scheme API](http://justinethier.github.io/husk-scheme/manual/node106.html). **Directory Structure**
hs-src/Compiler/huskc.hs view
@@ -91,7 +91,7 @@ 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+-- TODO: would nice to have this as well as a /real/ usage printout, perhaps via --help -- |Print a usage message showUsage :: IO ()
hs-src/Interpreter/shell.hs view
@@ -7,7 +7,7 @@ Stability : experimental Portability : portable -This file implements a REPL "shell" to host the interpreter, and also+This file implements a REPL /shell/ to host the interpreter, and also allows execution of stand-alone files containing Scheme code. -}
hs-src/Language/Scheme/Compiler.hs view
@@ -249,13 +249,18 @@ val <- Language.Scheme.Macro.expand env False _body LSC.apply compileScalar (" return $ " ++ ast2Str val) copts) -compile env ast@(List (Atom "let-syntax" : List _bindings : _body)) copts = do+compile env ast@(List (Atom "let-syntax" : List _bindings : _body)) + copts@(CompileOptions thisFnc a b nextFnc) = do compileSpecialFormBody env ast copts (\ _ -> do bodyEnv <- liftIO $ extendEnv env [] _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False _bindings -- Expand whole body as a single continuous macro, to ensure hygiene expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) LSC.apply- divertVars bodyEnv expanded copts compexp)++ Atom loadMacroSym <- _gensym "loadMacroStub"+ stub <- compileScalar (" Language.Scheme.Macro.loadMacros env env Nothing False " ++ (asts2Str _bindings)) (CompileOptions thisFnc False False (Just loadMacroSym))+ rest <- divertVars bodyEnv expanded (CompileOptions loadMacroSym a b nextFnc) compexp+ return $ stub ++ rest) where -- Pick up execution here after expansion compexp bodyEnv' expanded' copts' = do@@ -263,13 +268,18 @@ List e -> compile bodyEnv' (List $ Atom "begin" : e) copts' e -> compile bodyEnv' e copts' -compile env ast@(List (Atom "letrec-syntax" : List _bindings : _body)) copts = do+compile env ast@(List (Atom "letrec-syntax" : List _bindings : _body))+ copts@(CompileOptions thisFnc a b nextFnc) = do compileSpecialFormBody env ast copts (\ _ -> do bodyEnv <- liftIO $ extendEnv env [] _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False _bindings -- Expand whole body as a single continuous macro, to ensure hygiene expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) LSC.apply- divertVars bodyEnv expanded copts compexp)++ Atom loadMacroSym <- _gensym "loadMacroStub"+ stub <- compileScalar (" Language.Scheme.Macro.loadMacros env env Nothing False " ++ (asts2Str _bindings)) (CompileOptions thisFnc False False (Just loadMacroSym))+ rest <- divertVars bodyEnv expanded (CompileOptions loadMacroSym a b nextFnc) compexp+ return $ stub ++ rest) where -- Pick up execution here after expansion compexp bodyEnv' expanded' copts' = do@@ -1268,7 +1278,7 @@ Just fnextExpr -> "(makeCPSWArgs env cont " ++ fnextExpr ++ " [])" -- |Compile each argument as its own continuation (lambda), and then- -- call the function using "applyWrapper"+ -- call the function using @applyWrapper@ compileArgs :: String -> Bool -> (Maybe String) -> [LispVal] -> IOThrowsError [HaskAST] compileArgs thisFunc thisFuncUseValue maybeFnc args = do case args of@@ -1279,7 +1289,7 @@ Atom stubFunc <- _gensym "applyFirstArg" -- Call into compiled stub Atom nextFunc <- do case lastArg of- True -> return $ Atom "applyWrapper" -- Use wrapper to call into 'apply'+ True -> return $ Atom "applyWrapper" -- Use wrapper to call into /apply/ _ -> _gensym "applyNextArg" -- Next func argument to execute... -- inline function?
hs-src/Language/Scheme/Compiler/Libraries.hs view
@@ -97,8 +97,8 @@ Bool False] importFunc <- return $ [- -- fromEnv is a LispEnv passed in as the 'value' parameter.- -- But the source of 'value' is different depending on the + -- fromEnv is a LispEnv passed in as the /value/ parameter.+ -- But the source of /value/ is different depending on the -- context, so we call into this function to figure it out codeToGetFromEnv moduleName code, AstValue $ " _ <- evalLisp env $ List [Atom \"%import\", LispEnv env, value, List [Atom \"quote\", " ++ @@ -114,8 +114,8 @@ importFunc] ++ code ++ stub where --- -- The import's "from" env can come from many places; this function- -- figures that out and creates a new 'value' if necessary to send+ -- The import's from env can come from many places; this function+ -- figures that out and creates a new /value/ if necessary to send -- the proper value to %import in the above code -- codeToGetFromEnv (List [Atom "scheme", Atom "r5rs"]) _ = do@@ -299,7 +299,7 @@ (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", +-- TODO: this pattern is common with the one below in @begin@, -- should consolidate (or at least consider doing so) Atom nextFunc <- _gensym "includeNext" code <- includeAll env dir files compileInc lopts $
hs-src/Language/Scheme/Compiler/Types.hs view
@@ -54,10 +54,10 @@ -- to call into it. coptsThisFuncUseValue :: Bool,- -- ^Whether to include the 'value' parameter in the current function+ -- ^Whether to include the /value/ parameter in the current function coptsThisFuncUseArgs :: Bool,- -- ^Whether to include the 'args' parameter in the current function+ -- ^Whether to include the /args/ parameter in the current function coptsNextFunc :: Maybe String -- ^The name to use for the next function after the current@@ -210,6 +210,7 @@ headerImports = [ "Language.Scheme.Core " , "Language.Scheme.Numerical "+ , "Language.Scheme.Macro " , "Language.Scheme.Primitives " , "Language.Scheme.Types -- Scheme data types " , "Language.Scheme.Variables -- Scheme variable operations "
hs-src/Language/Scheme/Core.hs view
@@ -343,7 +343,7 @@ -- -- This can make the code harder to follow, however some coding conventions have been established to make the -- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS,--- those additional functions are defined locally using 'where', and each has been given a 'cps' prefix.+-- those additional functions are defined locally using @where@, and each has been given a /cps/ prefix. -- eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal eval env cont val@(Nil _) = continueEval env cont val Nothing@@ -1125,7 +1125,7 @@ _ <- evalString env {-baseEnv-} $ "(load \"" ++ (escapeBackslashes core) ++ "\")" -- TODO: probably will have to load some scheme libraries for modules.scm to work--- maybe the 'base' libraries from (scheme base) would be good enough?+-- maybe the /base/ libraries from (scheme base) would be good enough? #ifdef UseLibraries -- Load module meta-language @@ -1161,9 +1161,9 @@ {- These functions have access to the current environment via the current continuation, which is passed as the first LispVal argument. -} ---evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind, +evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues,- evalfuncMakeEnv, evalfuncNullEnv, evalfuncUseParentEnv,+ evalfuncMakeEnv, evalfuncNullEnv, evalfuncUseParentEnv, evalfuncExit, evalfuncInteractionEnv, evalfuncImport :: [LispVal] -> IOThrowsError LispVal {-@@ -1201,6 +1201,27 @@ evalfuncDynamicWind (_ : args) = throwError $ NumArgs (Just 3) args -- Skip over continuation argument evalfuncDynamicWind _ = throwError $ NumArgs (Just 3) [] +-- |Evaluate all outstanding dynamic wind /after/ procedures, and exit program+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 [] -- Call into prod to get values where@@ -1365,6 +1386,7 @@ , ("call-with-current-continuation", evalfuncCallCC) , ("call-with-values", evalfuncCallWValues) , ("dynamic-wind", evalfuncDynamicWind)+ , ("exit", evalfuncExit) , ("eval", evalfuncEval) , ("load", evalfuncLoad) , ("null-environment", evalfuncNullEnv)
hs-src/Language/Scheme/Libraries.hs view
@@ -8,7 +8,7 @@ Portability : portable This module contains code to handle R7RS libraries.-NOTE: Libraries are usually referred to as "modules" in the husk source code.+NOTE: Libraries are usually referred to as /modules/ in the husk source code. -} @@ -27,7 +27,7 @@ -> IOThrowsError LispVal findModuleFile [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= findModuleFile findModuleFile [String file] = do- --- Good enough now that load searches 'lib' if file not found+ -- Good enough now that load searches @lib@ if file not found return $ String file findModuleFile _ = return $ Bool False @@ -55,8 +55,8 @@ divertBinding :: Env -- ^ Environment to import into -> Env -- ^ Environment to import from- -> String -- ^ Name of the binding in 'from'- -> String -- ^ Name to use for the binding in 'to'+ -> String -- ^ Name of the binding in @from@+ -> String -- ^ Name to use for the binding in @to@ -> IOThrowsError LispVal divertBinding to from nameOrig nameNew = do isMacroBound <- liftIO $ isNamespacedRecBound from macroNamespace nameOrig
hs-src/Language/Scheme/Macro.hs view
@@ -163,7 +163,7 @@ -- Transform the input and then call macroEval again, -- since a macro may be contained within...- expanded <- macroTransform defEnv env env renameEnv cleanupEnv + expanded <- macroTransform [defEnv] env env renameEnv cleanupEnv definedInMacro (List identifiers) rules lisp apply ellipsis@@ -189,7 +189,7 @@ - input - Code from the scheme application -} macroTransform :: - Env + [Env] -> Env -> Env -> Env @@ -223,7 +223,7 @@ {- Given input, determine if that input matches any rules @return Transformed code, or Nil if no rules match -}-matchRule :: Env -> Env -> Env -> Bool -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> String -> IOThrowsError LispVal+matchRule :: [Env] -> Env -> Env -> Bool -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> String -> IOThrowsError LispVal matchRule defEnv outerEnv divertEnv dim identifiers localEnv renameEnv cleanupEnv (List [pattern, template]) (List inputVar) esym = do let is = tail inputVar let p = case pattern of@@ -271,7 +271,7 @@ {- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go, in preparation for macro transformation. -}-loadLocal :: Env -> Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> String -> IOThrowsError LispVal+loadLocal :: [Env] -> Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> String -> IOThrowsError LispVal loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags esym = do --case (trace ("loadLocal [" ++ (show pattern) ++ "] [" ++ (show input) ++ "] flags = " ++ (show listFlags) ++ " ...lvl = " ++ (show ellipsisLevel) ++ " ...indx = " ++ (show ellipsisIndex)) (pattern, input)) of case (pattern, input) of@@ -366,7 +366,7 @@ -- This information is necessary for use during transformation, where the output may -- change depending upon the form of the input. ---flagUnmatchedVars :: Env -> Env -> Env -> LispVal -> LispVal -> Bool -> String -> IOThrowsError LispVal +flagUnmatchedVars :: [Env] -> Env -> Env -> LispVal -> LispVal -> Bool -> String -> IOThrowsError LispVal flagUnmatchedVars defEnv outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern esym = do flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern esym@@ -392,7 +392,7 @@ -- Note that an atom may not be flagged in certain cases, for example if -- the var is lexically defined in the outer environment. This logic -- matches that in the pattern matching code.-flagUnmatchedAtom :: Env -> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal +flagUnmatchedAtom :: [Env] -> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal flagUnmatchedAtom defEnv outerEnv localEnv identifiers p improperListFlag = do isDefined <- liftIO $ isBound localEnv p isIdent <- findAtom (Atom p) identifiers@@ -401,7 +401,7 @@ then continueFlagging else case isIdent of Bool True -> do- matches <- identifierMatches defEnv outerEnv p+ matches <- identifierMatches (head defEnv) outerEnv p if not matches then return $ Bool True else do _ <- flagUnmatchedVar localEnv p improperListFlag@@ -435,7 +435,7 @@ | otherwise = (False, False) -- ^ Check pattern against input to determine if there is a match-checkLocal :: Env -- ^ Environment where the macro was defined+checkLocal :: [Env] -- ^ Environment where the macro was defined -> Env -- ^ Outer environment where this macro was called -> Env -- ^ Outer env that the macro may divert values back to -> Env -- ^ Local environment used to store temporary variables for macro processing@@ -464,7 +464,7 @@ -- have the same lexical binding, or the two identifiers are equal and both have no -- lexical binding. isRenamed <- liftIO $ isRecBound renameEnv pattern- doesIdentMatch <- identifierMatches defEnv outerEnv pattern+ doesIdentMatch <- identifierMatches (head defEnv) outerEnv pattern match <- haveMatch isRenamed doesIdentMatch if match == 0 @@ -492,7 +492,7 @@ i' <- getOrigName renameEnv inpt pl <- isLexicallyDefined outerEnv renameEnv pattern il <- isLexicallyDefined outerEnv renameEnv inpt- if (((pattern == inpt && doesIdentMatch) && (not isRenamed)) || + if (((p' == i' && doesIdentMatch) && (not isRenamed)) || -- Equal and neither have a lexical binding, per spec (p' == i' && (not pl) && (not il))) then return 1@@ -601,20 +601,12 @@ expand env dim code apply = do renameEnv <- liftIO $ nullEnv cleanupEnv <- liftIO $ nullEnv---- TODO: not sure if it is a problem to use env for both def and use, however I cannot think--- of anything else to use below.------ However, I believe this does highlight problems later on where defEnv is taken from the--- function parameter instead of the Syntax object---- -- Keep track of diverted variables _ <- clearDivertedVars env- walkExpanded env env env renameEnv cleanupEnv dim True False (List []) code apply+ walkExpanded [env] env env renameEnv cleanupEnv dim True False (List []) code apply -- |Walk expanded code per Clinger's algorithm from Macros That Work-walkExpanded :: Env +walkExpanded :: [Env] -> Env -> Env -> Env @@ -692,7 +684,7 @@ -- Not sure if this is strictly desirable, but does not break any tests so we'll go with it for now. walkExpanded _ _ _ _ _ _ _ _ _ transform _ = return transform -walkExpandedAtom :: Env +walkExpandedAtom :: [Env] -> Env -> Env -> Env @@ -787,14 +779,13 @@ {-- - Notes regarding define and set- --TODO: need to call a new function to scan for define (and set! ??) forms. -if found, need to add an entry to renameEnv (?) so as to get the transLiteral-code to work. otherwise there is no way for that code to know that a (define)-called within a macro is inserting a new binding.-do not actually need to do anything to the (define) form, just mark somehow-that it is inserting a binding for the var+ Notes regarding define and set:++ if define or set is found, need to add an entry to renameEnv (?) so as to get + the transLiteral code to work. otherwise there is no way for that code to know + that a (define) called within a macro is inserting a new binding.+ do not actually need to do anything to the (define) form, just mark somehow+ that it is inserting a binding for the var -} walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _)@@ -850,7 +841,7 @@ -- lambda is malformed, just transform as normal atom... walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts) apply -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result)+walkExpandedAtom defEnvs useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a ts False (Just syn) apply = do@@ -876,10 +867,32 @@ -- I am still concerned that this may highlight a flaw in the husk -- implementation, and that this solution may not be complete. --- List lexpanded <- cleanExpanded defEnv useEnv divertEnv renameEnv renameEnv True False (List []) (List ts) apply- macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : lexpanded)) apply ellipsis+ List lexpanded <- cleanExpanded defEnvs useEnv divertEnv renameEnv renameEnv True False (List []) (List ts) apply+ macroTransform defEnvs useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : lexpanded)) apply ellipsis Syntax (Just _defEnv) _ definedInMacro ellipsis identifiers rules -> do - macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) apply ellipsis++ -- Experimenting with this workaround for 162. The problem is that it+ -- substantially increases the time to run the test suite (only a couple+ -- seconds but 50% longer). So for various reasons this is not a+ -- preferred change. May want to look into ramifications of just using defEnv.+ --+ -- Hack to use defEnv from original macro, to preserve definitions in+ -- that scope, instead of just using _defEnv. Not sure yet if this the+ -- correct solution or if there a hygiene problem this hides.+-- newEnv <- liftIO $ nullEnv+-- _ <- liftIO $ importEnv newEnv defEnv -- Start with outer macro's def+-- _ <- liftIO $ importEnv newEnv _defEnv -- But prefer this macro+--+-- macroTransform newEnv useEnv divertEnv renameEnv cleanupEnv +-- macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv ++-- Use defEnv from original macro, so any definitions are in scope for expansion+ let defEnvs' = if (elem _defEnv defEnvs)+ then defEnvs+ else defEnvs ++ [_defEnv]+ macroTransform defEnvs' useEnv divertEnv renameEnv cleanupEnv + definedInMacro (List identifiers) rules + (List (Atom a : ts)) apply ellipsis Syntax Nothing _ definedInMacro ellipsis identifiers rules -> do -- A child renameEnv is not created because for a macro call there is no way an -- renamed identifier inserted by the macro could override one in the outer env.@@ -887,13 +900,13 @@ -- This is because the macro renames non-matched identifiers and stores mappings -- from the {rename ==> original}. Each new name is unique by definition, so -- no conflicts are possible.- macroTransform defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) apply ellipsis+ macroTransform defEnvs useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) apply ellipsis SyntaxExplicitRenaming transformer -> do erRenameEnv <- liftIO $ nullEnv -- Local environment used just for this -- Different than the syntax-rules rename env (??) expanded <- explicitRenamingTransform useEnv erRenameEnv renameEnv (List (Atom a : ts)) transformer apply- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv + walkExpanded defEnvs useEnv divertEnv renameEnv cleanupEnv dim False False (List result) expanded apply _ -> throwError $ Default "Unexpected error processing a macro in walkExpandedAtom"@@ -960,10 +973,10 @@ -- need to be another environment with the reverse mappings. -- -- ALSO, due to parent Env logic going on, these bindings need to be in some sort of--- 'master' env that transcends those env's and maps all gensyms back to their original symbols+-- /master/ env that transcends those env's and maps all gensyms back to their original symbols -- cleanExpanded :: - Env + [Env] -> Env -> Env -> Env @@ -1013,7 +1026,7 @@ - collecting an env of variables that are renamed - diverting bindings back into the Env of use (outer env) -}-transformRule :: Env -- ^ Environment the macro was defined in+transformRule :: [Env] -- ^ Environment the macro was defined in -> Env -- ^ Outer, enclosing environment -> Env -- ^ Outer environment that the macro may divert values back to -> Env -- ^ Environment local to the macro containing pattern variables@@ -1241,13 +1254,13 @@ Nil _ -> return t List l -> do -- What's going on here is that if the pattern was a dotted list but the transform is not, we- -- need to "lift" the input up out of a list.+ -- need to /lift/ the input up out of a list. if (eqVal isImproperPattern $ Bool True) && (eqVal isImproperInput $ Bool True) then continueTransformWith $ result ++ (buildImproperList l) else continueTransformWith $ result ++ [t] _ -> continueTransformWith $ result ++ [t] - -- Transformed code should be an improper list, but may need to "promote" it to a proper list+ -- Transformed code should be an improper list, but may need to /promote/ it to a proper list buildImproperList lst | length lst > 1 = [DottedList (init lst) (last lst)] | otherwise = lst@@ -1289,9 +1302,9 @@ transformRule _ _ _ _ _ _ _ _ _ _ _ _ transform = return transform -- |A helper function for transforming an atom that has been marked as as literal identifier-transformLiteralIdentifier :: Env -> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal+transformLiteralIdentifier :: [Env] -> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal transformLiteralIdentifier defEnv outerEnv divertEnv renameEnv definedInMacro transform = do- isInDef <- liftIO $ isRecBound defEnv transform+ isInDef <- liftIO $ isRecBound (head defEnv) transform isRenamed <- liftIO $ isRecBound renameEnv transform if (isInDef && not definedInMacro) || (isInDef && definedInMacro && not isRenamed) then do@@ -1299,7 +1312,7 @@ so divert that value back into the environment of use. The value is diverted back with a different name so as not to be shadowed by a variable of the same name in env of use. -}- value <- getVar defEnv transform+ value <- getVar (head defEnv) transform Atom renamed <- _gensym transform _ <- defineVar divertEnv renamed value @@ -1314,7 +1327,7 @@ return $ Atom transform {- TODO: - above "else" is not entirely correct, a special form would not be defined but still+ above @else@ is not entirely correct, a special form would not be defined but still has a meaning and could be shadowed in useEnv. need some way of being able to divert a special form back into useEnv... @@ -1333,7 +1346,7 @@ -} -- | A helper function for transforming an improper list-transformDottedList :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal+transformDottedList :: [Env] -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) (List (DottedList ds d : ts)) = do lsto <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List []) (List ds) case lsto of@@ -1363,7 +1376,7 @@ _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d where -- Transform code as either a proper or improper list depending upon the data- -- These are rather crude methods of 'cons'-ing everything together... are all cases accounted for?+ -- These are rather crude methods of /cons/-ing everything together... are all cases accounted for? buildTransformedCode results ps p = do case p of [List []] -> List $ results ++ [List ps] -- Proper list has null list at the end@@ -1382,7 +1395,7 @@ transformDottedList _ _ _ _ _ _ _ _ _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList" -- |Continue transforming after a preceding match has ended -continueTransform :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal+continueTransform :: [Env] -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex result remaining = do if not (null remaining) then transformRule defEnv outerEnv divertEnv @@ -1534,9 +1547,18 @@ r <- liftIO $ isBound renameEnv a return $ o || r -findBoundMacro :: Env -> Env -> String -> IOThrowsError (Maybe LispVal)+findBoundMacro :: [Env] -> Env -> String -> IOThrowsError (Maybe LispVal) findBoundMacro defEnv useEnv a = do synUse <- getNamespacedVar' useEnv macroNamespace a case synUse of Just syn -> return $ Just syn- _ -> getNamespacedVar' defEnv macroNamespace a+ _ -> check defEnv+ where+ check (e : es) = do+ r <- getNamespacedVar' e macroNamespace a+ case r of+ Just _ -> return r+ _ -> check es+ check [] = return Nothing++
hs-src/Language/Scheme/Macro/ExplicitRenaming.hs view
@@ -52,7 +52,7 @@ explicitRenamingTransform _ _ _ _ _ _ = throwError $ InternalError "explicitRenamingTransform" --- |The explicit renaming "rename" function+-- |The explicit renaming /rename/ function -- -- From clinger's paper "Hygienic Macros Through Explicit Renaming": --@@ -107,7 +107,7 @@ return $ Atom a exRename _ _ _ _ form = throwError $ Default $ "Unable to rename: " ++ show form --- |The explicit renaming "compare" function+-- |The explicit renaming /compare/ function exCompare :: Env -- ^ Environment of use -> Env -- ^ Environment with renames -> Env -- ^ Environment of definition
hs-src/Language/Scheme/Macro/Matches.hs view
@@ -23,9 +23,9 @@ | level == 1 = List [] | otherwise = List [_create $ level - 1] --- |Fill any empty "holes" in a list from the beginning to the given length+-- |Fill any empty /holes/ in a list from the beginning to the given length ----- The problem here is how to handle case when a requested insertion leaves "holes".+-- The problem here is how to handle case when a requested insertion leaves /holes/. -- -- For example, in a 2-level nested list: ((1)) we have data as pos 0 but have none at pos 1. -- If the code then tries to add an element 2 at pos 2 we should end up with:@@ -40,7 +40,7 @@ -- |Get an element at given location in the nested list getData :: LispVal -- ^ The nested list to read from -> [Int] -- ^ Location to read an element from, all numbers are 0-based- -> LispVal -- ^ Value read, or 'Nil' if none+ -> LispVal -- ^ Value read, or @Nil@ if none getData (List lData) (i:is) = do if length lData < i then Nil "" -- Error: there are not enough elements in the list@@ -60,7 +60,7 @@ -> LispVal -- ^ Value to insert -> LispVal -- ^ Resulant list setData (List lData) (i:is) val = do- -- Fill "holes" as long as they are not at the leaves.+ -- Fill /holes/ as long as they are not at the leaves. -- -- This is because, when a match occurs it happens 0 or more times. -- Therefore it is not possible (at the leaves) for a match to occur @@ -139,7 +139,7 @@ (List [List[List [], List[Atom "test"]]]) -- Illustrates an important point, that if we are adding into - -- a 'hole', we need to create a list there first+ -- a /hole/, we need to create a list there first let cc = setData b [1, 0] $ Atom "test2" _cmp cc (List [List [Atom "test"], List [Atom "test2"]])
hs-src/Language/Scheme/Primitives.hs view
@@ -71,7 +71,6 @@ , stringCopy , symbol2String , string2Symbol- --data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a) -- ** Character , charCIBoolBinop @@ -100,6 +99,7 @@ , isSymbol -- ** Utility functions+ , Unpacker () , unpackEquals , boolBinop , unaryOp @@ -743,7 +743,7 @@ car [badArg] = throwError $ TypeMismatch "pair" badArg car badArgList = throwError $ NumArgs (Just 1) badArgList --- | Return the "tail" of a list, with the first element removed+-- | Return the /tail/ of a list, with the first element removed -- -- Arguments: --@@ -759,7 +759,7 @@ cdr [badArg] = throwError $ TypeMismatch "pair" badArg cdr badArgList = throwError $ NumArgs (Just 1) badArgList --- | The LISP "cons" operation - create a list from two values+-- | The LISP @cons@ operation - create a list from two values -- -- Arguments: --@@ -1594,7 +1594,7 @@ isDottedList :: [LispVal] -> IOThrowsError LispVal isDottedList ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isDottedList isDottedList ([DottedList _ _]) = return $ Bool True--- Must include lists as well since they are made up of 'chains' of pairs+-- Must include lists as well since they are made up of /chains/ of pairs isDottedList ([List []]) = return $ Bool False isDottedList ([List _]) = return $ Bool True isDottedList _ = return $ Bool False@@ -1887,7 +1887,7 @@ isSymbolEq [Atom _] = return $ Bool True isSymbolEq _ = return $ Bool False --- Utility functions+-- |Utility type for unpackEquals data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a) -- |Determine if two lispval's are equal
hs-src/Language/Scheme/Types.hs view
@@ -117,6 +117,10 @@ pointers :: (IORef (Data.Map.Map String (IORef [LispVal]))) } +instance Eq Env where+ (Environment _ xb xpts) == (Environment _ yb ypts) = + (xb == yb) && (xpts == ypts)+ -- |An empty environment nullEnv :: IO Env nullEnv = do @@ -190,10 +194,10 @@ -- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> Map has good performance characteristics compared to the alternatives. So it stays for the moment... -- | Number Integer -- ^Integer number- {- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful)+ {- FUTURE: rename this to @Integer@ (or @WholeNumber@ or something else more meaningful) Integer -} | Float Double -- ^Double-precision floating point number- {- FUTURE: rename this "Real" instead of "Float"...+ {- FUTURE: rename this @Real@ instead of @Float@... Floating point -} | Complex (Complex Double) -- ^Complex number@@ -264,7 +268,7 @@ | Nil String -- ^Internal use only; do not use this type directly. --- | Scheme "null" value+-- | Scheme /null/ value nullLisp :: LispVal nullLisp = List [] @@ -301,7 +305,7 @@ instance Show DynamicWinders where show = showDWVal --- |Make an "empty" continuation that does not contain any code+-- |Make an /empty/ continuation that does not contain any code makeNullContinuation :: Env -> LispVal makeNullContinuation env = Continuation env Nothing Nothing Nothing
hs-src/Language/Scheme/Variables.hs view
@@ -384,7 +384,7 @@ valueToStore <- getValueToStore namespace var envRef value _setNamespacedVarDirect envRef namespace var valueToStore --- |Do the actual "set" operation, with NO pointer operations.+-- |Do the actual /set/ operation, with NO pointer operations. -- Only call this if you know what you are doing! _setNamespacedVarDirect :: Env -- ^ Environment @@ -470,9 +470,9 @@ updateObject env = updateNamespacedObject env varNamespace --- |This function updates the object that "var" refers to. If "var" is+-- |This function updates the object that the variable refers to. If it is -- a pointer, that means this function will update that pointer (or the last--- pointer in the chain) to point to the given "value" object. If "var"+-- pointer in the chain) to point to the given /value/ object. If the variable -- is not a pointer, the result is the same as a setVar (but without updating -- any pointer references, see below). --@@ -480,7 +480,11 @@ -- update any associated pointers. So it should probably only be -- used internally by husk, unless you really know what you are -- doing!-updateNamespacedObject :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal+updateNamespacedObject :: Env -- ^ Environment+ -> Char -- ^ Namespace+ -> String -- ^ Variable+ -> LispVal -- ^ Value+ -> IOThrowsError LispVal -- ^ Value updateNamespacedObject env namespace var value = do varContents <- getNamespacedVar env namespace var obj <- findPointerTo varContents@@ -519,7 +523,7 @@ -- If we are assigning to a pointer, we need a reverse lookup to - -- note that the pointer "value" points to "var"+ -- note that the pointer @value@ points to @var@ -- -- So run through this logic to figure out what exactly to store, -- both for bindings and for rev-lookup pointers@@ -645,7 +649,7 @@ liftThrows $ fnc result -- |A predicate to determine if the given lisp value --- is an "object" that can be pointed to.+-- is an /object/ that can be pointed to. isObject :: LispVal -> Bool isObject (List _) = True isObject (DottedList _ _) = True
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.17.1+Version: 3.18 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>
lib/core.scm view
@@ -223,7 +223,8 @@ (foldr (lambda (x y) (cons (f x) y)) '() lis1))) (define (for-each f lis1 . lists)- (if (pair? lists)+ (if (not (null? lis1))+ (if (pair? lists) (let recur ((lists (cons lis1 lists))) (receive (cars cdrs) (%cars+cdrs lists) (if (pair? cars)@@ -234,7 +235,7 @@ (if (eq? 1 (length lis1)) (f (car lis1)) (begin (f (car lis1))- (for-each f (cdr lis1))))))+ (for-each f (cdr lis1))))))) (define (list-tail lst k) (if (zero? k)
lib/scheme/base.sld view
@@ -188,8 +188,8 @@ ;floor-remainder ;floor/ flush-output-port- ;get-output-bytevector- ;get-output-string+ get-output-bytevector+ get-output-string ;guard ;if inexact?@@ -204,10 +204,10 @@ ;list-set! make-list make-parameter- ;open-input-bytevector- ;open-input-string- ;open-output-bytevector- ;open-output-string+ open-input-bytevector+ open-input-string+ open-output-bytevector+ open-output-string output-port-open? parameterize ;peek-u8@@ -215,11 +215,11 @@ ;quote ;raise ;raise-continuable- ;read-bytevector+ read-bytevector ;read-bytevector! ;read-error? read-line- ;read-string+ read-string ;read-u8 ;set! ;set-car!@@ -252,8 +252,8 @@ ;vector-set! when ;with-exception-handler- ;write-bytevector- ;write-string+ write-bytevector+ write-string ;write-u8 %husk-switch-to-parent-environment )
lib/scheme/process-context.sld view
@@ -9,11 +9,12 @@ (define-library (scheme process-context) (export + exit+ exit-fail+ exit-success emergency-exit get-environment-variable get-environment-variables- exit-fail- exit-success system) (import (scheme)) (begin
+ lib/srfi/28.sld view
@@ -0,0 +1,7 @@+(define-library (srfi 28)+ (export+ format)+ (import + (scheme base)+ (scheme write))+ (include "srfi-28.scm"))
+ lib/srfi/srfi-28.scm view
@@ -0,0 +1,38 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Implementation of SRFI-28: Basic Format Strings+;;;+(define format+ (lambda (format-string . objects)+ (let ((buffer (open-output-string)))+ (let loop ((format-list (string->list format-string))+ (objects objects))+ (cond ((null? format-list) (get-output-string buffer))+ ((char=? (car format-list) #\~)+ (if (null? (cdr format-list))+ (error 'format "Incomplete escape sequence")+ (case (cadr format-list)+ ((#\a)+ (if (null? objects)+ (error 'format "No value for escape sequence")+ (begin+ (display (car objects) buffer)+ (loop (cddr format-list) (cdr objects)))))+ ((#\s)+ (if (null? objects)+ (error 'format "No value for escape sequence")+ (begin+ (write (car objects) buffer)+ (loop (cddr format-list) (cdr objects)))))+ ((#\%)+ (newline buffer)+ (loop (cddr format-list) objects))+ ((#\~)+ (write-char #\~ buffer)+ (loop (cddr format-list) objects))+ (else+ (error 'format "Unrecognized escape sequence")))))+ (else (write-char (car format-list) buffer)+ (loop (cdr format-list) objects)))))))