diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -11,6 +11,7 @@ sw2wolf Satoshi Egi Douglas Huff + Bastian Holst References: Write Yourself a Scheme in 48 Hours diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,3 +1,22 @@ +v3.18 +-------- + +New Features: + +- Added `exit` from R7RS. +- 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 -------- diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,6 +1,6 @@ [husk-scheme](http://justinethier.github.com/husk-scheme) -Husk is a dialect of Scheme written in Haskell that implements a superset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/) and a large portion of the R7RS-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 [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/) and a large portion of the [R7RS-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 R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS 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. Prerequisites: 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. Install Husk 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. Adjust your PATH: 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** diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs --- a/hs-src/Compiler/huskc.hs +++ b/hs-src/Compiler/huskc.hs @@ -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 () diff --git a/hs-src/Interpreter/shell.hs b/hs-src/Interpreter/shell.hs --- a/hs-src/Interpreter/shell.hs +++ b/hs-src/Interpreter/shell.hs @@ -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. -} diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -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? diff --git a/hs-src/Language/Scheme/Compiler/Libraries.hs b/hs-src/Language/Scheme/Compiler/Libraries.hs --- a/hs-src/Language/Scheme/Compiler/Libraries.hs +++ b/hs-src/Language/Scheme/Compiler/Libraries.hs @@ -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 $ diff --git a/hs-src/Language/Scheme/Compiler/Types.hs b/hs-src/Language/Scheme/Compiler/Types.hs --- a/hs-src/Language/Scheme/Compiler/Types.hs +++ b/hs-src/Language/Scheme/Compiler/Types.hs @@ -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 " diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -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) diff --git a/hs-src/Language/Scheme/Libraries.hs b/hs-src/Language/Scheme/Libraries.hs --- a/hs-src/Language/Scheme/Libraries.hs +++ b/hs-src/Language/Scheme/Libraries.hs @@ -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 diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs --- a/hs-src/Language/Scheme/Macro.hs +++ b/hs-src/Language/Scheme/Macro.hs @@ -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 + + diff --git a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs --- a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs +++ b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs @@ -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 diff --git a/hs-src/Language/Scheme/Macro/Matches.hs b/hs-src/Language/Scheme/Macro/Matches.hs --- a/hs-src/Language/Scheme/Macro/Matches.hs +++ b/hs-src/Language/Scheme/Macro/Matches.hs @@ -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"]]) diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs --- a/hs-src/Language/Scheme/Primitives.hs +++ b/hs-src/Language/Scheme/Primitives.hs @@ -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 diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs --- a/hs-src/Language/Scheme/Types.hs +++ b/hs-src/Language/Scheme/Types.hs @@ -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 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 diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs --- a/hs-src/Language/Scheme/Variables.hs +++ b/hs-src/Language/Scheme/Variables.hs @@ -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 diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 3.17.1 +Version: 3.18 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> diff --git a/lib/core.scm b/lib/core.scm --- a/lib/core.scm +++ b/lib/core.scm @@ -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) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -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 ) diff --git a/lib/scheme/process-context.sld b/lib/scheme/process-context.sld --- a/lib/scheme/process-context.sld +++ b/lib/scheme/process-context.sld @@ -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 diff --git a/lib/srfi/28.sld b/lib/srfi/28.sld new file mode 100644 --- /dev/null +++ b/lib/srfi/28.sld @@ -0,0 +1,7 @@ +(define-library (srfi 28) + (export + format) + (import + (scheme base) + (scheme write)) + (include "srfi-28.scm")) diff --git a/lib/srfi/srfi-28.scm b/lib/srfi/srfi-28.scm new file mode 100644 --- /dev/null +++ b/lib/srfi/srfi-28.scm @@ -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)))))))