diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,10 +1,10 @@ ![husk Scheme](https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png) -husk is a dialect of Scheme written in Haskell that implements a subset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. +husk is a dialect of Scheme written in Haskell that adheres to the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. -husk provides many features and is intended as a good choice for non-performance critical applications, as it is not a highly optimized Scheme. Rather, the goal of the project is to provide a tight integration between Haskell and Scheme while at the same time providing an opportunity for deeper understanding of both languages. In addition, by closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. +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. -Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement the other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. +Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. Feature List ------------ @@ -37,7 +37,7 @@ Installation ------------ -husk may be easily installed using [cabal](http://www.haskell.org/cabal/) - just run the following command: +husk may be installed using [cabal](http://www.haskell.org/cabal/) - just run the following command: cabal install husk-scheme @@ -94,7 +94,7 @@ - [cabal-install](http://hackage.haskell.org/trac/hackage/wiki/CabalInstall) may be used to build, deploy, and generate packages for husk. - [Haskeline](http://trac.haskell.org/haskeline) - which may be installed using cabal: `cabal install haskeline` -The `scm-unit-tests` directory contains unit tests for much of the scheme code. All tests may be executed via `make test` command. +The `scm-unit-tests` directory contains unit tests for much of the scheme code. All tests may be executed via the `make test` command. The `examples` directory contains example scheme programs. 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 @@ -31,7 +31,7 @@ import Control.Monad.Error import Data.Array import qualified Data.Map -import IO hiding (try) +import System.IO {- |Evaluate a string containing Scheme code. @@ -274,26 +274,26 @@ cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" -- A rudimentary implementation of let-syntax -eval env cont (List (Atom "let-syntax" : List bindings : body)) = do +eval env cont (List (Atom "let-syntax" : List _bindings : _body)) = do -- TODO: check if let-syntax has been rebound? bodyEnv <- liftIO $ extendEnv env [] - _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False bindings + _ <- 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 + expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body case expanded of List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" e -> continueEval bodyEnv cont e -eval env cont args@(List (Atom "letrec-syntax" : List bindings : body)) = do +eval env cont (List (Atom "letrec-syntax" : List _bindings : _body)) = do -- TODO: check if letrec-syntax has been rebound? bodyEnv <- liftIO $ extendEnv env [] -- A primitive means of implementing letrec, by simply assuming that each macro is defined in -- the letrec's environment, instead of the parent env. Not sure if this is 100% correct but it -- is good enough to pass the R5RS test case so it will be used as a rudimentary implementation -- for now... - _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False bindings + _ <- 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 + expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body case expanded of List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" e -> continueEval bodyEnv cont e @@ -342,8 +342,8 @@ where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = case result of - Bool True -> meval e c conseq - _ -> continueEval e c $ Nil "" -- Unspecified return value per R5RS + Bool False -> continueEval e c $ Nil "" -- Unspecified return value per R5RS + _ -> meval e c conseq eval env cont fargs@(List (Atom "begin" : funcs)) = do bound <- liftIO $ isRecBound env "begin" diff --git a/hs-src/Language/Scheme/FFI.hs b/hs-src/Language/Scheme/FFI.hs --- a/hs-src/Language/Scheme/FFI.hs +++ b/hs-src/Language/Scheme/FFI.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {- | Module : Language.Scheme.FFI Copyright : Justin Ethier @@ -60,6 +62,9 @@ m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing #if __GLASGOW_HASKELL__ < 700 GHC.setContext [] [m] +#elif __GLASGOW_HASKELL__ == 702 + (_,oi) <- GHC.getContext + GHC.setContext [m] oi #else GHC.setContext [] [(m, Nothing)] #endif @@ -75,6 +80,9 @@ m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing #if __GLASGOW_HASKELL__ < 700 GHC.setContext [] [m] +#elif __GLASGOW_HASKELL__ == 702 + (_,oi) <- GHC.getContext + GHC.setContext [m] oi #else GHC.setContext [] [(m, Nothing)] #endif @@ -85,4 +93,9 @@ evalfuncLoadFFI _ = throwError $ NumArgs 3 [] defaultRunGhc :: GHC.Ghc a -> IO a -defaultRunGhc = GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir) +defaultRunGhc = +#if __GLASGOW_HASKELL__ < 720 + GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir) +#else + GHC.defaultErrorHandler DynFlags.defaultLogAction . GHC.runGhc (Just GHC.Paths.libdir) +#endif 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 @@ -149,7 +149,7 @@ localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation -- to hold pattern variables result <- matchRule defEnv env divertEnv dim identifiers localEnv renameEnv cleanupEnv rule input - case result of + case (result) of -- No match, check the next rule Nil _ -> macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers rs input _ -> do @@ -393,7 +393,7 @@ checkLocal _ _ _ _ _ _ _ _ (Float pattern) (Float input) _ = return $ Bool $ pattern == input checkLocal _ _ _ _ _ _ _ _ (String pattern) (String input) _ = return $ Bool $ pattern == input checkLocal _ _ _ _ _ _ _ _ (Char pattern) (Char input) _ = return $ Bool $ pattern == input -checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags = do +checkLocal defEnv outerEnv _ localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags = do -- TODO: -- @@ -578,7 +578,7 @@ l <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) d walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [DottedList ls l]) (List ts) -walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList inputIsQuoted (List result) transform@(List (Atom aa : ts)) = do +walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList inputIsQuoted (List result) (List (Atom aa : ts)) = do Atom a <- expandAtom renameEnv (Atom aa) @@ -587,9 +587,36 @@ let isQuoted = inputIsQuoted || (a == "quote") || (a == "quasiquote") isDefinedAsMacro <- liftIO $ isNamespacedRecBound useEnv macroNamespace a - walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList inputIsQuoted (List result) - (a) ts isQuoted isDefinedAsMacro + -- (currently) unused conditional variables for below test + --isDiverted <- liftIO $ isRecBound divertEnv a + --isMacroBound <- liftIO $ isRecBound renameEnv a + --isLocalRename <- liftIO $ isNamespacedRecBound renameEnv "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 + -- A complete hack I think. This will likely need to be revisited throughout the 3.4.x + -- series of macro-related releases. + || a == "if" + || a == "begin" + || a == "let-syntax" + || a == "letrec-syntax" + || a == "define-syntax" + || a == "define" + || a == "set!" + || a == "lambda" + then walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv + dim startOfList inputIsQuoted (List result) a ts isQuoted isDefinedAsMacro + else walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv + dim startOfList inputIsQuoted (List result) (List (Atom a : ts)) + + -- Transform anything else as itself... walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (t : ts)) = do walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [t]) (List ts) @@ -642,41 +669,35 @@ else -} -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List _) "let-syntax" - (List bindings : body) + (List _bindings : _body) False _ = do - --- TODO: use of bodyEnv is not entirely correct because diverted vars will be lost! --- may need to pass one more env around for divert... - bodyEnv <- liftIO $ extendEnv useEnv [] - _ <- loadMacros useEnv bodyEnv (Just renameEnv) True bindings - expanded <- walkExpanded defEnv bodyEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List body) + bodyRenameEnv <- liftIO $ extendEnv renameEnv [] + _ <- loadMacros useEnv bodyEnv (Just bodyRenameEnv) True _bindings + expanded <- walkExpanded defEnv bodyEnv divertEnv bodyRenameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List _body) return $ List [expanded] walkExpandedAtom _ _ _ _ _ _ True _ _ "let-syntax" ts False _ = do throwError $ BadSpecialForm "Malformed let-syntax expression" $ List (Atom "let-syntax" : ts) -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List _) "letrec-syntax" - (List bindings : body) + (List _bindings : _body) False _ = do - --- TODO: use of bodyEnv is not entirely correct because diverted vars will be lost! --- may need to pass one more env around for divert... - bodyEnv <- liftIO $ extendEnv useEnv [] - _ <- loadMacros bodyEnv bodyEnv (Just renameEnv) True bindings - expanded <- walkExpanded defEnv bodyEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List body) + bodyRenameEnv <- liftIO $ extendEnv renameEnv [] + _ <- loadMacros bodyEnv bodyEnv (Just bodyRenameEnv) True _bindings + expanded <- walkExpanded defEnv bodyEnv divertEnv bodyRenameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List _body) return $ List [expanded] walkExpandedAtom _ _ _ _ _ _ True _ _ "letrec-syntax" ts False _ = do throwError $ BadSpecialForm "Malformed letrec-syntax expression" $ List (Atom "letrec-syntax" : ts) -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom _ useEnv _ renameEnv _ _ True _ (List _) "define-syntax" - ts@([Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) + ([Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) False _ = do -- Do we need to rename the keyword, or at least take that into account? renameEnvClosure <- liftIO $ copyEnv renameEnv @@ -697,17 +718,24 @@ that it is inserting a binding for the var -} -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _) "define" [Atom var, val] False _ = do - _ <- defineVar renameEnv var $ Atom var - walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List [Atom "define", {-head renamedVars-} Atom var]) (List [val]) +{- It seems like this should be necessary, but it causes problems so it is + disabled for now... + isAlreadyRenamed <- liftIO $ isRecBound renameEnv var + case (isAlreadyRenamed) of + _ -> do --False -> do -} + _ <- defineVar renameEnv var $ Atom var + walk +-- _ -> walk + where walk = walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List [Atom "define", Atom var]) (List [val]) walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"define" ts False _ = do -- define is malformed, just transform as normal atom... walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts) -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _) "set!" [Atom var, val] False _ = do @@ -728,39 +756,63 @@ -- define is malformed, just transform as normal atom... walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts) -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List _) "lambda" (List vars : fbody) False _ = do -- Placed here, the lambda primitive trumps a macro of the same name... (desired behavior?) -- Create a new Env for this, so args of the same name do not overwrite those in the current Env +-- env <- liftIO $ extendEnv (trace ("found procedure abstraction, vars = " ++ show vars ++ "body = " ++ show fbody) renameEnv) [] env <- liftIO $ extendEnv renameEnv [] renamedVars <- markBoundIdentifiers env cleanupEnv vars [] - walkExpanded defEnv useEnv divertEnv env cleanupEnv dim True False (List [Atom "lambda", renamedVars]) (List fbody) + walkExpanded defEnv useEnv divertEnv env cleanupEnv dim True False (List [Atom "lambda", (renamedVars)]) (List fbody) + walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"lambda" ts False _ = do -- lambda is malformed, just transform as normal atom... walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts) -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv _ True _ (List _) a ts False True = do syn <- getNamespacedVar useEnv macroNamespace a case syn of --- TODO: why do we assume that defEnv is the same as the one defined for the macro? Should read --- this out of the Syntax object +-- +-- Note: +-- +-- Why do we assume that defEnv is the same as the one defined for the macro? Should read +-- this out of the Syntax object, right? +-- +-- A) I think this is because for a macro with a renameClosure, it may only be defined +-- within another macro. So defEnv is not modified by this macro definition, and +-- there is no need to insert it. +-- Syntax _ (Just renameClosure) definedInMacro identifiers rules -> do - macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) - Syntax _ _ definedInMacro 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. - -- - -- 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)) + -- Before expanding the macro, make a pass across the macro body to mark + -- any instances of renamed variables. + -- + -- It seems this does not need to be done in the two cases below. + -- Presumably this is because in those cases there is no rename + -- environment inserted by the macro call, so no information is lost. + -- + -- 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 False (List []) (List ts) + macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : lexpanded)) + Syntax (Just _defEnv) _ definedInMacro identifiers rules -> do + macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) + Syntax Nothing _ definedInMacro 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. + -- + -- 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)) + _ -> throwError $ Default "Unexpected error processing a macro in walkExpandedAtom" -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ _ (List result) a ts True _ = do @@ -772,12 +824,14 @@ (List []) (List ts) return $ List $ result ++ (Atom a : cleaned) -walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ inputIsQuoted (List result) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ _ (List result) a ts isQuoted _ = do walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [Atom a]) (List ts) +walkExpandedAtom _ _ _ _ _ _ _ _ _ _ _ _ _ = throwError $ Default "Unexpected error in walkExpandedAtom" + -- |Accept a list of bound identifiers from a lambda expression, and rename them -- Returns a list of the renamed identifiers as well as marking those identifiers -- in the given environment, so they can be renamed during expansion. @@ -797,6 +851,7 @@ if isDefined then do expanded <- getVar renameEnv a +-- return (trace ("ea renaming " ++ a ++ " to " ++ show expanded) expanded) -- disabled this; just expand once. expandAtom renameEnv expanded -- Recursively expand return expanded -- disabled this; just expand once. expandAtom renameEnv expanded -- Recursively expand else return $ Atom a expandAtom _ a = return a @@ -1081,13 +1136,16 @@ if isAlreadyRenamed then do renamed <- getNamespacedVar localEnv "renamed" a +-- return (trace ("macro call renaming (again) " ++ a ++ " to " ++ show renamed) renamed) return renamed else do Atom renamed <- _gensym a _ <- defineNamespacedVar localEnv "renamed" a $ Atom renamed + _ <- defineNamespacedVar renameEnv "renamed" a $ Atom renamed -- Keep track of vars that are renamed; maintain reverse mapping _ <- defineVar cleanupEnv renamed $ Atom a -- Global record for final cleanup of macro _ <- defineVar (renameEnv) renamed $ Atom a -- Keep for Clinger +-- return $ Atom (trace ("macro call renamed " ++ a ++ " to " ++ renamed) renamed) return $ Atom renamed case t of Nil "var not defined in pattern" -> @@ -1150,7 +1208,7 @@ -- |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 defEnv outerEnv divertEnv renameEnv definedInMacro transform = do +transformLiteralIdentifier defEnv _ divertEnv renameEnv definedInMacro transform = do isInDef <- liftIO $ isRecBound defEnv transform isRenamed <- liftIO $ isRecBound renameEnv transform -- if (trace ("a = " ++ transform ++ " inDef = " ++ show isInDef ++ " isRnm = " ++ show isRenamed ++ " dim = " ++ show definedInMacro) isInDef) && not isRenamed @@ -1164,6 +1222,7 @@ value <- getVar defEnv transform Atom renamed <- _gensym transform _ <- defineVar divertEnv renamed value +-- return $ Atom (trace ("diverted " ++ transform ++ " into " ++ renamed) renamed) return $ Atom renamed else do {- TODO: @@ -1292,10 +1351,28 @@ -> Bool -- ^ True if the macro was defined inside another macro -> [LispVal] -- ^ List containing syntax-rule definitions -> IOThrowsError LispVal -- ^ A dummy value, unless an error is thrown -loadMacros e be re dim (List [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] : bs) = do +loadMacros e be Nothing dim (List [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] : bs) = do -- TODO: error checking _ <- defineNamespacedVar be macroNamespace keyword $ - Syntax (Just e) re dim identifiers rules - loadMacros e be re dim bs + Syntax (Just e) Nothing dim identifiers rules + loadMacros e be Nothing dim bs +loadMacros e be (Just re) dim args@(List [Atom keyword, (List (Atom syntaxrules : (List identifiers : rules)))] : bs) = do + Atom exKeyword <- expandAtom re (Atom keyword) + exSynRules <- expandAtom re (Atom syntaxrules) + +-- TODO: need to process identifiers and rules - are they just expanded, or cleaned up? + + case exSynRules of + Atom "syntax-rules" -> do +-- -- Temporary hack to expand the rules +-- List exRules <- cleanExpanded e e e re re dim False False (List []) (List rules) + + -- TODO: error checking + _ <- defineNamespacedVar be macroNamespace exKeyword $ +-- Syntax (Just e) (Just re) dim identifiers (trace ("exRules = " ++ show exRules) exRules) --rules +-- Syntax (Just e) (Just re) dim identifiers exRules --rules + Syntax (Just e) (Just re) dim identifiers rules + loadMacros e be (Just re) dim bs + _ -> throwError $ BadSpecialForm "Unable to evaluate form" $ List args loadMacros _ _ _ _ [] = return $ Nil "" loadMacros _ _ _ _ form = throwError $ BadSpecialForm "Unable to evaluate form" $ List form diff --git a/hs-src/Language/Scheme/Numerical.hs b/hs-src/Language/Scheme/Numerical.hs --- a/hs-src/Language/Scheme/Numerical.hs +++ b/hs-src/Language/Scheme/Numerical.hs @@ -16,11 +16,11 @@ module Language.Scheme.Numerical where import Language.Scheme.Types -import Complex +import Data.Complex import Control.Monad.Error import Data.Char import Numeric -import Ratio +import Data.Ratio import Text.Printf numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal diff --git a/hs-src/Language/Scheme/Parser.hs b/hs-src/Language/Scheme/Parser.hs --- a/hs-src/Language/Scheme/Parser.hs +++ b/hs-src/Language/Scheme/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {- | Module : Language.Scheme.Parser Copyright : Justin Ethier @@ -17,14 +18,23 @@ module Language.Scheme.Parser where import Language.Scheme.Types import Control.Monad.Error -import Char -import Complex +import qualified Data.Char as Char +import Data.Complex import Data.Array import Numeric -import Ratio +import Data.Ratio import Text.ParserCombinators.Parsec hiding (spaces) import Text.Parsec.Language +import Text.Parsec.Prim (ParsecT) import qualified Text.Parsec.Token as P +-- This was added by pull request #63 as part of a series of fixes +-- to get husk to build on ghc 7.2.2 +-- +-- For now this has been removed to allow husk to support the older +-- GHC 6.x.x series. But if removing this breaks things on 7.2 then +-- it will force a "real" solution... +-- +--import Data.Functor.Identity (Identity) lispDef :: LanguageDef () lispDef @@ -39,12 +49,23 @@ , P.caseSensitive = True } +--lexer :: P.GenTokenParser String () Identity lexer = P.makeTokenParser lispDef + +--dot :: ParsecT String () Identity String dot = P.dot lexer + +--parens :: ParsecT String () Identity a -> ParsecT String () Identity a parens = P.parens lexer + +--identifier :: ParsecT String () Identity String identifier = P.identifier lexer + -- TODO: typedef. starting point was: whiteSpace :: CharParser () +--whiteSpace :: ParsecT String () Identity () whiteSpace = P.whiteSpace lexer + +--lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a lexeme = P.lexeme lexer symbol :: Parser Char 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 @@ -19,11 +19,11 @@ import Language.Scheme.Parser import Language.Scheme.Types import Control.Monad.Error -import Char +import Data.Char import Data.Array import Data.Unique import qualified Data.Map -import IO hiding (try) +import System.IO import System.Directory (doesFileExist) import System.IO.Error 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 @@ -18,13 +18,13 @@ -} module Language.Scheme.Types where -import Complex +import Data.Complex import Control.Monad.Error import Data.Array import Data.IORef import qualified Data.Map -import IO hiding (try) -import Ratio +import System.IO +import Data.Ratio import Text.ParserCombinators.Parsec hiding (spaces) -- Environment management 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 @@ -48,6 +48,17 @@ Nothing -> return False -- Var never found -} +-- |Show the contents of an environment +printEnv :: Env -> IO String +printEnv env = do + binds <- liftIO $ readIORef $ bindings env + l <- mapM showVar binds + return $ unlines l + where + showVar ((_, name), val) = do + v <- liftIO $ readIORef val + return $ name ++ ": " ++ show v + -- |Create a deep copy of an environment copyEnv :: Env -> IO Env copyEnv env = do diff --git a/hs-src/shell.hs b/hs-src/shell.hs --- a/hs-src/shell.hs +++ b/hs-src/shell.hs @@ -21,7 +21,7 @@ import Language.Scheme.Types -- Scheme data types import Language.Scheme.Variables -- Scheme variable operations import Control.Monad.Error -import IO hiding (try) +import System.IO import System.Environment import System.Console.Haskeline @@ -67,7 +67,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " " - putStrLn " husk Scheme Interpreter Version 3.4.2 " + putStrLn " husk Scheme Interpreter Version 3.4.3 " putStrLn " (c) 2010-2011 Justin Ethier github.com/justinethier/husk-scheme " putStrLn " " 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.4.2 +Version: 3.4.3 Synopsis: R5RS Scheme interpreter program and library. Description: A dialect of R5RS Scheme written in Haskell. Provides advanced features including continuations, hygienic macros, a Haskell FFI, @@ -19,7 +19,7 @@ Data-Files: stdlib.scm Library - Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths + Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core @@ -34,7 +34,7 @@ Language.Scheme.Primitives Executable huski - Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths + Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Main-is: shell.hs Hs-Source-Dirs: hs-src diff --git a/stdlib.scm b/stdlib.scm --- a/stdlib.scm +++ b/stdlib.scm @@ -130,43 +130,26 @@ (begin result1 result2 ...) (cond clause1 clause2 ...))))) ; Case -; -; TODO: form from R5RS: -;(define-syntax case -; (syntax-rules (else) -; ((case (key ...) -; clauses ...) -; (let ((atom-key (key ...))) -; (case atom-key clauses ...))) -; ((case key -; (else result1 result2 ...)) -; (begin result1 result2 ...)) -; ((case key -; ((atoms ...) result1 result2 ...)) -; (if (memv key '(atoms ...)) -; (begin result1 result2 ...))) -; ((case key -; ((atoms ...) result1 result2 ...) -; clause clauses ...) -; (if (memv key '(atoms ...)) -; (begin result1 result2 ...) -; (case key clause clauses ...))))) -; -; Based loosely on implementation from: -; http://blog.jcoglan.com/2009/02/25/announcing-heist-a-new-scheme-implementation-written-in-ruby/ +; Form from R5RS: (define-syntax case (syntax-rules (else) - ((_ key) ((lambda () #f))) - ((_ key (else expr1 expr2 ...)) - (begin expr1 expr2 ...)) - ((_ key (() expr ...) clause ...) - (case key clause ...)) - ((_ key - ((datum1 datum2 ...) expr1 expr2 ...) - clause ...) - (if (eqv? #f (memv key '(datum1 datum2 ...))) - (case key clause ...) - (begin expr1 expr2 ...))))) + ((case (key ...) + clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key + ((atoms ...) result1 result2 ...) + clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) (define (my-mem-helper obj lst cmp-proc) (cond @@ -202,7 +185,20 @@ (list-tail (cdr lst) (- k 1)))) (define (list-ref lst k) (car (list-tail lst k))) -(define (append inlist alist) (foldr (lambda (ap in) (cons ap in)) alist inlist)) +; append accepts a variable number of arguments, per R5RS. So a wrapper +; has been provided for the standard 2-argument version of (append). +; +; We return the given value if less than 2 arguments are given, and +; otherwise fold over each arg, appending it to its predecessor. +(define (append . lst) + (let ((append-2 + (lambda (inlist alist) + (foldr (lambda (ap in) (cons ap in)) alist inlist)))) + (if (null? lst) + lst + (if (null? (cdr lst)) + (car lst) + (fold (lambda (a b) (append-2 b a)) (car lst) (cdr lst)))))) ; Let forms (define-syntax letrec