husk-scheme 3.16 → 3.16.1
raw patch · 11 files changed
+183/−140 lines, 11 files
Files
- AUTHORS +2/−1
- ChangeLog.markdown +12/−0
- hs-src/Compiler/huskc.hs +9/−7
- hs-src/Language/Scheme/Compiler.hs +27/−23
- hs-src/Language/Scheme/Compiler/Types.hs +17/−2
- hs-src/Language/Scheme/Core.hs +6/−5
- hs-src/Language/Scheme/Environments.hs +1/−0
- hs-src/Language/Scheme/Macro.hs +92/−100
- hs-src/Language/Scheme/Primitives.hs +11/−0
- husk-scheme.cabal +1/−1
- lib/modules.scm +5/−1
AUTHORS view
@@ -7,11 +7,12 @@ Arseniy <https://github.com/Rotsor> Eli Barzilay <eli@barzilay.org> Ricardo Lanziano <ricardo.lanziano@gmail.com>- SaitoAtsushi <https://github.com/SaitoAtsushi>+ Saito Atsushi <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> R5RS <http://www.schemers.org/Documents/Standards/R5RS/HTML/>+ R7RS <http://trac.sacrideo.us/wg/wiki> CHICKEN <http://www.call-cc.org/> Chibi-Scheme <http://code.google.com/p/chibi-scheme/>
ChangeLog.markdown view
@@ -1,3 +1,15 @@+v3.16.1+--------++- Allow import of a library in the same directory as a program. For example to import `lib.sld`:++ (import (lib))++Bug Fixes:++- Husk no longer throws an error during expansion of a library macro that references another macro which is not exported from the same library.+- Fixed a bug where a `syntax-rules` macro's literal identifier would not match the input when both identifiers are equal and both have no lexical binding.+ v3.16 --------
hs-src/Compiler/huskc.hs view
@@ -33,6 +33,8 @@ opts <- foldl (>>=) (return defaultOptions) actions let Options {optOutput = output, optLibs = lib, optDynamic = dynamic, optCustomOptions = extra, optSchemeRev = langrev} = opts + let debugOpt = False+ if null nonOpts then showUsage else do@@ -45,7 +47,7 @@ Just args' -> args' Nothing -> "" -- TODO: pass language revision- process inFile outHaskell outExec lib dynamic extraOpts langrev+ process inFile outHaskell outExec lib dynamic extraOpts langrev debugOpt -- -- For an explanation of the command line options code, see:@@ -135,8 +137,8 @@ exitWith ExitSuccess -- |High level code to compile the given file-process :: String -> String -> String -> Bool -> Bool -> String -> String -> IO ()-process inFile outHaskell outExec libs dynamic extraArgs langrev = do+process :: String -> String -> String -> Bool -> Bool -> String -> String -> Bool -> IO ()+process inFile outHaskell outExec libs dynamic extraArgs langrev debugOpt = do env <- case langrev of "7" -> Language.Scheme.Core.r7rsEnv' _ -> Language.Scheme.Core.r5rsEnv'@@ -147,14 +149,14 @@ then Just stdlib else Nothing - result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlibArg srfi55 inFile outHaskell langrev)+ result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlibArg srfi55 inFile outHaskell langrev debugOpt) case result of Just errMsg -> putStrLn errMsg _ -> compileHaskellFile outHaskell outExec dynamic extraArgs -- |Compile a scheme file to haskell-compileSchemeFile :: Env -> Maybe String -> String -> String -> String -> String -> IOThrowsError LispVal-compileSchemeFile env stdlib srfi55 filename outHaskell langrev = do+compileSchemeFile :: Env -> Maybe String -> String -> String -> String -> String -> Bool -> IOThrowsError LispVal+compileSchemeFile env stdlib srfi55 filename outHaskell langrev debugOpt = do let conv :: LispVal -> String conv (String s) = s conv l = show l@@ -189,7 +191,7 @@ _ <- liftIO $ writeList outH headerModule _ <- liftIO $ writeList outH $ map (\modl -> "import " ++ modl ++ " ") $ headerImports ++ moreHeaderImports filepath <- liftIO $ getDataFileName ""- _ <- liftIO $ writeList outH $ header filepath compileLibraries langrev+ _ <- liftIO $ writeList outH $ header filepath compileLibraries langrev debugOpt _ <- liftIO $ case compileLibraries of True -> do _ <- writeList outH $ map show libsC
hs-src/Language/Scheme/Compiler.hs view
@@ -1143,7 +1143,8 @@ compileArgs thisFunc thisFuncUseValue maybeFnc args = do case args of (a:as) -> do- let (asRest, asLiterals) = (as, []) --TODO: takeLiterals a as+ let (asRest, asLiterals) = (as, [])+-- let (asRest, asLiterals) = takeLiterals a as let lastArg = null asRest Atom stubFunc <- _gensym "applyFirstArg" -- Call into compiled stub Atom nextFunc <- do@@ -1154,13 +1155,15 @@ -- inline function? fnc <- case maybeFnc of- Just fncName -> compileInlineVar env fncName "value"- _ -> return $ AstValue ""+ Just fncName -> do+ var <- compileInlineVar env fncName "value"+ return [var]+ _ -> return [] -- Flag below means that the expression's value matters, add it to args- f <- if thisFuncUseValue- then return $ AstValue $ thisFunc ++ " env cont value (Just args) = do "- else return $ AstValue $ thisFunc ++ " env cont _ (Just args) = do "+ let fargs = if thisFuncUseValue+ then " env cont value (Just args) "+ else " env cont _ (Just args) " c <- do let nextCont' = case (lastArg, coptsNext) of (True, Just fnextExpr) -> "(makeCPSWArgs env cont " ++ fnextExpr ++ " [])"@@ -1179,7 +1182,7 @@ rest <- case lastArg of True -> return [] -- Using apply wrapper, so no more code _ -> compileArgs nextFunc True Nothing asRest -- True indicates nextFunc needs to use value arg passed into it- return $ [ f, fnc, c] ++ _comp ++ rest+ return $ [AstFunction thisFunc fargs (fnc ++ [c])] ++ _comp ++ rest _ -> throwError $ TypeMismatch "nonempty list" $ List args @@ -1213,22 +1216,23 @@ collectLiteralsAndVars args = _collectLiterals args [] True collectLiterals args = _collectLiterals args [] False --- Take as many literals as possible from the given list, and--- return those literals and the rest of the list-takeLiterals :: LispVal -> [LispVal] -> ([LispVal], [LispVal])-takeLiterals (List _) ls = (ls, [])-takeLiterals _ ls' = do- loop ls' []- where- loop (l : ls) acc = do- if isLiteral l- then loop ls (l : acc)- else ((l:ls), acc)- loop [] acc = ([], Data.List.reverse acc)-- isLiteral (List _) = False- isLiteral (Atom _) = False- isLiteral _ = True+-- Experimental:+-- -- Take as many literals as possible from the given list, and+-- -- return those literals and the rest of the list+-- takeLiterals :: LispVal -> [LispVal] -> ([LispVal], [LispVal])+-- takeLiterals (List _) ls = (ls, [])+-- takeLiterals _ ls' = do+-- loop ls' []+-- where+-- loop (l : ls) acc = do+-- if isLiteral l+-- then loop ls (l : acc)+-- else ((l:ls), Data.List.reverse acc)+-- loop [] acc = ([], Data.List.reverse acc)+-- +-- isLiteral (List _) = False+-- isLiteral (Atom _) = False+-- isLiteral _ = True -- Compile variable as a stand-alone line of code compileInlineVar :: Env -> String -> String -> IOThrowsError HaskAST
hs-src/Language/Scheme/Compiler/Types.hs view
@@ -127,6 +127,18 @@ let typeSig = "\n" ++ name ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal " let fheader = "\n" ++ name ++ args ++ " = do " let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code+-- let appendArg arg = do+-- if Data.List.isInfixOf arg args+-- then " ++ \" \" ++ " ++ (show arg) ++ +-- " ++ \" [\" ++ (show " ++ arg ++ ")" ++ +-- " ++ \"] \""+-- else ""+-- let fdebug = "\n _ <- liftIO $ (trace (\"" ++ +-- name ++ "\"" ++ +-- (appendArg "value") ++ +-- (appendArg "args") ++ +-- ") getCPUTime)"+-- typeSig ++ fheader ++ fdebug ++ fbody typeSig ++ fheader ++ fbody showValAST (AstValue v) = v showValAST (AstContinuation nextFunc args) =@@ -209,8 +221,8 @@ -- |Block of code used in the header of a Haskell program -- generated by the compiler.-header :: String -> Bool -> String -> [String]-header filepath useCompiledLibs langRev = do+header :: String -> Bool -> String -> Bool -> [String]+header filepath useCompiledLibs langRev debug = do let env = if useCompiledLibs then "primitiveBindings" else case langRev of@@ -223,6 +235,9 @@ , " liftIO $ registerExtensions env getDataFileName' " , " continueEval env (makeCPSWArgs env cont exec []) (Nil \"\")"] [ " "+ , if debug then "import System.CPUTime " else ""+ , if debug then "import Debug.Trace " else ""+ , " " , "-- |Get variable at runtime " , "getRTVar env var = do " , " v <- getVar env var "
hs-src/Language/Scheme/Core.hs view
@@ -46,7 +46,7 @@ -- * Internal use only , meval ) where-import qualified Paths_husk_scheme as PHS (getDataFileName)+import qualified Paths_husk_scheme as PHS (getDataFileName, version) #ifdef UseFfi import qualified Language.Scheme.FFI #endif@@ -62,14 +62,15 @@ import Data.Array import qualified Data.ByteString as BS import qualified Data.Map+import Data.Version as DV import Data.Word import qualified System.Exit import qualified System.Info as SysInfo -- import Debug.Trace --- |husk version number+-- |Husk version number version :: String-version = "3.16"+version = DV.showVersion PHS.version -- |A utility function to display the husk console banner showBanner :: IO ()@@ -83,7 +84,7 @@ putStrLn " " putStrLn " http://justinethier.github.io/husk-scheme " putStrLn " (c) 2010-2014 Justin Ethier "- putStrLn $ " Version " ++ version ++ " "+ putStrLn $ " Version " ++ (DV.showVersion PHS.version) ++ " " putStrLn " " getHuskFeatures :: IO [LispVal]@@ -91,7 +92,7 @@ -- TODO: windows posix return [ Atom "r7rs" , Atom "husk"- , Atom $ "husk-" ++ version + , Atom $ "husk-" ++ (DV.showVersion PHS.version) , Atom $ SysInfo.arch , Atom $ SysInfo.os , Atom "full-unicode"
hs-src/Language/Scheme/Environments.hs view
@@ -152,6 +152,7 @@ ("read-all", readAll), ("find-module-file", findModuleFile), ("system", system),+-- ("system-read", systemRead), ("gensym", gensym)]
hs-src/Language/Scheme/Macro.hs view
@@ -455,76 +455,55 @@ 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 _ = do-- -- TODO: - --- -- The code below uses this rename boolean as a factor to determine whether a named- -- identifier has been redefined and thus should not match itself in the input. But the- -- thing is, the actual code is supposed to compare the value at macro definition- -- time with the value in the environment of use (outerEnv) to make this determination.- -- So what is below is close but not truly correct.+ -- This code mostly just loads up pattern variables, but it also needs to be+ -- careful to take into account literal identifiers. From spec: --+ -- Identifiers that appear in <literals> are interpreted as literal identifiers + -- to be matched against corresponding subforms of the input. A subform in the input + -- matches a literal identifier if and only if it is an identifier and either both + -- its occurrence in the macro expression and its occurrence in the macro definition + -- 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-- if (ellipsisLevel) > 0- {- FUTURE: may be able to simplify both cases below by using a- lambda function to store the 'save' actions -}+ match <- haveMatch isRenamed doesIdentMatch + if match == 0 + then return $ Bool False+ else if (ellipsisLevel) > 0 -- Var is part of a 0-to-many match, store up in a list...- then do isDefined <- liftIO $ isBound localEnv pattern- --- -- If pattern is a literal identifier, need to ensure- -- input matches that literal, or that (in this case)- -- the literal is missing from the input (0 match)- --- isIdent <- findAtom (Atom pattern) identifiers- case isIdent of- Bool True -> do- case input of- Atom inpt -> do- if (pattern == inpt) - then if (doesIdentMatch) && (not isRenamed)- -- Var is not bound in outer code; proceed- then do- -- Set variable in the local environment- addPatternVar isDefined ellipsisLevel ellipsisIndex pattern $ Atom pattern- -- Var already bound in enclosing environment prior to evaluating macro.- -- So... do not match it here.- --- -- See section 4.3.2 of R5RS, in particular:- -- " If a literal identifier is inserted as a bound identifier then it is - -- in effect renamed to prevent inadvertent captures of free identifiers "- else return $ Bool False- else return $ Bool False- -- Pattern/Input cannot match because input is not an atom- _ -> return $ Bool False- -- No literal identifier, just load up the var- _ -> addPatternVar isDefined ellipsisLevel ellipsisIndex pattern input- --- -- Simple var, try to load up into macro env- --- else do+ then do isDefined <- liftIO $ isBound localEnv pattern+ if match == 1 -- Literal identifier+ then addPatternVar isDefined ellipsisLevel ellipsisIndex pattern $ Atom pattern+ else addPatternVar isDefined ellipsisLevel ellipsisIndex pattern input+ -- Simple var, try to load up into macro env+ else do+ _ <- defineVar localEnv pattern input+ return $ Bool True+ where+ haveMatch :: Bool -> Bool -> IOThrowsError Int+ haveMatch isRenamed doesIdentMatch = do isIdent <- findAtom (Atom pattern) identifiers- --isLexicallyDefinedPatternVar <- liftIO $ isBound outerEnv pattern -- Var defined in scope outside macro- case (isIdent) of- -- Fail the match if pattern is a literal identifier and input does not match+ case isIdent of+ -- Literal identifier in pattern, do we have a match? Bool True -> do case input of Atom inpt -> do- -- Pattern/Input are atoms; both must match- if (pattern == inpt && (doesIdentMatch)) && (not isRenamed) -- Regarding lex binding; see above, sec 4.3.2 from spec--- if (pattern == inpt && (not isLexicallyDefinedPatternVar)) && (not isRenamed) -- Regarding lex binding; see above, sec 4.3.2 from spec- then do _ <- defineVar localEnv pattern input- return $ Bool True- else return $ (Bool False)+ p' <- getOrigName renameEnv pattern+ i' <- getOrigName renameEnv inpt+ pl <- isLexicallyDefined outerEnv renameEnv pattern+ il <- isLexicallyDefined outerEnv renameEnv inpt+ if (((pattern == inpt && (doesIdentMatch)) && (not isRenamed)) || + -- Equal and neither have a lexical binding, per spec+ (p' == i' && (not pl) && (not il)))+ then return 1+ else return 0 -- Pattern/Input cannot match because input is not an atom- _ -> return $ (Bool False)+ _ -> return 0 -- No literal identifier, just load up the var- _ -> do _ <- defineVar localEnv pattern input- return $ Bool True- where+ _ -> return 2+ -- Store pattern variable in a nested list -- FUTURE: ellipsisLevel should probably be used here for validation. -- @@ -657,50 +636,42 @@ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [DottedList ls l]) (List ts) apply walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList inputIsQuoted (List result) (List (Atom aa : ts)) apply = do- Atom a <- expandAtom renameEnv (Atom aa)-+ maybeMacro <- findBoundMacro defEnv useEnv a -- If a macro is quoted, keep track of it and do not invoke rules below for -- procedure abstraction or macro calls let isQuoted = inputIsQuoted || (a == "quote") - isDefinedAsMacro <- liftIO $ isNamespacedRecBound useEnv macroNamespace a-- -- (currently) unused conditional variables for below test- --isDiverted <- liftIO $ isRecBound divertEnv a- --isMacroBound <- liftIO $ isRecBound renameEnv a- --isLocalRename <- liftIO $ isNamespacedRecBound renameEnv 'r' {-"renamed"-} a-- -- Determine if we should recursively rename an atom- -- This code is a bit of a hack/mess at the moment- if isDefinedAsMacro --- || isDiverted--- || (isMacroBound && not isLocalRename)--- || not startOfList- || a == aa -- Prevent an infinite loop- -- Preserve keywords encountered in the macro - -- as each of these is really a special form, and renaming them- -- would not work because there is nothing to divert back...- || a == "if"- || a == "let-syntax" - || a == "letrec-syntax" - || a == "define-syntax" - || a == "define" - || a == "set!"- || a == "lambda"- || a == "quote"- || a == "expand"- || a == "string-set!"- || a == "set-car!"- || a == "set-cdr!"- || a == "vector-set!"- || a == "hash-table-set!"- || a == "hash-table-delete!"- then walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv - dim startOfList inputIsQuoted (List result) a ts isQuoted isDefinedAsMacro apply- else walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv - dim startOfList inputIsQuoted (List result) (List (Atom a : ts)) apply-+ case maybeMacro of+ Just _ -> walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv + dim startOfList inputIsQuoted (List result) + a ts isQuoted maybeMacro apply+ _ -> do+ -- Determine if we should recursively rename an atom+ -- This code is a bit of a hack/mess at the moment+ if a == aa -- Prevent an infinite loop+ -- Preserve keywords encountered in the macro + -- as each of these is really a special form, and renaming them+ -- would not work because there is nothing to divert back...+ || a == "if"+ || a == "let-syntax" + || a == "letrec-syntax" + || a == "define-syntax" + || a == "define" + || a == "set!"+ || a == "lambda"+ || a == "quote"+ || a == "expand"+ || a == "string-set!"+ || a == "set-car!"+ || a == "set-cdr!"+ || a == "vector-set!"+ || a == "hash-table-set!"+ || a == "hash-table-delete!"+ then walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv + dim startOfList inputIsQuoted (List result) a ts isQuoted maybeMacro apply+ else walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv + dim startOfList inputIsQuoted (List result) (List (Atom a : ts)) apply -- Transform anything else as itself... walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (t : ts)) apply = do@@ -728,7 +699,7 @@ -> String -> [LispVal] -> Bool -- is Quoted- -> Bool -- is defined as macro+ -> Maybe LispVal -- is defined as macro -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func -> IOThrowsError LispVal @@ -877,8 +848,7 @@ walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a ts - False True apply = do- syn <- getNamespacedVar useEnv macroNamespace a+ False (Just syn) apply = do case syn of -- -- Note:@@ -1547,3 +1517,25 @@ loadMacros _ _ _ _ [] = return $ Nil "" loadMacros _ _ _ _ form = throwError $ BadSpecialForm "Unable to evaluate form" $ List form ++-- |Retrieve original (non-renamed) identifier+getOrigName :: Env -> String -> IOThrowsError String+getOrigName renameEnv a = do+ v <- getVar' renameEnv a+ case v of + Just (Atom a') -> getOrigName renameEnv a'+ _ -> return a++-- |Determine if the given identifier is lexically defined+isLexicallyDefined :: Env -> Env -> String -> IOThrowsError Bool+isLexicallyDefined outerEnv renameEnv a = do+ o <- liftIO $ isBound outerEnv a+ r <- liftIO $ isBound renameEnv a+ return $ o || r++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
hs-src/Language/Scheme/Primitives.hs view
@@ -152,6 +152,7 @@ -- ** System , eofObject , system+-- , systemRead ) where import Language.Scheme.Numerical@@ -175,6 +176,7 @@ import System.Exit (ExitCode(..)) import System.IO import System.IO.Error+--import System.Process (readProcess) -- import Debug.Trace #if __GLASGOW_HASKELL__ < 702@@ -1938,3 +1940,12 @@ ExitFailure code -> return $ Number $ toInteger code system err = throwError $ TypeMismatch "string" $ List err +-- FUTURE (?):+-- systemRead :: [LispVal] -> IOThrowsError LispVal+-- systemRead ((String cmd) : args) = do+-- let args' = map conv args+-- result <- liftIO $ readProcess cmd args' ""+-- return $ String result+-- where+-- conv (String s) = s+-- conv _ = ""
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.16+Version: 3.16.1 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>
lib/modules.scm view
@@ -51,7 +51,11 @@ (reverse (cons ".sld" (cdr (module-name->strings name '())))))) (define (module-name-prefix name)- (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))+ (cond + ((and (pair? name) (pair? (cdr name)))+ (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))+ (else+ ""))) (define load-module-definition (let ((meta-env (current-environment)))