diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -7,11 +7,12 @@ Arseniy Eli Barzilay Ricardo Lanziano - SaitoAtsushi + Saito Atsushi sw2wolf References: Write Yourself a Scheme in 48 Hours R5RS + R7RS CHICKEN Chibi-Scheme diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -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 -------- 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 @@ -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 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 @@ -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 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 @@ -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 " 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 @@ -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" diff --git a/hs-src/Language/Scheme/Environments.hs b/hs-src/Language/Scheme/Environments.hs --- a/hs-src/Language/Scheme/Environments.hs +++ b/hs-src/Language/Scheme/Environments.hs @@ -152,6 +152,7 @@ ("read-all", readAll), ("find-module-file", findModuleFile), ("system", system), +-- ("system-read", systemRead), ("gensym", gensym)] 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 @@ -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 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 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 @@ -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 _ = "" 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.16 +Version: 3.16.1 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> diff --git a/lib/modules.scm b/lib/modules.scm --- a/lib/modules.scm +++ b/lib/modules.scm @@ -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)))