husk-scheme 3.4.2 → 3.4.3
raw patch · 12 files changed
+231/−113 lines, 12 filesdep +transformersdep −haskell98
Dependencies added: transformers
Dependencies removed: haskell98
Files
- README.markdown +5/−5
- hs-src/Language/Scheme/Core.hs +9/−9
- hs-src/Language/Scheme/FFI.hs +14/−1
- hs-src/Language/Scheme/Macro.hs +124/−47
- hs-src/Language/Scheme/Numerical.hs +2/−2
- hs-src/Language/Scheme/Parser.hs +24/−3
- hs-src/Language/Scheme/Primitives.hs +2/−2
- hs-src/Language/Scheme/Types.hs +3/−3
- hs-src/Language/Scheme/Variables.hs +11/−0
- hs-src/shell.hs +2/−2
- husk-scheme.cabal +3/−3
- stdlib.scm +32/−36
README.markdown view
@@ -1,10 +1,10 @@  -husk is a dialect of Scheme written in Haskell that implements a subset of the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS 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 [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS 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 R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS Schemes.+husk may be used as either a stand-alone interpreter or as an extension language within a larger Haskell application. By closely following the R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS Schemes. husk is mature enough for use in production applications, however it is not optimized for performance-critical applications. -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.
hs-src/Language/Scheme/Core.hs view
@@ -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"
hs-src/Language/Scheme/FFI.hs view
@@ -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
hs-src/Language/Scheme/Macro.hs view
@@ -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
hs-src/Language/Scheme/Numerical.hs view
@@ -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
hs-src/Language/Scheme/Parser.hs view
@@ -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
hs-src/Language/Scheme/Primitives.hs view
@@ -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
hs-src/Language/Scheme/Types.hs view
@@ -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
hs-src/Language/Scheme/Variables.hs view
@@ -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
hs-src/shell.hs view
@@ -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 " "
husk-scheme.cabal view
@@ -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
stdlib.scm view
@@ -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