diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -6,7 +6,9 @@ ------------ husk includes the following features: -- Most primitive data types and their standard forms (TODO: which are? string, char, etc) +- Primitive data types and their standard forms, including string, char, numbers (integer, rational, floating point, and complex), list, pair, vector, and symbols +- Proper tail recursion +- Proper lexical scoping - Conditionals: if, case, cond - Assignment operations - Sequencing: begin @@ -17,7 +19,6 @@ - Basic IO functions - Standard library of Scheme functions - Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline -- Proper tail recursion - Full numeric tower - includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types, other constraints from spec. - Hash tables, as specified by [SRFI 69](http://srfi.schemers.org/srfi-69/srfi-69.html) - Hygenic Macros: High-level macros via define-syntax - *Note this is still a heavy work in progress* and while it works well enough that many derived forms are implemented in our standard library, you may still run into problems when defining your own macros. diff --git a/hs-src/Scheme/Core.hs b/hs-src/Scheme/Core.hs --- a/hs-src/Scheme/Core.hs +++ b/hs-src/Scheme/Core.hs @@ -30,18 +30,13 @@ import Scheme.Parser import Scheme.Types import Scheme.Variables -import Complex -import Control.Monad import Control.Monad.Error import Char import Data.Array -import Data.IORef import qualified Data.Map import Maybe import List import IO hiding (try) -import Numeric -import Ratio {-| Evaluate a string containing Scheme code. @@ -77,18 +72,18 @@ -- -- NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' eval :: Env -> LispVal -> IOThrowsError LispVal -eval env val@(Nil _) = return val -eval env val@(String _) = return val -eval env val@(Char _) = return val -eval env val@(Complex _) = return val -eval env val@(Float _) = return val -eval env val@(Rational _) = return val -eval env val@(Number _) = return val -eval env val@(Bool _) = return val -eval env val@(HashTable _) = return val -eval env (Atom id) = getVar env id -eval env (List [Atom "quote", val]) = return val -eval env (List [Atom "quasiquote", val]) = doUnQuote env val +eval _ val@(Nil _) = return val +eval _ val@(String _) = return val +eval _ val@(Char _) = return val +eval _ val@(Complex _) = return val +eval _ val@(Float _) = return val +eval _ val@(Rational _) = return val +eval _ val@(Number _) = return val +eval _ val@(Bool _) = return val +eval _ val@(HashTable _) = return val +eval env (Atom a) = getVar env a +eval _ (List [Atom "quote", val]) = return val +eval envi (List [Atom "quasiquote", value]) = doUnQuote envi value where doUnQuote :: Env -> LispVal -> IOThrowsError LispVal doUnQuote env val = do case val of @@ -101,12 +96,12 @@ List [] -> return $ List rxs List rxlst -> return $ List $ rxs ++ rxlst DottedList rxlst rxlast -> return $ DottedList (rxs ++ rxlst) rxlast - otherwise -> return $ DottedList rxs rx + _ -> return $ DottedList rxs rx Vector vec -> do let len = length (elems vec) vList <- unquoteListM env $ elems vec >>= return return $ Vector $ listArray (0, len) vList - otherwise -> eval env (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... + _ -> eval env (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... unquoteListM env lst = foldlM (unquoteListFld env) ([]) lst unquoteListFld env (acc) val = do case val of @@ -122,10 +117,10 @@ -- least we will not allow anything invalid to be returned. -- -- Old code that we might build on if this changes down the road: otherwise -> return $ (acc ++ [v]) - otherwise -> throwError $ TypeMismatch "proper list" value + _ -> throwError $ TypeMismatch "proper list" value - otherwise -> do result <- doUnQuote env val - return $ (acc ++ [result]) + _ -> do result <- doUnQuote env val + return $ (acc ++ [result]) eval env (List [Atom "if", pred, conseq, alt]) = do result <- eval env pred @@ -203,13 +198,11 @@ eval env (List [Atom "string-set!", Atom var, index, character]) = do idx <- eval env index - chr <- eval env character str <- eval env =<< getVar env var (eval env $ substr(str, character, idx)) >>= setVar env var - where substr (String str, Char chr, Number index) = do - let slength = fromInteger index + where substr (String str, Char char, Number index) = do String $ (take (fromInteger index) . drop 0) str ++ - [chr] ++ + [char] ++ (take (length str) . drop (fromInteger index + 1)) str -- TODO: error handler @@ -241,14 +234,14 @@ h <- eval env =<< getVar env var case h of HashTable ht -> (eval env $ HashTable $ Data.Map.insert key value ht) >>= setVar env var - otherwise -> throwError $ TypeMismatch "hash-table" otherwise + other -> throwError $ TypeMismatch "hash-table" other eval env (List [Atom "hash-table-delete!", Atom var, rkey]) = do key <- eval env rkey h <- eval env =<< getVar env var case h of HashTable ht -> (eval env $ HashTable $ Data.Map.delete key ht) >>= setVar env var - otherwise -> throwError $ TypeMismatch "hash-table" otherwise + other -> throwError $ TypeMismatch "hash-table" other -- TODO: -- hash-table-merge! @@ -273,44 +266,54 @@ List (List cond : exprs) -> do test <- checkEq env ekey (List cond) case test of Bool True -> last $ map (eval env) exprs - otherwise -> evalCase env $ List $ ekey : tail cases + _ -> evalCase env $ List $ ekey : tail cases badForm -> throwError $ BadSpecialForm "Unrecognized special form in case" badForm where checkEq env ekey (List (x : xs)) = do test <- eval env $ List [Atom "eqv?", ekey, x] case test of Bool True -> eval env $ Bool True - otherwise -> checkEq env ekey (List xs) + _ -> checkEq env ekey (List xs) checkEq env ekey val = case val of List [] -> eval env $ Bool False -- If nothing else is left, then nothing matched key - otherwise -> do + _ -> do test <- eval env $ List [Atom "eqv?", ekey, val] case test of Bool True -> eval env $ Bool True - otherwise -> eval env $ Bool False + _ -> eval env $ Bool False -evalCase key badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm +evalCase _ badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm -- Helper function for evaluating 'cond' evalCond :: Env -> LispVal -> IOThrowsError LispVal -evalCond env (List [test, expr]) = eval env expr -evalCond env (List (test : expr)) = last $ map (eval env) expr -- TODO: all expr's need to be evaluated, not sure happening right now -evalCond env badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm +evalCond env (List [_, expr]) = eval env expr +evalCond env (List (_ : expr)) = last $ map (eval env) expr -- TODO: all expr's need to be evaluated, not sure happening right now +evalCond _ badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm +--makeFunc :: forall (m :: * -> *).(Monad m) => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal makeFunc varargs env params body = return $ Func (map showVal params) varargs body env False +{-makeNormalFunc :: Env + -> [LispVal] + -> [LispVal] + -> m LispVal-} makeNormalFunc = makeFunc Nothing +{-makeVarargs :: LispVal -> Env + -> [LispVal] + -> [LispVal] + -> m LispVal-} makeVarargs = makeFunc . Just . showVal apply :: LispVal -> [LispVal] -> IOThrowsError LispVal apply (IOFunc func) args = func args apply (PrimitiveFunc func) args = liftThrows $ func args -apply (Func params varargs body closure _) args = - if num params /= num args && varargs == Nothing - then throwError $ NumArgs (num params) args - else (liftIO $ bindVars closure $ zip (map ((,) varNamespace) params) args) >>= bindVarArgs varargs >>= (evalBody body) - where remainingArgs = drop (length params) args +apply (Func aparams avarargs abody aclosure _) args = + if num aparams /= num args && avarargs == Nothing + then throwError $ NumArgs (num aparams) args + else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody) +-- else (liftIO $ bindVars closure $ zip (map ((,) varNamespace) params) args) >>= bindVarArgs varargs >>= (evalBody body) + where remainingArgs = drop (length aparams) args num = toInteger . length evalBody restBody env = do -- Iterate through, executing each member of the body @@ -325,7 +328,8 @@ eval env lv evalBody lvs env bindVarArgs arg env = case arg of - Just argName -> liftIO $ bindVars env [((varNamespace, argName), List $ remainingArgs)] + Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)] +-- Just argName -> liftIO $ bindVars env [((varNamespace, argName), List $ remainingArgs)] Nothing -> return env apply func args = throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : args) @@ -333,9 +337,9 @@ -- 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). primitiveBindings :: IO Env -primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives - ++ map (makeFunc PrimitiveFunc) primitives) - where makeFunc constructor (var, func) = ((varNamespace, var), constructor func) +primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives + ++ map (domakeFunc PrimitiveFunc) primitives) + where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] ioPrimitives = [("apply", applyProc), @@ -351,6 +355,7 @@ applyProc :: [LispVal] -> IOThrowsError LispVal applyProc [func, List args] = apply func args applyProc (func : args) = apply func args +applyProc [] = throwError $ BadSpecialForm "applyProc" $ String "Function not specified" makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode @@ -521,9 +526,11 @@ unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal unaryOp f [v] = f v - -numBoolBinop = boolBinop unpackNum +--numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal +--numBoolBinop = boolBinop unpackNum +strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal strBoolBinop = boolBinop unpackStr +boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal boolBoolBinop = boolBinop unpackBool unpackStr :: LispVal -> ThrowsError String @@ -538,14 +545,14 @@ {- List primitives -} car :: [LispVal] -> ThrowsError LispVal -car [List (x : xs)] = return x -car [DottedList (x : xs) _] = return x +car [List (x : _)] = return x +car [DottedList (x : _) _] = return x car [badArg] = throwError $ TypeMismatch "pair" badArg car badArgList = throwError $ NumArgs 1 badArgList cdr :: [LispVal] -> ThrowsError LispVal -cdr [List (x : xs)] = return $ List xs -cdr [DottedList [xs] x] = return x +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 @@ -560,7 +567,7 @@ equal :: [LispVal] -> ThrowsError LispVal equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] -- TODO: hash table? -equal [l1@(List arg1), l2@(List arg2)] = eqvList equal [l1, l2] +equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2] equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]] equal [arg1, arg2] = do primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) @@ -611,18 +618,19 @@ hashTblExists [(HashTable ht), key@(_)] = do case Data.Map.lookup key ht of - Just val -> return $ Bool True + Just _ -> return $ Bool True Nothing -> return $ Bool False hashTblRef [(HashTable ht), key@(_)] = do case Data.Map.lookup key ht of Just val -> return $ val Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key --- TODO: a thunk can optionally be specified, this drives definition of /default -hashTblRef [(HashTable ht), key@(_), thunk@(Func params vararg body closure _)] = do +hashTblRef [(HashTable ht), key@(_), Func _ _ _ _ _] = do --thunk@(Func _ _ _ _ _)] = do case Data.Map.lookup key ht of Just val -> return $ val --- TODO: Nothing -> apply thunk [] + Nothing -> throwError $ NotImplemented "thunk" +-- 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 @@ -636,12 +644,12 @@ hashTbl2List badArgList = throwError $ NumArgs 1 badArgList hashTblKeys [(HashTable ht)] = do - return $ List $ map (\(k, v) -> k) $ Data.Map.toList ht + return $ List $ map (\(k, _) -> k) $ Data.Map.toList ht hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType hashTblKeys badArgList = throwError $ NumArgs 1 badArgList hashTblValues [(HashTable ht)] = do - return $ List $ map (\(k, v) -> v) $ Data.Map.toList ht + return $ List $ map (\(_, v) -> v) $ Data.Map.toList ht hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType hashTblValues badArgList = throwError $ NumArgs 1 badArgList @@ -667,10 +675,11 @@ makeString [(Number n), (Char c)] = return $ doMakeString n c "" makeString badArgList = throwError $ NumArgs 1 badArgList -doMakeString n chr s = +doMakeString :: forall a.(Num a) => a -> Char -> String -> LispVal +doMakeString n char s = if n == 0 then String s - else doMakeString (n - 1) chr (s ++ [chr]) + else doMakeString (n - 1) char (s ++ [char]) stringLength :: [LispVal] -> ThrowsError LispVal stringLength [String s] = return $ Number $ foldr (const (+1)) 0 s -- Could probably do 'length s' instead... @@ -684,17 +693,17 @@ substring :: [LispVal] -> ThrowsError LispVal substring [(String s), (Number start), (Number end)] = - do let length = fromInteger $ end - start + do let slength = fromInteger $ end - start let begin = fromInteger start - return $ String $ (take length . drop begin) s + return $ String $ (take slength . drop begin) s substring [badType] = throwError $ TypeMismatch "string number number" badType substring badArgList = throwError $ NumArgs 3 badArgList stringCIEquals :: [LispVal] -> ThrowsError LispVal -stringCIEquals [(String s1), (String s2)] = do - if (length s1) /= (length s2) +stringCIEquals [(String str1), (String str2)] = do + if (length str1) /= (length str2) then return $ Bool False - else return $ Bool $ ciCmp s1 s2 0 + else return $ Bool $ ciCmp str1 str2 0 where ciCmp s1 s2 idx = if idx == (length s1) then True else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx) @@ -706,8 +715,8 @@ 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 op [badType] = throwError $ TypeMismatch "string string" badType -stringCIBoolBinop op badArgList = throwError $ NumArgs 2 badArgList +stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType +stringCIBoolBinop _ badArgList = throwError $ NumArgs 2 badArgList stringAppend :: [LispVal] -> ThrowsError LispVal stringAppend [(String s)] = return $ String s -- Needed for "last" string value @@ -717,7 +726,7 @@ -- TBD: this probably will solve type problems when processing other lists of objects in the other string functions case rest of String s -> return $ String $ st ++ s - otherwise -> throwError $ TypeMismatch "string" otherwise + other -> throwError $ TypeMismatch "string" other stringAppend [badType] = throwError $ TypeMismatch "string" badType stringAppend badArgList = throwError $ NumArgs 1 badArgList @@ -731,7 +740,7 @@ n@(Rational _) -> return n n@(Float _) -> return n n@(Complex _) -> return n - otherwise -> return $ Bool False + _ -> return $ Bool False stringToNumber [badType] = throwError $ TypeMismatch "string" badType stringToNumber badArgList = throwError $ NumArgs 1 badArgList @@ -751,13 +760,13 @@ stringCopy badArgList = throwError $ NumArgs 2 badArgList isDottedList :: [LispVal] -> ThrowsError LispVal -isDottedList ([DottedList l d]) = return $ Bool True +isDottedList ([DottedList _ _]) = return $ Bool True isDottedList _ = return $ Bool False isProcedure :: [LispVal] -> ThrowsError LispVal -isProcedure ([PrimitiveFunc f]) = return $ Bool True -isProcedure ([Func params vararg body closure partial]) = return $ Bool True -isProcedure ([IOFunc f]) = return $ Bool True +isProcedure ([PrimitiveFunc _]) = return $ Bool True +isProcedure ([Func _ _ _ _ _]) = return $ Bool True +isProcedure ([IOFunc _]) = return $ Bool True isProcedure _ = return $ Bool False isVector, isList :: LispVal -> ThrowsError LispVal @@ -771,7 +780,7 @@ isNull _ = return $ Bool False isSymbol :: [LispVal] -> ThrowsError LispVal -isSymbol ([Atom a]) = return $ Bool True +isSymbol ([Atom _]) = return $ Bool True isSymbol _ = return $ Bool False symbol2String :: [LispVal] -> ThrowsError LispVal @@ -783,15 +792,15 @@ string2Symbol [notString] = throwError $ TypeMismatch "string" notString isChar :: [LispVal] -> ThrowsError LispVal -isChar ([Char a]) = return $ Bool True +isChar ([Char _]) = return $ Bool True isChar _ = return $ Bool False isString :: [LispVal] -> ThrowsError LispVal -isString ([String s]) = return $ Bool True +isString ([String _]) = return $ Bool True isString _ = return $ Bool False isBoolean :: [LispVal] -> ThrowsError LispVal -isBoolean ([Bool n]) = return $ Bool True +isBoolean ([Bool _]) = return $ Bool True isBoolean _ = return $ Bool False -- end Eval section diff --git a/hs-src/Scheme/Types.hs b/hs-src/Scheme/Types.hs --- a/hs-src/Scheme/Types.hs +++ b/hs-src/Scheme/Types.hs @@ -24,11 +24,12 @@ {- Environment management -} -- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@ -type Env = IORef [((String, String), IORef LispVal)] -- lookup via: (namespace, variable) +data Env = Environment {parentEnv :: (Maybe Env), bindings :: (IORef [((String, String), IORef LispVal)])} -- lookup via: (namespace, variable) -- |An empty environment nullEnv :: IO Env -nullEnv = newIORef [] +nullEnv = do bindings <- newIORef [] + return $ Environment Nothing bindings -- Internal namespace for macros macroNamespace = "m" @@ -44,6 +45,7 @@ | NotFunction String String | UnboundVar String String | DivideByZero -- ^Divide by Zero error + | NotImplemented String | Default String -- ^Default error -- |Create a textual description for a 'LispError' @@ -57,6 +59,7 @@ showError (NotFunction message func) = message ++ ": " ++ show func showError (UnboundVar message varname) = message ++ ": " ++ varname showError (DivideByZero) = "Division by zero" +showError (NotImplemented message) = "Not implemented: " ++ message instance Show LispError where show = showError instance Error LispError where diff --git a/hs-src/Scheme/Variables.hs b/hs-src/Scheme/Variables.hs --- a/hs-src/Scheme/Variables.hs +++ b/hs-src/Scheme/Variables.hs @@ -13,13 +13,34 @@ import Control.Monad.Error import Data.IORef +-- |Extend given environment by binding a series of values to a new environment. +extendEnv :: Env -> [((String, String), LispVal)] -> IO Env +extendEnv envRef bindings = do bindinglist <- mapM (\((namespace, name), val) -> + do ref <- newIORef val + return ((namespace, name), ref)) bindings + >>= newIORef + return $ Environment (Just envRef) bindinglist + +{- +-- Old implementation, left for the moment for reference purposes only: +-- +-- |Bind a series of values to the given environment. +-- +-- Input is of form: @(namespaceName, variableName), variableValue@ +bindVars :: Env -> [((String, String), LispVal)] -> IO Env +bindVars envRef abindings = (readIORef $ bindings envRef) >>= myExtendEnv abindings >>= newIORef + where myExtendEnv bindings env = liftM (++ env) (mapM addBinding bindings) + addBinding (var, value) = do ref <- newIORef value + return (var, ref) +-} + -- |Determine if a variable is bound in the default namespace isBound :: Env -> String -> IO Bool isBound envRef var = isNamespacedBound envRef varNamespace var -- |Determine if a variable is bound in a given namespace isNamespacedBound :: Env -> String -> String -> IO Bool -isNamespacedBound envRef namespace var = readIORef envRef >>= return . maybe False (const True) . lookup (namespace, var) +isNamespacedBound envRef namespace var = (readIORef $ bindings envRef) >>= return . maybe False (const True) . lookup (namespace, var) -- |Retrieve the value of a variable defined in the default namespace getVar :: Env -> String -> IOThrowsError LispVal @@ -29,10 +50,12 @@ getNamespacedVar :: Env -> String -> String -> IOThrowsError LispVal getNamespacedVar envRef namespace - var = do env <- liftIO $ readIORef envRef - maybe (throwError $ UnboundVar "Getting an unbound variable" var) - (liftIO . readIORef) - (lookup (namespace, var) env) + var = do binds <- liftIO $ readIORef $ bindings envRef + case lookup (namespace, var) binds of + (Just a) -> liftIO $ readIORef a + Nothing -> case parentEnv envRef of + (Just par) -> getNamespacedVar par namespace var + Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var) -- |Set a variable in the default namespace setVar, defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal @@ -45,11 +68,14 @@ setNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal setNamespacedVar envRef namespace - var value = do env <- liftIO $ readIORef envRef - maybe (throwError $ UnboundVar "Setting an unbound variable: " var) - (liftIO . (flip writeIORef value)) - (lookup (namespace, var) env) - return value + var value = do env <- liftIO $ readIORef $ bindings envRef + case lookup (namespace, var) env of + (Just a) -> do vprime <- liftIO $ readIORef a + liftIO $ writeIORef a value + return value + Nothing -> case parentEnv envRef of + (Just par) -> setNamespacedVar par namespace var value + Nothing -> throwError $ UnboundVar "Setting an unbound variable: " var -- |Bind a variable in the given namespace defineNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal @@ -61,16 +87,6 @@ then setNamespacedVar envRef namespace var value >> return value else liftIO $ do valueRef <- newIORef value - env <- readIORef envRef - writeIORef envRef (((namespace, var), valueRef) : env) + env <- readIORef $ bindings envRef + writeIORef (bindings envRef) (((namespace, var), valueRef) : env) return value - --- |Bind a series of values to the given environment. --- --- Input is of form: @(namespaceName, variableName), variableValue@ -bindVars :: Env -> [((String, String), LispVal)] -> IO Env -bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef - where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings) - addBinding (var, value) = do ref <- newIORef value - return (var, ref) - diff --git a/hs-src/shell.hs b/hs-src/shell.hs --- a/hs-src/shell.hs +++ b/hs-src/shell.hs @@ -32,7 +32,7 @@ runOne :: [String] -> IO () runOne args = do - env <-primitiveBindings >>= flip bindVars [((varNamespace, "args"), List $ map String $ drop 1 args)] + env <- primitiveBindings >>= flip extendEnv [((varNamespace, "args"), List $ map String $ drop 1 args)] (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)])) >>= hPutStrLn stderr -- echo this or not?? @@ -47,7 +47,7 @@ showBanner = do putStrLn " __ __ __ __ ______ __ __ " putStrLn "/\\ \\_\\ \\ /\\ \\/\\ \\ /\\ ___\\ /\\ \\/ / Scheme Interpreter " - putStrLn "\\ \\ __ \\ \\ \\ \\_\\ \\ \\ \\___ \\ \\ \\ _\\\"-. Version 1.1" + putStrLn "\\ \\ __ \\ \\ \\ \\_\\ \\ \\ \\___ \\ \\ \\ _\\\"-. Version 1.2" putStrLn " \\ \\_\\ \\_\\ \\ \\_____\\ \\/\\_____\\ \\ \\_\\ \\_\\ (c) 2010 Justin Ethier " putStrLn " \\/_/\\/_/ \\/_____/ \\/_____/ \\/_/\\/_/ github.com/justinethier/husk-scheme " putStrLn "" diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 1.1 +Version: 1.2 Synopsis: R5RS Scheme interpreter program and library. Description: Husk is a dialect of Scheme written in Haskell that implements a subset of the R5RS standard. Husk is not intended to be a