husk-scheme 3.6.3 → 3.7

raw patch · 20 files changed

+887/−269 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.markdown +19/−2
• hs-src/Compiler/huskc.hs +5/−0
• hs-src/Interpreter/shell.hs +63/−28
• hs-src/Language/Scheme/Compiler.hs +3/−2
• hs-src/Language/Scheme/Core.hs +134/−84
• hs-src/Language/Scheme/Libraries.hs +73/−0
• hs-src/Language/Scheme/Macro.hs +1/−0
• hs-src/Language/Scheme/Macro/ExplicitRenaming.hs +12/−6
• hs-src/Language/Scheme/Numerical.hs +80/−65
• hs-src/Language/Scheme/Parser.hs +4/−2
• hs-src/Language/Scheme/Plugins/CPUTime.hs +2/−2
• hs-src/Language/Scheme/Primitives.hs +58/−58
• hs-src/Language/Scheme/Types.hs +5/−3
• hs-src/Language/Scheme/Util.hs +26/−0
• hs-src/Language/Scheme/Variables.hs +41/−6
• husk-scheme.cabal +16/−5
• lib/modules.scm +331/−0
• lib/r5rs/base.sld +3/−0
• lib/scheme/base.sld +5/−0
• lib/stdlib.scm +6/−6

@@ -1,9 +1,26 @@+v3.7+--------++A major change for this release is the introduction of Scheme libraries using R7RS library syntax. For an example of how to use libraries, see `examples/hello-library/hello.scm` in the husk source tree. Note that since R7RS is not currently implemented by husk, the library system only has the built-in import `(r5rs base)` to allow you to import the standard husk R5RS environment. Also, please keep in mind this is still a beta feature that is not yet implemented by the compiler.++This release also contains many improvements to the Haskell API:++- Added `r5rsEnv` to the Core module to expose the full environment, including functions loaded from the Scheme standard library.+- Added `getDataFileFullPath` to the Core module to allow third party code to reference Scheme files such as `stdlib.scm` that are installed alongside husk.+- Modified `NumArgs` to optionally require an explicit number of arguments. This helps when writing variable-length functions where specifying a single number of arguments may be misleading.+- Added a new module `Language.Scheme.Util` to contain general purpose utility functions.++Bug fixes:++- Updated the parser to accept floating point numbers that contain only a fractional component, such as `.5`.+- Enhanced numerical comparison operators (`=`, `<`, `<=`, `>`, `>=`) to be able to accept an unlimited number of arguments, per R5RS.+ v3.6.3 --------  Added support for R<sup>7</sup>RS bytevectors. -Added the Haskell function `evalLisp'` to evaluate a lisp data structure and return the `LispVal` or `LispError` result directly:+Improved support for using husk as an extension language by adding Haskell function `evalLisp'`. This function evaluates a lisp data structure and returns the `LispVal` or `LispError` result directly:      evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal) @@ -14,7 +31,7 @@       Left err -> putStrLn $ "Error: " ++ (show err)       Right val -> putStrLn $ show val -Fixed a bug where setting a variable to refer back to itself would result in an infinite loop. For example, the last line of the following code would cause `huski` to hang:+Finally, fixed a bug where setting a variable to refer back to itself would result in an infinite loop. For example, the last line of the following code would cause `huski` to hang:      (define a '())     (define b a)

@@ -130,6 +130,11 @@ -- |High level code to compile the given file process :: String -> String -> Bool -> String -> IO () process inFile outExec dynamic extraArgs = do+++-- TODO: how to integrate r5rsEnv and libraries?++   env <- Language.Scheme.Core.primitiveBindings   stdlib <- getDataFileName "lib/stdlib.scm"   srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension)

@@ -15,31 +15,78 @@ import Paths_husk_scheme import Language.Scheme.Core      -- Scheme Interpreter import Language.Scheme.Types     -- Scheme data types+import Language.Scheme.Util import Language.Scheme.Variables -- Scheme variable operations --import Control.Monad (when) import Control.Monad.Error-import System.IO-import System.Environment+import System.Cmd (system)+import System.Console.GetOpt import System.Console.Haskeline+import System.Environment+import System.Exit (ExitCode (..), exitWith, exitFailure)+import System.IO  main :: IO ()-main = do args <- getArgs-          if null args then do showBanner-                               runRepl-                       else runOne $ args+main = do +  args <- getArgs +  let (actions, nonOpts, msgs) = getOpt Permute options args+  opts <- foldl (>>=) (return defaultOptions) actions+  let Options {optSchemeRev = schemeRev} = opts++  if null nonOpts +     then do +       showBanner+       runRepl schemeRev+     else runOne schemeRev nonOpts++-- Command line options section+data Options = Options {+    optSchemeRev :: String -- RxRS version+    }++-- |Default values for the command line options+defaultOptions :: Options+defaultOptions = Options {+    optSchemeRev = "5"+    }+options :: [OptDescr (Options -> IO Options)]+options = [+  Option ['r'] ["revision"] (ReqArg writeRxRSVersion "Scheme") "scheme RxRS version",+  Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information"+  ]++writeRxRSVersion arg opt = return opt { optSchemeRev = arg }++showHelp :: Options -> IO Options+showHelp _ = do+  putStrLn "Usage: huski [options] [file]"+  putStrLn ""+  putStrLn "  huski is the husk scheme interpreter."+  putStrLn ""+  putStrLn "  File is a scheme source file to execute. If no file is specified"+  putStrLn "  the husk REPL will be started."+  putStrLn ""+  putStrLn "  Options may be any of the following:"+  putStrLn ""+  putStrLn "  -h -? --help      Display this information"+  putStrLn "  -r --revision     Specify the scheme revision to use:"+  putStrLn ""+  putStrLn "                      5 - r5rs (default)"+  putStrLn "                      7 - r7rs small"+  putStrLn ""+  exitWith ExitSuccess+ -- REPL Section flushStr :: String -> IO () flushStr str = putStr str >> hFlush stdout  -- |Execute a single scheme file from the command line-runOne :: [String] -> IO ()-runOne args = do-  env <- primitiveBindings >>= flip extendEnv-                                   [((varNamespace, "args"),-                                    List $ map String $ drop 1 args)]-  -- Load standard library-  _ <- loadLibraries env+runOne :: String -> [String] -> IO ()+runOne _ args = do+  env <- r5rsEnv >>= flip extendEnv+                          [((varNamespace, "args"),+                           List $ map String $ drop 1 args)]    result <- (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)]))   case result of@@ -54,22 +101,10 @@           Just errMsg -> putStrLn errMsg           _  -> return ()) --- |Load standard libraries into the given environment-loadLibraries :: Env -> IO ()-loadLibraries env = do-  stdlib <- getDataFileName "lib/stdlib.scm"-  srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension)-  -- Load standard library-  _ <- evalString env $ "(load \"" ++ (escapeBackslashes stdlib) ++ "\")" -  -- Load (require-extension), which can be used to load other SRFI's-  _ <- evalString env $ "(load \"" ++ (escapeBackslashes srfi55) ++ "\")"-  registerExtensions env getDataFileName- -- |Start the REPL (interactive interpreter)-runRepl :: IO ()-runRepl = do-    env <- primitiveBindings-    _ <- loadLibraries env+runRepl :: String -> IO ()+runRepl _ = do+    env <- r5rsEnv      runInputT defaultSettings (loop env)     where

@@ -22,10 +22,11 @@ -}  module Language.Scheme.Compiler where -import qualified Language.Scheme.Core (apply, escapeBackslashes, evalLisp)+import qualified Language.Scheme.Core (apply, evalLisp) import qualified Language.Scheme.Macro import Language.Scheme.Primitives import Language.Scheme.Types+import qualified Language.Scheme.Util (escapeBackslashes) import Language.Scheme.Variables import Control.Monad.Error import qualified Data.Array@@ -145,7 +146,7 @@ header filepath = do   [ " "     , "getDataFileName' :: FilePath -> IO FilePath "-    , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Core.escapeBackslashes filepath) ++ "\" ++ name "+    , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Util.escapeBackslashes filepath) ++ "\" ++ name "     , " "     , "exec55_2 env cont _ _ = do "     , "  liftIO $ registerExtensions env getDataFileName' "

@@ -23,23 +23,27 @@     , continueEval     -- * Core data     , primitiveBindings+    , r5rsEnv     , version     -- * Utility functions+    , getDataFileFullPath     , registerExtensions-    , escapeBackslashes     , showBanner     , substr     , updateVector     , updateByteVector     ) where+import qualified Paths_husk_scheme as PHS (getDataFileName) #ifdef UseFfi import qualified Language.Scheme.FFI #endif+import Language.Scheme.Libraries import qualified Language.Scheme.Macro import Language.Scheme.Numerical import Language.Scheme.Parser import Language.Scheme.Primitives import Language.Scheme.Types+import Language.Scheme.Util import Language.Scheme.Variables import Control.Monad.Error import Data.Array@@ -49,11 +53,11 @@ import Data.Word import qualified System.Exit import System.IO-import Debug.Trace+-- import Debug.Trace  -- |husk version number version :: String-version = "3.6.3"+version = "3.7"  -- |A utility function to display the husk console banner showBanner :: IO ()@@ -70,6 +74,10 @@   putStrLn $ " Version " ++ version ++ " "   putStrLn "                                                                         " +-- |Get the full path to a data file installed for husk+getDataFileFullPath :: String -> IO String+getDataFileFullPath s = PHS.getDataFileName s+ -- |Register optional SRFI extensions registerExtensions :: Env -> (FilePath -> IO FilePath) -> IO () registerExtensions env getDataFileName = do@@ -85,13 +93,7 @@   (escapeBackslashes filename) ++ "\")"  return () --- |A utility function to escape backslashes in the given string-escapeBackslashes :: String -> String-escapeBackslashes s = foldr step [] s-  where step x xs  | x == '\\'  = '\\' : '\\' : xs-                   | otherwise =  x : xs  - {- |Evaluate a string containing Scheme code  @@@ -250,6 +252,7 @@ eval env cont val@(HashTable _) = continueEval env cont val eval env cont val@(Vector _) = continueEval env cont val eval env cont val@(ByteVector _) = continueEval env cont val+eval env cont val@(LispEnv _) = continueEval env cont val eval env cont val@(Pointer _ _) = continueEval env cont val eval env cont (Atom a) = do   v <- getVar env a@@ -306,6 +309,17 @@      List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil ""       e -> continueEval bodyEnv cont e +-- A non-standard way to rebind a macro to another keyword+eval env cont args@(List [Atom "define-syntax", +                          Atom newKeyword,+                          Atom keyword]) = do+  bound <- liftIO $ isNamespacedRecBound env macroNamespace keyword+  if bound+     then do+       m <- getNamespacedVar env macroNamespace keyword+       defineNamespacedVar env macroNamespace newKeyword m+     else throwError $ TypeMismatch "macro" $ Atom keyword+ eval env cont args@(List [Atom "define-syntax", Atom keyword,   (List [Atom "er-macro-transformer",      (List (Atom "lambda" : List fparams : fbody))])]) = do@@ -384,7 +398,7 @@  bound <- liftIO $ isRecBound env "set!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 2 args+  else throwError $ NumArgs (Just 2) args  eval env cont args@(List [Atom "define", Atom var, form]) = do  bound <- liftIO $ isRecBound env "define"@@ -398,8 +412,11 @@  bound <- liftIO $ isRecBound env "define"  if bound   then prepareApply env cont args -- if is bound to a variable in this scope; call into it-  else do result <- (makeNormalFunc env fparams fbody >>= defineVar env var)-          continueEval env cont result+  else do +      -- Experimenting with macro expansion of body of function+      -- ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody+      result <- (makeNormalFunc env fparams fbody >>= defineVar env var)+      continueEval env cont result  eval env cont args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do  bound <- liftIO $ isRecBound env "define"@@ -455,7 +472,7 @@  bound <- liftIO $ isRecBound env "string-set!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 3 args+  else throwError $ NumArgs (Just 3) args  eval env cont args@(List [Atom "set-car!", Atom var, argObj]) = do  bound <- liftIO $ isRecBound env "set-car!"@@ -485,7 +502,7 @@  bound <- liftIO $ isRecBound env "set-car!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 2 args+  else throwError $ NumArgs (Just 2) args  eval env cont args@(List [Atom "set-cdr!", Atom var, argObj]) = do  bound <- liftIO $ isRecBound env "set-cdr!"@@ -523,7 +540,7 @@  bound <- liftIO $ isRecBound env "set-cdr!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 2 args+  else throwError $ NumArgs (Just 2) args  eval env cont args@(List [Atom "vector-set!", Atom var, i, object]) = do  bound <- liftIO $ isRecBound env "vector-set!"@@ -552,7 +569,7 @@  bound <- liftIO $ isRecBound env "vector-set!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 3 args+  else throwError $ NumArgs (Just 3) args  eval env cont args@(List [Atom "bytevector-u8-set!", Atom var, i, object]) = do  bound <- liftIO $ isRecBound env "bytevector-u8-set!"@@ -581,7 +598,7 @@  bound <- liftIO $ isRecBound env "bytevector-u8-set!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 3 args+  else throwError $ NumArgs (Just 3) args  eval env cont args@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do  bound <- liftIO $ isRecBound env "hash-table-set!"@@ -615,7 +632,7 @@  bound <- liftIO $ isRecBound env "hash-table-set!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 3 args+  else throwError $ NumArgs (Just 3) args  eval env cont args@(List [Atom "hash-table-delete!", Atom var, rkey]) = do  bound <- liftIO $ isRecBound env "hash-table-delete!"@@ -645,7 +662,7 @@  bound <- liftIO $ isRecBound env "hash-table-delete!"  if bound   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it-  else throwError $ NumArgs 2 args+  else throwError $ NumArgs (Just 2) args  eval env cont args@(List (_ : _)) = mprepareApply env cont args eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm@@ -729,7 +746,7 @@    doApply e c = do       -- TODO (?): List dargs <- recDerefPtrs $ List args -- Deref any pointers       case (toInteger $ length args) of-        0 -> throwError $ NumArgs 1 []+        0 -> throwError $ NumArgs (Just 1) []         1 -> continueEval e c $ head args         _ ->  -- Pass along additional arguments, so they are available to (call-with-values)              continueEval e (Continuation env ccont ncont (Just $ tail args) ndynwind) $ head args@@ -752,7 +769,7 @@     _ -> return result apply cont (Func aparams avarargs abody aclosure) args =   if num aparams /= num args && avarargs == Nothing-     then throwError $ NumArgs (num aparams) args+     then throwError $ NumArgs (Just (num aparams)) args      else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody)   where remainingArgs = drop (length aparams) args         num = toInteger . length@@ -785,7 +802,7 @@           Nothing -> return env apply cont (HFunc aparams avarargs abody aclosure) args =   if num aparams /= num args && avarargs == Nothing-     then throwError $ NumArgs (num aparams) args+     then throwError $ NumArgs (Just (num aparams)) args      else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody)   where remainingArgs = drop (length aparams) args         num = toInteger . length@@ -810,15 +827,49 @@   List args' <- recDerefPtrs $ List args   throwError $ BadSpecialForm "Unable to evaluate form" $ List (func' : args') -{- |Environment containing the primitive forms that are built into the Scheme language. Note that this only includes-forms that are implemented in Haskell; derived forms implemented in Scheme (such as let, list, etc) are available-in the standard library which must be pulled into the environment using /(load)/. -}+-- |Environment containing the primitive forms that are built into the Scheme +--  language. This function only includes forms that are implemented in Haskell; +--  derived forms implemented in Scheme (such as let, list, etc) are available+--  in the standard library which must be pulled into the environment using /(load)/+--+--  For the purposes of using husk as an extension language, /r5rsEnv/ will+--  probably be more useful. primitiveBindings :: IO Env primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives                                                ++ map (domakeFunc EvalFunc) evalFunctions                                                ++ map (domakeFunc PrimitiveFunc) primitives)   where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) +-- |Load the standard r5rs environment, including libraries+r5rsEnv :: IO Env+r5rsEnv = do+  env <- primitiveBindings+  stdlib <- PHS.getDataFileName "lib/stdlib.scm"+  srfi55 <- PHS.getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension)+  +  -- Load standard library+  _ <- evalString env $ "(load \"" ++ (escapeBackslashes stdlib) ++ "\")" ++  -- Load (require-extension), which can be used to load other SRFI's+  _ <- evalString env $ "(load \"" ++ (escapeBackslashes srfi55) ++ "\")"+  registerExtensions env PHS.getDataFileName++#ifdef UseLibraries+  -- Load module meta-language +  metalib <- PHS.getDataFileName "lib/modules.scm"+  metaEnv <- nullEnvWithParent env -- Load env as parent of metaenv+  _ <- evalString metaEnv $ "(load \"" ++ (escapeBackslashes metalib) ++ "\")"+  -- Load meta-env so we can find it later+  _ <- evalLisp' env $ List [Atom "define", Atom "*meta-env*", LispEnv metaEnv]+  -- Bit of a hack to load (import)+  _ <- evalLisp' env $ List [Atom "%bootstrap-import"]+  -- Load (r5rs base)+  _ <- evalString metaEnv+         "(add-module! '(r5rs) (make-module #f (interaction-environment) '()))"+#endif++  return env+ -- Functions that extend the core evaluator, but that can be defined separately. -- {- These functions have access to the current environment via the@@ -858,8 +909,8 @@                                thunkFunc []    cpsThunk _ _ _ _ = throwError $ Default "Unexpected error in cpsThunk during (dynamic-wind)"    cpsAfter _ c _ _ = apply c afterFunc [] -- FUTURE: remove dynamicWinder from above from the list before calling after-evalfuncDynamicWind (_ : args) = throwError $ NumArgs 3 args -- Skip over continuation argument-evalfuncDynamicWind _ = throwError $ NumArgs 3 []+evalfuncDynamicWind (_ : args) = throwError $ NumArgs (Just 3) args -- Skip over continuation argument+evalfuncDynamicWind _ = throwError $ NumArgs (Just 3) []  evalfuncCallWValues [cont@(Continuation env _ _ _ _), producer, consumer] = do   apply (makeCPS env cont cpsEval) producer [] -- Call into prod to get values@@ -867,15 +918,15 @@    cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal    cpsEval _ c@(Continuation _ _ _ (Just xargs) _) value _ = apply c consumer (value : xargs)    cpsEval _ c value _ = apply c consumer [value]-evalfuncCallWValues (_ : args) = throwError $ NumArgs 2 args -- Skip over continuation argument-evalfuncCallWValues _ = throwError $ NumArgs 2 []+evalfuncCallWValues (_ : args) = throwError $ NumArgs (Just 2) args -- Skip over continuation argument+evalfuncCallWValues _ = throwError $ NumArgs (Just 2) []  --evalfuncApply [cont@(Continuation _ _ _ _ _), func, List args] = apply cont func args evalfuncApply (cont@(Continuation _ _ _ _ _) : func : args) = do   let aRev = reverse args    if null args-     then throwError $ NumArgs 2 args+     then throwError $ NumArgs (Just 2) args      else applyArgs $ head aRev  where    applyArgs aRev = do@@ -886,8 +937,8 @@         value <- recDerefPtrs aRev         applyArgs value       other -> throwError $ TypeMismatch "List" other-evalfuncApply (_ : args) = throwError $ NumArgs 2 args -- Skip over continuation argument-evalfuncApply _ = throwError $ NumArgs 2 []+evalfuncApply (_ : args) = throwError $ NumArgs (Just 2) args -- Skip over continuation argument+evalfuncApply _ = throwError $ NumArgs (Just 2) []   evalfuncMakeEnv (cont@(Continuation env _ _ _ _) : _) = do@@ -897,67 +948,53 @@ evalfuncNullEnv [cont@(Continuation env _ _ _ _), Number version] = do     nullEnv <- liftIO $ primitiveBindings     continueEval env cont $ LispEnv nullEnv-evalfuncNullEnv (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument-evalfuncNullEnv _ = throwError $ NumArgs 1 []+evalfuncNullEnv (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument+evalfuncNullEnv _ = throwError $ NumArgs (Just 1) []  evalfuncInteractionEnv (cont@(Continuation env _ _ _ _) : _) = do     continueEval env cont $ LispEnv env --- TODO: just testing out a binding for %import--- evalfuncImport [---     cont@(Continuation env _ _ _ _), ---     LispEnv toEnv,---     LispEnv fromEnv, ---     List imports,---     _] = do--- --    topmostEnv <- liftIO $ topmostEnv toEnv -- TODO: testing this out; trying to overcome introducing vars to a nested env---     LispEnv toEnv' <- getVar toEnv "meta-env"---     result <- moduleImport toEnv' fromEnv imports---     continueEval env cont (trace ("finished import") result)--- --- evalfuncImport [---     cont@(Continuation env a b c d), ---     Bool False, -- Default to env---     LispEnv fromEnv, ---     List imports,---     _] = do--- --    topmostEnv <- liftIO $ topmostEnv env -- TODO: testing this out; trying to overcome introducing vars to a nested env---     LispEnv toEnv <- getVar env "meta-env"---     LispEnv env' <- moduleImport toEnv fromEnv imports---     continueEval---         env'---         (Continuation env' a b c d)---         (trace ("finished import 2") $ LispEnv env')--- -- TODO: should env' be passed along?    continueEval env' cont (trace ("finished import") $ LispEnv env')- evalfuncImport [-    cont@(Continuation env _ _ _ _), +    cont@(Continuation env a b c d),      toEnv,     LispEnv fromEnv,      imports,     _] = do-    let sourceEnv = case toEnv of-                        LispEnv e -> e-                        Bool False -> env+    LispEnv toEnv' <- +        case toEnv of+            LispEnv e -> return toEnv+            Bool False -> do+                -- A hack to load imports into the main env, which+                -- in modules.scm is the grandparent env+                case parentEnv env of+                    Just (Environment (Just gp) _ _) -> +                        return $ LispEnv gp+                    Just (Environment Nothing _ _ ) -> throwError $ InternalError "import into empty parent env"+                    Nothing -> throwError $ InternalError "import into empty env" -    LispEnv toEnv' <- getVar sourceEnv "meta-env"     case imports of         List i -> do             result <- moduleImport toEnv' fromEnv i-            continueEval env cont (trace ("finished import") result)--- TODO:        Bool False -> do -- Export everything (?)+            continueEval env cont result+        Bool False -> do -- Export everything+            newEnv <- liftIO $ importEnv toEnv' fromEnv+            continueEval +                env +               (Continuation env a b c d) +               (LispEnv newEnv)  -- This is just for debugging purposes: evalfuncImport (cont@(Continuation env _ _ _ _ ) : cs) = do-    (trace ("import DEBUG: " ++ show cs) continueEval) env cont $ Nil ""+    continueEval env cont $ Nil "" -moduleImport to from (Atom i : is) = do-  v <- getVar from i -  _ <- defineVar to i (trace ("Import toEnv: " ++ "[" ++ i ++ "]" ++ show v) v)-  moduleImport to from is-moduleImport to from [] = do-  return $ LispEnv to+-- |Load import into the main environment+bootstrapImport [cont@(Continuation env _ _ _ _)] = do+    LispEnv me <- getVar env "*meta-env*"+    ri <- getNamespacedVar me macroNamespace "repl-import"+    renv <- defineNamespacedVar env macroNamespace "import" ri+    continueEval env cont renv + evalfuncLoad [cont@(Continuation _ a b c d), String filename, LispEnv env] = do     evalfuncLoad [Continuation env a b c d, String filename] @@ -979,8 +1016,8 @@        else return $ Nil "" -- Empty, unspecified value   where evaluate env2 cont2 val2 = meval env2 cont2 val2 -evalfuncLoad (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument-evalfuncLoad _ = throwError $ NumArgs 1 []+evalfuncLoad (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument+evalfuncLoad _ = throwError $ NumArgs (Just 1) []  -- Evaluate an expression in the current environment --@@ -991,8 +1028,8 @@ -- evalfuncEval [cont@(Continuation env _ _ _ _), val] = meval env cont val evalfuncEval [cont@(Continuation _ _ _ _ _), val, LispEnv env] = meval env cont val-evalfuncEval (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument-evalfuncEval _ = throwError $ NumArgs 1 []+evalfuncEval (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument+evalfuncEval _ = throwError $ NumArgs (Just 1) []  evalfuncCallCC [cont@(Continuation _ _ _ _ _), func] = do    case func of@@ -1006,15 +1043,15 @@      Func aparams _ _ _ ->        if (toInteger $ length aparams) == 1          then apply cont func [cont]-         else throwError $ NumArgs (toInteger $ length aparams) [cont]+         else throwError $ NumArgs (Just (toInteger $ length aparams)) [cont]      HFunc _ (Just _) _ _ -> apply cont func [cont] -- Variable # of args (pair). Just call into cont        HFunc aparams _ _ _ ->        if (toInteger $ length aparams) == 1          then apply cont func [cont]-         else throwError $ NumArgs (toInteger $ length aparams) [cont]+         else throwError $ NumArgs (Just (toInteger $ length aparams)) [cont]      other -> throwError $ TypeMismatch "procedure" other-evalfuncCallCC (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument-evalfuncCallCC _ = throwError $ NumArgs 1 []+evalfuncCallCC (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument+evalfuncCallCC _ = throwError $ NumArgs (Just 1) []  evalfuncExitFail _ = do   _ <- liftIO $ System.Exit.exitFailure@@ -1034,16 +1071,20 @@                   , ("null-environment", evalfuncNullEnv)                   , ("current-environment", evalfuncInteractionEnv)                   , ("interaction-environment", evalfuncInteractionEnv)-                  , ("%import", evalfuncImport)                   , ("make-environment", evalfuncMakeEnv)                 -- Non-standard extensions #ifdef UseFfi                   , ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI) #endif+#ifdef UseLibraries+                  , ("%import", evalfuncImport)+                  , ("%bootstrap-import", bootstrapImport)+#endif                   , ("exit-fail", evalfuncExitFail)                   , ("exit-success", evalfuncExitSuccess)                 ]+ {- I/O primitives Primitive functions that execute within the IO monad -} ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]@@ -1083,14 +1124,23 @@                  -- Other I/O functions                 ("print-env", printEnv'),+                ("env-exports", exportsFromEnv'),                 ("read-contents", readContents),                 ("read-all", readAll),+                ("find-module-file", findModuleFile),                 ("gensym", gensym)]  printEnv' :: [LispVal] -> IOThrowsError LispVal printEnv' [LispEnv env] = do     result <- liftIO $ printEnv env     return $ String result++exportsFromEnv' :: [LispVal] -> IOThrowsError LispVal+exportsFromEnv' [LispEnv env] = do+    result <- liftIO $ exportsFromEnv env+    return $ List result+--exportsFromEnv' err = throwError $ Default $ "bad args: " ++ show err+exportsFromEnv' err = return $ List []  {- "Pure" primitive functions -} primitives :: [(String, [LispVal] -> ThrowsError LispVal)]

@@ -0,0 +1,73 @@+{- |+Module      : Language.Scheme.Libraries+Copyright   : Justin Ethier+Licence     : MIT (see LICENSE in the distribution)++Maintainer  : github.com/justinethier+Stability   : experimental+Portability : portable++This module contains code to handle R7RS libraries.+NOTE: Libraries are usually referred to as "modules" in the husk source code.++-}++module Language.Scheme.Libraries+    (+      findModuleFile+    , moduleImport+    ) where+import qualified Paths_husk_scheme as PHS (getDataFileName)+import Language.Scheme.Types+import Language.Scheme.Util+import Language.Scheme.Variables+import Control.Monad.Error++-- |Get the full path to a module file+findModuleFile +    :: [LispVal]+    -> IOThrowsError LispVal+findModuleFile [String file] +    -- Built-in modules+-- TODO: does this work in Windows, since it uses the "wrong" type of slashes for that OS?+    | file == "r5rs/base.sld" ||+      file == "scheme/base.sld" ||+      file == "scheme/write.sld" = do+        path <- liftIO $ PHS.getDataFileName $ "lib/" ++ file+        return $ String path+    | otherwise = return $ String file+findModuleFile _ = return $ Bool False++-- |Import definitions from one environment into another+moduleImport +    :: Env  -- ^ Environment to import into+    -> Env  -- ^ Environment to import from+    -> [LispVal] -- ^ Identifiers to import+    -> IOThrowsError LispVal+moduleImport to from (Atom i : is) = do+  _ <- divertBinding to from i i+  moduleImport to from is+moduleImport to from (DottedList [Atom iRenamed] (Atom iOrig) : is) = do+  _ <- divertBinding to from iOrig iRenamed+  moduleImport to from is+moduleImport to from [] = do+  return $ LispEnv to+-- DEBUG:+-- moduleImport to from unknown = do+--   (trace ("MODULE IMPORT DEBUG: " ++ show unknown) return) $ Nil ""++-- |Copy a binding from one env to another+divertBinding+    :: Env  -- ^ Environment to import into+    -> Env  -- ^ Environment to import from+    -> String -- ^ Name of the binding in 'from'+    -> String -- ^ Name to use for the binding in 'to'+    -> IOThrowsError LispVal+divertBinding to from nameOrig nameNew = do+  isMacroBound <- liftIO $ isNamespacedRecBound from macroNamespace nameOrig+  namespace <- liftIO $ case isMacroBound of+                          True -> return macroNamespace+                          _ -> return varNamespace+  m <- getNamespacedVar from namespace nameOrig+  defineNamespacedVar to namespace nameNew m+

@@ -147,6 +147,7 @@   if isDefined      then do        var <- getNamespacedVar env macroNamespace x+       -- DEBUG: var <- (trace ("expand: " ++ x) getNamespacedVar) env macroNamespace x        case var of          -- Explicit Renaming          SyntaxExplicitRenaming transformer@(Func _ _ _ _) -> do

@@ -73,21 +73,27 @@   isDef <- liftIO $ isRecBound defEnv a   if isDef      then do-       isRenamed <- liftIO $ isRecBound renameEnv a++       -- NOTE: useEnv/"er" is used to store renamed variables due+       --       to issues with separate invocations of er macros+       --       renaming the same variable differently within the+       --       same context. This caused the module meta language+       --       to not work properly...+       isRenamed <- liftIO $ isNamespacedRecBound useEnv "er" a        if isRenamed           then do-            renamed <- getVar renameEnv a+            renamed <- getNamespacedVar useEnv "er" a             return renamed           else do             value <- getVar defEnv a             Atom renamed <- _gensym a -- Unique name             _ <- defineVar useEnv renamed value -- divert value to Use Env-            _ <- defineVar renameEnv a $ Atom renamed -- Record renamed sym+            _ <- defineNamespacedVar useEnv "er" a $ Atom renamed -- Record renamed sym  -- TODO: this is temporary testing code-            List diverted <- getNamespacedVar useEnv " " "diverted"-            _ <- setNamespacedVar useEnv " " "diverted" $ -                List (diverted ++ [List [Atom renamed, Atom a]])+--            List diverted <- getNamespacedVar useEnv " " "diverted"+--            _ <- setNamespacedVar useEnv " " "diverted" $ +--                List (diverted ++ [List [Atom renamed, Atom a]]) -- END              return $ Atom renamed

@@ -75,7 +75,7 @@  -- |A helper function to perform a numeric operation on two values numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal-numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+numericBinop _ singleVal@[_] = throwError $ NumArgs (Just 2) singleVal numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op  -- - Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs@@ -106,7 +106,7 @@  -- |Subtract the given numbers numSub :: [LispVal] -> ThrowsError LispVal-numSub [] = throwError $ NumArgs 1 []+numSub [] = throwError $ NumArgs (Just 1) [] numSub [Number n] = return $ Number $ -1 * n numSub [Float n] = return $ Float $ -1 * n numSub [Rational n] = return $ Rational $ -1 * n@@ -132,7 +132,7 @@  -- |Divide the given numbers numDiv :: [LispVal] -> ThrowsError LispVal-numDiv [] = throwError $ NumArgs 1 []+numDiv [] = throwError $ NumArgs (Just 1) [] numDiv [Number 0] = throwError $ DivideByZero  numDiv [Rational 0] = throwError $ DivideByZero   numDiv [Number n] = return $ Rational $ 1 / (fromInteger n)@@ -169,56 +169,71 @@         doMod (List [(Complex _), (Complex _)]) = throwError $ Default "modulo not implemented for complex numbers"          doMod _ = throwError $ Default "Unexpected error in modulo" +-- |Compare a series of numbers using a given numeric comparison+--  function and an array of lisp values+numBoolBinopCompare cmp n1 (n2 : ns) = do+  List [n1', n2'] <- numCast [n1, n2]+  result <- cmp n1' n2'+  case result of+    Bool True -> numBoolBinopCompare cmp n2' ns+    _ -> return $ Bool False+numBoolBinopCompare _ _ _ = return $ Bool True+ -- |Numeric equals numBoolBinopEq :: [LispVal] -> ThrowsError LispVal-numBoolBinopEq [] = throwError $ NumArgs 0 []-numBoolBinopEq aparams = do-  foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams-  where doOp (List [(Number a), (Number b)]) = return $ Bool $ a == b-        doOp (List [(Float a), (Float b)]) = return $ Bool $ a == b-        doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a == b-        doOp (List [(Complex a), (Complex b)]) = return $ Bool $ a == b-        doOp _ = throwError $ Default "Unexpected error in ="+numBoolBinopEq [] = throwError $ NumArgs (Just 0) []+numBoolBinopEq (n : ns) = numBoolBinopCompare cmp n ns+  where+    f a b = a == b+    cmp (Number a) (Number b) = return $ Bool $ f a b+    cmp (Float a) (Float b) = return $ Bool $ f a b+    cmp (Rational a) (Rational b) = return $ Bool $ f a b+    cmp (Complex a) (Complex b) = return $ Bool $ f a b+    cmp _ _ = throwError $ Default "Unexpected error in ="  -- |Numeric greater than numBoolBinopGt :: [LispVal] -> ThrowsError LispVal-numBoolBinopGt [] = throwError $ NumArgs 0 []-numBoolBinopGt aparams = do-  foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams-  where doOp (List [(Number a), (Number b)]) = return $ Bool $ a > b-        doOp (List [(Float a), (Float b)]) = return $ Bool $ a > b-        doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a > b-        doOp _ = throwError $ Default "Unexpected error in >"+numBoolBinopGt [] = throwError $ NumArgs (Just 0) []+numBoolBinopGt (n : ns) = numBoolBinopCompare cmp n ns+  where+    f a b = a > b+    cmp (Number a) (Number b) = return $ Bool $ f a b+    cmp (Float a) (Float b) = return $ Bool $ f a b+    cmp (Rational a) (Rational b) = return $ Bool $ f a b+    cmp _ _ = throwError $ Default "Unexpected error in >"  -- |Numeric greater than equal numBoolBinopGte :: [LispVal] -> ThrowsError LispVal-numBoolBinopGte [] = throwError $ NumArgs 0 []-numBoolBinopGte aparams = do-  foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams-  where doOp (List [(Number a), (Number b)]) = return $ Bool $ a >= b-        doOp (List [(Float a), (Float b)]) = return $ Bool $ a >= b-        doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a >= b-        doOp _ = throwError $ Default "Unexpected error in >="+numBoolBinopGte [] = throwError $ NumArgs (Just 0) []+numBoolBinopGte (n : ns) = numBoolBinopCompare cmp n ns+  where+    f a b = a >= b+    cmp (Number a) (Number b) = return $ Bool $ f a b+    cmp (Float a) (Float b) = return $ Bool $ f a b+    cmp (Rational a) (Rational b) = return $ Bool $ f a b+    cmp _ _ = throwError $ Default "Unexpected error in >="  -- |Numeric less than  numBoolBinopLt :: [LispVal] -> ThrowsError LispVal-numBoolBinopLt [] = throwError $ NumArgs 0 []-numBoolBinopLt aparams = do-  foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams-  where doOp (List [(Number a), (Number b)]) = return $ Bool $ a < b-        doOp (List [(Float a), (Float b)]) = return $ Bool $ a < b-        doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a < b-        doOp _ = throwError $ Default "Unexpected error in <"+numBoolBinopLt [] = throwError $ NumArgs (Just 0) []+numBoolBinopLt (n : ns) = numBoolBinopCompare cmp n ns+  where+    f a b = a < b+    cmp (Number a) (Number b) = return $ Bool $ f a b+    cmp (Float a) (Float b) = return $ Bool $ f a b+    cmp (Rational a) (Rational b) = return $ Bool $ f a b+    cmp _ _ = throwError $ Default "Unexpected error in <"  -- |Numeric less than equal numBoolBinopLte :: [LispVal] -> ThrowsError LispVal-numBoolBinopLte [] = throwError $ NumArgs 0 []-numBoolBinopLte aparams = do-  foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams-  where doOp (List [(Number a), (Number b)]) = return $ Bool $ a <= b-        doOp (List [(Float a), (Float b)]) = return $ Bool $ a <= b-        doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a <= b-        doOp _ = throwError $ Default "Unexpected error in <="+numBoolBinopLte [] = throwError $ NumArgs (Just 0) []+numBoolBinopLte (n : ns) = numBoolBinopCompare cmp n ns+  where+    f a b = a <= b+    cmp (Number a) (Number b) = return $ Bool $ f a b+    cmp (Float a) (Float b) = return $ Bool $ f a b+    cmp (Rational a) (Rational b) = return $ Bool $ f a b+    cmp _ _ = throwError $ Default "Unexpected error in <="  -- |Accept two numbers and cast one of them to the appropriate type, if necessary numCast :: [LispVal] -> ThrowsError LispVal@@ -253,7 +268,7 @@ numRationalize [(Float n)] = return $ Rational $ toRational n numRationalize [n@(Rational _)] = return n numRationalize [x] = throwError $ TypeMismatch "number" x-numRationalize badArgList = throwError $ NumArgs 1 badArgList+numRationalize badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Round the given number numRound :: [LispVal] -> ThrowsError LispVal@@ -263,7 +278,7 @@ numRound [(Complex n)] = do   return $ Complex $ (fromInteger $ round $ realPart n) :+ (fromInteger $ round $ imagPart n) numRound [x] = throwError $ TypeMismatch "number" x-numRound badArgList = throwError $ NumArgs 1 badArgList+numRound badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Floor the given number numFloor :: [LispVal] -> ThrowsError LispVal@@ -273,7 +288,7 @@ numFloor [(Complex n)] = do   return $ Complex $ (fromInteger $ floor $ realPart n) :+ (fromInteger $ floor $ imagPart n) numFloor [x] = throwError $ TypeMismatch "number" x-numFloor badArgList = throwError $ NumArgs 1 badArgList+numFloor badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Take the ceiling of the given number numCeiling :: [LispVal] -> ThrowsError LispVal@@ -283,7 +298,7 @@ numCeiling [(Complex n)] = do   return $ Complex $ (fromInteger $ ceiling $ realPart n) :+ (fromInteger $ ceiling $ imagPart n) numCeiling [x] = throwError $ TypeMismatch "number" x-numCeiling badArgList = throwError $ NumArgs 1 badArgList+numCeiling badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Truncate the given number numTruncate :: [LispVal] -> ThrowsError LispVal@@ -293,7 +308,7 @@ numTruncate [(Complex n)] = do   return $ Complex $ (fromInteger $ truncate $ realPart n) :+ (fromInteger $ truncate $ imagPart n) numTruncate [x] = throwError $ TypeMismatch "number" x-numTruncate badArgList = throwError $ NumArgs 1 badArgList+numTruncate badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Sine numSin :: [LispVal] -> ThrowsError LispVal@@ -302,7 +317,7 @@ numSin [(Rational n)] = return $ Float $ sin $ fromRational n numSin [(Complex n)] = return $ Complex $ sin n numSin [x] = throwError $ TypeMismatch "number" x-numSin badArgList = throwError $ NumArgs 1 badArgList+numSin badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Cosine numCos :: [LispVal] -> ThrowsError LispVal@@ -311,7 +326,7 @@ numCos [(Rational n)] = return $ Float $ cos $ fromRational n numCos [(Complex n)] = return $ Complex $ cos n numCos [x] = throwError $ TypeMismatch "number" x-numCos badArgList = throwError $ NumArgs 1 badArgList+numCos badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Tangent numTan :: [LispVal] -> ThrowsError LispVal@@ -320,7 +335,7 @@ numTan [(Rational n)] = return $ Float $ tan $ fromRational n numTan [(Complex n)] = return $ Complex $ tan n numTan [x] = throwError $ TypeMismatch "number" x-numTan badArgList = throwError $ NumArgs 1 badArgList+numTan badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Arcsine numAsin :: [LispVal] -> ThrowsError LispVal@@ -329,7 +344,7 @@ numAsin [(Rational n)] = return $ Float $ asin $ fromRational n numAsin [(Complex n)] = return $ Complex $ asin n numAsin [x] = throwError $ TypeMismatch "number" x-numAsin badArgList = throwError $ NumArgs 1 badArgList+numAsin badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Arccosine numAcos :: [LispVal] -> ThrowsError LispVal@@ -338,7 +353,7 @@ numAcos [(Rational n)] = return $ Float $ acos $ fromRational n numAcos [(Complex n)] = return $ Complex $ acos n numAcos [x] = throwError $ TypeMismatch "number" x-numAcos badArgList = throwError $ NumArgs 1 badArgList+numAcos badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Arctangent numAtan :: [LispVal] -> ThrowsError LispVal@@ -350,7 +365,7 @@ numAtan [Rational y, Rational x] = return $ Float $ phase $ (fromRational x) :+ (fromRational y) numAtan [(Complex n)] = return $ Complex $ atan n numAtan [x] = throwError $ TypeMismatch "number" x-numAtan badArgList = throwError $ NumArgs 1 badArgList+numAtan badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Take the square root of the given number numSqrt :: [LispVal] -> ThrowsError LispVal@@ -361,7 +376,7 @@ numSqrt [(Rational n)] = numSqrt [Float $ fromRational n] numSqrt [(Complex n)] = return $ Complex $ sqrt n numSqrt [x] = throwError $ TypeMismatch "number" x-numSqrt badArgList = throwError $ NumArgs 1 badArgList+numSqrt badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Raise the first number to the power of the second numExpt :: [LispVal] -> ThrowsError LispVal@@ -370,7 +385,7 @@ numExpt [(Float n), (Number p)] = return $ Float $ n ^ p numExpt [(Complex n), (Number p)] = return $ Complex $ n ^ p numExpt [_, y] = throwError $ TypeMismatch "integer" y-numExpt badArgList = throwError $ NumArgs 2 badArgList+numExpt badArgList = throwError $ NumArgs (Just 2) badArgList  {- numExpt params = do   foldl1M (\a b -> doExpt =<< (numCast [a, b])) params@@ -386,7 +401,7 @@ numExp [(Rational n)] = return $ Float $ exp $ fromRational n numExp [(Complex n)] = return $ Complex $ exp n numExp [x] = throwError $ TypeMismatch "number" x-numExp badArgList = throwError $ NumArgs 1 badArgList+numExp badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Compute the log of a given number numLog :: [LispVal] -> ThrowsError LispVal@@ -395,7 +410,7 @@ numLog [(Rational n)] = return $ Float $ log $ fromRational n numLog [(Complex n)] = return $ Complex $ log n numLog [x] = throwError $ TypeMismatch "number" x-numLog badArgList = throwError $ NumArgs 1 badArgList+numLog badArgList = throwError $ NumArgs (Just 1) badArgList  -- Complex number functions @@ -420,38 +435,38 @@ -- |Create a complex number given its real and imaginary parts numMakeRectangular :: [LispVal] -> ThrowsError LispVal numMakeRectangular [x, y] = buildComplex x y-numMakeRectangular badArgList = throwError $ NumArgs 2 badArgList+numMakeRectangular badArgList = throwError $ NumArgs (Just 2) badArgList  -- |Create a complex number from its magnitude and phase (angle) numMakePolar :: [LispVal] -> ThrowsError LispVal numMakePolar [(Float x), (Float y)] = return $ Complex $ mkPolar x y numMakePolar [(Float _), y] = throwError $ TypeMismatch "real" y numMakePolar [x, (Float _)] = throwError $ TypeMismatch "real real" $ x-numMakePolar badArgList = throwError $ NumArgs 2 badArgList+numMakePolar badArgList = throwError $ NumArgs (Just 2) badArgList  -- |The phase of a complex number numAngle :: [LispVal] -> ThrowsError LispVal numAngle [(Complex c)] = return $ Float $ phase c numAngle [x] = throwError $ TypeMismatch "complex number" x-numAngle badArgList = throwError $ NumArgs 1 badArgList+numAngle badArgList = throwError $ NumArgs (Just 1) badArgList  -- |The nonnegative magnitude of a complex number numMagnitude :: [LispVal] -> ThrowsError LispVal numMagnitude [(Complex c)] = return $ Float $ magnitude c numMagnitude [x] = throwError $ TypeMismatch "complex number" x-numMagnitude badArgList = throwError $ NumArgs 1 badArgList+numMagnitude badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Retrieve real part of a complex number numRealPart :: [LispVal] -> ThrowsError LispVal numRealPart [(Complex c)] = return $ Float $ realPart c numRealPart [x] = throwError $ TypeMismatch "complex number" x-numRealPart badArgList = throwError $ NumArgs 1 badArgList+numRealPart badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Retrieve imaginary part of a complex number numImagPart :: [LispVal] -> ThrowsError LispVal numImagPart [(Complex c)] = return $ Float $ imagPart c numImagPart [x] = throwError $ TypeMismatch "complex number" x-numImagPart badArgList = throwError $ NumArgs 1 badArgList+numImagPart badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Take the numerator of the given number numNumerator :: [LispVal] -> ThrowsError LispVal@@ -459,7 +474,7 @@ numNumerator [(Rational r)] = return $ Number $ numerator r numNumerator [(Float f)] = return $ Float $ fromInteger . numerator . toRational $ f numNumerator [x] = throwError $ TypeMismatch "rational number" x-numNumerator badArgList = throwError $ NumArgs 1 badArgList+numNumerator badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Take the denominator of the given number numDenominator :: [LispVal] -> ThrowsError LispVal@@ -467,7 +482,7 @@ numDenominator [(Rational r)] = return $ Number $ denominator r numDenominator [(Float f)] = return $ Float $ fromInteger $ denominator $ toRational f numDenominator [x] = throwError $ TypeMismatch "rational number" x-numDenominator badArgList = throwError $ NumArgs 1 badArgList+numDenominator badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Convert an exact number to inexact numExact2Inexact :: [LispVal] -> ThrowsError LispVal@@ -476,7 +491,7 @@ numExact2Inexact [n@(Float _)] = return n numExact2Inexact [n@(Complex _)] = return n numExact2Inexact [badType] = throwError $ TypeMismatch "number" badType-numExact2Inexact badArgList = throwError $ NumArgs 1 badArgList+numExact2Inexact badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Convert an inexact number to exact numInexact2Exact :: [LispVal] -> ThrowsError LispVal@@ -485,7 +500,7 @@ numInexact2Exact [(Float n)] = return $ Number $ round n numInexact2Exact [c@(Complex _)] = numRound [c] numInexact2Exact [badType] = throwError $ TypeMismatch "number" badType-numInexact2Exact badArgList = throwError $ NumArgs 1 badArgList+numInexact2Exact badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Convert a number to a string; radix is optional, defaults to base 10 num2String :: [LispVal] -> ThrowsError LispVal@@ -502,7 +517,7 @@ num2String [(Float n)] = return $ String $ show n num2String [n@(Complex _)] = return $ String $ show n num2String [x] = throwError $ TypeMismatch "number" x-num2String badArgList = throwError $ NumArgs 1 badArgList+num2String badArgList = throwError $ NumArgs (Just 1) badArgList  -- |Predicate to determine if given value is a number isNumber :: [LispVal] -> ThrowsError LispVal

@@ -202,10 +202,12 @@ parseRealNumber :: Parser LispVal parseRealNumber = do   sign <- many (oneOf "-+")-  num <- many1 (digit)+  num <- many (digit)   _ <- char '.'   frac <- many1 (digit)-  let dec = num ++ "." ++ frac+  let dec = if length num > 0+               then num ++ "." ++ frac+               else "0." ++ frac   f <- case (length sign) of      0 -> return $ Float $ fst $ Numeric.readFloat dec !! 0           -- Bit of a hack, but need to support the + sign as well as the minus.

@@ -27,9 +27,9 @@ get [] = do   t <- liftIO $ System.CPUTime.getCPUTime   return $ Number t-get badArgList = throwError $ NumArgs 0 badArgList+get badArgList = throwError $ NumArgs (Just 0) badArgList  -- |Wrapper for CPUTime.cpuTimePrecision precision :: [LispVal] -> IOThrowsError LispVal precision [] = return $ Number $ System.CPUTime.cpuTimePrecision-precision badArgList = throwError $ NumArgs 0 badArgList+precision badArgList = throwError $ NumArgs (Just 0) badArgList

@@ -150,8 +150,8 @@  makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode-makePort _ [] = throwError $ NumArgs 1 []-makePort _ args@(_ : _) = throwError $ NumArgs 1 args+makePort _ [] = throwError $ NumArgs (Just 1) []+makePort _ args@(_ : _) = throwError $ NumArgs (Just 1) args  closePort :: [LispVal] -> IOThrowsError LispVal closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)@@ -219,7 +219,7 @@         Right _ -> return $ Nil "" writeProc _ other = if length other == 2                      then throwError $ TypeMismatch "(value port)" $ List other-                     else throwError $ NumArgs 2 other+                     else throwError $ NumArgs (Just 2) other  writeCharProc :: [LispVal] -> IOThrowsError LispVal writeCharProc [obj] = writeCharProc [obj, Port stdout]@@ -230,27 +230,27 @@         Right _ -> return $ Nil "" writeCharProc other = if length other == 2                      then throwError $ TypeMismatch "(character port)" $ List other-                     else throwError $ NumArgs 2 other+                     else throwError $ NumArgs (Just 2) other  fileExists, deleteFile :: [LispVal] -> IOThrowsError LispVal fileExists [String filename] = do     exists <- liftIO $ doesFileExist filename     return $ Bool exists-fileExists [] = throwError $ NumArgs 1 []-fileExists args@(_ : _) = throwError $ NumArgs 1 args+fileExists [] = throwError $ NumArgs (Just 1) []+fileExists args@(_ : _) = throwError $ NumArgs (Just 1) args  deleteFile [String filename] = do     output <- liftIO $ try' (liftIO $ removeFile filename)     case output of         Left _ -> return $ Bool False         Right _ -> return $ Bool True-deleteFile [] = throwError $ NumArgs 1 []-deleteFile args@(_ : _) = throwError $ NumArgs 1 args+deleteFile [] = throwError $ NumArgs (Just 1) []+deleteFile args@(_ : _) = throwError $ NumArgs (Just 1) args  readContents :: [LispVal] -> IOThrowsError LispVal readContents [String filename] = liftM String $ liftIO $ readFile filename-readContents [] = throwError $ NumArgs 1 []-readContents args@(_ : _) = throwError $ NumArgs 1 args+readContents [] = throwError $ NumArgs (Just 1) []+readContents args@(_ : _) = throwError $ NumArgs (Just 1) args  load :: String -> IOThrowsError [LispVal] load filename = do@@ -261,8 +261,8 @@  readAll :: [LispVal] -> IOThrowsError LispVal readAll [String filename] = liftM List $ load filename-readAll [] = throwError $ NumArgs 1 []-readAll args@(_ : _) = throwError $ NumArgs 1 args+readAll [] = throwError $ NumArgs (Just 1) []+readAll args@(_ : _) = throwError $ NumArgs (Just 1) args  -- |Version of gensym that can be conveniently called from Haskell. _gensym :: String -> IOThrowsError LispVal@@ -275,7 +275,7 @@ gensym :: [LispVal] -> IOThrowsError LispVal gensym [String prefix] = _gensym prefix gensym [] = _gensym " g"-gensym args@(_ : _) = throwError $ NumArgs 1 args+gensym args@(_ : _) = throwError $ NumArgs (Just 1) args   ---------------------------------------------------@@ -287,21 +287,21 @@ car [List (x : _)] = return x car [DottedList (x : _) _] = return x car [badArg] = throwError $ TypeMismatch "pair" badArg-car badArgList = throwError $ NumArgs 1 badArgList+car badArgList = throwError $ NumArgs (Just 1) badArgList  cdr :: [LispVal] -> ThrowsError LispVal cdr [List (_ : xs)] = return $ List xs cdr [DottedList [_] x] = return x cdr [DottedList (_ : xs) x] = return $ DottedList xs x cdr [badArg] = throwError $ TypeMismatch "pair" badArg-cdr badArgList = throwError $ NumArgs 1 badArgList+cdr badArgList = throwError $ NumArgs (Just 1) badArgList  cons :: [LispVal] -> ThrowsError LispVal cons [x1, List []] = return $ List [x1] cons [x, List xs] = return $ List $ x : xs cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast cons [x1, x2] = return $ DottedList [x1] x2-cons badArgList = throwError $ NumArgs 2 badArgList+cons badArgList = throwError $ NumArgs (Just 2) badArgList  equal :: [LispVal] -> ThrowsError LispVal equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)]@@ -312,7 +312,7 @@                      [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]   eqvEquals <- eqv [arg1, arg2]   return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)-equal badArgList = throwError $ NumArgs 2 badArgList+equal badArgList = throwError $ NumArgs (Just 2) badArgList  -- ------------ Vector Primitives -------------- @@ -322,16 +322,16 @@   let l = replicate (fromInteger n) a   return $ Vector $ (listArray (0, length l - 1)) l makeVector [badType] = throwError $ TypeMismatch "integer" badType-makeVector badArgList = throwError $ NumArgs 1 badArgList+makeVector badArgList = throwError $ NumArgs (Just 1) badArgList  buildVector (o : os) = do   let lst = o : os   return $ Vector $ (listArray (0, length lst - 1)) lst-buildVector badArgList = throwError $ NumArgs 1 badArgList+buildVector badArgList = throwError $ NumArgs (Just 1) badArgList  vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v) vectorLength [badType] = throwError $ TypeMismatch "vector" badType-vectorLength badArgList = throwError $ NumArgs 1 badArgList+vectorLength badArgList = throwError $ NumArgs (Just 1) badArgList  vectorRef [(Vector v), (Number n)] = do     let len = toInteger $ (length $ elems v) - 1@@ -339,15 +339,15 @@        then throwError $ Default "Invalid index"        else return $ v ! (fromInteger n) vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType-vectorRef badArgList = throwError $ NumArgs 2 badArgList+vectorRef badArgList = throwError $ NumArgs (Just 2) badArgList  vectorToList [(Vector v)] = return $ List $ elems v vectorToList [badType] = throwError $ TypeMismatch "vector" badType-vectorToList badArgList = throwError $ NumArgs 1 badArgList+vectorToList badArgList = throwError $ NumArgs (Just 1) badArgList  listToVector [(List l)] = return $ Vector $ (listArray (0, length l - 1)) l listToVector [badType] = throwError $ TypeMismatch "list" badType-listToVector badArgList = throwError $ NumArgs 1 badArgList+listToVector badArgList = throwError $ NumArgs (Just 1) badArgList  -- ------------ Bytevector Primitives -------------- makeByteVector, byteVector, byteVectorLength, byteVectorRef, byteVectorCopy, byteVectorAppend, byteVectorUtf2Str, byteVectorStr2Utf :: [LispVal] -> ThrowsError LispVal@@ -358,7 +358,7 @@   let ls = replicate (fromInteger n) (fromInteger byte :: Word8)   return $ ByteVector $ BS.pack ls makeByteVector [badType] = throwError $ TypeMismatch "integer" badType-makeByteVector badArgList = throwError $ NumArgs 2 badArgList+makeByteVector badArgList = throwError $ NumArgs (Just 2) badArgList  byteVector bs = do  return $ ByteVector $ BS.pack $ map conv bs@@ -380,7 +380,7 @@             (fromInteger start)             bv) byteVectorCopy [badType] = throwError $ TypeMismatch "bytevector" badType-byteVectorCopy badArgList = throwError $ NumArgs 1 badArgList+byteVectorCopy badArgList = throwError $ NumArgs (Just 1) badArgList  byteVectorAppend bs = do     let acc = BS.pack []@@ -392,7 +392,7 @@  byteVectorLength [(ByteVector bv)] = return $ Number $ toInteger $ BS.length bv byteVectorLength [badType] = throwError $ TypeMismatch "bytevector" badType-byteVectorLength badArgList = throwError $ NumArgs 1 badArgList+byteVectorLength badArgList = throwError $ NumArgs (Just 1) badArgList  byteVectorRef [(ByteVector bv), (Number n)] = do     let len = toInteger $ (BS.length bv) - 1@@ -400,18 +400,18 @@        then throwError $ Default "Invalid index"        else return $ Number $ toInteger $ BS.index bv (fromInteger n) byteVectorRef [badType] = throwError $ TypeMismatch "bytevector integer" badType-byteVectorRef badArgList = throwError $ NumArgs 2 badArgList+byteVectorRef badArgList = throwError $ NumArgs (Just 2) badArgList  byteVectorUtf2Str [(ByteVector bv)] = do     return $ String $ BSU.toString bv  -- TODO: need to support other overloads of this function byteVectorUtf2Str [badType] = throwError $ TypeMismatch "bytevector" badType-byteVectorUtf2Str badArgList = throwError $ NumArgs 1 badArgList+byteVectorUtf2Str badArgList = throwError $ NumArgs (Just 1) badArgList byteVectorStr2Utf [(String s)] = do     return $ ByteVector $ BSU.fromString s -- TODO: need to support other overloads of this function byteVectorStr2Utf [badType] = throwError $ TypeMismatch "string" badType-byteVectorStr2Utf badArgList = throwError $ NumArgs 1 badArgList+byteVectorStr2Utf badArgList = throwError $ NumArgs (Just 1) badArgList   -- ------------ Hash Table Primitives --------------@@ -427,8 +427,8 @@   case Data.Map.lookup key ht of     Just _ -> return $ Bool True     Nothing -> return $ Bool False-hashTblExists [] = throwError $ NumArgs 2 []-hashTblExists args@(_ : _) = throwError $ NumArgs 2 args+hashTblExists [] = throwError $ NumArgs (Just 2) []+hashTblExists args@(_ : _) = throwError $ NumArgs (Just 2) args  hashTblRef [(HashTable ht), key@(_)] = do   case Data.Map.lookup key ht of@@ -441,31 +441,31 @@ {- FUTURE: a thunk can optionally be specified, this drives definition of /default Nothing -> apply thunk [] -} hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType-hashTblRef badArgList = throwError $ NumArgs 2 badArgList+hashTblRef badArgList = throwError $ NumArgs (Just 2) badArgList  hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType-hashTblSize badArgList = throwError $ NumArgs 1 badArgList+hashTblSize badArgList = throwError $ NumArgs (Just 1) badArgList  hashTbl2List [(HashTable ht)] = do   return $ List $ map (\ (k, v) -> List [k, v]) $ Data.Map.toList ht hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType-hashTbl2List badArgList = throwError $ NumArgs 1 badArgList+hashTbl2List badArgList = throwError $ NumArgs (Just 1) badArgList  hashTblKeys [(HashTable ht)] = do   return $ List $ map (\ (k, _) -> k) $ Data.Map.toList ht hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType-hashTblKeys badArgList = throwError $ NumArgs 1 badArgList+hashTblKeys badArgList = throwError $ NumArgs (Just 1) badArgList  hashTblValues [(HashTable ht)] = do   return $ List $ map (\ (_, v) -> v) $ Data.Map.toList ht hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType-hashTblValues badArgList = throwError $ NumArgs 1 badArgList+hashTblValues badArgList = throwError $ NumArgs (Just 1) badArgList  hashTblCopy [(HashTable ht)] = do   return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType-hashTblCopy badArgList = throwError $ NumArgs 1 badArgList+hashTblCopy badArgList = throwError $ NumArgs (Just 1) badArgList  -- ------------ String Primitives -------------- @@ -477,12 +477,12 @@     String s -> return $ String $ [c] ++ s     badType -> throwError $ TypeMismatch "character" badType buildString [badType] = throwError $ TypeMismatch "character" badType-buildString badArgList = throwError $ NumArgs 1 badArgList+buildString badArgList = throwError $ NumArgs (Just 1) badArgList  makeString :: [LispVal] -> ThrowsError LispVal makeString [(Number n)] = return $ doMakeString n ' ' "" makeString [(Number n), (Char c)] = return $ doMakeString n c ""-makeString badArgList = throwError $ NumArgs 1 badArgList+makeString badArgList = throwError $ NumArgs (Just 1) badArgList  doMakeString :: forall a . (Num a, Eq a) => a -> Char -> String -> LispVal doMakeString n char s =@@ -493,12 +493,12 @@ stringLength :: [LispVal] -> ThrowsError LispVal stringLength [String s] = return $ Number $ foldr (const (+ 1)) 0 s -- Could probably do 'length s' instead... stringLength [badType] = throwError $ TypeMismatch "string" badType-stringLength badArgList = throwError $ NumArgs 1 badArgList+stringLength badArgList = throwError $ NumArgs (Just 1) badArgList  stringRef :: [LispVal] -> ThrowsError LispVal stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k stringRef [badType] = throwError $ TypeMismatch "string number" badType-stringRef badArgList = throwError $ NumArgs 2 badArgList+stringRef badArgList = throwError $ NumArgs (Just 2) badArgList  substring :: [LispVal] -> ThrowsError LispVal substring [(String s), (Number start), (Number end)] =@@ -506,7 +506,7 @@      let begin = fromInteger start      return $ String $ (take slength . drop begin) s substring [badType] = throwError $ TypeMismatch "string number number" badType-substring badArgList = throwError $ NumArgs 3 badArgList+substring badArgList = throwError $ NumArgs (Just 3) badArgList  stringCIEquals :: [LispVal] -> ThrowsError LispVal stringCIEquals [(String str1), (String str2)] = do@@ -519,18 +519,18 @@                                      then ciCmp s1 s2 (idx + 1)                                      else False stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType-stringCIEquals badArgList = throwError $ NumArgs 2 badArgList+stringCIEquals badArgList = throwError $ NumArgs (Just 2) badArgList  stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> ThrowsError LispVal stringCIBoolBinop op [(String s1), (String s2)] = boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)]   where strToLower str = map (toLower) str stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType-stringCIBoolBinop _ badArgList = throwError $ NumArgs 2 badArgList+stringCIBoolBinop _ badArgList = throwError $ NumArgs (Just 2) badArgList  charCIBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal charCIBoolBinop op [(Char s1), (Char s2)] = boolBinop unpackChar op [(Char $ toLower s1), (Char $ toLower s2)] charCIBoolBinop _ [badType] = throwError $ TypeMismatch "character character" badType-charCIBoolBinop _ badArgList = throwError $ NumArgs 2 badArgList+charCIBoolBinop _ badArgList = throwError $ NumArgs (Just 2) badArgList  stringAppend :: [LispVal] -> ThrowsError LispVal stringAppend [(String s)] = return $ String s -- Needed for "last" string value@@ -540,7 +540,7 @@     String s -> return $ String $ st ++ s     other -> throwError $ TypeMismatch "string" other stringAppend [badType] = throwError $ TypeMismatch "string" badType-stringAppend badArgList = throwError $ NumArgs 1 badArgList+stringAppend badArgList = throwError $ NumArgs (Just 1) badArgList  stringToNumber :: [LispVal] -> ThrowsError LispVal stringToNumber [(String s)] = do@@ -559,24 +559,24 @@     16 -> stringToNumber [String $ "#x" ++ s]     _ -> throwError $ Default $ "Invalid radix: " ++ show radix stringToNumber [badType] = throwError $ TypeMismatch "string" badType-stringToNumber badArgList = throwError $ NumArgs 1 badArgList+stringToNumber badArgList = throwError $ NumArgs (Just 1) badArgList  stringToList :: [LispVal] -> ThrowsError LispVal stringToList [(String s)] = return $ List $ map (Char) s stringToList [badType] = throwError $ TypeMismatch "string" badType-stringToList badArgList = throwError $ NumArgs 1 badArgList+stringToList badArgList = throwError $ NumArgs (Just 1) badArgList  listToString :: [LispVal] -> ThrowsError LispVal listToString [(List [])] = return $ String "" listToString [(List l)] = buildString l listToString [badType] = throwError $ TypeMismatch "list" badType-listToString [] = throwError $ NumArgs 1 []-listToString args@(_ : _) = throwError $ NumArgs 1 args+listToString [] = throwError $ NumArgs (Just 1) []+listToString args@(_ : _) = throwError $ NumArgs (Just 1) args  stringCopy :: [LispVal] -> ThrowsError LispVal stringCopy [String s] = return $ String s stringCopy [badType] = throwError $ TypeMismatch "string" badType-stringCopy badArgList = throwError $ NumArgs 2 badArgList+stringCopy badArgList = throwError $ NumArgs (Just 2) badArgList  isDottedList :: [LispVal] -> ThrowsError LispVal isDottedList ([DottedList _ _]) = return $ Bool True@@ -618,14 +618,14 @@ symbol2String :: [LispVal] -> ThrowsError LispVal symbol2String ([Atom a]) = return $ String a symbol2String [notAtom] = throwError $ TypeMismatch "symbol" notAtom-symbol2String [] = throwError $ NumArgs 1 []-symbol2String args@(_ : _) = throwError $ NumArgs 1 args+symbol2String [] = throwError $ NumArgs (Just 1) []+symbol2String args@(_ : _) = throwError $ NumArgs (Just 1) args  string2Symbol :: [LispVal] -> ThrowsError LispVal string2Symbol ([String s]) = return $ Atom s-string2Symbol [] = throwError $ NumArgs 1 []+string2Symbol [] = throwError $ NumArgs (Just 1) [] string2Symbol [notString] = throwError $ TypeMismatch "string" notString-string2Symbol args@(_ : _) = throwError $ NumArgs 1 args+string2Symbol args@(_ : _) = throwError $ NumArgs (Just 1) args  charUpper :: [LispVal] -> ThrowsError LispVal charUpper [Char c] = return $ Char $ toUpper c@@ -673,15 +673,15 @@  boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal boolBinop unpacker op args = if length args /= 2-                             then throwError $ NumArgs 2 args+                             then throwError $ NumArgs (Just 2) args                              else do left <- unpacker $ args !! 0                                      right <- unpacker $ args !! 1                                      return $ Bool $ left `op` right  unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal unaryOp f [v] = f v-unaryOp _ [] = throwError $ NumArgs 1 []-unaryOp _ args@(_ : _) = throwError $ NumArgs 1 args+unaryOp _ [] = throwError $ NumArgs (Just 1) []+unaryOp _ args@(_ : _) = throwError $ NumArgs (Just 1) args  {- numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal numBoolBinop = boolBinop unpackNum -}

@@ -124,7 +124,7 @@     return $ Environment Nothing nullBindings nullPointers  -- |Types of errors that may occur when evaluating Scheme code-data LispError = NumArgs Integer [LispVal] -- ^Invalid number of function arguments+data LispError = NumArgs (Maybe Integer) [LispVal] -- ^Invalid number of function arguments   | TypeMismatch String LispVal -- ^Type error   | Parser ParseError -- ^Parsing error   | BadSpecialForm String LispVal -- ^Invalid special (built-in) form@@ -138,8 +138,10 @@  -- |Create a textual description for a 'LispError' showError :: LispError -> String-showError (NumArgs expected found) = "Expected " ++ show expected+showError (NumArgs (Just expected) found) = "Expected " ++ show expected                                   ++ " args; found values " ++ unwordsList found+showError (NumArgs Nothing found) = "Incorrect number of args; " +++                                    " found values " ++ unwordsList found showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected                                   ++ ", found " ++ show found showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr@@ -414,7 +416,7 @@ -- FUTURE: comparison of two continuations eqv [l1@(List _), l2@(List _)] = eqvList eqv [l1, l2] eqv [_, _] = return $ Bool False-eqv badArgList = throwError $ NumArgs 2 badArgList+eqv badArgList = throwError $ NumArgs (Just 2) badArgList  -- |Compare two lists of haskell values, using the given comparison function eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal

@@ -0,0 +1,26 @@+{- |+Module      : Language.Scheme.Util+Copyright   : Justin Ethier+Licence     : MIT (see LICENSE in the distribution)++Maintainer  : github.com/justinethier+Stability   : experimental+Portability : portable++This module contains general-purpose utility functions+-}++module Language.Scheme.Util+    (+      escapeBackslashes+    ) where+-- import qualified Paths_husk_scheme as PHS (getDataFileName)+-- import Language.Scheme.Types+-- import Language.Scheme.Variables++-- |A utility function to escape backslashes in the given string+escapeBackslashes :: String -> String+escapeBackslashes s = foldr step [] s+  where step x xs  | x == '\\'  = '\\' : '\\' : xs+                   | otherwise =  x : xs +

@@ -18,9 +18,12 @@     (     -- * Environments       printEnv+    , exportsFromEnv      , copyEnv     , extendEnv+    , importEnv     , topmostEnv+    , nullEnvWithParent     , findNamespacedEnv     , macroNamespace     , varNamespace @@ -103,6 +106,18 @@     v <- liftIO $ readIORef val     return $ "[" ++ name ++ "]" ++ ": " ++ show v +-- |Return a list of symbols exported from an environment+exportsFromEnv :: Env +               -> IO [LispVal]+exportsFromEnv env = do+  binds <- liftIO $ readIORef $ bindings env+  return $ getExports [] $ fst $ unzip $ Data.Map.toList binds + where +  getExports acc (('m':'_':b) : bs) = getExports (Atom b:acc) bs+  getExports acc (('v':'_':b) : bs) = getExports (Atom b:acc) bs+  getExports acc (_ : bs) = getExports acc bs+  getExports acc [] = acc+ -- |Create a deep copy of an environment copyEnv :: Env      -- ^ Source environment         -> IO Env   -- ^ A copy of the source environment@@ -119,13 +134,28 @@          ref <- newIORef x          return (name, ref) --- -- |Perform a deep copy of an environment's contents to a new environment--- importEnv ---   :: Env -- ^ Source environment---   -> Env -- ^ Destination environment---   -> IO () = do--- -- TODO: need to do this recursively?+-- |Perform a deep copy of an environment's contents into+--  another environment.+--+--  The destination environment is modified!+--+importEnv +  :: Env -- ^ Destination environment+  -> Env -- ^ Source environment+  -> IO Env+importEnv dEnv sEnv = do+  sPtrs <- liftIO $ readIORef $ pointers sEnv+  dPtrs <- liftIO $ readIORef $ pointers dEnv+  writeIORef (pointers dEnv) $ Data.Map.union sPtrs dPtrs +  sBinds <- liftIO $ readIORef $ bindings sEnv+  dBinds <- liftIO $ readIORef $ bindings dEnv+  writeIORef (bindings dEnv)  $ Data.Map.union sBinds dBinds++  case parentEnv sEnv of+    Just ps -> importEnv dEnv ps +    Nothing -> return dEnv + -- |Extend given environment by binding a series of values to a new environment. extendEnv :: Env -- ^ Environment            -> [((String, String), LispVal)] -- ^ Extensions to the environment@@ -144,6 +174,11 @@     case parentEnv envRef of         Just p -> topmostEnv p         Nothing -> return envRef++nullEnvWithParent :: Env -> IO Env +nullEnvWithParent p = do+  Environment _ binds ptrs <- nullEnv+  return $ Environment (Just p) binds ptrs  -- |Recursively search environments to find one that contains the given variable. findNamespacedEnv 

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             3.6.3+Version:             3.7 Synopsis:            R5RS Scheme interpreter, compiler, and library. Description:            <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>@@ -32,6 +32,7 @@ Author:              Justin Ethier Maintainer:          Justin Ethier <github.com/justinethier> Homepage:            http://justinethier.github.com/husk-scheme+Bug-Reports:         http://github.com/justinethier/husk-scheme/issues Cabal-Version:       >= 1.8 Build-Type:          Simple Category:            Compilers/Interpreters, Language@@ -41,14 +42,18 @@                      ChangeLog.markdown                      LICENSE                      AUTHORS-Data-Files:          lib/stdlib.scm lib/srfi/*.scm+Data-Files:          lib/*.scm lib/r5rs/*.sld lib/scheme/*.sld lib/srfi/*.scm  Source-Repository head     Type:            git     Location:        git://github.com/justinethier/husk-scheme.git  flag useffi-    description: Turn off FFI to decrease build times and minimize executable sizes+    description: Haskell Foreign Function Interface (FFI). Allows husk to import and call into Haskell code directly from Scheme code. Turn off FFI to decrease build times and minimize executable sizes+    default: False++flag uselibraries+    description: R7RS-style libraries.      default: True  flag useptrs@@ -64,23 +69,29 @@                    Language.Scheme.Variables                    Language.Scheme.Compiler                    Language.Scheme.Plugins.CPUTime--- Other-Modules:                    Language.Scheme.Macro                    Language.Scheme.Macro.ExplicitRenaming                    Language.Scheme.Macro.Matches+                   Language.Scheme.Libraries                    Language.Scheme.Numerical                    Language.Scheme.Parser                    Language.Scheme.Primitives+                   Language.Scheme.Util+  Other-Modules:   Paths_husk_scheme+   if flag(useffi)     Build-Depends: ghc, ghc-paths     Exposed-Modules:  Language.Scheme.FFI     cpp-options: -DUseFfi +  if flag(uselibraries)+    cpp-options: -DUseLibraries+   if flag(useptrs)     cpp-options: -DUsePointers  Executable         huski-  Build-Depends:   husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory+  Build-Depends:   husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, process   if flag(useffi)     Build-Depends: ghc, ghc-paths     cpp-options: -DUseFfi

@@ -0,0 +1,331 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; A modified version of chibi scheme's module meta language+;;; used to implement modules (r7rs libraries) in husk+;;;++;; meta.scm -- meta langauge for describing modules+;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.+;; BSD-style license: http://synthcode.com/license.txt++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; modules++;; Hacked version of this function req'd to get everything to work+(define (identifier->symbol s) s)++(define *this-module* '())++(define (make-module exports env meta) (vector exports env meta #f))+(define (%module-exports mod) (vector-ref mod 0))+(define (module-env mod) (vector-ref mod 1))+(define (module-env-set! mod env) (vector-set! mod 1 env))+(define (module-meta-data mod) (vector-ref mod 2))+(define (module-meta-data-set! mod x) (vector-set! mod 2 x))++(define (module-exports mod)+  (or (%module-exports mod) (env-exports (module-env mod))))++(define (module-name->strings ls res)+  (if (null? ls)+      res+      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))+                       ((number? (car ls)) (number->string (car ls)))+                       ((string? (car ls)) (car ls))+                       (else (error "invalid module name" (car ls))))))+        (module-name->strings (cdr ls) (cons "/" (cons str res))))))++(define (module-name->file name)+  (string-concatenate+   (reverse (cons ".sld" (cdr (module-name->strings name '()))))))++(define (module-name-prefix name)+  (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))++(define load-module-definition+  (let ((meta-env (current-environment)))+    (lambda (name)+      (let* ((file (module-name->file name))+             (path (find-module-file file)))+        (if path (load path meta-env))))))++(define (find-module name)+  (cond+   ((assoc name *modules*) => cdr)+   (else+    (load-module-definition name)+    (cond ((assoc name *modules*) => cdr)+          (else #f)))))++(define (add-module! name module)+  (set! *modules* (cons (cons name module) *modules*)))++(define (delete-module! name)+  (let lp ((ls *modules*) (prev #f))+    (cond ((null? ls))+          ((equal? name (car (car ls)))+           (if prev+               (set-cdr! prev (cdr ls))+               (set! *modules* (cdr ls))))+          (else (lp (cdr ls) ls)))))++(define (symbol-append a b)+  (string->symbol (string-append (symbol->string a) (symbol->string b))))++(define (symbol-drop a b)+  (let ((as (symbol->string a))+        (bs (symbol->string b)))+    (if (and (> (string-length bs) (string-length as))+             (string=? as (substring bs 0 (string-length as))))+        (string->symbol (substring bs (string-length as) (string-length bs)))+        b)))++;; (define (warn msg . args)+;;   (display msg (current-error-port))+;;   (display ":" (current-error-port))+;;   (for-each (lambda (a)+;;               (display " " (current-error-port))+;;               (write a (current-error-port)))+;;             args)+;;   (newline (current-error-port)))++(define (to-id id) (if (pair? id) (car id) id))+(define (from-id id) (if (pair? id) (cdr id) id))+(define (id-filter pred ls)+  (cond ((null? ls) '())+        ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))+        (else (id-filter pred (cdr ls)))))++(define (resolve-import x)+  (cond+   ((not (and (pair? x) (list? x)))+    (error "invalid module syntax" x))+   ((and (memq (car x) '(prefix drop-prefix))+         (symbol? (car (cddr x))) (list? (cadr x)))+    (let ((mod-name+imports (resolve-import (cadr x))))+      (cons (car mod-name+imports)+            (map (lambda (i)+                   (cons ((if (eq? (car x) 'drop-prefix)+                              symbol-drop+                              symbol-append)+                          (car (cddr x))+                          (to-id i))+                         (from-id i)))+                 (or (cdr mod-name+imports)+                     (module-exports (find-module (car mod-name+imports))))))))+   ((and (pair? (cdr x)) (pair? (cadr x)))+    (if (memq (car x) '(only except rename))+        (let* ((mod-name+imports (resolve-import (cadr x)))+               (imp-ids (or (cdr mod-name+imports)+                            (and (not (eq? 'only (car x)))+                                 (module-exports+                                  (find-module (car mod-name+imports)))))))+          ;; (if (not (eq? 'only (car x)))+          ;;     (let ((unbound+          ;;            (id-filter (lambda (i) (not (memq i imp-ids))) (cddr x))))+          ;;       (if (pair? unbound)+          ;;           (warn "import excepting unbound identifiers" unbound))))+          (cons (car mod-name+imports)+                (case (car x)+                  ((only)+                   (cddr x))+                  ((except)+                   (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))+                  ((rename)+                   (map (lambda (i)+                          (let ((rename (assq (to-id i) (cddr x))))+                            (if rename (cons (cadr rename) (from-id i)) i)))+                        imp-ids)))))+        (error "invalid import modifier" x)))+   ((find-module x)+    => (lambda (mod) (cons x (%module-exports mod))))+   (else+    (error "couldn't find import" x))))++(define (eval-module name mod . o)+  (let ((env (if (pair? o) (car o) (make-environment)))+        (meta (module-meta-data mod))+        (dir (module-name-prefix name)))+    (define (load-modules files extension fold?)+      (for-each+       (lambda (f)+         (let ((f (string-append dir f extension)))+           (cond+            ((find-module-file f)+             => (lambda (path)+                  (cond (fold?+                         (let ((in (open-input-file path)))+                           (set-port-fold-case! in #t)+                           (load in env)))+                        (else+                         (load path env)))))+            (else (error "couldn't find include" f)))))+       files))+    ;; catch cyclic references+    (module-meta-data-set!+     mod+     `((error "module attempted to reference itself while loading" ,name)))+    (for-each+     (lambda (x)+       (case (and (pair? x) (car x))+         ((import import-immutable)+          (for-each+           (lambda (m)+             (let* ((mod2-name+imports (resolve-import m))+                    (mod2 (load-module (car mod2-name+imports))))+               (%import env (module-env mod2) (cdr mod2-name+imports) #t)))+           (cdr x)))))+     meta)+    (for-each+     (lambda (x)+       (case (and (pair? x) (car x))+         ((include)+          (load-modules (cdr x) "" #f))+         ((include-ci)+          (load-modules (cdr x) "" #t))+         ((include-shared)+          (load-modules (cdr x) *shared-object-extension* #f))+         ((body begin)+          (for-each +            (lambda (expr) +                (eval expr env)) +            (cdr x)))+         ((error)+          (apply error (cdr x)))))+     meta)+    (module-meta-data-set! mod meta)+    ;(warn-undefs env #f) ; JAE - commented this out (TODO)+    env))++(define (environment . ls)+  (let ((env (make-environment)))+    (for-each+     (lambda (m)+       (let* ((mod2-name+imports (resolve-import m))+              (mod2 (load-module (car mod2-name+imports))))+         (%import env (module-env mod2) (cdr mod2-name+imports) #t)))+     ls)+    env))++(define (load-module name)+  (let ((mod (find-module name)))+    (if (and mod (not (module-env mod)))+        (module-env-set! mod (eval-module name mod)))+    mod))++;TODO: see below:+;(define define-library-transformer+(define-syntax define-library+  (er-macro-transformer+   (lambda (expr rename compare)+     (let ((name (cadr expr))+           (body (cddr expr))+           (tmp (rename 'tmp))+           (this-module (rename '*this-module*))+           (add-module! (rename 'add-module!)))+       `(let ((,tmp ,this-module))+          (define (rewrite-export x)+; JAE            (write (list "DEBUG: rewrite-export" x))+            (if (pair? x)+                (if (and (= 3 (length x))+                         (eq? 'rename (identifier->symbol (car x))))+                    (cons (car (cddr x)) (cadr x))+                    (error "invalid module export" x))+                x))+          (define (extract-exports)+;            (write "entered extract-exports") ; JAE Debugging+;            (write ,this-module) ; JAE Debugging+            (cond+             ((assq 'export-all ,this-module)+              => (lambda (x)+                   (if (pair? (cdr x))+                       (error "export-all takes no parameters" x))+                   #f))+             (else+              (let lp ((ls ,this-module) (res '()))+                (cond+                 ((null? ls) res)+                 ((and (pair? (car ls)) (eq? 'export (caar ls)))+                  (lp (cdr ls) (append (map rewrite-export (cdar ls)) res)))+                 (else (lp (cdr ls) res)))))))+          (set! ,this-module '())+          ,@body+          (set! ,this-module (reverse ,this-module))+          (,add-module! ',name (make-module (extract-exports) #f ,this-module))+          (set! ,this-module ,tmp))))))++; JAE TODO: chibi supports 'module' as well as 'define-library'+;(define-syntax define-library define-library-transformer)+;(define-syntax module define-library-transformer)++(define-syntax define-config-primitive+  (er-macro-transformer+   (lambda (expr rename compare)+     `(define-syntax ,(cadr expr)+        (er-macro-transformer+         (lambda (expr rename compare)+           (let ((this-module (rename '*this-module*)))+             `(set! ,this-module (cons ',expr ,this-module)))))))))++(define-syntax orig-begin begin)+(define-config-primitive import)+(define-config-primitive import-immutable)+(define-config-primitive export)+(define-config-primitive export-all)+(define-config-primitive include)+(define-config-primitive include-ci)+(define-config-primitive include-shared)+(define-config-primitive body)+(define-config-primitive begin)++; The `import' binding used by (scheme) and (scheme base), etc.+(define-syntax repl-import+  (er-macro-transformer+   ;(let ((meta-env (current-environment)))+     (lambda (expr rename compare)+       (let lp ((ls (cdr expr)) (res '()))+         (cond+          ((null? ls)+           ; JAE - Using expanded version of begin because there were+           ;       problems with using the following line from chibi.+           ;       This may highlight a problem in husk, but for the+           ;       purposes of this file we are moving on...+           ;+           ;(cons (rename 'orig-begin) (reverse res)))+           (cons +             (cons +               'lambda+               (cons+                 '()+                 (reverse res)))+             '()))+          (else+           (let ((mod+imps (resolve-import (car ls))))+             (cond+              ((pair? mod+imps)+               (lp (cdr ls)+                   (cons `(,(rename '%import)+                           #f+                           (,(rename 'module-env)+                            (,(rename 'load-module)+                             (,(rename 'quote) ,(car mod+imps))))+                           (,(rename 'quote) ,(cdr mod+imps))+                           #f)+                         res)))+              (else+               (error "couldn't find module" (car ls)))))))))));)++(define *modules* '())++; Old code from original file:+;  (list (cons '(scheme) (make-module #f (interaction-environment)+;                                     '((include "init-7.scm"))))+;        (cons '(meta) (make-module #f (current-environment) '()))+;        (cons '(srfi 0) (make-module (list 'cond-expand)+;                                     (current-environment)+;                                     (list (list 'export 'cond-expand))))))+

@@ -0,0 +1,3 @@+(define-library (r5rs base)+    (export-all)+    (import (r5rs)))

@@ -0,0 +1,5 @@+; TODO: This file is just a stub for+;       future r7rs library support+;(define-library (scheme base)+;    (export-all)+;    (import (scheme)))

@@ -119,7 +119,7 @@ ; updated to take this into acccount, so the pitfall ; still fails ;-     (if #t (begin result1 result2 ...)))+     (if #t ((lambda () result1 result2 ...)))) ;; TODO: should use begin     ((cond (test => result))      (let ((temp test))        (if temp (result temp))))@@ -135,11 +135,11 @@            temp            (cond clause1 clause2 ...))))     ((cond (test result1 result2 ...))-     (if test (begin result1 result2 ...)))+     (if test ((lambda () result1 result2 ...)))) ;; TODO: should use begin     ((cond (test result1 result2 ...)            clause1 clause2 ...)      (if test-         (begin result1 result2 ...)+         ((lambda () result1 result2 ...)) ;; TODO: should use begin          (cond clause1 clause2 ...))))) ; Case ; Form from R5RS:@@ -151,16 +151,16 @@        (case atom-key clauses ...)))     ((case key        (else result1 result2 ...))-     (if #t (begin result1 result2 ...)))+     (if #t ((lambda () result1 result2 ...)))) ;; TODO: should use begin     ((case key        ((atoms ...) result1 result2 ...))      (if (memv key '(atoms ...))-         (begin result1 result2 ...)))+         ((lambda () result1 result2 ...)))) ;; TODO: should use begin     ((case key        ((atoms ...) result1 result2 ...)        clause clauses ...)      (if (memv key '(atoms ...))-         (begin result1 result2 ...)+         ((lambda () result1 result2 ...)) ;; TODO: should use begin          (case key clause clauses ...)))))  (define (my-mem-helper obj lst cmp-proc)