diff --git a/ChangeLog.markdown b/ChangeLog.markdown
--- a/ChangeLog.markdown
+++ b/ChangeLog.markdown
@@ -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 R7RS 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)
diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs
--- a/hs-src/Compiler/huskc.hs
+++ b/hs-src/Compiler/huskc.hs
@@ -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)
diff --git a/hs-src/Interpreter/shell.hs b/hs-src/Interpreter/shell.hs
--- a/hs-src/Interpreter/shell.hs
+++ b/hs-src/Interpreter/shell.hs
@@ -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
diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs
--- a/hs-src/Language/Scheme/Compiler.hs
+++ b/hs-src/Language/Scheme/Compiler.hs
@@ -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' "
diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs
--- a/hs-src/Language/Scheme/Core.hs
+++ b/hs-src/Language/Scheme/Core.hs
@@ -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)]
diff --git a/hs-src/Language/Scheme/Libraries.hs b/hs-src/Language/Scheme/Libraries.hs
new file mode 100644
--- /dev/null
+++ b/hs-src/Language/Scheme/Libraries.hs
@@ -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
+
diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs
--- a/hs-src/Language/Scheme/Macro.hs
+++ b/hs-src/Language/Scheme/Macro.hs
@@ -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
diff --git a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs
--- a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs
+++ b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs
@@ -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
diff --git a/hs-src/Language/Scheme/Numerical.hs b/hs-src/Language/Scheme/Numerical.hs
--- a/hs-src/Language/Scheme/Numerical.hs
+++ b/hs-src/Language/Scheme/Numerical.hs
@@ -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
diff --git a/hs-src/Language/Scheme/Parser.hs b/hs-src/Language/Scheme/Parser.hs
--- a/hs-src/Language/Scheme/Parser.hs
+++ b/hs-src/Language/Scheme/Parser.hs
@@ -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.
diff --git a/hs-src/Language/Scheme/Plugins/CPUTime.hs b/hs-src/Language/Scheme/Plugins/CPUTime.hs
--- a/hs-src/Language/Scheme/Plugins/CPUTime.hs
+++ b/hs-src/Language/Scheme/Plugins/CPUTime.hs
@@ -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
diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs
--- a/hs-src/Language/Scheme/Primitives.hs
+++ b/hs-src/Language/Scheme/Primitives.hs
@@ -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 -}
diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs
--- a/hs-src/Language/Scheme/Types.hs
+++ b/hs-src/Language/Scheme/Types.hs
@@ -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
diff --git a/hs-src/Language/Scheme/Util.hs b/hs-src/Language/Scheme/Util.hs
new file mode 100644
--- /dev/null
+++ b/hs-src/Language/Scheme/Util.hs
@@ -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
+
diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs
--- a/hs-src/Language/Scheme/Variables.hs
+++ b/hs-src/Language/Scheme/Variables.hs
@@ -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
diff --git a/husk-scheme.cabal b/husk-scheme.cabal
--- a/husk-scheme.cabal
+++ b/husk-scheme.cabal
@@ -1,5 +1,5 @@
Name: husk-scheme
-Version: 3.6.3
+Version: 3.7
Synopsis: R5RS Scheme interpreter, compiler, and library.
Description:
<>
@@ -32,6 +32,7 @@
Author: Justin Ethier
Maintainer: Justin Ethier
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
diff --git a/lib/modules.scm b/lib/modules.scm
new file mode 100644
--- /dev/null
+++ b/lib/modules.scm
@@ -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))))))
+
diff --git a/lib/r5rs/base.sld b/lib/r5rs/base.sld
new file mode 100644
--- /dev/null
+++ b/lib/r5rs/base.sld
@@ -0,0 +1,3 @@
+(define-library (r5rs base)
+ (export-all)
+ (import (r5rs)))
diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld
new file mode 100644
--- /dev/null
+++ b/lib/scheme/base.sld
@@ -0,0 +1,5 @@
+; TODO: This file is just a stub for
+; future r7rs library support
+;(define-library (scheme base)
+; (export-all)
+; (import (scheme)))
diff --git a/lib/stdlib.scm b/lib/stdlib.scm
--- a/lib/stdlib.scm
+++ b/lib/stdlib.scm
@@ -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)